DPMJET/dpmjet3.0-5F.f

   1 *$ CREATE DT_INIT.FOR
   2 *COPY DT_INIT
   3 *
   4 *    +-------------------------------------------------------------+
   5 *    |                                                             |
   6 *    |                                                             |
   7 *    |                        DPMJET 3.0                           |
   8 *    |                                                             |
   9 *    |                                                             |
  10 *    |         S. Roesler+), R. Engel#), J. Ranft*)                |
  11 *    |                                                             |
  12 *    |         +) CERN, SC-RP                                      |
  13 *    |            CH-1211 Geneva 23, Switzerland                   |
  14 *    |            Email: Stefan.Roesler@cern.ch                    |
  15 *    |                                                             |
  16 *    |         #) Institut fuer Kernphysik                         |
  17 *    |            Forschungszentrum Karlsruhe                      |
  18 *    |            D-76021 Karlsruhe, Germany                       |
  19 *    |                                                             |
  20 *    |         *) University of Siegen, Dept. of Physics           |
  21 *    |            D-57068 Siegen, Germany                          |
  22 *    |                                                             |
  23 *    |                                                             |
  24 *    |       http://home.cern.ch/sroesler/dpmjet3.html             |
  25 *    |                                                             |
  26 *    |                                                             |
  27 *    |       Monte Carlo models used for event generation:         |
  28 *    |          PHOJET 1.12, JETSET 7.4 and LEPTO 6.5.1            |
  29 *    |                                                             |
  30 *    +-------------------------------------------------------------+
  31 *
  32 *
  33 *===init===============================================================*
  34 *
  35       SUBROUTINE DT_INIT(NCASES,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
  36      &                                             IDP,IGLAU)
  37
  38 ************************************************************************
  39 * Initialization of event generation                                   *
  40 * This version dated  7.4.98  is written by S. Roesler.                *
  41 *                                                                      *
  42 * Last change 27.12.2006 by S. Roesler.                                *
  43 ************************************************************************
  44
  45       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  46       SAVE
  47
  48       PARAMETER ( LINP = 10 ,
  49      &            LOUT = 6 ,
  50      &            LDAT = 9 )
  51       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
  52
  53 * particle properties (BAMJET index convention)
  54       CHARACTER*8  ANAME
  55       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
  56      &                IICH(210),IIBAR(210),K1(210),K2(210)
  57
  58 * names of hadrons used in input-cards
  59       CHARACTER*8 BTYPE
  60       COMMON /DTPAIN/ BTYPE(30)
  61
  62 *      INCLUDE '(DIMPAR)'
  63 *     DIMPAR taken from FLUKA
  64       PARAMETER ( MXXRGN =20000 )
  65       PARAMETER ( MXXMDF =  710 )
  66       PARAMETER ( MXXMDE =  702 )
  67       PARAMETER ( MFSTCK =40000 )
  68       PARAMETER ( MESTCK =  100 )
  69       PARAMETER ( MOSTCK = 2000 )
  70       PARAMETER ( MXPRSN =  100 )
  71       PARAMETER ( MXPDPM =  800 )
  72       PARAMETER ( MXPSCS =30000 )
  73       PARAMETER ( MXGLWN =  300 )
  74       PARAMETER ( MXOUTU =   50 )
  75       PARAMETER ( NALLWP =   64 )
  76       PARAMETER ( NELEMX =   80 )
  77       PARAMETER ( MPDPDX =   18 )
  78       PARAMETER ( MXHTTR =  260 )
  79       PARAMETER ( MXSEAX =   20 )
  80       PARAMETER ( MXHTNC = MXSEAX + 1 )
  81       PARAMETER ( ICOMAX = 2400 )
  82       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
  83       PARAMETER ( NSTBIS =  304 )
  84       PARAMETER ( NQSTIS =   46 )
  85       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
  86       PARAMETER ( MXPABL =  120 )
  87       PARAMETER ( IDMAXP =  450 )
  88       PARAMETER ( IDMXDC = 2000 )
  89       PARAMETER ( MXMCIN =  410 )
  90       PARAMETER ( IHYPMX =    4 )
  91       PARAMETER ( MKBMX1 =   11 )
  92       PARAMETER ( MKBMX2 =   11 )
  93       PARAMETER ( MXIRRD = 2500 )
  94       PARAMETER ( MXTRDC = 1500 )
  95       PARAMETER ( NKTL   =   17 )
  96       PARAMETER ( NBLNMX = 40000000 )
  97
  98 *      INCLUDE '(PAREVT)'
  99 *     PAREVT taken from FLUKA
 100       PARAMETER ( FRDIFF = 0.2D+00 )
 101       PARAMETER ( ETHSEA = 1.0D+00 )
 102 *
 103       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
 104      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
 105      &        LNUCRI, LPEANU, LEVBME, LPHDRC, LATMSS, LISMRS, LCHDCY,
 106      &        LCHDCR, LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
 107       COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
 108      &                  LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
 109      &                  LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
 110      &                  LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LEVBME,
 111      &                  LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR,
 112      &                  LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
 113
 114 *      INCLUDE '(EVAFLG)'
 115 *     EVAFLG taken from FLUKA
 116       LOGICAL LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
 117      &        LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
 118      &        LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
 119      &        LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP, LEEXLV, LGEXLV
 120       COMMON / EVAFLG /     BRPNFR (0:2), EBRPFR (0:2), EMVBRP (0:2),
 121      &        FDSCST,
 122      &        ILVMOD, JLVMOD, JSIPFL, IMSSFR, JMSSFR, IEVFSS, MXAHEV,
 123      &        MXZHEV, IFHVFL, IFKYMX, IGMCMP, MPMODE, MSMODE, MUMODE,
 124      &        MFMODE, MEMODE, MRMODE, ITMCRR, IASYCR, IFSBCR, IFSSBR,
 125      &        LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
 126      &        LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
 127      &        LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
 128      &        LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP, LEEXLV, LGEXLV
 129
 130 *      INCLUDE '(FRBKCM)'
 131 *     FRBKCM taken from FLUKA
 132 *  Maximum number of fragments to be emitted:
 133       PARAMETER ( MXFFBK =     6 )
 134       PARAMETER ( MXZFBK =    10 )
 135       PARAMETER ( MXNFBK =    12 )
 136       PARAMETER ( MXAFBK =    16 )
 137       PARAMETER ( MXASST =    25 )
 138       PARAMETER ( NXAFBK = MXAFBK + 1 )
 139       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 + MXASST - NXAFBK )
 140       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 + MXASST - NXAFBK )
 141       PARAMETER ( MXPSST =   700 )
 142 *  Maximum number of pre-computed break-up combinations
 143       PARAMETER ( MXPPFB = 42500 )
 144 *  Maximum number of break-up combinations, including special
 145 *  run-time ones:
 146       PARAMETER ( MXPSFB = 43000 )
 147 *  Base for J multiplicity encoding:
 148       PARAMETER ( IBFRBK =    73 )
 149 *  Maximum Ibfrbk exponent to avoid overflow of I*4(roughly at 2.1x10^9)
 150 *  it must be (Ibfrbk-1) + (Ibfrbk-1)*Ibfrbk + (Ibfrbk-1)*Ibfrbk^2 + ...
 151 *  ... + (Ibfrbk-1)*Ibfrbk^Jpwfbx < 2100000000,
 152 *  --> Ibfrbk^(Jpwfbx+1) < 2100000000
 153       PARAMETER ( JPWFBX =     4 )
 154       LOGICAL LFRMBK, LNCMSS
 155       COMMON / FRBKCM /  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
 156      &          WEIFBK (MXPSST), GAMFBK (MXPSST), EXFRBK (MXPSFB),
 157      &          SDMFBK (MXPSFB), COUFBK (MXPSFB), CENFBK (MXPSFB),
 158      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, FRBKLS,
 159      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
 160      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
 161      &          IPSIND (0:NXNFBK,0:NXZFBK,2), JPSIND (0:MXASST),
 162      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
 163      &          IFBCHA (9,MXPSFB), IPOSST, IPOSFB, IFBSTF, IFBPSF,
 164      &          IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, LFRMBK, LNCMSS
 165       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
 166
 167 * emulsion treatment
 168       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
 169      &                NCOMPO,IEMUL
 170
 171 * Glauber formalism: parameters
 172       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
 173      &                BMAX(NCOMPX),BSTEP(NCOMPX),
 174      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
 175      &                NSITEB,NSTATB
 176
 177 * Glauber formalism: cross sections
 178       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
 179      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
 180      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
 181      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
 182      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
 183      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
 184      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
 185      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
 186      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
 187      &                BSLOPE,NEBINI,NQBINI
 188
 189 * interface HADRIN-DPM
 190       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
 191
 192 * central particle production, impact parameter biasing
 193       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
 194
 195 * parameter for intranuclear cascade
 196       LOGICAL LPAULI
 197       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
 198
 199 * various options for treatment of partons (DTUNUC 1.x)
 200 * (chain recombination, Cronin,..)
 201       LOGICAL LCO2CR,LINTPT
 202       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
 203      &                LCO2CR,LINTPT
 204
 205 * threshold values for x-sampling (DTUNUC 1.x)
 206       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
 207      &                SSMIMQ,VVMTHR
 208
 209 * flags for input different options
 210       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
 211       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
 212      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
 213
 214 * nuclear potential
 215       LOGICAL LFERMI
 216       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
 217      &                EBINDP(2),EBINDN(2),EPOT(2,210),
 218      &                ETACOU(2),ICOUL,LFERMI
 219
 220 * n-n cross section fluctuations
 221       PARAMETER (NBINS = 1000)
 222       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
 223
 224 * flags for particle decays
 225       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
 226      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
 227      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
 228
 229 * diquark-breaking mechanism
 230       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
 231
 232 * nucleon-nucleon event-generator
 233       CHARACTER*8 CMODEL
 234       LOGICAL LPHOIN
 235       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
 236
 237 * properties of interacting particles
 238       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
 239
 240 * properties of photon/lepton projectiles
 241       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
 242
 243 * flags for diffractive interactions (DTUNUC 1.x)
 244       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
 245
 246 * parameters for hA-diffraction
 247       COMMON /DTDIHA/ DIBETA,DIALPH
 248
 249 * Lorentz-parameters of the current interaction
 250       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
 251      &                UMO,PPCM,EPROJ,PPROJ
 252
 253 * kinematical cuts for lepton-nucleus interactions
 254       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
 255      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
 256
 257 * VDM parameter for photon-nucleus interactions
 258       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
 259
 260 * Glauber formalism: flags and parameters for statistics
 261       LOGICAL LPROD
 262       CHARACTER*8 CGLB
 263       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
 264
 265 * cuts for variable energy runs
 266       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
 267
 268 * flags for activated histograms
 269       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
 270
 271       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
 272       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
 273
 274 * LEPTO
 275 **LUND single / double precision
 276       REAL CUT,PARL,TMPX,TMPY,TMPW2,TMPQ2,TMPU
 277       COMMON /LEPTOU/ CUT(14),LST(40),PARL(30),
 278      &                TMPX,TMPY,TMPW2,TMPQ2,TMPU
 279
 280 * LEPTO
 281       REAL RPPN
 282       COMMON /LEPTOI/ RPPN,LEPIN,INTER
 283
 284 * steering flags for qel neutrino scattering modules
 285       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
 286
 287 * event flag
 288       COMMON /DTEVNO/ NEVENT,ICASCA
 289
 290       INTEGER PYCOMP
 291
 292 C     DIMENSION XPARA(5)
 293       DIMENSION XDUMB(40),IPRANG(5)
 294
 295       PARAMETER (MXCARD=58)
 296       CHARACTER*78 CLINE,CTITLE
 297       CHARACTER*60 CWHAT
 298       CHARACTER*8  BLANK,SDUM
 299       CHARACTER*10 CODE,CODEWD
 300       CHARACTER*72 HEADER
 301       LOGICAL LSTART,LEINP,LXSTAB
 302       DIMENSION WHAT(6),CODE(MXCARD)
 303       DATA CODE/
 304      &   'TITLE     ','PROJPAR   ','TARPAR    ','ENERGY    ',
 305      &   'MOMENTUM  ','CMENERGY  ','EMULSION  ','FERMI     ',
 306      &   'TAUFOR    ','PAULI     ','COULOMB   ','HADRIN    ',
 307      &   'EVAP      ','EMCCHECK  ','MODEL     ','PHOINPUT  ',
 308      &   'GLAUBERI  ','FLUCTUAT  ','CENTRAL   ','RECOMBIN  ',
 309      &   'COMBIJET  ','XCUTS     ','INTPT     ','CRONINPT  ',
 310      &   'SEADISTR  ','SEASU3    ','DIQUARKS  ','RESONANC  ',
 311      &   'DIFFRACT  ','SINGLECH  ','NOFRAGME  ','HADRONIZE ',
 312      &   'POPCORN   ','PARDECAY  ','BEAM      ','LUND-MSTU ',
 313      &   'LUND-MSTJ ','LUND-MDCY ','LUND-PARJ ','LUND-PARU ',
 314      &   'OUTLEVEL  ','FRAME     ','L-TAG     ','L-ETAG    ',
 315      &   'ECMS-CUT  ','VDM-PAR1  ','HISTOGRAM ','XS-TABLE  ',
 316      &   'GLAUB-PAR ','GLAUB-INI ','VDM-PAR2  ','XS-QELPRO ',
 317      &   'RNDMINIT  ','LEPTO-CUT ','LEPTO-LST ','LEPTO-PARL',
 318      &   'START     ','STOP      '/
 319       DATA BLANK /'        '/
 320
 321       DATA LSTART,LXSTAB,IFIRST /.TRUE.,.FALSE.,1/
 322       DATA CMEOLD /0.0D0/
 323
 324 *---------------------------------------------------------------------
 325 * at the first call of INIT: initialize event generation
 326       EPNSAV = EPN
 327       IF (LSTART) THEN
 328          CALL DT_TITLE
 329 *   initialization and test of the random number generator
 330          IF (ITRSPT.NE.1) THEN
 331
 332             IJKLIN = -1
 333             INSEED = 1
 334             ISEED1 = 0
 335             ISEED2 = 0
 336             CALL RNINIT (INSEED,IJKLIN,ISEED1,ISEED2)
 337
 338          ENDIF
 339 *   initialization of BAMJET, DECAY and HADRIN
 340          CALL DT_DDATAR
 341          CALL DT_DHADDE
 342          CALL DT_DCHANT
 343          CALL DT_DCHANH
 344 *   set default values for input variables
 345          CALL DT_DEFAUL(EPN,PPN)
 346          IGLAU  = 0
 347          IXSQEL = 0
 348 *   flag for collision energy input
 349          LEINP  = .FALSE.
 350          LSTART = .FALSE.
 351       ENDIF
 352
 353 *---------------------------------------------------------------------
 354    10 CONTINUE
 355
 356 * bypass reading input cards (e.g. for use with Fluka)
 357 *  in this case Epn is expected to carry the beam momentum
 358       IF (NCASES.EQ.-1) THEN
 359          IP      = NPMASS
 360          IPZ     = NPCHAR
 361          PPN     = EPNSAV
 362          EPN     = ZERO
 363          CMENER  = ZERO
 364          LEINP   = .TRUE.
 365          MKCRON  = 0
 366          WHAT(1) = 1
 367          WHAT(2) = 0
 368          CODEWD  = 'START     '
 369          GOTO 900
 370       ENDIF
 371
 372 * read control card from input-unit LINP
 373       READ(LINP,'(A78)',END=9999) CLINE
 374       IF (CLINE(1:1).EQ.'*') THEN
 375 * comment-line
 376          WRITE(LOUT,'(A78)') CLINE
 377          GOTO 10
 378       ENDIF
 379 C     READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM
 380 C1000 FORMAT(A10,6E10.0,A8)
 381       DO 1008 I=1,6
 382          WHAT(I) = ZERO
 383  1008 CONTINUE
 384       READ(CLINE,1006,END=9999) CODEWD,CWHAT,SDUM
 385  1006 FORMAT(A10,A60,A8)
 386       READ(CWHAT,*,END=1007) (WHAT(I),I=1,6)
 387  1007 CONTINUE
 388       WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM
 389  1001 FORMAT(A10,6G10.3,A8)
 390
 391   900 CONTINUE
 392
 393 * check for valid control card and get card index
 394       ICW = 0
 395       DO 11 I=1,MXCARD
 396          IF (CODEWD.EQ.CODE(I)) ICW = I
 397    11 CONTINUE
 398       IF (ICW.EQ.0) THEN
 399          WRITE(LOUT,1002) CODEWD
 400  1002    FORMAT(/,1X,'---> ',A10,': invalid control-card !',/)
 401          GOTO 10
 402       ENDIF
 403
 404       GOTO(
 405 *------------------------------------------------------------
 406 *       TITLE   ,  PROJPAR ,  TARPAR  ,  ENERGY  ,  MOMENTUM,
 407      &  100     ,  110     ,  120     ,  130     ,  140     ,
 408 *
 409 *------------------------------------------------------------
 410 *       CMENERGY,  EMULSION,  FERMI   ,  TAUFOR  ,  PAULI   ,
 411      &  150     ,  160     ,  170     ,  180     ,  190     ,
 412 *
 413 *------------------------------------------------------------
 414 *       COULOMB ,  HADRIN  ,  EVAP    ,  EMCCHECK,  MODEL   ,
 415      &  200     ,  210     ,  220     ,  230     ,  240     ,
 416 *
 417 *------------------------------------------------------------
 418 *       PHOINPUT,  GLAUBERI,  FLUCTUAT,  CENTRAL ,  RECOMBIN,
 419      &  250     ,  260     ,  270     ,  280     ,  290     ,
 420 *
 421 *------------------------------------------------------------
 422 *       COMBIJET,  XCUTS   ,  INTPT   ,  CRONINPT,  SEADISTR,
 423      &  300     ,  310     ,  320     ,  330     ,  340     ,
 424 *
 425 *------------------------------------------------------------
 426 *       SEASU3  ,  DIQUARKS,  RESONANC,  DIFFRACT,  SINGLECH,
 427      &  350     ,  360     ,  370     ,  380     ,  390     ,
 428 *
 429 *------------------------------------------------------------
 430 *       NOFRAGME, HADRONIZE,  POPCORN ,  PARDECAY,  BEAM    ,
 431      &  400     ,  410     ,  420     ,  430     ,  440     ,
 432 *
 433 *------------------------------------------------------------
 434 *      LUND-MSTU, LUND-MSTJ, LUND-MDCY, LUND-PARJ, LUND-PARU,
 435      &  450     ,  451     ,  452     ,  460     ,  470     ,
 436 *
 437 *------------------------------------------------------------
 438 *       OUTLEVEL,  FRAME   , L-TAG    ,  L-ETAG  ,  ECMS-CUT,
 439      &  480     ,  490     ,  500     ,  510     ,  520     ,
 440 *
 441 *------------------------------------------------------------
 442 *       VDM-PAR1, HISTOGRAM, XS-TABLE , GLAUB-PAR, GLAUB-INI,
 443      &  530     ,  540     ,  550     ,  560     ,  565     ,
 444 *
 445 *------------------------------------------------------------
 446 *               ,          ,  VDM-PAR2, XS-QELPRO, RNDMINIT ,
 447      &                        570     ,  580     ,  590     ,
 448 *
 449 *------------------------------------------------------------
 450 *      LEPTO-CUT, LEPTO-LST,LEPTO-PARL,  START   ,  STOP    )
 451      &  600     ,  610     ,  620     ,  630     ,  640     ) , ICW
 452 *
 453 *------------------------------------------------------------
 454
 455       GOTO 10
 456
 457 *********************************************************************
 458 *                                                                   *
 459 *               control card:  codewd = TITLE                       *
 460 *                                                                   *
 461 *       what (1..6), sdum   no meaning                              *
 462 *                                                                   *
 463 *       Note:  The control-card following this must consist of      *
 464 *              a string of characters usually giving the title of   *
 465 *              the run.                                             *
 466 *                                                                   *
 467 *********************************************************************
 468
 469   100 CONTINUE
 470       READ(LINP,'(A78)') CTITLE
 471       WRITE(LOUT,'(//,5X,A78,//)') CTITLE
 472       GOTO 10
 473
 474 *********************************************************************
 475 *                                                                   *
 476 *               control card:  codewd = PROJPAR                     *
 477 *                                                                   *
 478 *       what (1) =  mass number of projectile nucleus  default: 1   *
 479 *       what (2) =  charge of projectile nucleus       default: 1   *
 480 *       what (3..6)   no meaning                                    *
 481 *       sdum        projectile particle code word                   *
 482 *                                                                   *
 483 *       Note: If sdum is defined what (1..2) have no meaning.       *
 484 *                                                                   *
 485 *********************************************************************
 486
 487   110 CONTINUE
 488       IF (SDUM.EQ.BLANK) THEN
 489          IP     = INT(WHAT(1))
 490          IPZ    = INT(WHAT(2))
 491          IJPROJ = 1
 492          IBPROJ = 1
 493       ELSE
 494          IJPROJ = 0
 495          DO 111 II=1,30
 496             IF (SDUM.EQ.BTYPE(II)) THEN
 497                IP     = 1
 498                IPZ    = 1
 499                IF (II.EQ.26) THEN
 500                   IJPROJ = 135
 501                ELSEIF (II.EQ.27) THEN
 502                   IJPROJ = 136
 503                ELSEIF (II.EQ.28) THEN
 504                   IJPROJ = 133
 505                ELSEIF (II.EQ.29) THEN
 506                   IJPROJ = 134
 507                ELSE
 508                   IJPROJ = II
 509                ENDIF
 510                IBPROJ = IIBAR(IJPROJ)
 511 * photon
 512                IF ((IJPROJ.EQ.7).AND.(WHAT(1).GT.ZERO)) VIRT = WHAT(1)
 513 * lepton
 514                IF (((IJPROJ.EQ. 3).OR.(IJPROJ.EQ. 4).OR.
 515      &              (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11)).AND.
 516      &                              (WHAT(1).GT.ZERO)) Q2HI = WHAT(1)
 517             ENDIF
 518   111    CONTINUE
 519          IF (IJPROJ.EQ.0) THEN
 520             WRITE(LOUT,1110)
 521  1110       FORMAT(/,1X,'invalid PROJPAR card !',/)
 522             GOTO 9999
 523          ENDIF
 524       ENDIF
 525       GOTO 10
 526
 527 *********************************************************************
 528 *                                                                   *
 529 *               control card:  codewd = TARPAR                      *
 530 *                                                                   *
 531 *       what (1) =  mass number of target nucleus      default: 1   *
 532 *       what (2) =  charge of target nucleus           default: 1   *
 533 *       what (3..6)   no meaning                                    *
 534 *       sdum        target particle code word                       *
 535 *                                                                   *
 536 *       Note: If sdum is defined what (1..2) have no meaning.       *
 537 *                                                                   *
 538 *********************************************************************
 539
 540   120 CONTINUE
 541       IF (SDUM.EQ.BLANK) THEN
 542          IT     = INT(WHAT(1))
 543          ITZ    = INT(WHAT(2))
 544          IJTARG = 1
 545          IBTARG = 1
 546       ELSE
 547          IJTARG = 0
 548          DO 121 II=1,30
 549             IF (SDUM.EQ.BTYPE(II)) THEN
 550                IT     = 1
 551                ITZ    = 1
 552                IJTARG = II
 553                IBTARG = IIBAR(IJTARG)
 554             ENDIF
 555   121    CONTINUE
 556          IF (IJTARG.EQ.0) THEN
 557             WRITE(LOUT,1120)
 558  1120       FORMAT(/,1X,'invalid TARPAR card !',/)
 559             GOTO 9999
 560          ENDIF
 561       ENDIF
 562       GOTO 10
 563
 564 *********************************************************************
 565 *                                                                   *
 566 *               control card:  codewd = ENERGY                      *
 567 *                                                                   *
 568 *       what (1) =  energy (GeV) of projectile in Lab.              *
 569 *                   if what(1) < 0:  |what(1)| = kinetic energy     *
 570 *                                                default: 200 GeV   *
 571 *                   if |what(2)| > 0: min. energy for variable      *
 572 *                                     energy runs                   *
 573 *       what (2) =  max. energy for variable energy runs            *
 574 *                   if what(2) < 0:  |what(2)| = kinetic energy     *
 575 *                                                                   *
 576 *********************************************************************
 577
 578   130 CONTINUE
 579       EPN    = WHAT(1)
 580       PPN    = ZERO
 581       CMENER = ZERO
 582       IF ((ABS(WHAT(2)).GT.ZERO).AND.
 583      &    (ABS(WHAT(2)).GT.ABS(WHAT(1)))) THEN
 584          VARELO = WHAT(1)
 585          VAREHI = WHAT(2)
 586          EPN    = VAREHI
 587       ENDIF
 588       LEINP  = .TRUE.
 589       GOTO 10
 590
 591 *********************************************************************
 592 *                                                                   *
 593 *               control card:  codewd = MOMENTUM                    *
 594 *                                                                   *
 595 *       what (1) =  momentum (GeV/c) of projectile in Lab.          *
 596 *                                                default: 200 GeV/c *
 597 *       what (2..6), sdum   no meaning                              *
 598 *                                                                   *
 599 *********************************************************************
 600
 601   140 CONTINUE
 602       EPN    = ZERO
 603       PPN    = WHAT(1)
 604       CMENER = ZERO
 605       LEINP  = .TRUE.
 606       GOTO 10
 607
 608 *********************************************************************
 609 *                                                                   *
 610 *               control card:  codewd = CMENERGY                    *
 611 *                                                                   *
 612 *       what (1) =  energy in nucleon-nucleon cms.                  *
 613 *                                                default: none      *
 614 *       what (2..6), sdum   no meaning                              *
 615 *                                                                   *
 616 *********************************************************************
 617
 618   150 CONTINUE
 619       EPN    = ZERO
 620       PPN    = ZERO
 621       CMENER = WHAT(1)
 622       LEINP  = .TRUE.
 623       GOTO 10
 624
 625 *********************************************************************
 626 *                                                                   *
 627 *               control card:  codewd = EMULSION                    *
 628 *                                                                   *
 629 *               definition of nuclear emulsions                     *
 630 *                                                                   *
 631 *     what(1)      mass number of emulsion component                *
 632 *     what(2)      charge of emulsion component                     *
 633 *     what(3)      fraction of events in which a scattering on a    *
 634 *                  nucleus of this properties is performed          *
 635 *     what(4,5,6)  as what(1,2,3) but for another component         *
 636 *                                             default: no emulsion  *
 637 *     sdum         no meaning                                       *
 638 *                                                                   *
 639 *     Note: If this input-card is once used with valid parameters   *
 640 *           TARPAR is obsolete.                                     *
 641 *           Not the absolute values of the fractions are important  *
 642 *           but only the ratios of fractions of different comp.     *
 643 *           This control card can be repeatedly used to define      *
 644 *           emulsions consisting of up to 10 elements.              *
 645 *                                                                   *
 646 *********************************************************************
 647
 648   160 CONTINUE
 649       IF ((WHAT(1).GT.ZERO).AND.(WHAT(2).GT.ZERO)
 650      &                     .AND.(ABS(WHAT(3)).GT.ZERO)) THEN
 651          NCOMPO = NCOMPO+1
 652          IF (NCOMPO.GT.NCOMPX) THEN
 653             WRITE(LOUT,1600)
 654             STOP
 655          ENDIF
 656          IEMUMA(NCOMPO) = INT(WHAT(1))
 657          IEMUCH(NCOMPO) = INT(WHAT(2))
 658          EMUFRA(NCOMPO) = WHAT(3)
 659          IEMUL = 1
 660 C        CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
 661       ENDIF
 662       IF ((WHAT(4).GT.ZERO).AND.(WHAT(5).GT.ZERO)
 663      &                     .AND.(ABS(WHAT(6)).GT.ZERO)) THEN
 664          NCOMPO = NCOMPO+1
 665          IF (NCOMPO.GT.NCOMPX) THEN
 666             WRITE(LOUT,1001)
 667             STOP
 668          ENDIF
 669          IEMUMA(NCOMPO) = INT(WHAT(4))
 670          IEMUCH(NCOMPO) = INT(WHAT(5))
 671          EMUFRA(NCOMPO) = WHAT(6)
 672 C        CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
 673       ENDIF
 674  1600 FORMAT(1X,'too many emulsion components - program stopped')
 675       GOTO 10
 676
 677 *********************************************************************
 678 *                                                                   *
 679 *               control card:  codewd = FERMI                       *
 680 *                                                                   *
 681 *       what (1) = -1 Fermi-motion of nucleons not treated          *
 682 *                                                 default: 1        *
 683 *       what (2) =    scale factor for Fermi-momentum               *
 684 *                                                 default: 0.75     *
 685 *       what (3..6), sdum   no meaning                              *
 686 *                                                                   *
 687 *********************************************************************
 688
 689   170 CONTINUE
 690       IF (WHAT(1).EQ.-1.0D0) THEN
 691          LFERMI = .FALSE.
 692       ELSE
 693          LFERMI = .TRUE.
 694       ENDIF
 695       XMOD = WHAT(2)
 696       IF (XMOD.GE.ZERO) FERMOD = XMOD
 697       GOTO 10
 698
 699 *********************************************************************
 700 *                                                                   *
 701 *               control card:  codewd = TAUFOR                      *
 702 *                                                                   *
 703 *          formation time supressed intranuclear cascade            *
 704 *                                                                   *
 705 *    what (1)      formation time (in fm/c)                         *
 706 *                  note: what(1)=10. corresponds roughly to an      *
 707 *                        average formation time of 1 fm/c           *
 708 *                                                 default: 5. fm/c  *
 709 *    what (2)      number of generations followed                   *
 710 *                                                 default: 25       *
 711 *    what (3) = 1. p_t-dependent formation zone                     *
 712 *             = 2. constant formation zone                          *
 713 *                                                 default: 1        *
 714 *    what (4)      modus of selection of nucleus where the          *
 715 *                  cascade if followed first                        *
 716 *             = 1.  proj./target-nucleus with probab. 1/2           *
 717 *             = 2.  nucleus with highest mass                       *
 718 *             = 3.  proj. nucleus if particle is moving in pos. z   *
 719 *                   targ. nucleus if particle is moving in neg. z   *
 720 *                                                 default: 1        *
 721 *    what (5..6), sdum   no meaning                                 *
 722 *                                                                   *
 723 *********************************************************************
 724
 725   180 CONTINUE
 726       TAUFOR = WHAT(1)
 727       KTAUGE = INT(WHAT(2))
 728       INCMOD = 1
 729       IF ((WHAT(3).GE.1.0D0).AND.(WHAT(3).LE.2.0D0))
 730      &                                    ITAUVE = INT(WHAT(3))
 731       IF ((WHAT(4).GE.1.0D0).AND.(WHAT(4).LE.3.0D0))
 732      &                                    INCMOD = INT(WHAT(4))
 733       GOTO 10
 734
 735 *********************************************************************
 736 *                                                                   *
 737 *               control card:  codewd = PAULI                       *
 738 *                                                                   *
 739 *       what (1) =  -1  Pauli's principle for secondary             *
 740 *                       interactions not treated                    *
 741 *                                                    default: 1     *
 742 *       what (2..6), sdum   no meaning                              *
 743 *                                                                   *
 744 *********************************************************************
 745
 746   190 CONTINUE
 747       IF (WHAT(1).EQ.-1.0D0) THEN
 748          LPAULI = .FALSE.
 749       ELSE
 750          LPAULI = .TRUE.
 751       ENDIF
 752       GOTO 10
 753
 754 *********************************************************************
 755 *                                                                   *
 756 *               control card:  codewd = COULOMB                     *
 757 *                                                                   *
 758 *       what (1) = -1. Coulomb-energy treatment switched off        *
 759 *                                                    default: 1     *
 760 *       what (2..6), sdum   no meaning                              *
 761 *                                                                   *
 762 *********************************************************************
 763
 764   200 CONTINUE
 765       ICOUL = 1
 766       IF (WHAT(1).EQ.-1.0D0) THEN
 767          ICOUL = 0
 768       ELSE
 769          ICOUL = 1
 770       ENDIF
 771       GOTO 10
 772
 773 *********************************************************************
 774 *                                                                   *
 775 *               control card:  codewd = HADRIN                      *
 776 *                                                                   *
 777 *                       HADRIN module                               *
 778 *                                                                   *
 779 *    what (1) = 0. elastic/inelastic interactions with probab.      *
 780 *                  as defined by cross-sections                     *
 781 *             = 1. inelastic interactions forced                    *
 782 *             = 2. elastic interactions forced                      *
 783 *                                                 default: 1        *
 784 *    what (2)      upper threshold in total energy (GeV) below      *
 785 *                  which interactions are sampled by HADRIN         *
 786 *                                                 default: 5. GeV   *
 787 *    what (3..6), sdum   no meaning                                 *
 788 *                                                                   *
 789 *********************************************************************
 790
 791   210 CONTINUE
 792       IWHAT = INT(WHAT(1))
 793       IF ((IWHAT.GE.0).AND.(IWHAT.LE.2)) INTHAD = IWHAT
 794       IF ((WHAT(2).GT.ZERO).AND.(WHAT(2).LT.15.0D0)) EHADTH = WHAT(2)
 795       GOTO 10
 796
 797 *********************************************************************
 798 *                                                                   *
 799 *               control card:  codewd = EVAP                        *
 800 *                                                                   *
 801 *                    evaporation module                             *
 802 *                                                                   *
 803 *  what (1) =< -1 ==> evaporation is switched off                   *
 804 *           >=  1 ==> evaporation is performed                      *
 805 *                                                                   *
 806 *         what (1) = i1 + i2*10 + i3*100 + i4*10000                 *
 807 *                    (i1, i2, i3, i4 >= 0 )                         *
 808 *                                                                   *
 809 *   i1 is the flag for selecting the T=0 level density option used  *
 810 *      =  1: standard EVAP level densities with Cook pairing        *
 811 *            energies                                               *
 812 *      =  2: Z,N-dependent Gilbert & Cameron level densities        *
 813 *                                                        (default)  *
 814 *      =  3: Julich A-dependent level densities                     *
 815 *      =  4: Z,N-dependent Brancazio & Cameron level densities      *
 816 *                                                                   *
 817 *   i2 >= 1: high energy fission activated                          *
 818 *            (default high energy fission activated)                *
 819 *                                                                   *
 820 *   i3 =  0: No energy dependence for level densities               *
 821 *      =  1: Standard Ignyatuk (1975, 1st) energy dependence        *
 822 *            for level densities (default)                          *
 823 *      =  2: Standard Ignyatuk (1975, 1st) energy dependence        *
 824 *            for level densities with NOT used set of parameters    *
 825 *      =  3: Standard Ignyatuk (1975, 1st) energy dependence        *
 826 *            for level densities with NOT used set of parameters    *
 827 *      =  4: Second   Ignyatuk (1975, 2nd) energy dependence        *
 828 *            for level densities                                    *
 829 *      =  5: Second   Ignyatuk (1975, 2nd) energy dependence        *
 830 *            for level densities with fit 1 Iljinov & Mebel set of  *
 831 *            parameters                                             *
 832 *      =  6: Second   Ignyatuk (1975, 2nd) energy dependence        *
 833 *            for level densities with fit 2 Iljinov & Mebel set of  *
 834 *            parameters                                             *
 835 *      =  7: Second   Ignyatuk (1975, 2nd) energy dependence        *
 836 *            for level densities with fit 3 Iljinov & Mebel set of  *
 837 *            parameters                                             *
 838 *      =  8: Second   Ignyatuk (1975, 2nd) energy dependence        *
 839 *            for level densities with fit 4 Iljinov & Mebel set of  *
 840 *            parameters                                             *
 841 *                                                                   *
 842 *   i4 >= 1: Original Gilbert and Cameron pairing energies used     *
 843 *            (default Cook's modified pairing energies)             *
 844 *                                                                   *
 845 *  what (2) = ig + 10 * if   (ig and if must have the same sign)    *
 846 *                                                                   *
 847 *   ig =< -1 ==> deexcitation gammas are not produced               *
 848 *                (if the evaporation step is not performed          *
 849 *                 they are never produced)                          *
 850 *   if =< -1 ==> Fermi Break Up is not invoked                      *
 851 *                (if the evaporation step is not performed          *
 852 *                 it is never invoked)                              *
 853 *   The default is: deexcitation gamma produced and Fermi break up  *
 854 *                   activated for the new  preequilibrium, not      *
 855 *                   activated otherwise.                            *
 856 *  what (3..6), sdum   no meaning                                   *
 857 *                                                                   *
 858 *********************************************************************
 859
 860  220  CONTINUE
 861       IF (WHAT(1).LE.-1.0D0) THEN
 862          LEVPRT = .FALSE.
 863          LDEEXG = .FALSE.
 864          LHEAVY = .FALSE.
 865          GOTO 10
 866       ENDIF
 867       WHTSAV = WHAT (1)
 868       IF ( NINT (WHAT (1)) .GE. 10000 ) THEN
 869          LLVMOD   = .FALSE.
 870          JLVHLP   = NINT (WHAT (1)) / 10000
 871          WHAT (1) = WHAT (1) - 10000.D+00 * JLVHLP
 872       END IF
 873       IF ( NINT (WHAT (1)) .GE. 100 ) THEN
 874          JLVMOD   = NINT (WHAT (1)) / 100
 875          WHAT (1) = WHAT (1) - 100.D+00 * JLVMOD
 876       END IF
 877       IF ( NINT (WHAT (1)) .GE. 10  ) THEN
 878
 879          IEVFSS   = 1
 880
 881          JLVHLP   = NINT (WHAT (1)) / 10
 882          WHAT (1) = WHAT (1) - 10.D+00 * JLVHLP
 883       ELSE IF ( NINT (WHTSAV) .NE. 0 ) THEN
 884
 885          IEVFSS   = 0
 886
 887       END IF
 888       IF ( NINT (WHAT (1)) .GE. 0 ) THEN
 889          LEVPRT = .TRUE.
 890          ILVMOD = NINT (WHAT(1))
 891          IF ( ABS (NINT (WHAT (2))) .GE. 10  ) THEN
 892             LFRMBK   = .TRUE.
 893             JLVHLP   = NINT (WHAT (2)) / 10
 894             WHAT (2) = WHAT (2) - 10.D+00 * JLVHLP
 895          ELSE IF ( NINT (WHAT (2)) .NE. 0 ) THEN
 896             LFRMBK   = .FALSE.
 897          END IF
 898          IF ( NINT (WHAT (2)) .GE. 0 ) THEN
 899             LDEEXG = .TRUE.
 900          ELSE
 901             LDEEXG = .FALSE.
 902          END IF
 903 **sr heavies are always put to /FKFHVY/
 904 C        IF ( NINT (WHAT(3)) .GE. 1 ) THEN
 905 C           LHEAVY = .TRUE.
 906 C        ELSE
 907 C           LHEAVY = .FALSE.
 908 C        END IF
 909          LHEAVY = .TRUE.
 910       ELSE
 911          LEVPRT = .FALSE.
 912          LDEEXG = .FALSE.
 913          LHEAVY = .FALSE.
 914       END IF
 915
 916       LOLDEV = .FALSE.
 917
 918       GOTO 10
 919
 920 *********************************************************************
 921 *                                                                   *
 922 *               control card:  codewd = EMCCHECK                    *
 923 *                                                                   *
 924 *    extended energy-momentum / quantum-number conservation check   *
 925 *                                                                   *
 926 *       what (1) = -1   extended check not performed                *
 927 *                                                    default: 1.    *
 928 *       what (2..6), sdum   no meaning                              *
 929 *                                                                   *
 930 *********************************************************************
 931
 932   230 CONTINUE
 933       IF (WHAT(1).EQ.-1) THEN
 934          LEMCCK = .FALSE.
 935       ELSE
 936          LEMCCK = .TRUE.
 937       ENDIF
 938       GOTO 10
 939
 940 *********************************************************************
 941 *                                                                   *
 942 *               control card:  codewd = MODEL                       *
 943 *                                                                   *
 944 *     Model to be used to treat nucleon-nucleon interactions        *
 945 *                                                                   *
 946 *       sdum = DTUNUC    two-chain model                            *
 947 *            = PHOJET    multiple chains including minijets         *
 948 *            = LEPTO     DIS                                        *
 949 *            = QNEUTRIN  quasi-elastic neutrino scattering          *
 950 *                                                  default: PHOJET  *
 951 *                                                                   *
 952 *       if sdum = LEPTO:                                            *
 953 *       what (1)         (variable INTER)                           *
 954 *                        = 1  gamma exchange                        *
 955 *                        = 2  W+-   exchange                        *
 956 *                        = 3  Z0    exchange                        *
 957 *                        = 4  gamma/Z0 exchange                     *
 958 *                                                                   *
 959 *       if sdum = QNEUTRIN:                                         *
 960 *       what (1)         = 0  elastic scattering on nucleon and     *
 961 *                             tau does not decay (default)          *
 962 *                        = 1  decay of tau into mu..                *
 963 *                        = 2  decay of tau into e..                 *
 964 *                        = 10 CC events on p and n                  *
 965 *                        = 11 NC events on p and n                  *
 966 *                                                                   *
 967 *       what (2..6)      no meaning                                 *
 968 *                                                                   *
 969 *********************************************************************
 970
 971   240 CONTINUE
 972       IF (SDUM.EQ.CMODEL(1)) THEN
 973          MCGENE = 1
 974       ELSEIF (SDUM.EQ.CMODEL(2)) THEN
 975          MCGENE = 2
 976       ELSEIF (SDUM.EQ.CMODEL(3)) THEN
 977          MCGENE = 3
 978          IF ((WHAT(1).GE.1.0D0).AND.(WHAT(1).LE.4.0D0))
 979      &      INTER = INT(WHAT(1))
 980       ELSEIF (SDUM.EQ.CMODEL(4)) THEN
 981          MCGENE = 4
 982          IWHAT  = INT(WHAT(1))
 983          IF ((IWHAT.EQ.1 ).OR.(IWHAT.EQ.2 ).OR.
 984      &       (IWHAT.EQ.10).OR.(IWHAT.EQ.11))
 985      &      NEUDEC = IWHAT
 986       ELSE
 987          STOP ' Unknown model !'
 988       ENDIF
 989       GOTO 10
 990
 991 *********************************************************************
 992 *                                                                   *
 993 *               control card:  codewd = PHOINPUT                    *
 994 *                                                                   *
 995 *       Start of input-section for PHOJET-specific input-cards      *
 996 *       Note:  This section will not be finished before giving      *
 997 *              ENDINPUT-card                                        *
 998 *       what (1..6), sdum   no meaning                              *
 999 *                                                                   *
1000 *********************************************************************
1001
1002   250 CONTINUE
1003       IF (LPHOIN) THEN
1004
1005          CALL PHO_INIT(LINP,LOUT,IREJ1)
1006
1007          IF (IREJ1.NE.0) THEN
1008             WRITE(LOUT,'(1X,A)')'INIT:   reading PHOJET-input failed'
1009             STOP
1010          ENDIF
1011          LPHOIN = .FALSE.
1012       ENDIF
1013       GOTO 10
1014
1015 *********************************************************************
1016 *                                                                   *
1017 *               control card:  codewd = GLAUBERI                    *
1018 *                                                                   *
1019 *        Pre-initialization of impact parameter selection           *
1020 *                                                                   *
1021 *        what (1..6), sdum   no meaning                             *
1022 *                                                                   *
1023 *********************************************************************
1024
1025   260 CONTINUE
1026       IF (IFIRST.NE.99) THEN
1027          CALL DT_RNDMST(12,34,56,78)
1028          CALL DT_RNDMTE(1)
1029          OPEN(40,FILE='outdata0/shm.out',STATUS='UNKNOWN')
1030 C        OPEN(11,FILE='outdata0/shm.dbg',STATUS='UNKNOWN')
1031          IFIRST = 99
1032       ENDIF
1033
1034       IPPN = 8
1035       PLOW = 10.0D0
1036 C     IPPN = 1
1037 C     PLOW = 100.0D0
1038       PHI  = 1.0D5
1039       APLOW = LOG10(PLOW)
1040       APHI  = LOG10(PHI)
1041       ADP   = (APHI-APLOW)/DBLE(IPPN)
1042
1043       IPLOW = 1
1044       IDIP  = 1
1045       IIP   = 5
1046 C     IPLOW = 1
1047 C     IDIP  = 1
1048 C     IIP   = 1
1049       IPRANG(1) = 1
1050       IPRANG(2) = 2
1051       IPRANG(3) = 5
1052       IPRANG(4) = 10
1053       IPRANG(5) = 20
1054
1055       ITLOW = 30
1056       IDIT  = 3
1057       IIT   = 60
1058 C     IDIT  = 10
1059 C     IIT   = 21
1060
1061       DO 473 NCIT=1,IIT
1062          IT   = ITLOW+(NCIT-1)*IDIT
1063 C        IPHI = IT
1064 C        IDIP = 10
1065 C        IIP  = (IPHI-IPLOW)/IDIP
1066 C        IF (IIP.EQ.0) IIP = 1
1067 C        IF (IT.EQ.IPLOW) IIP = 0
1068
1069          DO 472 NCIP=1,IIP
1070             IP = IPRANG(NCIP)
1071 CC           IF (NCIP.LE.IIP) THEN
1072 C               IP = IPLOW+(NCIP-1)*IDIP
1073 CC           ELSE
1074 CC              IP = IT
1075 CC           ENDIF
1076             IF (IP.GT.IT) GOTO 472
1077
1078             DO 471 NCP=1,IPPN+1
1079                APPN = APLOW+DBLE(NCP-1)*ADP
1080                PPN  = 10**APPN
1081
1082                OPEN(12,FILE='outdata0/shm.sta',STATUS='UNKNOWN')
1083                WRITE(12,'(1X,2I5,E15.3)') IP,IT,PPN
1084                CLOSE(12)
1085
1086                XLIM1 = 0.0D0
1087                XLIM2 = 50.0D0
1088                XLIM3 = ZERO
1089                IBIN  = 50
1090                CALL DT_NEWHGR(XDUM,XDUM,XDUM,XDUMB,-1,IHDUM)
1091                CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHSHMA)
1092
1093                NEVFIT = 5
1094 C              IF ((IP.GT.10).OR.(IT.GT.10)) THEN
1095 C                 NEVFIT = 5
1096 C              ELSE
1097 C                 NEVFIT = 10
1098 C              ENDIF
1099                SIGAV  = 0.0D0
1100
1101                DO 478 I=1,NEVFIT
1102                   CALL DT_SHMAKI(IP,IDUM1,IT,IDUM1,IJPROJ,PPN,99)
1103                   SIGAV = SIGAV+XSPRO(1,1,1)
1104                   DO 479 J=1,50
1105                      XC = DBLE(J)
1106                      CALL DT_FILHGR(XC,BSITE(1,1,1,J),IHSHMA,I)
1107   479             CONTINUE
1108   478          CONTINUE
1109
1110                CALL DT_EVTHIS(IDUM)
1111                HEADER = ' BSITE'
1112 C              CALL OUTGEN(IHSHMA,0,0,0,0,0,HEADER,0,NEVFIT,ONE,0,1,-1)
1113
1114 C              CALL GENFIT(XPARA)
1115 C              WRITE(40,'(2I4,E11.3,F6.0,5E11.3)')
1116 C    &              IP,IT,PPN,SIGAV/DBLE(NEVFIT),XPARA
1117
1118   471       CONTINUE
1119
1120   472    CONTINUE
1121
1122   473 CONTINUE
1123
1124       STOP
1125
1126 *********************************************************************
1127 *                                                                   *
1128 *               control card:  codewd = FLUCTUAT                    *
1129 *                                                                   *
1130 *           Treatment of cross section fluctuations                 *
1131 *                                                                   *
1132 *       what (1) = 1  treat cross section fluctuations              *
1133 *                                                    default: 0.    *
1134 *       what (1..6), sdum   no meaning                              *
1135 *                                                                   *
1136 *********************************************************************
1137
1138  270  CONTINUE
1139       IFLUCT = 0
1140       IF (WHAT(1).EQ.ONE) THEN
1141          IFLUCT = 1
1142          CALL DT_FLUINI
1143       ENDIF
1144       GOTO 10
1145
1146 *********************************************************************
1147 *                                                                   *
1148 *               control card:  codewd = CENTRAL                     *
1149 *                                                                   *
1150 *       what (1) = 1.  central production forced     default: 0     *
1151 *  if what (1) < 0 and > -100                                       *
1152 *       what (2) = min. impact parameter             default: 0     *
1153 *       what (3) = max. impact parameter             default: b_max *
1154 *  if what (1) < -99                                                *
1155 *       what (2) = fraction of cross section         default: 1     *
1156 *  if what (1) = -1 : evaporation/fzc suppressed                    *
1157 *  if what (1) < -1 : evaporation/fzc allowed                       *
1158 *                                                                   *
1159 *       what (4..6), sdum   no meaning                              *
1160 *                                                                   *
1161 *********************************************************************
1162
1163   280 CONTINUE
1164       ICENTR = INT(WHAT(1))
1165       IF (ICENTR.LT.0) THEN
1166          IF (ICENTR.GT.-100) THEN
1167             BIMIN = WHAT(2)
1168             BIMAX = WHAT(3)
1169          ELSE
1170             XSFRAC = WHAT(2)
1171          ENDIF
1172       ENDIF
1173       GOTO 10
1174
1175 *********************************************************************
1176 *                                                                   *
1177 *               control card:  codewd = RECOMBIN                    *
1178 *                                                                   *
1179 *                     Chain recombination                           *
1180 *        (recombine S-S and V-V chains to V-S chains)               *
1181 *                                                                   *
1182 *       what (1) = -1. recombination switched off    default: 1     *
1183 *       what (2..6), sdum   no meaning                              *
1184 *                                                                   *
1185 *********************************************************************
1186
1187   290 CONTINUE
1188       IRECOM = 1
1189       IF (WHAT(1).EQ.-1.0D0) IRECOM = 0
1190       GOTO 10
1191
1192 *********************************************************************
1193 *                                                                   *
1194 *               control card:  codewd = COMBIJET                    *
1195 *                                                                   *
1196 *               chain fusion (2 q-aq --> qq-aqaq)                   *
1197 *                                                                   *
1198 *       what (1) = 1   fusion treated                               *
1199 *                                                    default: 0.    *
1200 *       what (2)       minimum number of uncombined chains from     *
1201 *                      single projectile or target nucleons         *
1202 *                                                    default: 0.    *
1203 *       what (3..6), sdum   no meaning                              *
1204 *                                                                   *
1205 *********************************************************************
1206
1207   300 CONTINUE
1208       LCO2CR = .FALSE.
1209       IF (INT(WHAT(1)).EQ.1) LCO2CR = .TRUE.
1210       IF (WHAT(2).GE.ZERO) CUTOF = WHAT(2)
1211       GOTO 10
1212
1213 *********************************************************************
1214 *                                                                   *
1215 *               control card:  codewd = XCUTS                       *
1216 *                                                                   *
1217 *                 thresholds for x-sampling                         *
1218 *                                                                   *
1219 *    what (1)    defines lower threshold for val.-q x-value (CVQ)   *
1220 *                                                 default: 1.       *
1221 *    what (2)    defines lower threshold for val.-qq x-value (CDQ)  *
1222 *                                                 default: 2.       *
1223 *    what (3)    defines lower threshold for sea-q x-value (CSEA)   *
1224 *                                                 default: 0.2      *
1225 *    what (4)    sea-q x-values in S-S chains (SSMIMA)              *
1226 *                                                 default: 0.14     *
1227 *    what (5)    not used                                           *
1228 *                                                 default: 2.       *
1229 *    what (6), sdum   no meaning                                    *
1230 *                                                                   *
1231 *    Note: Lower thresholds (what(1..3)) are def. as x_thr=CXXX/ECM *
1232 *                                                                   *
1233 *********************************************************************
1234
1235   310 CONTINUE
1236       IF (WHAT(1).GE.0.5D0) CVQ    = WHAT(1)
1237       IF (WHAT(2).GE.ONE)   CDQ    = WHAT(2)
1238       IF (WHAT(3).GE.0.1D0) CSEA   = WHAT(3)
1239       IF (WHAT(4).GE.ZERO) THEN
1240          SSMIMA = WHAT(4)
1241          SSMIMQ = SSMIMA**2
1242       ENDIF
1243       IF (WHAT(5).GT.2.0D0) VVMTHR = WHAT(5)
1244       GOTO 10
1245
1246 *********************************************************************
1247 *                                                                   *
1248 *               control card:  codewd = INTPT                       *
1249 *                                                                   *
1250 *     what (1) = -1   intrinsic transverse momenta of partons       *
1251 *                     not treated                default: 1         *
1252 *     what (2..6), sdum   no meaning                                *
1253 *                                                                   *
1254 *********************************************************************
1255
1256   320 CONTINUE
1257       IF (WHAT(1).EQ.-1.0D0) THEN
1258          LINTPT = .FALSE.
1259       ELSE
1260          LINTPT = .TRUE.
1261       ENDIF
1262       GOTO 10
1263
1264 *********************************************************************
1265 *                                                                   *
1266 *               control card:  codewd = CRONINPT                    *
1267 *                                                                   *
1268 *    Cronin effect (multiple scattering of partons at chain ends)   *
1269 *                                                                   *
1270 *       what (1) = -1  Cronin effect not treated     default: 1     *
1271 *       what (2) = 0   scattering parameter          default: 0.64  *
1272 *       what (3..6), sdum   no meaning                              *
1273 *                                                                   *
1274 *********************************************************************
1275
1276   330 CONTINUE
1277       IF (WHAT(1).EQ.-1.0D0) THEN
1278          MKCRON = 0
1279       ELSE
1280          MKCRON = 1
1281       ENDIF
1282       CRONCO = WHAT(2)
1283       GOTO 10
1284
1285 *********************************************************************
1286 *                                                                   *
1287 *               control card:  codewd = SEADISTR                    *
1288 *                                                                   *
1289 *     what (1)  (XSEACO)  sea(x) prop. 1/x**what (1)   default: 1.  *
1290 *     what (2)  (UNON)                                 default: 2.  *
1291 *     what (3)  (UNOM)                                 default: 1.5 *
1292 *     what (4)  (UNOSEA)                               default: 5.  *
1293 *                        qdis(x) prop. (1-x)**what (1)  etc.        *
1294 *     what (5..6), sdum   no meaning                                *
1295 *                                                                   *
1296 *********************************************************************
1297
1298   340 CONTINUE
1299       XSEACO = WHAT(1)
1300       XSEACU = 1.05D0-XSEACO
1301       UNON   = WHAT(2)
1302       IF (UNON.LT.0.1D0) UNON = 2.0D0
1303       UNOM   = WHAT(3)
1304       IF (UNOM.LT.0.1D0) UNOM = 1.5D0
1305       UNOSEA = WHAT(4)
1306       IF (UNOSEA.LT.0.1D0) UNOSEA = 5.0D0
1307       GOTO 10
1308
1309 *********************************************************************
1310 *                                                                   *
1311 *               control card:  codewd = SEASU3                      *
1312 *                                                                   *
1313 *          Treatment of strange-quarks at chain ends                *
1314 *                                                                   *
1315 *       what (1)   (SEASQ)  strange-quark supression factor         *
1316 *                  iflav = 1.+rndm*(2.+SEASQ)                       *
1317 *                                                    default: 1.    *
1318 *       what (2..6), sdum   no meaning                              *
1319 *                                                                   *
1320 *********************************************************************
1321
1322   350 CONTINUE
1323       SEASQ = WHAT(1)
1324       GOTO 10
1325
1326 *********************************************************************
1327 *                                                                   *
1328 *               control card:  codewd = DIQUARKS                    *
1329 *                                                                   *
1330 *     what (1) = -1.  sea-diquark/antidiquark-pairs not treated     *
1331 *                                                    default: 1.    *
1332 *     what (2..6), sdum   no meaning                                *
1333 *                                                                   *
1334 *********************************************************************
1335
1336  360  CONTINUE
1337       IF (WHAT(1).EQ.-1.0D0) THEN
1338          LSEADI = .FALSE.
1339       ELSE
1340          LSEADI = .TRUE.
1341       ENDIF
1342       GOTO 10
1343
1344 *********************************************************************
1345 *                                                                   *
1346 *               control card:  codewd = RESONANC                    *
1347 *                                                                   *
1348 *                 treatment of low mass chains                      *
1349 *                                                                   *
1350 *    what (1) = -1 low chain masses are not corrected for resonance *
1351 *                  masses (obsolete for BAMJET-fragmentation)       *
1352 *                                       default: 1.                 *
1353 *    what (2) = -1 massless partons     default: 1. (massive)       *
1354 *                                       default: 1. (massive)       *
1355 *    what (3) = -1 chain-system containing chain of too small       *
1356 *                  mass is rejected (note: this does not fully      *
1357 *                  apply to S-S chains) default: 0.                 *
1358 *    what (4..6), sdum   no meaning                                 *
1359 *                                                                   *
1360 *********************************************************************
1361
1362   370 CONTINUE
1363       IRESCO = 1
1364       IMSHL  = 1
1365       IRESRJ = 0
1366       IF (WHAT(1).EQ.-ONE) IRESCO = 0
1367       IF (WHAT(2).EQ.-ONE) IMSHL  = 0
1368       IF (WHAT(3).EQ.-ONE) IRESRJ = 1
1369       GOTO 10
1370
1371 *********************************************************************
1372 *                                                                   *
1373 *               control card:  codewd = DIFFRACT                    *
1374 *                                                                   *
1375 *                Treatment of diffractive events                    *
1376 *                                                                   *
1377 *     what (1) = (ISINGD) 0  no single diffraction                  *
1378 *                         1  single diffraction included            *
1379 *                       +-2  single diffractive events only         *
1380 *                       +-3  projectile single diffraction only     *
1381 *                       +-4  target single diffraction only         *
1382 *                        -5  double pomeron exchange only           *
1383 *                      (neg. sign applies to PHOJET events)         *
1384 *                                                     default: 0.   *
1385 *                                                                   *
1386 *     what (2) = (IDOUBD) 0  no double diffraction                  *
1387 *                         1  double diffraction included            *
1388 *                         2  double diffractive events only         *
1389 *                                                     default: 0.   *
1390 *     what (3) = 1 projectile diffraction treated (2-channel form.) *
1391 *                                                     default: 0.   *
1392 *     what (4) = alpha-parameter in projectile diffraction          *
1393 *                                                     default: 0.   *
1394 *     what (5..6), sdum   no meaning                                *
1395 *                                                                   *
1396 *********************************************************************
1397
1398   380 CONTINUE
1399       IF (ABS(WHAT(1)).GT.ZERO) ISINGD = INT(WHAT(1))
1400       IF (ABS(WHAT(2)).GT.ZERO) IDOUBD = INT(WHAT(2))
1401       IF ((ISINGD.GT.1).AND.(IDOUBD.GT.1)) THEN
1402          WRITE(LOUT,1380)
1403  1380    FORMAT(1X,'INIT:   inconsistent DIFFRACT - input !',/,
1404      &          11X,'IDOUBD is reset to zero')
1405          IDOUBD = 0
1406       ENDIF
1407       IF (WHAT(3).GT.ZERO) DIBETA = WHAT(3)
1408       IF (WHAT(4).GT.ZERO) DIALPH = WHAT(4)
1409       GOTO 10
1410
1411 *********************************************************************
1412 *                                                                   *
1413 *               control card:  codewd = SINGLECH                    *
1414 *                                                                   *
1415 *       what (1) = 1.  Regge contribution (one chain) included      *
1416 *                                                   default: 0.     *
1417 *       what (2..6), sdum   no meaning                              *
1418 *                                                                   *
1419 *********************************************************************
1420
1421  390  CONTINUE
1422       ISICHA = 0
1423       IF (WHAT(1).EQ.ONE) ISICHA = 1
1424       GOTO 10
1425
1426 *********************************************************************
1427 *                                                                   *
1428 *               control card:  codewd = NOFRAGME                    *
1429 *                                                                   *
1430 *                 biased chain hadronization                        *
1431 *                                                                   *
1432 *       what (1..6) = -1  no of hadronizsation of S-S chains        *
1433 *                   = -2  no of hadronizsation of D-S chains        *
1434 *                   = -3  no of hadronizsation of S-D chains        *
1435 *                   = -4  no of hadronizsation of S-V chains        *
1436 *                   = -5  no of hadronizsation of D-V chains        *
1437 *                   = -6  no of hadronizsation of V-S chains        *
1438 *                   = -7  no of hadronizsation of V-D chains        *
1439 *                   = -8  no of hadronizsation of V-V chains        *
1440 *                   = -9  no of hadronizsation of comb. chains      *
1441 *                                  default:  complete hadronization *
1442 *       sdum   no meaning                                           *
1443 *                                                                   *
1444 *********************************************************************
1445
1446   400 CONTINUE
1447       DO 401 I=1,6
1448          ICHAIN = INT(WHAT(I))
1449          IF ((ICHAIN.LE.-1).AND.(ICHAIN.GE.-9))
1450      &      LHADRO(ABS(ICHAIN)) = .FALSE.
1451   401 CONTINUE
1452       GOTO 10
1453
1454 *********************************************************************
1455 *                                                                   *
1456 *               control card:  codewd = HADRONIZE                   *
1457 *                                                                   *
1458 *           hadronization model and parameter switch                *
1459 *                                                                   *
1460 *       what (1) = 1    hadronization via BAMJET                    *
1461 *                = 2    hadronization via JETSET                    *
1462 *                                                    default: 2     *
1463 *       what (2) = 1..3 parameter set to be used                    *
1464 *                       JETSET: 3 sets available                    *
1465 *                               ( = 3 default JETSET-parameters)    *
1466 *                       BAMJET: 1 set available                     *
1467 *                                                    default: 1     *
1468 *       what (3..6), sdum   no meaning                              *
1469 *                                                                   *
1470 *********************************************************************
1471
1472   410 CONTINUE
1473       IWHAT1 = INT(WHAT(1))
1474       IWHAT2 = INT(WHAT(2))
1475       IF ((IWHAT1.EQ.1).OR.(IWHAT1.EQ.2)) IFRAG(1) = IWHAT1
1476       IF ((IWHAT1.EQ.2).AND.(IWHAT2.GE.1).AND.(IWHAT2.LE.3))
1477      &                                    IFRAG(2) = IWHAT2
1478       GOTO 10
1479
1480 *********************************************************************
1481 *                                                                   *
1482 *               control card:  codewd = POPCORN                     *
1483 *                                                                   *
1484 *  "Popcorn-effect" in fragmentation and diquark breaking diagrams  *
1485 *                                                                   *
1486 *   what (1) = (PDB) frac. of diquark fragmenting directly into     *
1487 *                    baryons (PYTHIA/JETSET fragmentation)          *
1488 *                    (JETSET: = 0. Popcorn mechanism switched off)  *
1489 *                                                    default: 0.5   *
1490 *   what (2) = probability for accepting a diquark breaking         *
1491 *              diagram involving the generation of a u/d quark-     *
1492 *              antiquark pair                        default: 0.0   *
1493 *   what (3) = same a what (2), here for s quark-antiquark pair     *
1494 *                                                    default: 0.0   *
1495 *   what (4..6), sdum   no meaning                                  *
1496 *                                                                   *
1497 *********************************************************************
1498
1499   420 CONTINUE
1500       IF (WHAT(1).GE.0.0D0) PDB = WHAT(1)
1501       IF (WHAT(2).GE.0.0D0) THEN
1502          PDBSEA(1) = WHAT(2)
1503          PDBSEA(2) = WHAT(2)
1504       ENDIF
1505       IF (WHAT(3).GE.0.0D0) PDBSEA(3) = WHAT(3)
1506       DO 421 I=1,8
1507          DBRKA(1,I) = DBRKR(1,I)*PDBSEA(1)/(1.D0-PDBSEA(1))
1508          DBRKA(2,I) = DBRKR(2,I)*PDBSEA(2)/(1.D0-PDBSEA(2))
1509          DBRKA(3,I) = DBRKR(3,I)*PDBSEA(3)/(1.D0-PDBSEA(3))
1510   421 CONTINUE
1511       GOTO 10
1512
1513 *********************************************************************
1514 *                                                                   *
1515 *               control card:  codewd = PARDECAY                    *
1516 *                                                                   *
1517 *      what (1) = 1.  Sigma0/Asigma0 are decaying within JETSET     *
1518 *               = 2.  pion^0 decay after intranucl. cascade         *
1519 *                                                default: no decay  *
1520 *      what (2..6), sdum   no meaning                               *
1521 *                                                                   *
1522 *********************************************************************
1523
1524  430  CONTINUE
1525       IF (WHAT(1).EQ.ONE)  ISIG0 = 1
1526       IF (WHAT(1).EQ.2.0D0) IPI0 = 1
1527       GOTO 10
1528
1529 *********************************************************************
1530 *                                                                   *
1531 *               control card:  codewd = BEAM                        *
1532 *                                                                   *
1533 *              definition of beam parameters                        *
1534 *                                                                   *
1535 *      what (1/2)  > 0 : energy of beam 1/2 (GeV)                   *
1536 *                  < 0 : abs(what(1/2)) energy per charge of        *
1537 *                        beam 1/2 (GeV)                             *
1538 *                  (beam 1 is directed into positive z-direction)   *
1539 *      what (3)    beam crossing angle, defined as 2x angle between *
1540 *                  one beam and the z-axis (micro rad)              *
1541 *      what (4)    angle with x-axis defining the collision plane   *
1542 *      what (5..6), sdum   no meaning                               *
1543 *                                                                   *
1544 *      Note: this card requires previously defined projectile and   *
1545 *            target identities (PROJPAR, TARPAR)                    *
1546 *                                                                   *
1547 *********************************************************************
1548
1549   440 CONTINUE
1550       CALL DT_BEAMPR(WHAT,PPN,1)
1551       EPN    = ZERO
1552       CMENER = ZERO
1553       LEINP  = .TRUE.
1554       GOTO 10
1555
1556 *********************************************************************
1557 *                                                                   *
1558 *               control card:  codewd = LUND-MSTU                   *
1559 *                                                                   *
1560 *          set parameter MSTU in JETSET-common /LUDAT1/             *
1561 *                                                                   *
1562 *       what (1) =  index according to LUND-common block            *
1563 *       what (2) =  new value of MSTU( int(what(1)) )               *
1564 *       what (3), what(4) and what (5), what(6) further             *
1565 *                   parameter in the same way as what (1) and       *
1566 *                   what (2)                                        *
1567 *                        default: default-Lund or corresponding to  *
1568 *                                 the set given in HADRONIZE        *
1569 *                                                                   *
1570 *********************************************************************
1571
1572   450 CONTINUE
1573       IF (WHAT(1).GT.ZERO) THEN
1574          NMSTU = NMSTU+1
1575          IMSTU(NMSTU) = INT(WHAT(1))
1576          MSTUX(NMSTU) = INT(WHAT(2))
1577       ENDIF
1578       IF (WHAT(3).GT.ZERO) THEN
1579          NMSTU = NMSTU+1
1580          IMSTU(NMSTU) = INT(WHAT(3))
1581          MSTUX(NMSTU) = INT(WHAT(4))
1582       ENDIF
1583       IF (WHAT(5).GT.ZERO) THEN
1584          NMSTU = NMSTU+1
1585          IMSTU(NMSTU) = INT(WHAT(5))
1586          MSTUX(NMSTU) = INT(WHAT(6))
1587       ENDIF
1588       GOTO 10
1589
1590 *********************************************************************
1591 *                                                                   *
1592 *               control card:  codewd = LUND-MSTJ                   *
1593 *                                                                   *
1594 *          set parameter MSTJ in JETSET-common /LUDAT1/             *
1595 *                                                                   *
1596 *       what (1) =  index according to LUND-common block            *
1597 *       what (2) =  new value of MSTJ( int(what(1)) )               *
1598 *       what (3), what(4) and what (5), what(6) further             *
1599 *                   parameter in the same way as what (1) and       *
1600 *                   what (2)                                        *
1601 *                        default: default-Lund or corresponding to  *
1602 *                                 the set given in HADRONIZE        *
1603 *                                                                   *
1604 *********************************************************************
1605
1606   451 CONTINUE
1607       IF (WHAT(1).GT.ZERO) THEN
1608          NMSTJ = NMSTJ+1
1609          IMSTJ(NMSTJ) = INT(WHAT(1))
1610          MSTJX(NMSTJ) = INT(WHAT(2))
1611       ENDIF
1612       IF (WHAT(3).GT.ZERO) THEN
1613          NMSTJ = NMSTJ+1
1614          IMSTJ(NMSTJ) = INT(WHAT(3))
1615          MSTJX(NMSTJ) = INT(WHAT(4))
1616       ENDIF
1617       IF (WHAT(5).GT.ZERO) THEN
1618          NMSTJ = NMSTJ+1
1619          IMSTJ(NMSTJ) = INT(WHAT(5))
1620          MSTJX(NMSTJ) = INT(WHAT(6))
1621       ENDIF
1622       GOTO 10
1623
1624 *********************************************************************
1625 *                                                                   *
1626 *               control card:  codewd = LUND-MDCY                   *
1627 *                                                                   *
1628 *  set parameter MDCY(I,1) for particle decays in JETSET-common     *
1629 *                                                      /LUDAT3/     *
1630 *                                                                   *
1631 *       what (1-6) = PDG particle index of particle which should    *
1632 *                    not decay                                      *
1633 *                        default: default-Lund or forced in         *
1634 *                                 DT_INITJS                         *
1635 *                                                                   *
1636 *********************************************************************
1637
1638   452 CONTINUE
1639       DO 4521 I=1,6
1640          IF (WHAT(I).NE.ZERO) THEN
1641
1642             KC = PYCOMP(INT(WHAT(I)))
1643
1644             MDCY(KC,1) = 0
1645          ENDIF
1646  4521 CONTINUE
1647       GOTO 10
1648
1649 *********************************************************************
1650 *                                                                   *
1651 *               control card:  codewd = LUND-PARJ                   *
1652 *                                                                   *
1653 *          set parameter PARJ in JETSET-common /LUDAT1/             *
1654 *                                                                   *
1655 *       what (1) =  index according to LUND-common block            *
1656 *       what (2) =  new value of PARJ( int(what(1)) )               *
1657 *       what (3), what(4) and what (5), what(6) further             *
1658 *                   parameter in the same way as what (1) and       *
1659 *                   what (2)                                        *
1660 *                        default: default-Lund or corresponding to  *
1661 *                                 the set given in HADRONIZE        *
1662 *                                                                   *
1663 *********************************************************************
1664
1665   460 CONTINUE
1666       IF (WHAT(1).NE.ZERO) THEN
1667          NPARJ = NPARJ+1
1668          IPARJ(NPARJ) = INT(WHAT(1))
1669          PARJX(NPARJ) = WHAT(2)
1670       ENDIF
1671       IF (WHAT(3).NE.ZERO) THEN
1672          NPARJ = NPARJ+1
1673          IPARJ(NPARJ) = INT(WHAT(3))
1674          PARJX(NPARJ) = WHAT(4)
1675       ENDIF
1676       IF (WHAT(5).NE.ZERO) THEN
1677          NPARJ = NPARJ+1
1678          IPARJ(NPARJ) = INT(WHAT(5))
1679          PARJX(NPARJ) = WHAT(6)
1680       ENDIF
1681       GOTO 10
1682
1683 *********************************************************************
1684 *                                                                   *
1685 *               control card:  codewd = LUND-PARU                   *
1686 *                                                                   *
1687 *          set parameter PARJ in JETSET-common /LUDAT1/             *
1688 *                                                                   *
1689 *       what (1) =  index according to LUND-common block            *
1690 *       what (2) =  new value of PARU( int(what(1)) )               *
1691 *       what (3), what(4) and what (5), what(6) further             *
1692 *                   parameter in the same way as what (1) and       *
1693 *                   what (2)                                        *
1694 *                        default: default-Lund or corresponding to  *
1695 *                                 the set given in HADRONIZE        *
1696 *                                                                   *
1697 *********************************************************************
1698
1699   470 CONTINUE
1700       IF (WHAT(1).GT.ZERO) THEN
1701          NPARU = NPARU+1
1702          IPARU(NPARU) = INT(WHAT(1))
1703          PARUX(NPARU) = WHAT(2)
1704       ENDIF
1705       IF (WHAT(3).GT.ZERO) THEN
1706          NPARU = NPARU+1
1707          IPARU(NPARU) = INT(WHAT(3))
1708          PARUX(NPARU) = WHAT(4)
1709       ENDIF
1710       IF (WHAT(5).GT.ZERO) THEN
1711          NPARU = NPARU+1
1712          IPARU(NPARU) = INT(WHAT(5))
1713          PARUX(NPARU) = WHAT(6)
1714       ENDIF
1715       GOTO 10
1716
1717 *********************************************************************
1718 *                                                                   *
1719 *               control card:  codewd = OUTLEVEL                    *
1720 *                                                                   *
1721 *                    output control switches                        *
1722 *                                                                   *
1723 *       what (1) =  internal rejection informations  default: 0     *
1724 *       what (2) =  energy-momentum conservation check output       *
1725 *                                                    default: 0     *
1726 *       what (3) =  internal warning messages        default: 0     *
1727 *       what (4..6), sdum    not yet used                           *
1728 *                                                                   *
1729 *********************************************************************
1730
1731   480 CONTINUE
1732       DO 481 K=1,6
1733          IOULEV(K) = INT(WHAT(K))
1734   481 CONTINUE
1735       GOTO 10
1736
1737 *********************************************************************
1738 *                                                                   *
1739 *               control card:  codewd = FRAME                       *
1740 *                                                                   *
1741 *          frame in which final state is given in DTEVT1            *
1742 *                                                                   *
1743 *       what (1) = 1  target rest frame (laboratory)                *
1744 *                = 2  nucleon-nucleon cms                           *
1745 *                                                    default: 1     *
1746 *                                                                   *
1747 *********************************************************************
1748
1749   490 CONTINUE
1750       KFRAME = INT(WHAT(1))
1751       IF ((KFRAME.GE.1).AND.(KFRAME.LE.2)) IFRAME = KFRAME
1752       GOTO 10
1753
1754 *********************************************************************
1755 *                                                                   *
1756 *               control card:  codewd = L-TAG                       *
1757 *                                                                   *
1758 *                        lepton tagger:                             *
1759 *   definition of kinematical cuts for radiated photon and          *
1760 *   outgoing lepton detection in lepton-nucleus interactions        *
1761 *                                                                   *
1762 *       what (1) = y_min                                            *
1763 *       what (2) = y_max                                            *
1764 *       what (3) = Q^2_min                                          *
1765 *       what (4) = Q^2_max                                          *
1766 *       what (5) = theta_min  (Lab)                                 *
1767 *       what (6) = theta_max  (Lab)                                 *
1768 *                                       default: no cuts            *
1769 *       sdum    no meaning                                          *
1770 *                                                                   *
1771 *********************************************************************
1772
1773   500 CONTINUE
1774       YMIN  = WHAT(1)
1775       YMAX  = WHAT(2)
1776       Q2MIN = WHAT(3)
1777       Q2MAX = WHAT(4)
1778       THMIN = WHAT(5)
1779       THMAX = WHAT(6)
1780       GOTO 10
1781
1782 *********************************************************************
1783 *                                                                   *
1784 *               control card:  codewd = L-ETAG                      *
1785 *                                                                   *
1786 *                        lepton tagger:                             *
1787 *       what (1) = min. outgoing lepton energy  (in Lab)            *
1788 *       what (2) = min. photon energy           (in Lab)            *
1789 *       what (3) = max. photon energy           (in Lab)            *
1790 *                                       default: no cuts            *
1791 *       what (2..6), sdum    no meaning                             *
1792 *                                                                   *
1793 *********************************************************************
1794
1795   510 CONTINUE
1796       ELMIN = MAX(WHAT(1),ZERO)
1797       EGMIN = MAX(WHAT(2),ZERO)
1798       EGMAX = MAX(WHAT(3),ZERO)
1799       GOTO 10
1800
1801 *********************************************************************
1802 *                                                                   *
1803 *               control card:  codewd = ECMS-CUT                    *
1804 *                                                                   *
1805 *     what (1) = min. c.m. energy to be sampled                     *
1806 *     what (2) = max. c.m. energy to be sampled                     *
1807 *     what (3) = min x_Bj         to be sampled                     *
1808 *                                       default: no cuts            *
1809 *     what (3..6), sdum    no meaning                               *
1810 *                                                                   *
1811 *********************************************************************
1812
1813   520 CONTINUE
1814       ECMIN  = WHAT(1)
1815       ECMAX  = WHAT(2)
1816       IF (ECMIN.GT.ECMAX) ECMIN = ECMAX
1817       XBJMIN = MAX(WHAT(3),ZERO)
1818       GOTO 10
1819
1820 *********************************************************************
1821 *                                                                   *
1822 *               control card:  codewd = VDM-PAR1                    *
1823 *                                                                   *
1824 *      parameters in gamma-nucleus cross section calculation        *
1825 *                                                                   *
1826 *       what (1) =  Lambda^2                       default: 2.      *
1827 *       what (2)    lower limit in M^2 integration                  *
1828 *                =  1  (3m_pi)^2                                    *
1829 *                =  2  (m_rho0)^2                                   *
1830 *                =  3  (m_phi)^2                   default: 1       *
1831 *       what (3)    upper limit in M^2 integration                  *
1832 *                =  1   s/2                                         *
1833 *                =  2   s/4                                         *
1834 *                =  3   s                          default: 3       *
1835 *       what (4)    CKMT F_2 structure function                     *
1836 *                =  2212  proton                                    *
1837 *                =  100   deuteron                 default: 2212    *
1838 *       what (5)    calculation of gamma-nucleon xsections          *
1839 *                =  1  according to CKMT-parametrization of F_2     *
1840 *                =  2  integrating SIGVP over M^2                   *
1841 *                =  3  using SIGGA                                  *
1842 *                =  4  PHOJET cross sections       default:  4      *
1843 *                                                                   *
1844 *       what (6), sdum    no meaning                                *
1845 *                                                                   *
1846 *********************************************************************
1847
1848   530 CONTINUE
1849       IF (WHAT(1).GE.ZERO) RL2 = WHAT(1)
1850       IF ((WHAT(2).GE.1).AND.(WHAT(2).LE.3)) INTRGE(1) = INT(WHAT(2))
1851       IF ((WHAT(3).GE.1).AND.(WHAT(3).LE.3)) INTRGE(2) = INT(WHAT(3))
1852       IF ((WHAT(4).EQ.2212).OR.(WHAT(4).EQ.100)) IDPDF = INT(WHAT(4))
1853       IF ((WHAT(5).GE.1).AND.(WHAT(5).LE.4)) MODEGA = INT(WHAT(5))
1854       GOTO 10
1855
1856 *********************************************************************
1857 *                                                                   *
1858 *               control card:  codewd = HISTOGRAM                   *
1859 *                                                                   *
1860 *           activate different classes of histograms                *
1861 *                                                                   *
1862 *                                default: no histograms             *
1863 *                                                                   *
1864 *********************************************************************
1865
1866   540 CONTINUE
1867       DO 541 J=1,6
1868          IF ((WHAT(J).GE.100).AND.(WHAT(J).LE.150)) THEN
1869             IHISPP(INT(WHAT(J))-100) = 1
1870          ELSEIF ((ABS(WHAT(J)).GE.200).AND.(ABS(WHAT(J)).LE.250)) THEN
1871             IHISXS(INT(ABS(WHAT(J)))-200) = 1
1872             IF (WHAT(J).LT.ZERO) IXSTBL = 1
1873          ENDIF
1874   541 CONTINUE
1875       GOTO 10
1876
1877 *********************************************************************
1878 *                                                                   *
1879 *               control card:  codewd = XS-TABLE                    *
1880 *                                                                   *
1881 *    output of cross section table for requested interaction        *
1882 *              - particle production deactivated ! -                *
1883 *                                                                   *
1884 *       what (1)      lower energy limit for tabulation             *
1885 *                > 0  Lab. frame                                    *
1886 *                < 0  nucleon-nucleon cms                           *
1887 *       what (2)      upper energy limit for tabulation             *
1888 *                > 0  Lab. frame                                    *
1889 *                < 0  nucleon-nucleon cms                           *
1890 *       what (3) > 0  # of equidistant lin. bins in E               *
1891 *                < 0  # of equidistant log. bins in E               *
1892 *       what (4)      lower limit of particle virtuality (photons)  *
1893 *       what (5)      upper limit of particle virtuality (photons)  *
1894 *       what (6) > 0  # of equidistant lin. bins in Q^2             *
1895 *                < 0  # of equidistant log. bins in Q^2             *
1896 *                                                                   *
1897 *********************************************************************
1898
1899   550 CONTINUE
1900       IF (WHAT(1).EQ.99999.0D0) THEN
1901          IRATIO = INT(WHAT(2))
1902          GOTO 10
1903       ENDIF
1904       CMENER = ABS(WHAT(2))
1905       IF (.NOT.LXSTAB) THEN
1906
1907          CALL NCDTRD
1908          CALL INCINI
1909
1910       ENDIF
1911       IF ((.NOT.LXSTAB).OR.(CMENER.NE.CMEOLD)) THEN
1912          CMEOLD = CMENER
1913          IF (WHAT(2).GT.ZERO)
1914      &      CMENER = SQRT(2.0D0*AAM(1)**2+2.0D0*WHAT(2)*AAM(1))
1915          EPN = ZERO
1916          PPN = ZERO
1917 C        WRITE(LOUT,*) 'CMENER = ',CMENER
1918          CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,CMENER,1)
1919          CALL DT_PHOINI
1920       ENDIF
1921       CALL DT_XSTABL(WHAT,IXSQEL,IRATIO)
1922       IXSQEL = 0
1923       LXSTAB = .TRUE.
1924       GOTO 10
1925
1926 *********************************************************************
1927 *                                                                   *
1928 *               control card:  codewd = GLAUB-PAR                   *
1929 *                                                                   *
1930 *                parameters in Glauber-formalism                    *
1931 *                                                                   *
1932 *    what (1)  # of nucleon configurations sampled in integration   *
1933 *              over nuclear desity                default: 1000     *
1934 *    what (2)  # of bins for integration over impact-parameter and  *
1935 *              for profile-function calculation   default: 49       *
1936 *    what (3)  = 1 calculation of tot., el. and qel. cross sections *
1937 *                                                 default: 0        *
1938 *    what (4)  = 1   read pre-calculated impact-parameter distrib.  *
1939 *                    from "sdum".glb                                *
1940 *              =-1   dump pre-calculated impact-parameter distrib.  *
1941 *                    into "sdum".glb                                *
1942 *              = 100 read pre-calculated impact-parameter distrib.  *
1943 *                    for variable projectile/target/energy runs     *
1944 *                    from "sdum".glb                                *
1945 *                                                 default: 0        *
1946 *    what (5..6)   no meaning                                       *
1947 *    sdum      if |what (4)| = 1 name of in/output-file (sdum.glb)  *
1948 *                                                                   *
1949 *********************************************************************
1950
1951   560 CONTINUE
1952       IF (WHAT(1).GT.ZERO) JSTATB = INT(WHAT(1))
1953       IF (WHAT(2).GT.ZERO) JBINSB = INT(WHAT(2))
1954       IF (WHAT(3).EQ.ONE) LPROD = .FALSE.
1955       IF ((ABS(WHAT(4)).EQ.ONE).OR.(WHAT(4).EQ.100)) THEN
1956          IOGLB = INT(WHAT(4))
1957          CGLB  = SDUM
1958       ENDIF
1959       GOTO 10
1960
1961 *********************************************************************
1962 *                                                                   *
1963 *               control card:  codewd = GLAUB-INI                   *
1964 *                                                                   *
1965 *             pre-initialization of profile function                *
1966 *                                                                   *
1967 *       what (1)      lower energy limit for initialization         *
1968 *                > 0  Lab. frame                                    *
1969 *                < 0  nucleon-nucleon cms                           *
1970 *       what (2)      upper energy limit for initialization         *
1971 *                > 0  Lab. frame                                    *
1972 *                < 0  nucleon-nucleon cms                           *
1973 *       what (3) > 0  # of equidistant lin. bins in E               *
1974 *                < 0  # of equidistant log. bins in E               *
1975 *       what (4)      maximum projectile mass number for which the  *
1976 *                     Glauber data are initialized for each         *
1977 *                     projectile mass number                        *
1978 *                     (if <= mass given with the PROJPAR-card)      *
1979 *                                              default: 18          *
1980 *       what (5)      steps in mass number starting from what (4)   *
1981 *                     up to mass number defined with PROJPAR-card   *
1982 *                     for which Glauber data are initialized        *
1983 *                                              default: 5           *
1984 *       what (6)      no meaning                                    *
1985 *       sdum          no meaning                                    *
1986 *                                                                   *
1987 *********************************************************************
1988
1989   565 CONTINUE
1990       IOGLB = -100
1991       CALL DT_GLBINI(WHAT)
1992       GOTO 10
1993
1994 *********************************************************************
1995 *                                                                   *
1996 *               control card:  codewd = VDM-PAR2                    *
1997 *                                                                   *
1998 *      parameters in gamma-nucleus cross section calculation        *
1999 *                                                                   *
2000 *      what (1) = 0 no suppression of shadowing by direct photon    *
2001 *                   processes                                       *
2002 *               = 1 suppression ..                   default: 1     *
2003 *      what (2) = 0 no suppression of shadowing by anomalous        *
2004 *                   component if photon-F_2                         *
2005 *               = 1 suppression ..                   default: 1     *
2006 *      what (3) = 0 no suppression of shadowing by coherence        *
2007 *                   length of the photon                            *
2008 *               = 1 suppression ..                   default: 1     *
2009 *      what (4) = 1 longitudinal polarized photons are taken into   *
2010 *                   account                                         *
2011 *                   eps*R*Q^2/M^2 = what(4)*Q^2/M^2  default: 0     *
2012 *      what (5..6), sdum    no meaning                              *
2013 *                                                                   *
2014 *********************************************************************
2015
2016   570 CONTINUE
2017       IF ((WHAT(1).EQ.ZERO).OR.(WHAT(1).EQ.ONE)) ISHAD(1) = INT(WHAT(1))
2018       IF ((WHAT(2).EQ.ZERO).OR.(WHAT(2).EQ.ONE)) ISHAD(2) = INT(WHAT(2))
2019       IF ((WHAT(3).EQ.ZERO).OR.(WHAT(3).EQ.ONE)) ISHAD(3) = INT(WHAT(3))
2020       EPSPOL  = WHAT(4)
2021       GOTO 10
2022
2023 *********************************************************************
2024 *                                                                   *
2025 *               control card:  XS-QELPRO                            *
2026 *                                                                   *
2027 *     what (1..6), sdum    no meaning                               *
2028 *                                                                   *
2029 *********************************************************************
2030
2031   580 CONTINUE
2032       IXSQEL = ABS(WHAT(1))
2033       GOTO 10
2034
2035 *********************************************************************
2036 *                                                                   *
2037 *               control card:  RNDMINIT                             *
2038 *                                                                   *
2039 *           initialization of random number generator               *
2040 *                                                                   *
2041 *     what (1..4)    values for initialization (= 1..168)           *
2042 *     what (5..6), sdum    no meaning                               *
2043 *                                                                   *
2044 *********************************************************************
2045
2046   590 CONTINUE
2047       IF ((WHAT(1).LT.1.0D0).OR.(WHAT(1).GT.168.0D0)) THEN
2048          NA1 = 22
2049       ELSE
2050          NA1 = WHAT(1)
2051       ENDIF
2052       IF ((WHAT(2).LT.1.0D0).OR.(WHAT(2).GT.168.0D0)) THEN
2053          NA2 = 54
2054       ELSE
2055          NA2 = WHAT(2)
2056       ENDIF
2057       IF ((WHAT(3).LT.1.0D0).OR.(WHAT(3).GT.168.0D0)) THEN
2058          NA3 = 76
2059       ELSE
2060          NA3 = WHAT(3)
2061       ENDIF
2062       IF ((WHAT(4).LT.1.0D0).OR.(WHAT(4).GT.168.0D0)) THEN
2063          NA4 = 92
2064       ELSE
2065          NA4 = WHAT(4)
2066       ENDIF
2067       CALL DT_RNDMST(NA1,NA2,NA3,NA4)
2068       GOTO 10
2069
2070 *********************************************************************
2071 *                                                                   *
2072 *               control card:  codewd = LEPTO-CUT                   *
2073 *                                                                   *
2074 *          set parameter CUT in LEPTO-common /LEPTOU/               *
2075 *                                                                   *
2076 *       what (1) =  index in CUT-array                              *
2077 *       what (2) =  new value of CUT( int(what(1)) )                *
2078 *       what (3), what(4) and what (5), what(6) further             *
2079 *                   parameter in the same way as what (1) and       *
2080 *                   what (2)                                        *
2081 *                        default: default-LEPTO parameters          *
2082 *                                                                   *
2083 *********************************************************************
2084
2085   600 CONTINUE
2086       IF (WHAT(1).GT.ZERO) CUT(INT(WHAT(1))) = WHAT(2)
2087       IF (WHAT(3).GT.ZERO) CUT(INT(WHAT(3))) = WHAT(4)
2088       IF (WHAT(5).GT.ZERO) CUT(INT(WHAT(5))) = WHAT(6)
2089       GOTO 10
2090
2091 *********************************************************************
2092 *                                                                   *
2093 *               control card:  codewd = LEPTO-LST                   *
2094 *                                                                   *
2095 *          set parameter LST in LEPTO-common /LEPTOU/               *
2096 *                                                                   *
2097 *       what (1) =  index in LST-array                              *
2098 *       what (2) =  new value of LST( int(what(1)) )                *
2099 *       what (3), what(4) and what (5), what(6) further             *
2100 *                   parameter in the same way as what (1) and       *
2101 *                   what (2)                                        *
2102 *                        default: default-LEPTO parameters          *
2103 *                                                                   *
2104 *********************************************************************
2105
2106   610 CONTINUE
2107       IF (WHAT(1).GT.ZERO) LST(INT(WHAT(1))) = INT(WHAT(2))
2108       IF (WHAT(3).GT.ZERO) LST(INT(WHAT(3))) = INT(WHAT(4))
2109       IF (WHAT(5).GT.ZERO) LST(INT(WHAT(5))) = INT(WHAT(6))
2110       GOTO 10
2111
2112 *********************************************************************
2113 *                                                                   *
2114 *               control card:  codewd = LEPTO-PARL                  *
2115 *                                                                   *
2116 *          set parameter PARL in LEPTO-common /LEPTOU/              *
2117 *                                                                   *
2118 *       what (1) =  index in PARL-array                             *
2119 *       what (2) =  new value of PARL( int(what(1)) )               *
2120 *       what (3), what(4) and what (5), what(6) further             *
2121 *                   parameter in the same way as what (1) and       *
2122 *                   what (2)                                        *
2123 *                        default: default-LEPTO parameters          *
2124 *                                                                   *
2125 *********************************************************************
2126
2127   620 CONTINUE
2128       IF (WHAT(1).GT.ZERO) PARL(INT(WHAT(1))) = WHAT(2)
2129       IF (WHAT(3).GT.ZERO) PARL(INT(WHAT(3))) = WHAT(4)
2130       IF (WHAT(5).GT.ZERO) PARL(INT(WHAT(5))) = WHAT(6)
2131       GOTO 10
2132
2133 *********************************************************************
2134 *                                                                   *
2135 *               control card:  codewd = START                       *
2136 *                                                                   *
2137 *       what (1) =   number of events                default: 100.  *
2138 *       what (2) = 0 Glauber initialization follows                 *
2139 *                = 1 Glauber initialization supressed, fitted       *
2140 *                    results are used instead                       *
2141 *                    (this does not apply if emulsion-treatment     *
2142 *                     is requested)                                 *
2143 *                = 2 Glauber initialization is written to           *
2144 *                    output-file shmakov.out                        *
2145 *                = 3 Glauber initialization is read from input-file *
2146 *                    shmakov.out                     default: 0     *
2147 *       what (3..6)  no meaning                                     *
2148 *       what (3..6)  no meaning                                     *
2149 *                                                                   *
2150 *********************************************************************
2151
2152   630 CONTINUE
2153
2154 * check for cross-section table output only
2155       IF (LXSTAB) STOP
2156
2157       NCASES = INT(WHAT(1))
2158       IF (NCASES.LE.0) NCASES = 100
2159       IGLAU = INT(WHAT(2))
2160       IF ((IGLAU.NE.1).AND.(IGLAU.NE.2).AND.(IGLAU.NE.3))
2161      &                                            IGLAU = 0
2162
2163       NPMASS = IP
2164       NPCHAR = IPZ
2165       NTMASS = IT
2166       NTCHAR = ITZ
2167       IDP    = IJPROJ
2168       IDT    = IJTARG
2169       IF (IDP.LE.0) IDP = 1
2170 * muon neutrinos: temporary (missing index)
2171 * (new patch in projpar: therefore the following this is probably not
2172 *  necessary anymore..)
2173 C     IF (IDP.EQ.26) IDP = 5
2174 C     IF (IDP.EQ.27) IDP = 6
2175
2176 * redefine collision energy
2177       IF (LEINP) THEN
2178          IF (ABS(VAREHI).GT.ZERO) THEN
2179             PDUM = ZERO
2180             IF (VARELO.LT.EHADLO) VARELO = EHADLO
2181             CALL DT_LTINI(IDP,IDT,VARELO,PDUM,VARCLO,1)
2182             PDUM = ZERO
2183             CALL DT_LTINI(IDP,IDT,VAREHI,PDUM,VARCHI,1)
2184          ENDIF
2185          CALL DT_LTINI(IDP,IDT,EPN,PPN,CMENER,1)
2186       ELSE
2187          WRITE(LOUT,1003)
2188  1003    FORMAT(1X,'INIT:   collision energy not defined!',/,
2189      &          1X,'              -program stopped-      ')
2190          STOP
2191       ENDIF
2192
2193 * switch off evaporation (even if requested) if central coll. requ.
2194       IF ((ICENTR.EQ.-1).OR.(ICENTR.GT.0).OR.(XSFRAC.LT.0.5D0)) THEN
2195          IF (LEVPRT) THEN
2196             WRITE(LOUT,1004)
2197  1004       FORMAT(1X,/,'Warning!  Evaporation request rejected since',
2198      &             ' central collisions forced.')
2199             LEVPRT = .FALSE.
2200             LDEEXG = .FALSE.
2201             LHEAVY = .FALSE.
2202          ENDIF
2203       ENDIF
2204
2205 * initialization of evaporation-module
2206
2207 *  initialize evaporation if the code is not used as Fluka event generator
2208       WRITE(LOUT,*) '  ITRSPT = ', ITRSPT
2209       IF (ITRSPT.NE.1) THEN
2210          CALL NCDTRD
2211          CALL INCINI
2212       ENDIF
2213       WRITE(LOUT,*) '  LEVPRT = ',LEVPRT
2214       IF (LEVPRT) LHEAVY = .TRUE.
2215 * save the default JETSET-parameter
2216       CALL DT_JSPARA(0)
2217
2218       WRITE(LOUT,*) ' IDP = ',IDP,'  MCGENE = ',MCGENE
2219 * force use of phojet for g-A
2220       IF ((IDP.EQ.7).AND.(MCGENE.NE.3)) MCGENE = 2
2221 * initialization of nucleon-nucleon event generator
2222       IF (MCGENE.EQ.2) CALL DT_PHOINI
2223 * initialization of LEPTO event generator
2224       IF (MCGENE.EQ.3) THEN
2225
2226          STOP ' This version does not contain LEPTO !'
2227
2228       ENDIF
2229
2230 * initialization of quasi-elastic neutrino scattering
2231       IF (MCGENE.EQ.4) THEN
2232          IF (IJPROJ.EQ.5) THEN
2233             NEUTYP = 1
2234          ELSEIF (IJPROJ.EQ.6) THEN
2235             NEUTYP = 2
2236          ELSEIF (IJPROJ.EQ.135) THEN
2237             NEUTYP = 3
2238          ELSEIF (IJPROJ.EQ.136) THEN
2239             NEUTYP = 4
2240          ELSEIF (IJPROJ.EQ.133) THEN
2241             NEUTYP = 5
2242          ELSEIF (IJPROJ.EQ.134) THEN
2243             NEUTYP = 6
2244          ENDIF
2245       ENDIF
2246
2247 * normalize fractions of emulsion components
2248       IF (NCOMPO.GT.0) THEN
2249          SUMFRA = ZERO
2250          DO 491 I=1,NCOMPO
2251             SUMFRA = SUMFRA+EMUFRA(I)
2252   491    CONTINUE
2253          IF (SUMFRA.GT.ZERO) THEN
2254             DO 492 I=1,NCOMPO
2255                EMUFRA(I) = EMUFRA(I)/SUMFRA
2256   492       CONTINUE
2257          ENDIF
2258       ENDIF
2259
2260 * disallow Cronin's multiple scattering for nucleus-nucleus interactions
2261       IF ((IP.GT.1) .AND. (IT.GT.1) .AND. (MKCRON.GT.0)) THEN
2262          WRITE(LOUT,1005)
2263  1005    FORMAT(/,1X,'INIT:  multiple scattering disallowed',/)
2264          MKCRON = 0
2265       ENDIF
2266
2267 * initialization of Glauber-formalism (moved to xAEVT, sr 26.3.96)
2268 C     IF (NCOMPO.LE.0) THEN
2269 C        CALL DT_SHMAKI(IP,IPZ,IT,ITZ,IDP,PPN,IGLAU)
2270 C     ELSE
2271 C        DO 493 I=1,NCOMPO
2272 C           CALL DT_SHMAKI(IP,IPZ,IEMUMA(I),IEMUCH(I),IDP,PPN,0)
2273 C 493    CONTINUE
2274 C     ENDIF
2275
2276 * pre-tabulation of elastic cross-sections
2277       CALL DT_SIGTBL(JDUM,JDUM,DUM,DUM,-1)
2278
2279       CALL DT_XTIME
2280
2281       RETURN
2282
2283 *********************************************************************
2284 *                                                                   *
2285 *               control card:  codewd = STOP                        *
2286 *                                                                   *
2287 *               stop of the event generation                        *
2288 *                                                                   *
2289 *       what (1..6)  no meaning                                     *
2290 *                                                                   *
2291 *********************************************************************
2292
2293  9999 CONTINUE
2294       WRITE(LOUT,9000)
2295  9000 FORMAT(1X,'---> unexpected end of input !')
2296
2297   640 CONTINUE
2298       STOP
2299
2300       END
2301
2302 *$ CREATE DT_KKINC.FOR
2303 *COPY DT_KKINC
2304 *
2305 *===kkinc==============================================================*
2306 *
2307       SUBROUTINE DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,
2308      &                                                         IREJ)
2309
2310 ************************************************************************
2311 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering   *
2312 * This subroutine is an update of the previous version written         *
2313 * by J. Ranft/ H.-J. Moehring.                                         *
2314 * This version dated 19.11.95 is written by S. Roesler                 *
2315 ************************************************************************
2316
2317       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2318       SAVE
2319
2320       PARAMETER ( LINP = 10 ,
2321      &            LOUT = 6 ,
2322      &            LDAT = 9 )
2323
2324       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY5=1.0D-5,
2325      &           TINY2=1.0D-2,TINY3=1.0D-3)
2326
2327       LOGICAL LFZC
2328
2329 * event history
2330
2331       PARAMETER (NMXHKK=200000)
2332
2333       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2334      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2335      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2336
2337 * extended event history
2338       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2339      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2340      &                IHIST(2,NMXHKK)
2341
2342 * particle properties (BAMJET index convention)
2343       CHARACTER*8  ANAME
2344       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2345      &                IICH(210),IIBAR(210),K1(210),K2(210)
2346
2347 * properties of interacting particles
2348       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2349
2350 * Lorentz-parameters of the current interaction
2351       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
2352      &                UMO,PPCM,EPROJ,PPROJ
2353
2354 * flags for input different options
2355       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2356       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2357      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2358
2359 * flags for particle decays
2360       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2361      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2362      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2363
2364 * cuts for variable energy runs
2365       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2366
2367 * Glauber formalism: flags and parameters for statistics
2368       LOGICAL LPROD
2369       CHARACTER*8 CGLB
2370       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2371
2372       DIMENSION WHAT(6)
2373
2374       IREJ  = 0
2375       ILOOP = 0
2376   100 CONTINUE
2377       IF (ILOOP.EQ.4) THEN
2378          WRITE(LOUT,1000) NEVHKK
2379  1000    FORMAT(1X,'KKINC: event ',I8,' rejected!')
2380          GOTO 9999
2381       ENDIF
2382       ILOOP = ILOOP+1
2383
2384 * variable energy-runs, recalculate parameters for LT's
2385       IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN
2386          PDUM = ZERO
2387          CDUM = ZERO
2388          CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1)
2389       ENDIF
2390       IF (EPN.GT.EPROJ) THEN
2391          WRITE(LOUT,'(A,E9.3,2A,E9.3,A)')
2392      &      ' Requested energy (',EPN,'GeV) exceeds',
2393      &      ' initialization energy (',EPROJ,'GeV) !'
2394          STOP
2395       ENDIF
2396
2397 * re-initialize /DTPRTA/
2398       IP  = NPMASS
2399       IPZ = NPCHAR
2400       IT  = NTMASS
2401       ITZ = NTCHAR
2402       IJPROJ = IDP
2403       IBPROJ = IIBAR(IJPROJ)
2404
2405 * calculate nuclear potentials (common /DTNPOT/)
2406       CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
2407
2408 * initialize treatment for residual nuclei
2409       CALL DT_RESNCL(EPN,NLOOP,1)
2410
2411 * sample hadron/nucleus-nucleus interaction
2412       CALL DT_KKEVNT(KKMAT,IREJ1)
2413       IF (IREJ1.GT.0) THEN
2414          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC'
2415          GOTO 9999
2416       ENDIF
2417
2418       IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN
2419
2420 * intranuclear cascade of final state particles for KTAUGE generations
2421 * of secondaries
2422          CALL DT_FOZOCA(LFZC,IREJ1)
2423          IF (IREJ1.GT.0) THEN
2424             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC'
2425             GOTO 9999
2426          ENDIF
2427
2428 * baryons unable to escape the nuclear potential are treated as
2429 * excited nucleons (ISTHKK=15,16)
2430          CALL DT_SCN4BA
2431
2432 * decay of resonances produced in intranuclear cascade processes
2433 **sr 15-11-95 should be obsolete
2434 C        IF (LFZC) CALL DT_DECAY1
2435
2436   101    CONTINUE
2437 * treatment of residual nuclei
2438          CALL DT_RESNCL(EPN,NLOOP,2)
2439
2440 * evaporation / fission / fragmentation
2441 * (if intranuclear cascade was sampled only)
2442          IF (LFZC) THEN
2443             CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1)
2444             IF (IREJ1.GT.1) GOTO 101
2445             IF (IREJ1.EQ.1) GOTO 100
2446          ENDIF
2447
2448       ENDIF
2449
2450 * rejection of unphysical configurations
2451 C     CALL DT_REJUCO(1,IREJ1)
2452 C     IF (IREJ1.GT.0) THEN
2453 C        IF (IOULEV(1).GT.0)
2454 C    &      WRITE(LOUT,*) 'rejected 3 in KKINC: too large x'
2455 C        GOTO 100
2456 C     ENDIF
2457
2458 * transform finale state into Lab.
2459       IFLAG = 2
2460       CALL DT_BEAMPR(WHAT,DUM,IFLAG)
2461       IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB
2462
2463       IF (IPI0.EQ.1) CALL DT_DECPI0
2464
2465 C     IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4)
2466
2467       RETURN
2468  9999 CONTINUE
2469       IREJ = 1
2470       RETURN
2471       END
2472
2473 *$ CREATE DT_DEFAUL.FOR
2474 *COPY DT_DEFAUL
2475 *
2476 *===defaul=============================================================*
2477 *
2478       SUBROUTINE DT_DEFAUL(EPN,PPN)
2479
2480 ************************************************************************
2481 * Variables are set to default values.                                 *
2482 * This version dated 8.5.95 is written by S. Roesler.                  *
2483 ************************************************************************
2484
2485       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2486       SAVE
2487       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
2488       PARAMETER (TWOPI  = 6.283185307179586454D+00)
2489
2490 * particle properties (BAMJET index convention)
2491       CHARACTER*8  ANAME
2492       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2493      &                IICH(210),IIBAR(210),K1(210),K2(210)
2494
2495 * nuclear potential
2496       LOGICAL LFERMI
2497       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
2498      &                EBINDP(2),EBINDN(2),EPOT(2,210),
2499      &                ETACOU(2),ICOUL,LFERMI
2500
2501 * interface HADRIN-DPM
2502       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
2503
2504 * central particle production, impact parameter biasing
2505       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
2506
2507 * properties of interacting particles
2508       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2509
2510 * properties of photon/lepton projectiles
2511       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2512
2513       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2514
2515 * emulsion treatment
2516       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2517      &                NCOMPO,IEMUL
2518
2519 * parameter for intranuclear cascade
2520       LOGICAL LPAULI
2521       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
2522
2523 * various options for treatment of partons (DTUNUC 1.x)
2524 * (chain recombination, Cronin,..)
2525       LOGICAL LCO2CR,LINTPT
2526       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
2527      &                LCO2CR,LINTPT
2528
2529 * threshold values for x-sampling (DTUNUC 1.x)
2530       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
2531      &                SSMIMQ,VVMTHR
2532
2533 * flags for input different options
2534       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2535       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2536      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2537
2538 * n-n cross section fluctuations
2539       PARAMETER (NBINS = 1000)
2540       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
2541
2542 * flags for particle decays
2543       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2544      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2545      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2546
2547 * diquark-breaking mechanism
2548       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
2549
2550 * nucleon-nucleon event-generator
2551       CHARACTER*8 CMODEL
2552       LOGICAL LPHOIN
2553       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2554
2555 * flags for diffractive interactions (DTUNUC 1.x)
2556       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
2557
2558 * VDM parameter for photon-nucleus interactions
2559       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
2560
2561 * Glauber formalism: flags and parameters for statistics
2562       LOGICAL LPROD
2563       CHARACTER*8 CGLB
2564       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2565
2566 * kinematical cuts for lepton-nucleus interactions
2567       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2568      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2569
2570 * flags for activated histograms
2571       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2572
2573 * cuts for variable energy runs
2574       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2575
2576 * parameters for hA-diffraction
2577       COMMON /DTDIHA/ DIBETA,DIALPH
2578
2579 * LEPTO
2580       REAL RPPN
2581       COMMON /LEPTOI/ RPPN,LEPIN,INTER
2582
2583 * steering flags for qel neutrino scattering modules
2584       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
2585
2586 * event flag
2587       COMMON /DTEVNO/ NEVENT,ICASCA
2588
2589       DATA POTMES /0.002D0/
2590
2591 * common /DTNPOT/
2592       DO 10 I=1,2
2593          PFERMP(I) = ZERO
2594          PFERMN(I) = ZERO
2595          EBINDP(I) = ZERO
2596          EBINDN(I) = ZERO
2597          DO 11 J=1,210
2598             EPOT(I,J) = ZERO
2599    11    CONTINUE
2600 * nucleus independent meson potential
2601          EPOT(I,13) = POTMES
2602          EPOT(I,14) = POTMES
2603          EPOT(I,15) = POTMES
2604          EPOT(I,16) = POTMES
2605          EPOT(I,23) = POTMES
2606          EPOT(I,24) = POTMES
2607          EPOT(I,25) = POTMES
2608    10 CONTINUE
2609       FERMOD    = 0.55D0
2610       ETACOU(1) = ZERO
2611       ETACOU(2) = ZERO
2612       ICOUL     = 1
2613       LFERMI    = .TRUE.
2614
2615 * common /HNTHRE/
2616       EHADTH = -99.0D0
2617       EHADLO = 4.06D0
2618       EHADHI = 6.0D0
2619       INTHAD = 1
2620       IDXTA  = 2
2621
2622 * common /DTIMPA/
2623       ICENTR = 0
2624       BIMIN  = ZERO
2625       BIMAX  = 1.0D10
2626       XSFRAC = 1.0D0
2627
2628 * common /DTPRTA/
2629       IP  = 1
2630       IPZ = 1
2631       IT  = 1
2632       ITZ = 1
2633       IJPROJ = 1
2634       IBPROJ = 1
2635       IJTARG = 1
2636       IBTARG = 1
2637 * common /DTGPRO/
2638       VIRT = ZERO
2639       DO 14 I=1,4
2640          PGAMM(I)  = ZERO
2641          PLEPT0(I) = ZERO
2642          PLEPT1(I) = ZERO
2643          PNUCL(I)  = ZERO
2644    14 CONTINUE
2645       IDIREC   = 0
2646
2647 * common /DTFOTI/
2648 **sr 7.4.98: changed after corrected B-sampling
2649 C     TAUFOR = 4.4D0
2650       TAUFOR = 3.5D0
2651       KTAUGE = 25
2652       ITAUVE = 1
2653       INCMOD = 1
2654       LPAULI = .TRUE.
2655
2656 * common /DTCHAI/
2657       SEASQ  = ONE
2658       MKCRON = 1
2659       CRONCO = 0.64D0
2660       ISICHA = 0
2661       CUTOF  = 100.0D0
2662       LCO2CR = .FALSE.
2663       IRECOM = 1
2664       LINTPT = .TRUE.
2665
2666 * common /DTXCUT/
2667 *  definition of soft quark distributions
2668       XSEACU = 0.05D0
2669       UNON   = 2.0D0
2670       UNOM   = 1.5D0
2671       UNOSEA = 5.0D0
2672 *  cutoff parameters for x-sampling
2673       CVQ    = 1.0D0
2674       CDQ    = 2.0D0
2675 C     CSEA   = 0.3D0
2676       CSEA   = 0.1D0
2677       SSMIMA = 1.2D0
2678       SSMIMQ = SSMIMA**2
2679       VVMTHR = 2.0D0
2680
2681 * common /DTXSFL/
2682       IFLUCT = 0
2683
2684 * common /DTFRPA/
2685       PDB = 0.15D0
2686       PDBSEA(1) = 0.0D0
2687       PDBSEA(2) = 0.0D0
2688       PDBSEA(3) = 0.0D0
2689       ISIG0 = 0
2690       IPI0  = 0
2691       NMSTU = 0
2692       NPARU = 0
2693       NMSTJ = 0
2694       NPARJ = 0
2695
2696 * common /DTDIQB/
2697       DO 15 I=1,8
2698          DBRKR(1,I) = 5.0D0
2699          DBRKR(2,I) = 5.0D0
2700          DBRKR(3,I) = 10.0D0
2701          DBRKA(1,I) = ZERO
2702          DBRKA(2,I) = ZERO
2703          DBRKA(3,I) = ZERO
2704    15 CONTINUE
2705       CHAM1 = 0.2D0
2706       CHAM3 = 0.5D0
2707       CHAB1 = 0.7D0
2708       CHAB3 = 1.0D0
2709
2710 * common /DTFLG3/
2711       ISINGD = 0
2712       IDOUBD = 0
2713       IFLAGD = 0
2714       IDIFF  = 0
2715
2716 * common /DTMODL/
2717       MCGENE    = 2
2718       CMODEL(1) = 'DTUNUC  '
2719       CMODEL(2) = 'PHOJET  '
2720       CMODEL(3) = 'LEPTO   '
2721       CMODEL(4) = 'QNEUTRIN'
2722       LPHOIN    = .TRUE.
2723       ELOJET    = 5.0D0
2724
2725 * common /DTLCUT/
2726       ECMIN  = 3.5D0
2727       ECMAX  = 1.0D10
2728       XBJMIN = ZERO
2729       ELMIN = ZERO
2730       EGMIN = ZERO
2731       EGMAX = 1.0D10
2732       YMIN  = TINY10
2733       YMAX  = 0.999D0
2734       Q2MIN = TINY10
2735       Q2MAX = 10.0D0
2736       THMIN = ZERO
2737       THMAX = TWOPI
2738       Q2LI  = ZERO
2739       Q2HI  = 1.0D10
2740       ECMLI = ZERO
2741       ECMHI = 1.0D10
2742
2743 * common /DTVDMP/
2744       RL2       = 2.0D0
2745       INTRGE(1) = 1
2746       INTRGE(2) = 3
2747       IDPDF     = 2212
2748       MODEGA    = 4
2749       ISHAD(1)  = 1
2750       ISHAD(2)  = 1
2751       ISHAD(3)  = 1
2752       EPSPOL    = ZERO
2753
2754 * common /DTGLGP/
2755       JSTATB = 1000
2756       JBINSB = 49
2757       CGLB   = '        '
2758       IF (ITRSPT.EQ.1) THEN
2759          IOGLB  = 100
2760       ELSE
2761          IOGLB  = 0
2762       ENDIF
2763       LPROD  = .TRUE.
2764
2765 * common /DTHIS3/
2766       DO 16 I=1,50
2767          IHISPP(I) = 0
2768          IHISXS(I) = 0
2769    16 CONTINUE
2770       IXSTBL = 0
2771
2772 * common /DTVARE/
2773       VARELO = ZERO
2774       VAREHI = ZERO
2775       VARCLO = ZERO
2776       VARCHI = ZERO
2777
2778 * common /DTDIHA/
2779       DIBETA = -1.0D0
2780       DIALPH = ZERO
2781
2782 * common /LEPTOI/
2783       RPPN  = 0.0
2784       LEPIN = 0
2785       INTER = 0
2786
2787 * common /QNEUTO/
2788       NEUTYP = 1
2789       NEUDEC = 0
2790
2791 * common /DTEVNO/
2792       NEVENT = 1
2793       IF (ITRSPT.EQ.1) THEN
2794          ICASCA = 1
2795       ELSE
2796          ICASCA = 0
2797       ENDIF
2798
2799 * default Lab.-energy
2800       EPN = 200.0D0
2801       PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ)))
2802
2803       RETURN
2804       END
2805
2806 *$ CREATE DT_AAEVT.FOR
2807 *COPY DT_AAEVT
2808 *
2809 *===aaevt==============================================================*
2810 *
2811       SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2812      &                                             IDP,IGLAU)
2813
2814 ************************************************************************
2815 * This version dated 22.03.96 is written by S. Roesler.                *
2816 ************************************************************************
2817
2818       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2819       SAVE
2820
2821       PARAMETER ( LINP = 10 ,
2822      &            LOUT = 6 ,
2823      &            LDAT = 9 )
2824
2825       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2826
2827 * emulsion treatment
2828       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2829      &                NCOMPO,IEMUL
2830
2831 * event flag
2832       COMMON /DTEVNO/ NEVENT,ICASCA
2833
2834       CHARACTER*8 DATE,HHMMSS
2835       CHARACTER*9 CHDATE,CHTIME,CHZONE
2836       DIMENSION JDMNYR(8),IDMNYR(3)
2837
2838       KKMAT  = 1
2839       NMSG   = MAX(NEVTS/100,1)
2840
2841 * initialization of run-statistics and histograms
2842       CALL DT_STATIS(1)
2843
2844       CALL PHO_PHIST(1000,DUM)
2845
2846 * initialization of Glauber-formalism
2847       IF (NCOMPO.LE.0) THEN
2848          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2849       ELSE
2850          DO 1 I=1,NCOMPO
2851             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2852     1    CONTINUE
2853       ENDIF
2854       CALL DT_SIGEMU
2855
2856 C     CALL IDATE(IDMNYR)
2857 C     WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2858 C    &   IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2859       CALL DATE_AND_TIME ( CHDATE, CHTIME, CHZONE, JDMNYR )
2860       WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2861      &   JDMNYR(3),JDMNYR(2),MOD(JDMNYR(1),100)
2862       CALL ITIME(IDMNYR)
2863       WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2864      &   IDMNYR(1),IDMNYR(2),IDMNYR(3)
2865       WRITE(LOUT,1001) DATE,HHMMSS
2866  1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8,
2867      &       '   Time: ',A8,' )')
2868
2869 * generate NEVTS events
2870       DO 2 IEVT=1,NEVTS
2871
2872 *  print run-status message
2873          IF (MOD(IEVT,NMSG).EQ.0) THEN
2874 C           CALL IDATE(IDMNYR)
2875 C           WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2876 C    &         IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2877             CALL DATE_AND_TIME ( CHDATE, CHTIME, CHZONE, JDMNYR )
2878             WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2879      &         JDMNYR(3),JDMNYR(2),MOD(JDMNYR(1),100)
2880             CALL ITIME(IDMNYR)
2881             WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2882      &         IDMNYR(1),IDMNYR(2),IDMNYR(3)
2883             WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS
2884  1000       FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A,
2885      &             '   Time: ',A,' )',/)
2886 C           WRITE(LOUT,1000) IEVT-1
2887 C1000       FORMAT(1X,I8,' events sampled')
2888          ENDIF
2889          NEVENT = IEVT
2890 *  treat nuclear emulsions
2891          IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
2892 *  composite targets only
2893          KKMAT = -KKMAT
2894 *  sample this event
2895          CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ)
2896
2897          CALL PHO_PHIST(2000,DUM)
2898
2899     2 CONTINUE
2900
2901 * print run-statistics and histograms to output-unit 6
2902
2903       CALL PHO_PHIST(3000,DUM)
2904
2905       CALL DT_STATIS(2)
2906
2907       RETURN
2908       END
2909
2910 *$ CREATE DT_LAEVT.FOR
2911 *COPY DT_LAEVT
2912 *
2913 *===laevt==============================================================*
2914 *
2915       SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2916      &                                             IDP,IGLAU)
2917
2918 ************************************************************************
2919 * Interface to run DPMJET for lepton-nucleus interactions.             *
2920 * Kinematics is sampled using the equivalent photon approximation      *
2921 * Based on GPHERA-routine by R. Engel.                                 *
2922 * This version dated 23.03.96 is written by S. Roesler.                *
2923 ************************************************************************
2924
2925       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2926       SAVE
2927
2928       PARAMETER ( LINP = 10 ,
2929      &            LOUT = 6 ,
2930      &            LDAT = 9 )
2931
2932       PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,
2933      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
2934       PARAMETER (TWOPI  = 6.283185307179586454D+00,
2935      &           PI     = TWOPI/TWO,
2936      &           ALPHEM = ONE/137.0D0)
2937
2938 C     CHARACTER*72 HEADER
2939
2940 * particle properties (BAMJET index convention)
2941       CHARACTER*8  ANAME
2942       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2943      &                IICH(210),IIBAR(210),K1(210),K2(210)
2944
2945 * event history
2946
2947       PARAMETER (NMXHKK=200000)
2948
2949       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2950      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2951      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2952
2953 * extended event history
2954       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2955      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2956      &                IHIST(2,NMXHKK)
2957
2958 * kinematical cuts for lepton-nucleus interactions
2959       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2960      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2961
2962 * properties of interacting particles
2963       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2964
2965 * properties of photon/lepton projectiles
2966       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2967
2968 * kinematics at lepton-gamma vertex
2969       COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4)
2970
2971 * flags for activated histograms
2972       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2973
2974       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2975
2976 * emulsion treatment
2977       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2978      &                NCOMPO,IEMUL
2979
2980 * Glauber formalism: cross sections
2981       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
2982      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
2983      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
2984      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
2985      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
2986      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
2987      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
2988      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
2989      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
2990      &                BSLOPE,NEBINI,NQBINI
2991
2992 * nucleon-nucleon event-generator
2993       CHARACTER*8 CMODEL
2994       LOGICAL LPHOIN
2995       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2996
2997 * flags for input different options
2998       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2999       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3000      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3001
3002 * event flag
3003       COMMON /DTEVNO/ NEVENT,ICASCA
3004
3005       DIMENSION XDUMB(40),BGTA(4)
3006
3007 * LEPTO
3008       IF (MCGENE.EQ.3) THEN
3009
3010          STOP ' This version does not contain LEPTO !'
3011
3012       ENDIF
3013
3014       KKMAT  = 1
3015       NMSG   = MAX(NEVTS/10,1)
3016
3017 * mass of incident lepton
3018       AMLPT  = AAM(IDP)
3019       AMLPT2 = AMLPT**2
3020       IDPPDG = IDT_IPDGHA(IDP)
3021
3022 * consistency of kinematical limits
3023       Q2MIN  = MAX(Q2MIN,TINY10)
3024       Q2MAX  = MAX(Q2MAX,TINY10)
3025       YMIN   = MIN(MAX(YMIN,TINY10),0.999D0)
3026       YMAX   = MIN(MAX(YMAX,TINY10),0.999D0)
3027
3028 * total energy of the lepton-nucleon system
3029       PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2
3030      &                                      +(PLEPT0(3)+PNUCL(3))**2 )
3031       ETOTLN = PLEPT0(4)+PNUCL(4)
3032       ECMLN  = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN))
3033       ECMAX  = MIN(ECMAX,ECMLN)
3034       WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN,
3035      &                 THMIN,THMAX,ELMIN
3036  1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X,
3037      &       '------------------',/,9X,'W (min)   =',
3038      &       F7.1,' GeV    (max) =',F7.1,' GeV',/,9X,'y (min)   =',
3039      &       F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1,
3040      &       ' GeV^2  (max) =',F7.1,' GeV^2',/,' (Lab)   E_g (min) ='
3041      &       ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =',
3042      &       F7.4,'   for E_lpt >',F7.1,' GeV',/)
3043
3044 * Lorentz-parameter for transf. into Lab
3045       BGTA(1) = PNUCL(1)/AAM(1)
3046       BGTA(2) = PNUCL(2)/AAM(1)
3047       BGTA(3) = PNUCL(3)/AAM(1)
3048       BGTA(4) = PNUCL(4)/AAM(1)
3049 * LT of incident lepton into Lab and dump it in DTEVT1
3050       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3051      &            PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4),
3052      &            PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4))
3053       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3054      &            PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4),
3055      &            PLTOT,PPA(1),PPA(2),PPA(3),PPA(4))
3056 * maximum energy of photon nucleon system
3057       PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2
3058      &                                      +(YMAX*PPL0(3)+PPA(3))**2)
3059       ETOTGN = YMAX*PPL0(4)+PPA(4)
3060       EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
3061       EGNMAX = MIN(EGNMAX,ECMAX)
3062 * minimum energy of photon nucleon system
3063       PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2
3064      &                                      +(YMIN*PPL0(3)+PPA(3))**2)
3065       ETOTGN = YMIN*PPL0(4)+PPA(4)
3066       EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
3067       EGNMIN = MAX(EGNMIN,ECMIN)
3068
3069 * limits for Glauber-initialization
3070       Q2LI  = Q2MIN
3071       Q2HI  = MAX(Q2LI,MIN(Q2HI,Q2MAX))
3072       ECMLI = MAX(EGNMIN,THREE)
3073       ECMHI = EGNMAX
3074       WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI
3075  1004 FORMAT(1X,'resulting limits:',/,9X,'W (min)   =',F7.1,
3076      &       ' GeV    (max) =',F7.1,' GeV',/,/,' limits for ',
3077      &       'Glauber-initialization:',/,9X,'W (min)   =',F7.1,
3078      &       ' GeV    (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1,
3079      &       ' GeV^2  (max) =',F7.1,' GeV^2',/)
3080 * initialization of Glauber-formalism
3081       IF (NCOMPO.LE.0) THEN
3082          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
3083       ELSE
3084          DO 9 I=1,NCOMPO
3085             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
3086     9    CONTINUE
3087       ENDIF
3088       CALL DT_SIGEMU
3089
3090 * initialization of run-statistics and histograms
3091       CALL DT_STATIS(1)
3092
3093       CALL PHO_PHIST(1000,DUM)
3094
3095 * maximum photon-nucleus cross section
3096       I1  = 1
3097       I2  = 1
3098       RAT = ONE
3099       IF (EGNMAX.GE.ECMNN(NEBINI)) THEN
3100          I1  = NEBINI
3101          I2  = NEBINI
3102          RAT = ONE
3103       ELSEIF (EGNMAX.GT.ECMNN(1)) THEN
3104          DO 5 I=2,NEBINI
3105             IF (EGNMAX.LT.ECMNN(I)) THEN
3106                I1  = I-1
3107                I2  = I
3108                RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
3109                GOTO 6
3110             ENDIF
3111     5    CONTINUE
3112     6    CONTINUE
3113       ENDIF
3114       SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
3115       EGNXX  = EGNMAX
3116       I1  = 1
3117       I2  = 1
3118       RAT = ONE
3119       IF (EGNMIN.GE.ECMNN(NEBINI)) THEN
3120          I1  = NEBINI
3121          I2  = NEBINI
3122          RAT = ONE
3123       ELSEIF (EGNMIN.GT.ECMNN(1)) THEN
3124          DO 7 I=2,NEBINI
3125             IF (EGNMIN.LT.ECMNN(I)) THEN
3126                I1  = I-1
3127                I2  = I
3128                RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
3129                GOTO 8
3130             ENDIF
3131     7    CONTINUE
3132     8    CONTINUE
3133       ENDIF
3134       SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
3135       IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN
3136       SIGMAX = MAX(SIGMAX,SIGXX)
3137       WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb'
3138
3139 * plot photon flux table
3140       AYMIN = LOG(YMIN)
3141       AYMAX = LOG(YMAX)
3142       AYRGE = AYMAX-AYMIN
3143       MAXTAB = 50
3144       ADY    = LOG(YMAX/YMIN)/DBLE(MAXTAB-1)
3145 C     WRITE(LOUT,'(/,1X,A)') 'LAEVT:   photon flux '
3146       DO 1 I=1,MAXTAB
3147          Y     = EXP(AYMIN+ADY*DBLE(I-1))
3148          Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y))
3149          FF1   = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
3150      &                           -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX))
3151          FF2   = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
3152      &                           -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX))
3153 C        WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2
3154     1 CONTINUE
3155
3156 * maximum residual weight for flux sampling (dy/y)
3157       YY     = YMIN
3158       Q2LOW  = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
3159       WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW)
3160      &         -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
3161
3162       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0)
3163       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1)
3164       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2)
3165       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0)
3166       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1)
3167       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2)
3168       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0)
3169       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1)
3170       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2)
3171       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0)
3172       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1)
3173       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2)
3174       XBLOW = 0.001D0
3175       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0)
3176       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1)
3177       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2)
3178
3179       ITRY = 0
3180       ITRW = 0
3181       NC0  = 0
3182       NC1  = 0
3183
3184 * generate events
3185       DO 2 IEVT=1,NEVTS
3186          IF (MOD(IEVT,NMSG).EQ.0) THEN
3187 C           OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out',
3188 C    &                                         STATUS='UNKNOWN')
3189             WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled'
3190 C           CLOSE(LDAT)
3191          ENDIF
3192          NEVENT = IEVT
3193
3194   100    CONTINUE
3195          ITRY = ITRY+1
3196
3197 *  sample y
3198   101    CONTINUE
3199          ITRW  = ITRW+1
3200          YY    = EXP(AYRGE*DT_RNDM(RAT)+AYMIN)
3201          Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
3202          Q2LOG = LOG(Q2MAX/Q2LOW)
3203          WGH   = (ONE+(ONE-YY)**2)*Q2LOG
3204      &           -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
3205          IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH
3206  1000    FORMAT(1X,'LAEVT:   weight error!',3E12.5)
3207          IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101
3208
3209 *  sample Q2
3210          YEFF = ONE+(ONE-YY)**2
3211   102    CONTINUE
3212          Q2  = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
3213          WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF
3214          IF (WGH.LT.DT_RNDM(Q2)) GOTO 102
3215
3216 c        NC0 = NC0+1
3217 c        CALL DT_FILHGR(YY,ONE,IHFLY0,NC0)
3218 c        CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0)
3219
3220 *  kinematics at lepton-photon vertex
3221 *   scattered electron
3222          YQ2 = SQRT((ONE-YY)*Q2)
3223          Q2E = Q2/(4.0D0*PLEPT0(4))
3224          E1Y = (ONE-YY)*PLEPT0(4)
3225          CALL DT_DSFECF(SIF,COF)
3226          PLEPT1(1) = YQ2*COF
3227          PLEPT1(2) = YQ2*SIF
3228          PLEPT1(3) = E1Y-Q2E
3229          PLEPT1(4) = E1Y+Q2E
3230 C        THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) )
3231 *   radiated photon
3232          PGAMM(1) = -PLEPT1(1)
3233          PGAMM(2) = -PLEPT1(2)
3234          PGAMM(3) = PLEPT0(3)-PLEPT1(3)
3235          PGAMM(4) = PLEPT0(4)-PLEPT1(4)
3236 *   E_cm cut
3237          PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2
3238      &                                        +(PGAMM(3)+PNUCL(3))**2 )
3239          ETOTGN = PGAMM(4)+PNUCL(4)
3240          ECMGN  = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)
3241          IF (ECMGN.LT.0.1D0) GOTO 101
3242          ECMGN  = SQRT(ECMGN)
3243          IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101
3244
3245 *  Lorentz-transformation into nucleon-rest system
3246          CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3247      &               PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4),
3248      &               PGTOT,PPG(1),PPG(2),PPG(3),PPG(4))
3249          CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3250      &               PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4),
3251      &               PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4))
3252 *  temporary checks..
3253          Q2TMP = ABS(PPG(4)**2-PGTOT**2)
3254          IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP
3255  1001    FORMAT(1X,'LAEVT:    inconsistent kinematics (Q2,Q2TMP) ',
3256      &          2F10.4)
3257          ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT))
3258          IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP
3259  1002    FORMAT(1X,'LAEVT:    inconsistent kinematics (ECMGN,ECMTMP) ',
3260      &          2F10.2)
3261          YYTMP = PPG(4)/PPL0(4)
3262          IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP
3263  1005    FORMAT(1X,'LAEVT:    inconsistent kinematics (YY,YYTMP) ',
3264      &          2F10.4)
3265
3266 *  lepton tagger (Lab)
3267          THETA = ACOS( PPL1(3)/PLTOT )
3268          IF (PPL1(4).GT.ELMIN) THEN
3269             IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101
3270          ENDIF
3271 *  photon energy-cut (Lab)
3272          IF (PPG(4).LT.EGMIN) GOTO 101
3273          IF (PPG(4).GT.EGMAX) GOTO 101
3274 *   x_Bj cut
3275          XBJ = ABS(Q2/(1.876D0*PPG(4)))
3276          IF (XBJ.LT.XBJMIN) GOTO 101
3277
3278          NC0 = NC0+1
3279          CALL DT_FILHGR(    Q2,ONE,IHFLQ0,NC0)
3280          CALL DT_FILHGR(    YY,ONE,IHFLY0,NC0)
3281          CALL DT_FILHGR(   XBJ,ONE,IHFLX0,NC0)
3282          CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0)
3283          CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0)
3284
3285 *  rotation angles against z-axis
3286          COD = PPG(3)/PGTOT
3287 C        SID = SQRT((ONE-COD)*(ONE+COD))
3288          PPT = SQRT(PPG(1)**2+PPG(2)**2)
3289          SID = PPT/PGTOT
3290          COF = ONE
3291          SIF = ZERO
3292          IF (PGTOT*SID.GT.TINY10) THEN
3293             COF   = PPG(1)/(SID*PGTOT)
3294             SIF   = PPG(2)/(SID*PGTOT)
3295             ANORF = SQRT(COF*COF+SIF*SIF)
3296             COF   = COF/ANORF
3297             SIF   = SIF/ANORF
3298          ENDIF
3299
3300          IF (IXSTBL.EQ.0) THEN
3301 *  change to photon projectile
3302             IJPROJ = 7
3303 *  set virtuality
3304             VIRT = Q2
3305 *  re-initialize LTs with new kinematics
3306 *  !!PGAMM ist set in cms (ECMGN) along z
3307             EPN = ZERO
3308             PPN = ZERO
3309             CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0)
3310 *  force Lab-system
3311             IFRAME = 1
3312 *  get emulsion component if requested
3313             IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
3314 *  convolute with cross section
3315             CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT)
3316             CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT)
3317             IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)')
3318      &         'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX,
3319      &                                        Q2,ECMGN,STOT
3320             IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100
3321             NC1 = NC1+1
3322             CALL DT_FILHGR(    Q2,ONE,IHFLQ1,NC1)
3323             CALL DT_FILHGR(    YY,ONE,IHFLY1,NC1)
3324             CALL DT_FILHGR(   XBJ,ONE,IHFLX1,NC1)
3325             CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1)
3326             CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1)
3327 *  composite targets only
3328             KKMAT = -KKMAT
3329 *  sample this event
3330             CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT,
3331      &                                                            IREJ)
3332 *  rotate momenta of final state particles back in photon-nucleon syst.
3333             DO 4 I=NPOINT(4),NHKK
3334                IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3335      &                                      (ISTHKK(I).EQ.1001)) THEN
3336                   PX = PHKK(1,I)
3337                   PY = PHKK(2,I)
3338                   PZ = PHKK(3,I)
3339                   CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF,
3340      &                        PHKK(1,I),PHKK(2,I),PHKK(3,I))
3341                ENDIF
3342     4       CONTINUE
3343          ENDIF
3344
3345          CALL DT_FILHGR(    Q2,ONE,IHFLQ2,NC1)
3346          CALL DT_FILHGR(    YY,ONE,IHFLY2,NC1)
3347          CALL DT_FILHGR(   XBJ,ONE,IHFLX2,NC1)
3348          CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1)
3349          CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1)
3350
3351 *  dump this event to histograms
3352
3353          CALL PHO_PHIST(2000,DUM)
3354
3355     2 CONTINUE
3356
3357       WGY    = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW)
3358       WGY    = WGY*LOG(YMAX/YMIN)
3359       WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY)
3360
3361 C     HEADER = ' LAEVT:  Q^2 distribution 0'
3362 C     CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3363 C     HEADER = ' LAEVT:  Q^2 distribution 1'
3364 C     CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3365 C     HEADER = ' LAEVT:  Q^2 distribution 2'
3366 C     CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3367 C     HEADER = ' LAEVT:  y   distribution 0'
3368 C     CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3369 C     HEADER = ' LAEVT:  y   distribution 1'
3370 C     CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3371 C     HEADER = ' LAEVT:  y   distribution 2'
3372 C     CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3373 C     HEADER = ' LAEVT:  x   distribution 0'
3374 C     CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3375 C     HEADER = ' LAEVT:  x   distribution 1'
3376 C     CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3377 C     HEADER = ' LAEVT:  x   distribution 2'
3378 C     CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3379 C     HEADER = ' LAEVT:  E_g distribution 0'
3380 C     CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3381 C     HEADER = ' LAEVT:  E_g distribution 1'
3382 C     CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3383 C     HEADER = ' LAEVT:  E_g distribution 2'
3384 C     CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3385 C     HEADER = ' LAEVT:  E_c distribution 0'
3386 C     CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3387 C     HEADER = ' LAEVT:  E_c distribution 1'
3388 C     CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3389 C     HEADER = ' LAEVT:  E_c distribution 2'
3390 C     CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3391
3392 * print run-statistics and histograms to output-unit 6
3393
3394       CALL PHO_PHIST(3000,DUM)
3395
3396       IF (IXSTBL.EQ.0) CALL DT_STATIS(2)
3397
3398       RETURN
3399       END
3400
3401 *$ CREATE DT_DTUINI.FOR
3402 *COPY DT_DTUINI
3403 *
3404 *===dtuini=============================================================*
3405 *
3406       SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
3407      &                                               IDP,IEMU)
3408
3409       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3410       SAVE
3411
3412       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
3413
3414 * emulsion treatment
3415       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
3416      &                NCOMPO,IEMUL
3417
3418 * Glauber formalism: flags and parameters for statistics
3419       LOGICAL LPROD
3420       CHARACTER*8 CGLB
3421       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
3422
3423       CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU)
3424       CALL DT_STATIS(1)
3425
3426       CALL PHO_PHIST(1000,DUM)
3427
3428       IF (NCOMPO.LE.0) THEN
3429          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
3430       ELSE
3431          DO 1 I=1,NCOMPO
3432             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
3433     1    CONTINUE
3434       ENDIF
3435       IF (IOGLB.NE.100) CALL DT_SIGEMU
3436       IEMU = IEMUL
3437
3438       RETURN
3439       END
3440
3441 *$ CREATE DT_DTUOUT.FOR
3442 *COPY DT_DTUOUT
3443 *
3444 *===dtuout=============================================================*
3445 *
3446       SUBROUTINE DT_DTUOUT
3447
3448       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3449       SAVE
3450
3451       CALL PHO_PHIST(3000,DUM)
3452
3453       CALL DT_STATIS(2)
3454
3455       RETURN
3456       END
3457
3458 *$ CREATE DT_BEAMPR.FOR
3459 *COPY DT_BEAMPR
3460 *
3461 *===beampr=============================================================*
3462 *
3463       SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE)
3464
3465 ************************************************************************
3466 * Initialization of event generation                                   *
3467 * This version dated  7.4.98  is written by S. Roesler.                *
3468 ************************************************************************
3469
3470       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3471       SAVE
3472
3473       PARAMETER ( LINP = 10 ,
3474      &            LOUT = 6 ,
3475      &            LDAT = 9 )
3476
3477       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3478       PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3479
3480       LOGICAL LBEAM
3481
3482 * event history
3483
3484       PARAMETER (NMXHKK=200000)
3485
3486       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3487      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3488      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3489
3490 * extended event history
3491       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3492      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3493      &                IHIST(2,NMXHKK)
3494
3495 * properties of interacting particles
3496       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3497
3498 * particle properties (BAMJET index convention)
3499       CHARACTER*8  ANAME
3500       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3501      &                IICH(210),IIBAR(210),K1(210),K2(210)
3502
3503 * beam momenta
3504       COMMON /DTBEAM/ P1(4),P2(4)
3505
3506 C     DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4)
3507       DIMENSION WHAT(6),P1CMS(4),P2CMS(4)
3508
3509       DATA LBEAM /.FALSE./
3510
3511       GOTO (1,2) MODE
3512
3513     1 CONTINUE
3514
3515       E1  = WHAT(1)
3516       IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1))
3517       E2  = WHAT(2)
3518       IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2))
3519       PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) )
3520       PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) )
3521       TH  = 1.D-6*WHAT(3)/2.D0
3522       PH  = WHAT(4)*BOG
3523       P1(1) = PP1*SIN(TH)*COS(PH)
3524       P1(2) = PP1*SIN(TH)*SIN(PH)
3525       P1(3) = PP1*COS(TH)
3526       P1(4) = E1
3527       P2(1) = PP2*SIN(TH)*COS(PH)
3528       P2(2) = PP2*SIN(TH)*SIN(PH)
3529       P2(3) = -PP2*COS(TH)
3530       P2(4) = E2
3531       ECM  = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
3532      &                                              -(P1(3)+P2(3))**2 )
3533       ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG))
3534       PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) )
3535       BGX  = (P1(1)+P2(1))/ECM
3536       BGY  = (P1(2)+P2(2))/ECM
3537       BGZ  = (P1(3)+P2(3))/ECM
3538       BGE  = (P1(4)+P2(4))/ECM
3539       CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4),
3540      &            P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4))
3541       CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4),
3542      &            P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4))
3543       COD = P1CMS(3)/P1TOT
3544 C     SID = SQRT((ONE-COD)*(ONE+COD))
3545       PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2)
3546       SID = PPT/P1TOT
3547       COF = ONE
3548       SIF = ZERO
3549       IF (P1TOT*SID.GT.TINY10) THEN
3550          COF   = P1CMS(1)/(SID*P1TOT)
3551          SIF   = P1CMS(2)/(SID*P1TOT)
3552          ANORF = SQRT(COF*COF+SIF*SIF)
3553          COF   = COF/ANORF
3554          SIF   = SIF/ANORF
3555       ENDIF
3556 **check
3557 C     WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3558 C     WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3559 C     WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT
3560 C     WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT
3561 C     PAX = ZERO
3562 C     PAY = ZERO
3563 C     PAZ = P1TOT
3564 C     PAE = SQRT(AAM(IJPROJ)**2+PAZ**2)
3565 C     PBX = ZERO
3566 C     PBY = ZERO
3567 C     PBZ = -P2TOT
3568 C     PBE = SQRT(AAM(IJTARG)**2+PBZ**2)
3569 C     WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE
3570 C     WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE
3571 C     CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF,
3572 C    &            P1CMS(1),P1CMS(2),P1CMS(3))
3573 C     CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF,
3574 C    &            P2CMS(1),P2CMS(2),P2CMS(3))
3575 C     WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)
3576 C     WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)
3577 C     CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),
3578 C    &            P1TOT,P1(1),P1(2),P1(3),P1(4))
3579 C     CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),
3580 C    &            P2TOT,P2(1),P2(2),P2(3),P2(4))
3581 C     WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3582 C     WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3583 C     STOP
3584 **
3585
3586       LBEAM = .TRUE.
3587
3588       RETURN
3589
3590     2 CONTINUE
3591
3592       IF (LBEAM) THEN
3593          IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3594          DO 20 I=NPOINT(4),NHKK
3595
3596             IF ((ABS(ISTHKK(I)).EQ.1)  .OR.
3597      &           (ABS(ISTHKK(I)).EQ.2) .OR.
3598      &           (ISTHKK(I).EQ.1000)   .OR.
3599      &           (ISTHKK(I).EQ.1001)) THEN
3600
3601                CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
3602      &                     COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
3603                PECMS = PHKK(4,I)
3604                CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
3605      &                     PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
3606             ENDIF
3607    20    CONTINUE
3608       ELSE
3609          MODE = -1
3610       ENDIF
3611
3612       RETURN
3613       END
3614
3615 *$ CREATE DT_REJUCO.FOR
3616 *COPY DT_REJUCO
3617 *
3618 *===rejuco=============================================================*
3619 *
3620       SUBROUTINE DT_REJUCO(MODE,IREJ)
3621
3622 ************************************************************************
3623 * REJection of Unphysical COnfigurations                               *
3624 *     MODE = 1  rejection of particles with unphysically large energy  *
3625 *                                                                      *
3626 * This version dated 27.12.2006 is written by S. Roesler.              *
3627 ************************************************************************
3628
3629       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3630       SAVE
3631
3632       PARAMETER ( LINP = 10 ,
3633      &            LOUT = 6 ,
3634      &            LDAT = 9 )
3635
3636       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3637       PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3638
3639 * maximum x_cms of final state particle
3640       PARAMETER (XCMSMX = 1.4D0)
3641
3642 * event history
3643
3644       PARAMETER (NMXHKK=200000)
3645
3646       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3647      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3648      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3649
3650 * extended event history
3651       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3652      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3653      &                IHIST(2,NMXHKK)
3654
3655 * Lorentz-parameters of the current interaction
3656       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
3657      &                UMO,PPCM,EPROJ,PPROJ
3658
3659       IREJ = 0
3660
3661       IF (MODE.EQ.1) THEN
3662          IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3663          ECMHLF = UMO/2.0D0
3664          DO 10 I=NPOINT(4),NHKK
3665             IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN
3666                XCMS = ABS(PHKK(4,I))/ECMHLF
3667                IF (XCMS.GT.XCMSMX) GOTO 9999
3668             ENDIF
3669    10    CONTINUE
3670       ENDIF
3671
3672       RETURN
3673  9999 CONTINUE
3674       IREJ = 1
3675       RETURN
3676       END
3677 *$ CREATE DT_EVENTB.FOR
3678 *COPY DT_EVENTB
3679 *
3680 *===eventb=============================================================*
3681 *
3682       SUBROUTINE DT_EVENTB(NCSY,IREJ)
3683
3684 ************************************************************************
3685 * Treatment of nucleon-nucleon interactions with full two-component    *
3686 * Dual Parton Model.                                                   *
3687 *          NCSY     number of nucleon-nucleon interactions             *
3688 *          IREJ     rejection flag                                     *
3689 * This version dated 14.01.2000 is written by S. Roesler               *
3690 ************************************************************************
3691
3692       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3693       SAVE
3694
3695       PARAMETER ( LINP = 10 ,
3696      &            LOUT = 6 ,
3697      &            LDAT = 9 )
3698
3699       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
3700
3701 * event history
3702
3703       PARAMETER (NMXHKK=200000)
3704
3705       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3706      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3707      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3708
3709 * extended event history
3710       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3711      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3712      &                IHIST(2,NMXHKK)
3713 *! uncomment this line for internal phojet-fragmentation
3714 C #include "dtu_dtevtp.inc"
3715
3716 * particle properties (BAMJET index convention)
3717       CHARACTER*8  ANAME
3718       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3719      &                IICH(210),IIBAR(210),K1(210),K2(210)
3720
3721 * flags for input different options
3722       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
3723       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3724      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3725
3726 * rejection counter
3727       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
3728      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
3729      &                IREXCI(3),IRDIFF(2),IRINC
3730
3731 * properties of interacting particles
3732       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3733
3734 * properties of photon/lepton projectiles
3735       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
3736
3737 * various options for treatment of partons (DTUNUC 1.x)
3738 * (chain recombination, Cronin,..)
3739       LOGICAL LCO2CR,LINTPT
3740       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
3741      &                LCO2CR,LINTPT
3742
3743 * statistics
3744       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
3745      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
3746      &                ICEVTG(8,0:30)
3747
3748 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
3749       COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
3750
3751 * Glauber formalism: collision properties
3752       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
3753      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
3754      &                NCP,NCT
3755 * flags for diffractive interactions (DTUNUC 1.x)
3756       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
3757
3758 * statistics: double-Pomeron exchange
3759       COMMON /DTFLG2/ INTFLG,IPOPO
3760
3761 * flags for particle decays
3762       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
3763      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
3764      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
3765
3766 * nucleon-nucleon event-generator
3767       CHARACTER*8 CMODEL
3768       LOGICAL LPHOIN
3769       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
3770
3771 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
3772       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3773       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3774       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3775      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3776
3777 C  model switches and parameters
3778       CHARACTER*8 MDLNA
3779       INTEGER ISWMDL,IPAMDL
3780       DOUBLE PRECISION PARMDL
3781       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3782
3783 C  initial state parton radiation (internal part)
3784       INTEGER MXISR3,MXISR4
3785       PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
3786       INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
3787       DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
3788       COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
3789      &                ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
3790      &                IFL1(2,MXISR3),IFL2(2,MXISR3),
3791      &                IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
3792
3793 C  event debugging information
3794       INTEGER NMAXD
3795       PARAMETER (NMAXD=100)
3796       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3797      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3798       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3799      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3800
3801 C  general process information
3802       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3803       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3804
3805       DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
3806      &          PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
3807      &          PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
3808      &          KPRON(15),ISINGL(2000)
3809
3810 * initial values for max. number of phojet scatterings and dtunuc chains
3811 * to be fragmented with one pyexec call
3812       DATA MXPHFR,MXDTFR /10,100/
3813
3814       IREJ      = 0
3815 * pointer to first parton of the first chain in dtevt common
3816       NPOINT(3) = NHKK+1
3817 * special flag for double-Pomeron statistics
3818       IPOPO = 1
3819 * counter for low-mass (DTUNUC) interactions
3820       NDTUSC = 0
3821 * counter for interactions treated by PHOJET
3822       NPHOSC = 0
3823
3824 * scan interactions for single nucleon-nucleon interactions
3825 * (this has to be checked here because Cronin modifies parton momenta)
3826       NC = NPOINT(2)
3827       IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
3828       DO 8 I=1,NCSY
3829          ISINGL(I) = 0
3830          MOP = JMOHKK(1,NC)
3831          MOT = JMOHKK(1,NC+1)
3832          DIFF1 = ABS(PHKK(4,MOP)-PHKK(4,  NC)-PHKK(4,NC+2))
3833          DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
3834          IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
3835          NC = NC+4
3836     8 CONTINUE
3837
3838 * multiple scattering of chain ends
3839       IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
3840       IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
3841
3842 * switch to PHOJET-settings for JETSET parameter
3843       CALL DT_INITJS(1)
3844
3845 * loop over nucleon-nucleon interaction
3846       NC = NPOINT(2)
3847       DO 2 I=1,NCSY
3848 *
3849 *   pick up one nucleon-nucleon interaction from DTEVT1
3850 *     ppnn  / ptnn   - momenta of the interacting nucleons (cms)
3851 *     ptotnn         - total momentum of the interacting nucleons (cms)
3852 *     pp1,2 / pt1,2  - momenta of the four partons
3853 *     pp    / pt     - total momenta of the proj / targ partons
3854 *     ptot           - total momentum of the four partons
3855          MOP = JMOHKK(1,NC)
3856          MOT = JMOHKK(1,NC+1)
3857          DO 3 K=1,4
3858             PPNN(K)   = PHKK(K,MOP)
3859             PTNN(K)   = PHKK(K,MOT)
3860             PTOTNN(K) = PPNN(K)+PTNN(K)
3861             PP1(K)    = PHKK(K,NC)
3862             PT1(K)    = PHKK(K,NC+1)
3863             PP2(K)    = PHKK(K,NC+2)
3864             PT2(K)    = PHKK(K,NC+3)
3865             PP(K)     = PP1(K)+PP2(K)
3866             PT(K)     = PT1(K)+PT2(K)
3867             PTOT(K)   = PP(K)+PT(K)
3868     3    CONTINUE
3869 *
3870 *-----------------------------------------------------------------------
3871 *   this is a complete nucleon-nucleon interaction
3872 *
3873          IF (ISINGL(I).EQ.1) THEN
3874 *
3875 *     initialize PHOJET-variables for remnant/valence-partons
3876             IHFLD(1,1) = 0
3877             IHFLD(1,2) = 0
3878             IHFLD(2,1) = 0
3879             IHFLD(2,2) = 0
3880             IHFLS(1) = 1
3881             IHFLS(2) = 1
3882 *     save current settings of PHOJET process and min. bias flags
3883             DO 9 K=1,11
3884                KPRON(K) = IPRON(K,1)
3885     9       CONTINUE
3886             ISWSAV   = ISWMDL(2)
3887 *
3888 *     check if forced sampling of diffractive interaction requested
3889             IF (ISINGD.LT.-1) THEN
3890                DO 90 K=1,11
3891                   IPRON(K,1) = 0
3892    90          CONTINUE
3893                IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
3894                IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
3895                IF (ISINGD.EQ.-5) IPRON(4,1) = 1
3896             ENDIF
3897 *
3898 *     for photons: a direct/anomalous interaction is not sampled
3899 *     in PHOJET but already in Glauber-formalism. Here we check if such
3900 *     an interaction is requested
3901             IF (IJPROJ.EQ.7) THEN
3902 *       first switch off direct interactions
3903                IPRON(8,1) = 0
3904 *       this is a direct interactions
3905                IF (IDIREC.EQ.1) THEN
3906                   DO 12 K=1,11
3907                      IPRON(K,1) = 0
3908    12             CONTINUE
3909                   IPRON(8,1) = 1
3910 *       this is an anomalous interactions
3911 *         (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
3912                ELSEIF (IDIREC.EQ.2) THEN
3913                   ISWMDL(2) = 0
3914                ENDIF
3915             ELSE
3916                IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
3917             ENDIF
3918 *
3919 *     make sure that total momenta of partons, pp and pt, are on mass
3920 *     shell (Cronin may have srewed this up..)
3921             CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
3922             IF (IR1.NE.0) THEN
3923                IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
3924      &              'EVENTB:  mass shell correction rejected'
3925                GOTO 9999
3926             ENDIF
3927 *
3928 *     initialize the incoming particles in PHOJET
3929             IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3930
3931                CALL PHO_SETPAR(1,22,0,VIRT)
3932
3933             ELSE
3934
3935                CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
3936
3937             ENDIF
3938
3939             CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
3940
3941 *
3942 *     initialize rejection loop counter for anomalous processes
3943             IRJANO = 0
3944   800       CONTINUE
3945             IRJANO = IRJANO+1
3946 *
3947 *     temporary fix for ifano problem
3948             IFANO(1) = 0
3949             IFANO(2) = 0
3950 *
3951 *     generate complete hadron/nucleon/photon-nucleon event with PHOJET
3952
3953             CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
3954
3955 *
3956 *     for photons: special consistency check for anomalous interactions
3957             IF (IJPROJ.EQ.7) THEN
3958                IF (IRJANO.LT.30) THEN
3959                   IF (IFANO(1).NE.0) THEN
3960 *       here, an anomalous interaction was generated. Check if it
3961 *       was also requested. Otherwise reject this event.
3962                      IF (IDIREC.EQ.0) GOTO 800
3963                   ELSE
3964 *       here, an anomalous interaction was not generated. Check if it
3965 *       was requested in which case we need to reject this event.
3966                      IF (IDIREC.EQ.2) GOTO 800
3967                   ENDIF
3968                ELSE
3969                   WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
3970      &                          IRJANO,IDIREC,NEVHKK
3971                ENDIF
3972             ENDIF
3973 *
3974 *     copy back original settings of PHOJET process and min. bias flags
3975             DO 10 K=1,11
3976                IPRON(K,1) = KPRON(K)
3977    10       CONTINUE
3978             ISWMDL(2) = ISWSAV
3979 *
3980 *     check if PHOJET has rejected this event
3981             IF (IREJ1.NE.0) THEN
3982 C              IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3983                WRITE(LOUT,'(1X,A,I4)')
3984      &            'EVENTB:  chain system rejected',IDIREC
3985
3986                CALL PHO_PREVNT(0)
3987
3988                GOTO 9999
3989             ENDIF
3990 *
3991 *     copy partons and strings from PHOJET common back into DTEVT for
3992 *     external fragmentation
3993             MO1 = NC
3994             MO2 = NC+3
3995 *!      uncomment this line for internal phojet-fragmentation
3996 C           CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
3997             NPHOSC = NPHOSC+1
3998             CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
3999             IF (IREJ1.NE.0) THEN
4000                IF (IOULEV(1).GT.0)
4001      &         WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
4002                GOTO 9999
4003             ENDIF
4004 *
4005 *     update statistics counter
4006             ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
4007 *
4008 *-----------------------------------------------------------------------
4009 *   this interaction involves "remnants"
4010 *
4011          ELSE
4012 *
4013 *     total mass of this system
4014             PPTOT  = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
4015             AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
4016             IF (AMTOT2.LT.ZERO) THEN
4017                AMTOT = ZERO
4018             ELSE
4019                AMTOT = SQRT(AMTOT2)
4020             ENDIF
4021 *
4022 *     systems with masses larger than elojet are treated with PHOJET
4023             IF (AMTOT.GT.ELOJET) THEN
4024 *
4025 *     initialize PHOJET-variables for remnant/valence-partons
4026 *       projectile parton flavors and valence flag
4027                IHFLD(1,1) = IDHKK(NC)
4028                IHFLD(1,2) = IDHKK(NC+2)
4029                IHFLS(1)   = 0
4030                IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
4031      &                            .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
4032 *       target parton flavors and valence flag
4033                IHFLD(2,1) = IDHKK(NC+1)
4034                IHFLD(2,2) = IDHKK(NC+3)
4035                IHFLS(2)   = 0
4036                IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
4037      &                            .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
4038 *       flag signalizing PHOJET how to treat the remnant:
4039 *         iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
4040 *         iremn > -1 valence remnant: PHOJET assumes flavors according
4041 *                    to mother particle
4042                IREMN1 = IHFLS(1)-1
4043                IREMN2 = IHFLS(2)-1
4044 *
4045 *     initialize the incoming particles in PHOJET
4046                IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
4047
4048                   CALL PHO_SETPAR(1,22,IREMN1,VIRT)
4049
4050                ELSE
4051
4052                   CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
4053
4054                ENDIF
4055
4056                CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
4057
4058 *
4059 *     calculate Lorentz parameter of the nucleon-nucleon cm-system
4060                PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
4061                AMNN   = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
4062                BGX    = PTOTNN(1)/AMNN
4063                BGY    = PTOTNN(2)/AMNN
4064                BGZ    = PTOTNN(3)/AMNN
4065                GAM    = PTOTNN(4)/AMNN
4066 *     transform interacting nucleons into nucleon-nucleon cm-system
4067                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4068      &                     PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
4069      &                     PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
4070                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4071      &                     PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
4072      &                     PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
4073 *     transform (total) momenta of the proj and targ partons into
4074 *     nucleon-nucleon cm-system
4075                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4076      &                     PP(1),PP(2),PP(3),PP(4),
4077      &                     PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
4078                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4079      &                     PT(1),PT(2),PT(3),PT(4),
4080      &                     PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
4081 *     energy fractions of the proj and targ partons
4082                XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
4083                XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
4084 ***
4085 * testprint
4086 c              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
4087 c    &                        (PPTCMS(2)+PTTCMS(2))**2 +
4088 c    &                        (PPTCMS(3)+PTTCMS(3))**2 )
4089 c              EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
4090 c    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
4091 c              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
4092 c    &                        (PPSUB(2)+PTSUB(2))**2 +
4093 c    &                        (PPSUB(3)+PTSUB(3))**2 )
4094 c              EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
4095 c    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
4096 ***
4097 *
4098 *     save current settings of PHOJET process and min. bias flags
4099                DO 7 K=1,11
4100                   KPRON(K) = IPRON(K,1)
4101     7          CONTINUE
4102 *     disallow direct photon int. (does not make sense here anyway)
4103                IPRON(8,1) = 0
4104 *     disallow double pomeron processes (due to technical problems
4105 *     in PHOJET, needs to be solved sometime)
4106                IPRON(4,1) = 0
4107 *     disallow diffraction for sea-diquarks
4108                IF ((IABS(IHFLD(1,1)).GT.1100).AND.
4109      &             (IABS(IHFLD(1,2)).GT.1100)) THEN
4110                   IPRON(3,1) = 0
4111                   IPRON(6,1) = 0
4112                ENDIF
4113                IF ((IABS(IHFLD(2,1)).GT.1100).AND.
4114      &             (IABS(IHFLD(2,2)).GT.1100)) THEN
4115                   IPRON(3,1) = 0
4116                   IPRON(5,1) = 0
4117                ENDIF
4118 *
4119 *     we need massless partons: transform them on mass shell
4120                XMP = ZERO
4121                XMT = ZERO
4122                DO 6 K=1,4
4123                   PPTMP(K) = PPSUB(K)
4124                   PTTMP(K) = PTSUB(K)
4125     6          CONTINUE
4126                CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
4127                PPSUTO  = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
4128                PTSUTO  = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
4129                PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
4130      &                  (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
4131 *     total energy of the subsysten after mass transformation
4132 *      (should be the same as before..)
4133                SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
4134      &                      (PPSUB(4)+PTSUB(4)+PSUTOT) )
4135 *
4136 *     after mass shell transformation the x_sub - relation has to be
4137 *     corrected. We therefore create "pseudo-momenta" of mother-nucleons.
4138 *
4139 *     The old version was to scale based on the original x_sub and the
4140 *     4-momenta of the subsystem. At very high energy this could lead to
4141 *     "pseudo-cm energies" of the parent system considerably exceeding
4142 *     the true cm energy. Now we keep the true cm energy and calculate
4143 *     new x_sub instead.
4144 C old version  PPTCMS(4) = PPSUB(4)/XPSUB
4145                PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
4146                XPSUB = PPSUB(4)/PPTCMS(4)
4147                IF (IJPROJ.EQ.7) THEN
4148                   AMP2  = PHKK(5,MOT)**2
4149                   PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
4150                ELSE
4151 *???????
4152                   PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
4153      &                        *(PPTCMS(4)+PHKK(5,MOP)))
4154 C                 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
4155 C    &                        *(PPTCMS(4)+PHKK(5,MOT)))
4156                ENDIF
4157 C old version  PTTCMS(4) = PTSUB(4)/XTSUB
4158                PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
4159                XTSUB = PTSUB(4)/PTTCMS(4)
4160                PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
4161      &                     *(PTTCMS(4)+PHKK(5,MOT)))
4162                DO 4 K=1,3
4163                   PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
4164                   PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
4165     4          CONTINUE
4166 ***
4167 * testprint
4168 *
4169 *     ppnn  / ptnn   - momenta of the int. nucleons (cms, negl. Fermi)
4170 *     ptotnn         - total momentum of the int. nucleons (cms, negl. Fermi)
4171 *     pptcms/ pttcms - momenta of the interacting nucleons (cms)
4172 *     pp1,2 / pt1,2  - momenta of the four partons
4173 *
4174 *     pp    / pt     - total momenta of the pr/ta partons (cms, negl. Fermi)
4175 *     ptot           - total momentum of the four partons (cms, negl. Fermi)
4176 *     ppsub / ptsub  - total momenta of the proj / targ partons (cms)
4177 *
4178 c              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
4179 c    &                        (PPTCMS(2)+PTTCMS(2))**2 +
4180 c    &                        (PPTCMS(3)+PTTCMS(3))**2 )
4181 c              ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
4182 c    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
4183 c              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
4184 c    &                        (PPSUB(2)+PTSUB(2))**2 +
4185 c    &                        (PPSUB(3)+PTSUB(3))**2 )
4186 c              ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
4187 c    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
4188 c              IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
4189 c                 WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
4190 c                 WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
4191 c                 WRITE(*,*) ' XPSUB,  XTSUB  : ',XPSUB,XTSUB
4192 c              ENDIF
4193 c              BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
4194 c              BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
4195 c              BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
4196 c              BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
4197 *     transform interacting nucleons into nucleon-nucleon cm-system
4198 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4199 c    &                    PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
4200 c    &                     PPNEW1,PPNEW2,PPNEW3,PPNEW4)
4201 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4202 c    &                    PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
4203 c    &                     PTNEW1,PTNEW2,PTNEW3,PTNEW4)
4204 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4205 c    &                     PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
4206 c    &                     PPSUB1,PPSUB2,PPSUB3,PPSUB4)
4207 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4208 c    &                     PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
4209 c    &                     PTSUB1,PTSUB2,PTSUB3,PTSUB4)
4210 c              PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
4211 c    &                        (PPNEW2+PTNEW2)**2 +
4212 c    &                        (PPNEW3+PTNEW3)**2 )
4213 c              ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
4214 c    &                        (PPNEW4+PTNEW4+PTSTCM) )
4215 c              PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
4216 c    &                        (PPSUB2+PTSUB2)**2 +
4217 c    &                        (PPSUB3+PTSUB3)**2 )
4218 c              ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
4219 c    &                        (PPSUB4+PTSUB4+PTSTSU) )
4220 C              WRITE(*,*) ' mother cmE :'
4221 C              WRITE(*,*) ETSTCM,ENEWCM
4222 C              WRITE(*,*) ' subsystem cmE :'
4223 C              WRITE(*,*) ETSTSU,ENEWSU
4224 C              WRITE(*,*) ' projectile mother :'
4225 C              WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
4226 C              WRITE(*,*) ' target mother :'
4227 C              WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
4228 C              WRITE(*,*) ' projectile subsystem:'
4229 C              WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
4230 C              WRITE(*,*) ' target subsystem:'
4231 C              WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
4232 C              WRITE(*,*) ' projectile subsystem should be:'
4233 C              WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
4234 C    &                    XPSUB*ETSTCM/2.0D0
4235 C              WRITE(*,*) ' target subsystem should be:'
4236 C              WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
4237 C    &                    XTSUB*ETSTCM/2.0D0
4238 C              WRITE(*,*) ' subsystem cmE should be: '
4239 C              WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
4240 ***
4241 *
4242 *     generate complete remnant - nucleon/remnant event with PHOJET
4243
4244                CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
4245
4246 *
4247 *     copy back original settings of PHOJET process flags
4248                DO 11 K=1,11
4249                   IPRON(K,1) = KPRON(K)
4250    11          CONTINUE
4251 *
4252 *     check if PHOJET has rejected this event
4253                IF (IREJ1.NE.0) THEN
4254                   IF (IOULEV(1).GT.0)
4255      &            WRITE(LOUT,'(1X,A)') 'EVENTB:  chain system rejected'
4256                   WRITE(LOUT,*)
4257      &                 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
4258
4259                   CALL PHO_PREVNT(0)
4260
4261                   GOTO 9999
4262                ENDIF
4263 *
4264 *     copy partons and strings from PHOJET common back into DTEVT for
4265 *     external fragmentation
4266                MO1 = NC
4267                MO2 = NC+3
4268 *!      uncomment this line for internal phojet-fragmentation
4269 C              CALL DT_GETFSP(MO1,MO2,PP,PT,1)
4270                NPHOSC = NPHOSC+1
4271                CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
4272                IF (IREJ1.NE.0) THEN
4273                   IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
4274      &               'EVENTB: chain system rejected 2'
4275                   GOTO 9999
4276                ENDIF
4277 *
4278 *     update statistics counter
4279                ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
4280 *
4281 *-----------------------------------------------------------------------
4282 * two-chain approx. for smaller systems
4283 *
4284             ELSE
4285 *
4286                NDTUSC = NDTUSC+1
4287 *   special flag for double-Pomeron statistics
4288                IPOPO = 0
4289 *
4290 *   pick up flavors at the ends of the two chains
4291                IFP1 = IDHKK(NC)
4292                IFT1 = IDHKK(NC+1)
4293                IFP2 = IDHKK(NC+2)
4294                IFT2 = IDHKK(NC+3)
4295 *   ..and the indices of the mothers
4296                MOP1 = NC
4297                MOT1 = NC+1
4298                MOP2 = NC+2
4299                MOT2 = NC+3
4300                CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
4301      &                     IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
4302 *
4303 *   check if this chain system was rejected
4304                IF (IREJ1.GT.0) THEN
4305                   IF (IOULEV(1).GT.0) THEN
4306                      WRITE(LOUT,*) 'rejected 1 in EVENTB'
4307                      WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
4308      &                  IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
4309                   ENDIF
4310                   IRHHA = IRHHA+1
4311                   GOTO 9999
4312                ENDIF
4313 *   the following lines are for sea-sea chains rejected in GETCSY
4314                IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
4315                ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
4316             ENDIF
4317 *
4318          ENDIF
4319 *
4320 *     update statistics counter
4321          ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
4322 *
4323          NC = NC+4
4324 *
4325     2 CONTINUE
4326 *
4327 *-----------------------------------------------------------------------
4328 * treatment of low-mass chains (if there are any)
4329 *
4330       IF (NDTUSC.GT.0) THEN
4331 *
4332 *   correct chains of very low masses for possible resonances
4333          IF (IRESCO.EQ.1) THEN
4334             CALL DT_EVTRES(IREJ1)
4335             IF (IREJ1.GT.0) THEN
4336                IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
4337                IRRES(1) = IRRES(1)+1
4338                GOTO 9999
4339             ENDIF
4340          ENDIF
4341 *   fragmentation of low-mass chains
4342 *!  uncomment this line for internal phojet-fragmentation
4343 *   (of course it will still be fragmented by DPMJET-routines but it
4344 *    has to be done here instead of further below)
4345 C        CALL DT_EVTFRA(IREJ1)
4346 C        IF (IREJ1.GT.0) THEN
4347 C           IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
4348 C           IRFRAG = IRFRAG+1
4349 C           GOTO 9999
4350 C        ENDIF
4351       ELSE
4352 *! uncomment this line for internal phojet-fragmentation
4353 C        NPOINT(4) = NHKK+1
4354          IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
4355       ENDIF
4356 *
4357 *-----------------------------------------------------------------------
4358 * new di-quark breaking mechanisms
4359 *
4360       MXLEFT = 2
4361       CALL DT_CHASTA(0)
4362       IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
4363      &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
4364          CALL DT_DIQBRK
4365          MXLEFT = 4
4366       ENDIF
4367 *
4368 *-----------------------------------------------------------------------
4369 * hadronize this event
4370 *
4371 *   hadronize PHOJET chain systems
4372       NPYMAX = 0
4373       NPJE   = NPHOSC/MXPHFR
4374       IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
4375       IF (NPJE.GT.1) THEN
4376          NLEFT = NPHOSC-NPJE*MXPHFR
4377          DO 20 JFRG=1,NPJE
4378             NFRG = JFRG*MXPHFR
4379             IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
4380                CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4381                IF (IREJ1.GT.0) GOTO 22
4382                NLEFT = 0
4383             ELSE
4384                CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
4385                IF (IREJ1.GT.0) GOTO 22
4386             ENDIF
4387             IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4388    20    CONTINUE
4389          IF (NLEFT.GT.0) THEN
4390             CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4391             IF (IREJ1.GT.0) GOTO 22
4392             IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4393          ENDIF
4394       ELSE
4395          CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4396          IF (IREJ1.GT.0) GOTO 22
4397          IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4398       ENDIF
4399 *
4400 *   check max. filling level of jetset common and
4401 *   reduce mxphfr if necessary
4402       IF (NPYMAX.GT.3000) THEN
4403          IF (NPYMAX.GT.3500) THEN
4404             MXPHFR = MAX(1,MXPHFR-2)
4405          ELSE
4406             MXPHFR = MAX(1,MXPHFR-1)
4407          ENDIF
4408 C        WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
4409       ENDIF
4410 *
4411 *   hadronize DTUNUC chain systems
4412    23 CONTINUE
4413       IBACK = MXDTFR
4414       CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
4415       IF (IREJ2.GT.0) GOTO 22
4416 *
4417 *   check max. filling level of jetset common and
4418 *   reduce mxdtfr if necessary
4419       IF (NPYMEM.GT.3000) THEN
4420          IF (NPYMEM.GT.3500) THEN
4421             MXDTFR = MAX(1,MXDTFR-20)
4422          ELSE
4423             MXDTFR = MAX(1,MXDTFR-10)
4424          ENDIF
4425 C        WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
4426       ENDIF
4427 *
4428       IF (IBACK.EQ.-1) GOTO 23
4429 *
4430    22 CONTINUE
4431 C     CALL DT_EVTFRG(1,IREJ1)
4432 C     CALL DT_EVTFRG(2,IREJ2)
4433       IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
4434          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
4435          IRFRAG = IRFRAG+1
4436          GOTO 9999
4437       ENDIF
4438 *
4439 * get final state particles from /DTEVTP/
4440 *! uncomment this line for internal phojet-fragmentation
4441 C     CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
4442
4443       IF (IJPROJ.NE.7)
4444      &   CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
4445 C     IF (IREJ3.NE.0) GOTO 9999
4446
4447       RETURN
4448
4449  9999 CONTINUE
4450       IREVT = IREVT+1
4451       IREJ  = 1
4452       RETURN
4453       END
4454
4455 *$ CREATE DT_GETPJE.FOR
4456 *COPY DT_GETPJE
4457 *
4458 *===getpje=============================================================*
4459 *
4460       SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
4461
4462 ************************************************************************
4463 * This subroutine copies PHOJET partons and strings from POEVT1 into   *
4464 * DTEVT1.                                                              *
4465 *      MO1,MO2   indices of first and last mother-parton in DTEVT1     *
4466 *      PP,PT     4-momenta of projectile/target being handled by       *
4467 *                PHOJET                                                *
4468 * This version dated 11.12.99 is written by S. Roesler                 *
4469 ************************************************************************
4470
4471       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4472       SAVE
4473
4474       PARAMETER ( LINP = 10 ,
4475      &            LOUT = 6 ,
4476      &            LDAT = 9 )
4477
4478       PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
4479      &           ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
4480
4481       LOGICAL LFLIP
4482
4483 * event history
4484
4485       PARAMETER (NMXHKK=200000)
4486
4487       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4488      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4489      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4490
4491 * extended event history
4492       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4493      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4494      &                IHIST(2,NMXHKK)
4495
4496 * Lorentz-parameters of the current interaction
4497       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4498      &                UMO,PPCM,EPROJ,PPROJ
4499
4500 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
4501       COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
4502
4503 * flags for input different options
4504       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4505       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4506      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4507
4508 * statistics: double-Pomeron exchange
4509       COMMON /DTFLG2/ INTFLG,IPOPO
4510
4511 * statistics
4512       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
4513      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
4514      &                ICEVTG(8,0:30)
4515
4516 * rejection counter
4517       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
4518      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
4519      &                IREXCI(3),IRDIFF(2),IRINC
4520 C  standard particle data interface
4521       INTEGER NMXHEP
4522
4523       PARAMETER (NMXHEP=4000)
4524
4525       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
4526       DOUBLE PRECISION PHEP,VHEP
4527       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
4528      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
4529      &                VHEP(4,NMXHEP)
4530 C  extension to standard particle data interface (PHOJET specific)
4531       INTEGER IMPART,IPHIST,ICOLOR
4532       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
4533
4534 C  color string configurations including collapsed strings and hadrons
4535       INTEGER MSTR
4536       PARAMETER (MSTR=500)
4537       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
4538       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
4539      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
4540      &                NNCH(MSTR),IBHAD(MSTR),ISTR
4541
4542 C  general process information
4543       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4544       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4545
4546 C  model switches and parameters
4547       CHARACTER*8 MDLNA
4548       INTEGER ISWMDL,IPAMDL
4549       DOUBLE PRECISION PARMDL
4550       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4551
4552 C  event debugging information
4553       INTEGER NMAXD
4554       PARAMETER (NMAXD=100)
4555       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4556      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4557       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4558      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4559
4560       DIMENSION PP(4),PT(4)
4561       DATA MAXLOP /10000/
4562
4563       INHKK = NHKK
4564       LFLIP = .TRUE.
4565     1 CONTINUE
4566       NPVAL = 0
4567       NTVAL = 0
4568       IREJ  = 0
4569
4570 *   store initial momenta for energy-momentum conservation check
4571       IF (LEMCCK) THEN
4572          CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
4573          CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
4574       ENDIF
4575 * copy partons and strings from POEVT1 into DTEVT1
4576       DO 11 I=1,ISTR
4577 C        IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
4578          IF (NCODE(I).EQ.-99) THEN
4579             IDXSTG = NPOS(1,I)
4580             IDSTG  = IDHEP(IDXSTG)
4581             PX = PHEP(1,IDXSTG)
4582             PY = PHEP(2,IDXSTG)
4583             PZ = PHEP(3,IDXSTG)
4584             PE = PHEP(4,IDXSTG)
4585             IF (MODE.LT.0) THEN
4586                ISTAT = 70000+IPJE
4587                CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
4588      &                        11,IDSTG,0)
4589                IF (LEMCCK) THEN
4590                   PX = -PX
4591                   PY = -PY
4592                   PZ = -PZ
4593                   PE = -PE
4594                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4595                ENDIF
4596             ELSE
4597                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4598      &                        PPX,PPY,PPZ,PPE)
4599                ISTAT = 70000+IPJE
4600                CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
4601      &                        11,IDSTG,0)
4602                IF (LEMCCK) THEN
4603                   PX = -PPX
4604                   PY = -PPY
4605                   PZ = -PPZ
4606                   PE = -PPE
4607                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4608                ENDIF
4609             ENDIF
4610             NOBAM(NHKK)   = 0
4611             IHIST(1,NHKK) = IPHIST(1,IDXSTG)
4612             IHIST(2,NHKK) = 0
4613          ELSEIF (NCODE(I).GE.0) THEN
4614 *   indices of partons and string in POEVT1
4615             IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
4616             IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
4617             IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
4618                WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
4619      &         ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
4620                STOP ' GETPJE 1'
4621             ENDIF
4622             IDXSTG = NPOS(1,I)
4623 *   find "mother" string of the string
4624             IDXMS1 = ABS(JMOHEP(1,IDX1))
4625             IDXMS2 = ABS(JMOHEP(1,IDX2))
4626             IF (IDXMS1.NE.IDXMS2) THEN
4627                IDXMS1 = IDXSTG
4628                IDXMS2 = IDXSTG
4629 C              STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
4630             ENDIF
4631 *   search POEVT1 for the original hadron of the parton
4632             ILOOP = 0
4633             IPOM1 = 0
4634    14       CONTINUE
4635             ILOOP = ILOOP+1
4636
4637             IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
4638
4639             IDXMS1 = ABS(JMOHEP(1,IDXMS1))
4640             IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
4641      &          (ILOOP.LT.MAXLOP)) GOTO 14
4642             IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
4643             IPOM2 = 0
4644             ILOOP = 0
4645    15       CONTINUE
4646             ILOOP = ILOOP+1
4647
4648             IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
4649
4650             IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
4651                IDXMS2 = ABS(JMOHEP(2,IDXMS2))
4652             ELSE
4653                IDXMS2 = ABS(JMOHEP(1,IDXMS2))
4654             ENDIF
4655             IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
4656      &          (ILOOP.LT.MAXLOP)) GOTO 15
4657             IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
4658 *   parton 1
4659             IF (IDXMS1.EQ.1) THEN
4660                ISPTN1 = ISTHKK(MO1)
4661                M1PTN1 = MO1
4662                M2PTN1 = MO1+2
4663             ELSE
4664                ISPTN1 = ISTHKK(MO2)
4665                M1PTN1 = MO2-2
4666                M2PTN1 = MO2
4667             ENDIF
4668 *   parton 2
4669             IF (IDXMS2.EQ.1) THEN
4670                ISPTN2 = ISTHKK(MO1)
4671                M1PTN2 = MO1
4672                M2PTN2 = MO1+2
4673             ELSE
4674                ISPTN2 = ISTHKK(MO2)
4675                M1PTN2 = MO2-2
4676                M2PTN2 = MO2
4677             ENDIF
4678 *   check for mis-identified mothers and switch mother indices if necessary
4679             IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
4680      &          .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
4681      &          (LFLIP)) THEN
4682                IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
4683                   ISPTN1 = ISTHKK(MO1)
4684                   M1PTN1 = MO1
4685                   M2PTN1 = MO1+2
4686                   ISPTN2 = ISTHKK(MO2)
4687                   M1PTN2 = MO2-2
4688                   M2PTN2 = MO2
4689                ELSE
4690                   ISPTN1 = ISTHKK(MO2)
4691                   M1PTN1 = MO2-2
4692                   M2PTN1 = MO2
4693                   ISPTN2 = ISTHKK(MO1)
4694                   M1PTN2 = MO1
4695                   M2PTN2 = MO1+2
4696                ENDIF
4697             ENDIF
4698 *   register partons in temporary common
4699 *     parton at chain end
4700             PX = PHEP(1,IDX1)
4701             PY = PHEP(2,IDX1)
4702             PZ = PHEP(3,IDX1)
4703             PE = PHEP(4,IDX1)
4704 * flag only partons coming from Pomeron with 41/42
4705 C           IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4706             IF (IPOM1.NE.0) THEN
4707                ISTX = ABS(ISPTN1)/10
4708                IMO  = ABS(ISPTN1)-10*ISTX
4709                ISPTN1 = -(40+IMO)
4710             ELSE
4711                IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
4712                   ISTX = ABS(ISPTN1)/10
4713                   IMO  = ABS(ISPTN1)-10*ISTX
4714                   IF ((IDHEP(IDX1).EQ.21).OR.
4715      &                (ABS(IPHIST(1,IDX1)).GE.100)) THEN
4716                      ISPTN1 = -(60+IMO)
4717                   ELSE
4718                      ISPTN1 = -(50+IMO)
4719                   ENDIF
4720                ENDIF
4721             ENDIF
4722             IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
4723             IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
4724             IF (MODE.LT.0) THEN
4725                CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
4726      &                        PZ,PE,0,0,0)
4727             ELSE
4728                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4729      &                        PPX,PPY,PPZ,PPE)
4730                CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
4731      &                        PPZ,PPE,0,0,0)
4732             ENDIF
4733             IHIST(1,NHKK) = IPHIST(1,IDX1)
4734             IHIST(2,NHKK) = 0
4735             DO 19 KK=1,4
4736                VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
4737                WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
4738    19       CONTINUE
4739             VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
4740             WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
4741             M1STRG = NHKK
4742 *     gluon kinks
4743             NGLUON = IDX2-IDX1-1
4744             IF (NGLUON.GT.0) THEN
4745                DO 17 IGLUON=1,NGLUON
4746                   IDX   = IDX1+IGLUON
4747                   IDXMS = ABS(JMOHEP(1,IDX))
4748                   IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
4749                      ILOOP = 0
4750    16                CONTINUE
4751                      ILOOP = ILOOP+1
4752                      IDXMS = ABS(JMOHEP(1,IDXMS))
4753                      IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
4754      &                   (ILOOP.LT.MAXLOP)) GOTO 16
4755                      IF (ILOOP.EQ.MAXLOP)
4756      &                  WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
4757                   ENDIF
4758                   IF (IDXMS.EQ.1) THEN
4759                      ISPTN = ISTHKK(MO1)
4760                      M1PTN = MO1
4761                      M2PTN = MO1+2
4762                   ELSE
4763                      ISPTN = ISTHKK(MO2)
4764                      M1PTN = MO2-2
4765                      M2PTN = MO2
4766                   ENDIF
4767                   PX = PHEP(1,IDX)
4768                   PY = PHEP(2,IDX)
4769                   PZ = PHEP(3,IDX)
4770                   PE = PHEP(4,IDX)
4771                   IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
4772                      ISTX = ABS(ISPTN)/10
4773                      IMO  = ABS(ISPTN)-10*ISTX
4774                      IF ((IDHEP(IDX).EQ.21).OR.
4775      &                   (ABS(IPHIST(1,IDX)).GE.100)) THEN
4776                         ISPTN = -(60+IMO)
4777                      ELSE
4778                         ISPTN = -(50+IMO)
4779                      ENDIF
4780                   ENDIF
4781                   IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
4782                   IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
4783                   IF (MODE.LT.0) THEN
4784                      CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4785      &                              PX,PY,PZ,PE,0,0,0)
4786                   ELSE
4787                      CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4788      &                              PPX,PPY,PPZ,PPE)
4789                      CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4790      &                              PPX,PPY,PPZ,PPE,0,0,0)
4791                   ENDIF
4792                   IHIST(1,NHKK) = IPHIST(1,IDX)
4793                   IHIST(2,NHKK) = 0
4794                   DO 20 KK=1,4
4795                      VHKK(KK,NHKK) = VHKK(KK,M2PTN)
4796                      WHKK(KK,NHKK) = WHKK(KK,M1PTN)
4797    20             CONTINUE
4798                   VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
4799                   WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
4800    17          CONTINUE
4801             ENDIF
4802 *     parton at chain end
4803             PX = PHEP(1,IDX2)
4804             PY = PHEP(2,IDX2)
4805             PZ = PHEP(3,IDX2)
4806             PE = PHEP(4,IDX2)
4807 * flag only partons coming from Pomeron with 41/42
4808 C           IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4809             IF (IPOM2.NE.0) THEN
4810                ISTX = ABS(ISPTN2)/10
4811                IMO  = ABS(ISPTN2)-10*ISTX
4812                ISPTN2 = -(40+IMO)
4813             ELSE
4814                IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
4815                   ISTX = ABS(ISPTN2)/10
4816                   IMO  = ABS(ISPTN2)-10*ISTX
4817                   IF ((IDHEP(IDX2).EQ.21).OR.
4818      &                (ABS(IPHIST(1,IDX2)).GE.100)) THEN
4819                      ISPTN2 = -(60+IMO)
4820                   ELSE
4821                      ISPTN2 = -(50+IMO)
4822                   ENDIF
4823                ENDIF
4824             ENDIF
4825             IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
4826             IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
4827             IF (MODE.LT.0) THEN
4828                CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4829      &                        PX,PY,PZ,PE,0,0,0)
4830             ELSE
4831                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4832      &                        PPX,PPY,PPZ,PPE)
4833                CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4834      &                        PPX,PPY,PPZ,PPE,0,0,0)
4835             ENDIF
4836             IHIST(1,NHKK) = IPHIST(1,IDX2)
4837             IHIST(2,NHKK) = 0
4838             DO 21 KK=1,4
4839                VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
4840                WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
4841    21       CONTINUE
4842             VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
4843             WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
4844             M2STRG = NHKK
4845 *   register string
4846             JSTRG = 100*IPROCE+NCODE(I)
4847             PX = PHEP(1,IDXSTG)
4848             PY = PHEP(2,IDXSTG)
4849             PZ = PHEP(3,IDXSTG)
4850             PE = PHEP(4,IDXSTG)
4851             IF (MODE.LT.0) THEN
4852                ISTAT = 70000+IPJE
4853                CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4854      &                        PX,PY,PZ,PE,0,0,0)
4855                IF (LEMCCK) THEN
4856                   PX = -PX
4857                   PY = -PY
4858                   PZ = -PZ
4859                   PE = -PE
4860                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4861                ENDIF
4862             ELSE
4863                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4864      &                        PPX,PPY,PPZ,PPE)
4865                ISTAT = 70000+IPJE
4866                CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4867      &                        PPX,PPY,PPZ,PPE,0,0,0)
4868                IF (LEMCCK) THEN
4869                   PX = -PPX
4870                   PY = -PPY
4871                   PZ = -PPZ
4872                   PE = -PPE
4873                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4874                ENDIF
4875             ENDIF
4876             NOBAM(NHKK)   = 0
4877             IHIST(1,NHKK) = 0
4878             IHIST(2,NHKK) = 0
4879             DO 18 KK=1,4
4880                VHKK(KK,NHKK) = VHKK(KK,MO2)
4881                WHKK(KK,NHKK) = WHKK(KK,MO1)
4882    18       CONTINUE
4883             VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
4884             WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
4885          ENDIF
4886    11 CONTINUE
4887
4888       IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
4889          NHKK  = INHKK
4890          LFLIP = .FALSE.
4891          GOTO 1
4892       ENDIF
4893
4894       IF (LEMCCK) THEN
4895          IF (UMO.GT.1.0D5) THEN
4896             CHKLEV = 1.0D0
4897          ELSE
4898             CHKLEV = TINY1
4899          ENDIF
4900          CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
4901
4902          IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
4903
4904       ENDIF
4905
4906 * internal statistics
4907 *   dble-Po statistics.
4908       IF (IPROCE.NE.4) IPOPO = 0
4909
4910       INTFLG = IPROCE
4911       IDCHSY = IDCH(MO1)
4912       IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
4913          ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
4914       ELSE
4915          WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
4916  1000    FORMAT(1X,'GETFSP:   warning! incons. process id. (',I2,
4917      &          ') at evt(chain) ',I6,'(',I2,')')
4918       ENDIF
4919       IF (IPROCE.EQ.5) THEN
4920          IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
4921             ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
4922          ELSE
4923 C           WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4924  1001       FORMAT(1X,'GETFSP:   warning! incons. diffrac. id. ',
4925      &             '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
4926          ENDIF
4927       ELSEIF (IPROCE.EQ.6) THEN
4928          IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4929             ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
4930          ELSE
4931 C           WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4932          ENDIF
4933       ELSEIF (IPROCE.EQ.7) THEN
4934          IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
4935      &       (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4936             IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
4937      &         ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
4938             IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
4939      &         ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
4940             IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
4941      &         ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
4942             IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
4943      &         ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
4944          ELSE
4945             WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4946          ENDIF
4947       ENDIF
4948       IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
4949      &                                                       THEN
4950          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4951          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4952          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4953       ENDIF
4954       ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
4955       ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
4956       ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
4957       ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
4958       ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
4959
4960       RETURN
4961
4962  9999 CONTINUE
4963       IREJ = 1
4964       RETURN
4965       END
4966
4967 *$ CREATE DT_PHOINI.FOR
4968 *COPY DT_PHOINI
4969 *
4970 *===phoini=============================================================*
4971 *
4972       SUBROUTINE DT_PHOINI
4973
4974 ************************************************************************
4975 * Initialization PHOJET-event generator for nucleon-nucleon interact.  *
4976 * This version dated 16.11.95 is written by S. Roesler                 *
4977 *                                                                      *
4978 * Last change 27.12.2006 by S. Roesler.                                *
4979 ************************************************************************
4980
4981       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4982       SAVE
4983
4984       PARAMETER ( LINP = 10 ,
4985      &            LOUT = 6 ,
4986      &            LDAT = 9 )
4987
4988       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
4989
4990 * nucleon-nucleon event-generator
4991       CHARACTER*8 CMODEL
4992       LOGICAL LPHOIN
4993       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
4994
4995 * particle properties (BAMJET index convention)
4996       CHARACTER*8  ANAME
4997       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
4998      &                IICH(210),IIBAR(210),K1(210),K2(210)
4999
5000 * Lorentz-parameters of the current interaction
5001       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5002      &                UMO,PPCM,EPROJ,PPROJ
5003
5004 * properties of interacting particles
5005       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5006
5007 * properties of photon/lepton projectiles
5008       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5009
5010       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
5011
5012 * emulsion treatment
5013       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
5014      &                NCOMPO,IEMUL
5015
5016 * VDM parameter for photon-nucleus interactions
5017       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
5018
5019 * nuclear potential
5020       LOGICAL LFERMI
5021       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5022      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5023      &                ETACOU(2),ICOUL,LFERMI
5024
5025 * Glauber formalism: flags and parameters for statistics
5026       LOGICAL LPROD
5027       CHARACTER*8 CGLB
5028       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
5029 *
5030 * parameters for cascade calculations:
5031 * maximum mumber of PDF's which can be defined in phojet (limited
5032 * by the dimension of ipdfs in pho_setpdf)
5033       PARAMETER (MAXPDF = 20)
5034 * PDF parametrization and number of set for the first 30 hadrons in
5035 * the bamjet-code list
5036 *   negative numbers mean that the PDF is set in phojet,
5037 *   zero stands for "not a hadron"
5038       DIMENSION IPARPD(30),ISETPD(30)
5039 * PDF parametrization
5040       DATA IPARPD /
5041      &  -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
5042      &   5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
5043 * number of set
5044       DATA ISETPD /
5045      &  -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
5046      &   6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
5047
5048 **PHOJET105a
5049 C     COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
5050 C     PARAMETER ( MAXPRO = 16 )
5051 C     PARAMETER ( MAXTAB = 20 )
5052 C     COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
5053 C    &                MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
5054 C     CHARACTER*8 MDLNA
5055 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
5056 C     COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
5057 **PHOJET110
5058
5059 C  global event kinematics and particle IDs
5060       INTEGER IFPAP,IFPAB
5061       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
5062       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
5063
5064 C  hard cross sections and MC selection weights
5065       INTEGER Max_pro_2
5066       PARAMETER ( Max_pro_2 = 16 )
5067       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
5068      &  MH_acc_1,MH_acc_2
5069       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
5070       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
5071      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
5072      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
5073      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
5074      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
5075
5076 C  model switches and parameters
5077       CHARACTER*8 MDLNA
5078       INTEGER ISWMDL,IPAMDL
5079       DOUBLE PRECISION PARMDL
5080       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
5081
5082 C  general process information
5083       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
5084       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
5085 **
5086       DIMENSION PP(4),PT(4)
5087
5088       LOGICAL LSTART
5089       DATA LSTART /.TRUE./
5090
5091       IJP = IJPROJ
5092       IJT = IJTARG
5093       Q2  = VIRT
5094 * lepton-projectiles: initialize real photon instead
5095       IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
5096          IJP = 7
5097          Q2  = ZERO
5098       ENDIF
5099
5100       IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM)
5101
5102 * switch Reggeon off
5103 C     IPAMDL(3)= 0
5104       IF (IP.EQ.1) THEN
5105          IFPAP(1) = IDT_IPDGHA(IJP)
5106          IFPAB(1) = IJP
5107       ELSE
5108          IFPAP(1) = 2212
5109          IFPAB(1) = IDT_ICIHAD(IFPAP(1))
5110       ENDIF
5111       PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
5112       PVIRT(1) = PMASS(1)**2
5113       IF (IT.EQ.1) THEN
5114          IFPAP(2) = IDT_IPDGHA(IJT)
5115          IFPAB(2) = IJT
5116       ELSE
5117          IFPAP(2) = 2212
5118          IFPAB(2) = IDT_ICIHAD(IFPAP(2))
5119       ENDIF
5120       PMASS(2) = AAM(IFPAB(2))
5121       PVIRT(2) = ZERO
5122       DO 1 K=1,4
5123          PP(K) = ZERO
5124          PT(K) = ZERO
5125     1 CONTINUE
5126 * get max. possible momenta of incoming particles to be used for PHOJET ini.
5127       PPF = ZERO
5128       PTF = ZERO
5129       SCPF= 1.5D0
5130       IF (UMO.GE.1.E5) THEN
5131          SCPF= 5.0D0
5132       ENDIF
5133       IF (NCOMPO.GT.0) THEN
5134          DO 2 I=1,NCOMPO
5135             IF (IT.GT.1) THEN
5136                CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
5137             ELSE
5138                CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
5139             ENDIF
5140             PPFTMP = MAX(PFERMP(1),PFERMN(1))
5141             PTFTMP = MAX(PFERMP(2),PFERMN(2))
5142             IF (PPFTMP.GT.PPF) PPF = PPFTMP
5143             IF (PTFTMP.GT.PTF) PTF = PTFTMP
5144     2    CONTINUE
5145       ELSE
5146          CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
5147          PPF = MAX(PFERMP(1),PFERMN(1))
5148          PTF = MAX(PFERMP(2),PFERMN(2))
5149       ENDIF
5150       PTF = -PTF
5151       PPF = SCPF*PPF
5152       PTF = SCPF*PTF
5153       IF (IJP.EQ.7) THEN
5154          AMP2  = SIGN(PMASS(1)**2,PMASS(1))
5155          PP(3) = PPCM
5156          PP(4) = SQRT(AMP2+PP(3)**2)
5157       ELSE
5158          EPF = SQRT(PPF**2+PMASS(1)**2)
5159          CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
5160       ENDIF
5161       ETF = SQRT(PTF**2+PMASS(2)**2)
5162       CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
5163       ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
5164      &              (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
5165       IF (LSTART) THEN
5166          WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
5167  1001    FORMAT(
5168      &      ' DT_PHOINI:    PHOJET initialized for projectile A,Z = ',
5169      &      I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
5170          IF (NCOMPO.GT.0) THEN
5171             WRITE(LOUT,1002) SCPF,PTF,PT
5172          ELSE
5173             WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
5174          ENDIF
5175  1002    FORMAT(
5176      &      ' DT_PHOINI:    PHOJET initialized for target emulsion  ',
5177      &          /,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
5178  1003    FORMAT(
5179      &      ' DT_PHOINI:    PHOJET initialized for target     A,Z = ',
5180      &      I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
5181          WRITE(LOUT,1004) ECMINI
5182  1004    FORMAT(' E_cm = ',E10.3)
5183          IF (IJP.EQ.8) WRITE(LOUT,1005)
5184  1005    FORMAT(
5185      &      ' DT_PHOINI: warning! proton parameters used for neutron',
5186      &          ' projectile')
5187          LSTART = .FALSE.
5188       ENDIF
5189 * switch off new diffractive cross sections at low energies for nuclei
5190 * (temporary solution)
5191       IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
5192          WRITE(LOUT,'(1X,A)')
5193      &      ' DT_PHOINI: model-switch 30 for nuclei re-set !'
5194          CALL PHO_SETMDL(30,0,1)
5195       ENDIF
5196 *
5197 C     IF (IJP.EQ.7) THEN
5198 C        AMP2  = SIGN(PMASS(1)**2,PMASS(1))
5199 C        PP(3) = PPCM
5200 C        PP(4) = SQRT(AMP2+PP(3)**2)
5201 C     ELSE
5202 C        PFERMX = ZERO
5203 C        IF (IP.GT.1) PFERMX = 0.5D0
5204 C        EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
5205 C        CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
5206 C     ENDIF
5207 C     PFERMX = ZERO
5208 C     IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
5209 C     EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
5210 C     CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
5211 **sr 26.10.96
5212       ISAV = IPAMDL(13)
5213       IF ((ISHAD(2).EQ.1).AND.
5214      &   ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
5215      &    (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
5216 **
5217
5218       CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
5219
5220 **sr 26.10.96
5221       IPAMDL(13) = ISAV
5222 **
5223 *
5224 * patch for cascade calculations:
5225 * define parton distribution functions for other hadrons, i.e. other
5226 * then defined already in phojet
5227       IF (IOGLB.EQ.100) THEN
5228          WRITE(LOUT,1006)
5229  1006    FORMAT(/,1X,'PHOINI: additional parton distribution functions',
5230      &          ' assiged (ID,IPAR,ISET)',/)
5231          NPDF = 0
5232          DO 3 I=1,30
5233             IF (IPARPD(I).NE.0) THEN
5234                NPDF = NPDF+1
5235                IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
5236                IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
5237                   IDPDG = IDT_IPDGHA(I)
5238                   IPAR  = IPARPD(I)
5239                   ISET  = ISETPD(I)
5240                   WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
5241                   CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
5242                ENDIF
5243             ENDIF
5244     3    CONTINUE
5245       ENDIF
5246
5247 C     CALL PHO_PHIST(-1,SIGMAX)
5248
5249       IF (IREJ1.NE.0) THEN
5250          WRITE(LOUT,1000)
5251  1000    FORMAT(1X,'PHOINI:   PHOJET event-initialization failed!')
5252          STOP
5253       ENDIF
5254
5255       RETURN
5256       END
5257
5258 *$ CREATE DT_EVENTD.FOR
5259 *COPY DT_EVENTD
5260 *
5261 *===eventd=============================================================*
5262 *
5263       SUBROUTINE DT_EVENTD(IREJ)
5264
5265 ************************************************************************
5266 * Quasi-elastic neutrino nucleus scattering.                           *
5267 * This version dated 29.04.00 is written by S. Roesler.                *
5268 ************************************************************************
5269
5270       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5271       SAVE
5272
5273       PARAMETER ( LINP = 10 ,
5274      &            LOUT = 6 ,
5275      &            LDAT = 9 )
5276
5277       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
5278       PARAMETER (SQTINF=1.0D+15)
5279
5280       LOGICAL LFIRST
5281
5282 * event history
5283
5284       PARAMETER (NMXHKK=200000)
5285
5286       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5287      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5288      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5289
5290 * extended event history
5291       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5292      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5293      &                IHIST(2,NMXHKK)
5294
5295 * flags for input different options
5296       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5297       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5298      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5299       PARAMETER (MAXLND=4000)
5300       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
5301
5302 * properties of interacting particles
5303       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5304
5305 * Lorentz-parameters of the current interaction
5306       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5307      &                UMO,PPCM,EPROJ,PPROJ
5308
5309 * nuclear potential
5310       LOGICAL LFERMI
5311       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5312      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5313      &                ETACOU(2),ICOUL,LFERMI
5314
5315 * steering flags for qel neutrino scattering modules
5316       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
5317
5318       COMMON /QNPOL/ POLARX(4),PMODUL
5319
5320       INTEGER PYK
5321
5322       DATA LFIRST /.TRUE./
5323
5324       IREJ = 0
5325
5326       IF (LFIRST) THEN
5327          LFIRST = .FALSE.
5328          CALL DT_MASS_INI
5329       ENDIF
5330
5331 * JETSET parameter
5332       CALL DT_INITJS(0)
5333
5334 * interacting target nucleon
5335       LTYP = NEUTYP
5336       IF (NEUDEC.LE.9) THEN
5337          IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
5338             NUCTYP = 2112
5339             NUCTOP = 2
5340          ELSE
5341             NUCTYP = 2212
5342             NUCTOP = 1
5343          ENDIF
5344       ELSE
5345          RTYP  = DT_RNDM(RTYP)
5346          ZFRAC = DBLE(ITZ)/DBLE(IT)
5347          IF (RTYP.LE.ZFRAC) THEN
5348             NUCTYP = 2212
5349             NUCTOP = 1
5350          ELSE
5351             NUCTYP = 2112
5352             NUCTOP = 2
5353          ENDIF
5354       ENDIF
5355
5356 * select first nucleon in list with matching id and reset all other
5357 * nucleons which have been marked as "wounded" by ININUC
5358       IFOUND = 0
5359       DO 1 I=1,NHKK
5360          IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
5361             ISTHKK(I) = 12
5362             IFOUND    = 1
5363             IDX = I
5364          ELSE
5365             IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
5366          ENDIF
5367     1 CONTINUE
5368       IF (IFOUND.EQ.0)
5369      &   STOP ' EVENTD: interacting target nucleon not found! '
5370
5371 * correct position of proj. lepton: assume position of target nucleon
5372       DO 3 I=1,4
5373          VHKK(I,1) = VHKK(I,IDX)
5374          WHKK(I,1) = WHKK(I,IDX)
5375     3 CONTINUE
5376
5377 * load initial momenta for conservation check
5378       IF (LEMCCK) THEN
5379          CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
5380          CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
5381      &                                                      2,IDUM,IDUM)
5382       ENDIF
5383
5384 * quasi-elastic scattering
5385       IF (NEUDEC.LT.9) THEN
5386          CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
5387      &                                          PHKK(4,IDX),PHKK(5,IDX))
5388 *  CC event on p or n
5389       ELSEIF (NEUDEC.EQ.10) THEN
5390          CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
5391      &                     PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5392 *  NC event on p or n
5393       ELSEIF (NEUDEC.EQ.11) THEN
5394          CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
5395      &                     PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5396       ENDIF
5397
5398 * get final state particles from Lund-common and write them into HKKEVT
5399       NPOINT(1) = NHKK+1
5400       NPOINT(4) = NHKK+1
5401
5402       NLINES = PYK(0,1)
5403
5404       NHKK0  = NHKK+1
5405       DO 4 I=4,NLINES
5406          IF (K(I,1).EQ.1) THEN
5407             ID = K(I,2)
5408             PX = P(I,1)
5409             PY = P(I,2)
5410             PZ = P(I,3)
5411             PE = P(I,4)
5412             CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
5413             IDBJ = IDT_ICIHAD(ID)
5414             EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
5415             IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
5416                IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
5417             ENDIF
5418             VHKK(1,NHKK) = VHKK(1,IDX)
5419             VHKK(2,NHKK) = VHKK(2,IDX)
5420             VHKK(3,NHKK) = VHKK(3,IDX)
5421             VHKK(4,NHKK) = VHKK(4,IDX)
5422 C           IF (I.EQ.4) THEN
5423 C              WHKK(1,NHKK) = POLARX(1)
5424 C              WHKK(2,NHKK) = POLARX(2)
5425 C              WHKK(3,NHKK) = POLARX(3)
5426 C              WHKK(4,NHKK) = POLARX(4)
5427 C           ELSE
5428                WHKK(1,NHKK) = WHKK(1,IDX)
5429                WHKK(2,NHKK) = WHKK(2,IDX)
5430                WHKK(3,NHKK) = WHKK(3,IDX)
5431                WHKK(4,NHKK) = WHKK(4,IDX)
5432 C           ENDIF
5433             IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
5434          ENDIF
5435     4 CONTINUE
5436
5437       IF (LEMCCK) THEN
5438          CHKLEV = TINY5
5439          CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
5440          IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
5441       ENDIF
5442
5443 * transform momenta into cms (as required for inc etc.)
5444       DO 5 I=NHKK0,NHKK
5445          IF (ISTHKK(I).EQ.1) THEN
5446             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
5447             PHKK(3,I) = PZ
5448             PHKK(4,I) = PE
5449          ENDIF
5450     5 CONTINUE
5451
5452       RETURN
5453       END
5454 *$ CREATE DT_KKEVNT.FOR
5455 *COPY DT_KKEVNT
5456 *
5457 *===kkevnt=============================================================*
5458 *
5459       SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
5460
5461 ************************************************************************
5462 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering   *
5463 * without nuclear effects (one event).                                 *
5464 * This subroutine is an update of the previous version (KKEVT) written *
5465 * by J. Ranft/ H.-J. Moehring.                                         *
5466 * This version dated 20.04.95 is written by S. Roesler                 *
5467 ************************************************************************
5468
5469       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5470       SAVE
5471
5472       PARAMETER ( LINP = 10 ,
5473      &            LOUT = 6 ,
5474      &            LDAT = 9 )
5475
5476       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
5477
5478       PARAMETER ( MAXNCL = 260,
5479
5480      &            MAXVQU = MAXNCL,
5481      &            MAXSQU = 20*MAXVQU,
5482      &            MAXINT = MAXVQU+MAXSQU)
5483
5484 * event history
5485
5486       PARAMETER (NMXHKK=200000)
5487
5488       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5489      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5490      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5491
5492 * extended event history
5493       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5494      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5495      &                IHIST(2,NMXHKK)
5496
5497 * flags for input different options
5498       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5499       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5500      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5501
5502 * rejection counter
5503       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
5504      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
5505      &                IREXCI(3),IRDIFF(2),IRINC
5506
5507 * statistics
5508       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5509      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5510      &                ICEVTG(8,0:30)
5511
5512 * properties of interacting particles
5513       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5514
5515 * Lorentz-parameters of the current interaction
5516       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5517      &                UMO,PPCM,EPROJ,PPROJ
5518
5519 * flags for diffractive interactions (DTUNUC 1.x)
5520       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5521
5522 * interface HADRIN-DPM
5523       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5524
5525 * nucleon-nucleon event-generator
5526       CHARACTER*8 CMODEL
5527       LOGICAL LPHOIN
5528       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
5529
5530 * coordinates of nucleons
5531       COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
5532
5533 * interface between Glauber formalism and DPM
5534       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
5535      &                INTER1(MAXINT),INTER2(MAXINT)
5536
5537 * Glauber formalism: collision properties
5538       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5539      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
5540      &                NCP,NCT
5541
5542 * central particle production, impact parameter biasing
5543       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5544 **temporary
5545
5546 * statistics: Glauber-formalism
5547       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5548 **
5549
5550       DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5551
5552       IREJ   = 0
5553       ICREQU = ICREQU+1
5554       NC     = 0
5555       NCP    = 0
5556       NCT    = 0
5557
5558     1 CONTINUE
5559       ICSAMP = ICSAMP+1
5560       NC     = NC+1
5561       IF (MOD(NC,10).EQ.0) THEN
5562          WRITE(LOUT,1000) NEVHKK
5563  1000    FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5564          GOTO 9999
5565       ENDIF
5566
5567 * initialize DTEVT1/DTEVT2
5568       CALL DT_EVTINI
5569
5570 * We need the following only in order to sample nucleon coordinates.
5571 * However we don't have parameters (cross sections, slope etc.)
5572 * for neutrinos available. Therefore switch projectile to proton
5573 * in this case.
5574       IF (MCGENE.EQ.4) THEN
5575          JJPROJ = 1
5576       ELSE
5577          JJPROJ = IJPROJ
5578       ENDIF
5579
5580    10 CONTINUE
5581       IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5582 * make sure that Glauber-formalism is called each time the interaction
5583 * configuration changed
5584      &     (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5585      &     (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5586 * sample number of nucleon-nucleon coll. according to Glauber-form.
5587          CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5588          NWTSAM = NN
5589          NWASAM = NP
5590          NWBSAM = NT
5591          NEVOLD = NEVHKK
5592          IPOLD  = IP
5593          ITOLD  = IT
5594          JJPOLD = JJPROJ
5595          EPROLD = EPROJ
5596       DO 8 I=1, IP
5597         NCP = NCP+JSSH(I)
5598 *        WRITE(6,*)' PROJ.NUCL. ',I,' NCOLL = ',NCP
5599     8 CONTINUE
5600       DO 9 I=1, IT
5601         NCT = NCT+JTSH(I)
5602 *        WRITE(6,*)' TAR.NUCL. ',I,' NCOLL = ',NCT
5603     9 CONTINUE
5604       ENDIF
5605
5606 * force diffractive particle production in h-K interactions
5607       IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5608      &    (IP.EQ.1).AND.(NN.NE.1)) THEN
5609          NEVOLD = 0
5610          GOTO 10
5611       ENDIF
5612
5613 * check number of involved proj. nucl. (NP) if central prod.is requested
5614       IF (ICENTR.GT.0) THEN
5615          CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5616          IF (IBACK.GT.0) GOTO 10
5617       ENDIF
5618
5619 * get initial nucleon-configuration in projectile and target
5620 * rest-system (including Fermi-momenta if requested)
5621       CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5622       MODE = 2
5623       IF (EPROJ.LE.EHADTH) MODE = 3
5624       CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5625
5626       IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5627
5628 * activate HADRIN at low energies (implemented for h-N scattering only)
5629          IF (EPROJ.LE.EHADHI) THEN
5630             IF (EHADTH.LT.ZERO) THEN
5631 *   smooth transition btwn. DPM and HADRIN
5632                FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5633                RR   = DT_RNDM(FRAC)
5634                IF (RR.GT.FRAC) THEN
5635                   IF (IP.EQ.1) THEN
5636                      CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5637                      IF (IREJ1.GT.0) GOTO 1
5638                      RETURN
5639                   ELSE
5640                      WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5641                   ENDIF
5642                ENDIF
5643             ELSE
5644 *   fixed threshold for onset of production via HADRIN
5645                IF (EPROJ.LE.EHADTH) THEN
5646                   IF (IP.EQ.1) THEN
5647                      CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5648                      IF (IREJ1.GT.0) GOTO 1
5649                      RETURN
5650                   ELSE
5651                      WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5652                   ENDIF
5653                ENDIF
5654             ENDIF
5655          ENDIF
5656  1001    FORMAT(1X,'KKEVNT:   warning! interaction of proj. (m=',
5657      &          I3,') with target (m=',I3,')',/,11X,
5658      &          'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5659      &          'GeV) cannot be handled')
5660
5661 * sampling of momentum-x fractions & flavors of chain ends
5662          CALL DT_SPLPTN(NN)
5663
5664 * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5665          CALL DT_NUC2CM
5666
5667 * collect momenta of chain ends and put them into DTEVT1
5668          CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5669          IF (IREJ1.NE.0) GOTO 1
5670
5671       ENDIF
5672
5673 * handle chains including fragmentation (two-chain approximation)
5674       IF (MCGENE.EQ.1) THEN
5675 *  two-chain approximation
5676          CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5677          IF (IREJ1.NE.0) THEN
5678             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5679             GOTO 1
5680          ENDIF
5681       ELSEIF (MCGENE.EQ.2) THEN
5682 *  multiple-Po exchange including minijets
5683          CALL DT_EVENTB(NCSY,IREJ1)
5684          IF (IREJ1.NE.0) THEN
5685             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5686             GOTO 1
5687          ENDIF
5688       ELSEIF (MCGENE.EQ.3) THEN
5689          STOP ' This version does not contain LEPTO !'
5690
5691       ELSEIF (MCGENE.EQ.4) THEN
5692 *  quasi-elastic neutrino scattering
5693          CALL DT_EVENTD(IREJ1)
5694          IF (IREJ1.NE.0) THEN
5695             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5696             GOTO 1
5697          ENDIF
5698       ELSE
5699          WRITE(LOUT,1002) MCGENE
5700  1002    FORMAT(1X,'KKEVNT:   warning! event-generator',I4,
5701      &         ' not available - program stopped')
5702          STOP
5703       ENDIF
5704
5705       RETURN
5706
5707  9999 CONTINUE
5708       IREJ = 1
5709       RETURN
5710       END
5711
5712 *$ CREATE DT_CHKCEN.FOR
5713 *COPY DT_CHKCEN
5714 *
5715 *===chkcen=============================================================*
5716 *
5717       SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5718
5719 ************************************************************************
5720 * Check of number of involved projectile nucleons if central production*
5721 * is requested.                                                        *
5722 * Adopted from a part of the old KKEVT routine which was written by    *
5723 * J. Ranft/H.-J.Moehring.                                              *
5724 * This version dated 13.01.95 is written by S. Roesler                 *
5725 ************************************************************************
5726
5727       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5728       SAVE
5729
5730       PARAMETER ( LINP = 10 ,
5731      &            LOUT = 6 ,
5732      &            LDAT = 9 )
5733
5734 * statistics
5735       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5736      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5737      &                ICEVTG(8,0:30)
5738
5739 * central particle production, impact parameter biasing
5740       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5741
5742       IBACK = 0
5743
5744 * old version
5745       IF (ICENTR.EQ.2) THEN
5746          IF (IP.LT.IT) THEN
5747             IF (IP.LE.8) THEN
5748                IF (NP.LT.IP-1) IBACK = 1
5749             ELSEIF (IP.LE.16) THEN
5750                IF (NP.LT.IP-2) IBACK = 1
5751             ELSEIF (IP.LE.32) THEN
5752                IF (NP.LT.IP-3) IBACK = 1
5753             ELSEIF (IP.GE.33) THEN
5754                IF (NP.LT.IP-5) IBACK = 1
5755             ENDIF
5756          ELSEIF (IP.EQ.IT) THEN
5757             IF (IP.EQ.32) THEN
5758                IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5759             ELSE
5760                IF (NP.LT.IP-IP/8) IBACK = 1
5761             ENDIF
5762          ELSEIF (ABS(IP-IT).LT.3) THEN
5763             IF (NP.LT.IP-IP/8) IBACK = 1
5764          ENDIF
5765       ELSE
5766 * new version (DPMJET, 5.6.99)
5767          IF (IP.LT.IT) THEN
5768             IF (IP.LE.8) THEN
5769                IF (NP.LT.IP-1) IBACK = 1
5770             ELSEIF (IP.LE.16) THEN
5771                IF (NP.LT.IP-2) IBACK = 1
5772             ELSEIF (IP.LT.32) THEN
5773                IF (NP.LT.IP-3) IBACK = 1
5774             ELSEIF (IP.GE.32) THEN
5775                IF (IT.LE.150) THEN
5776 *   Example: S-Ag
5777                   IF (NP.LT.IP-1) IBACK = 1
5778                ELSE
5779 *   Example: S-Au
5780                   IF (NP.LT.IP) IBACK = 1
5781                ENDIF
5782             ENDIF
5783          ELSEIF (IP.EQ.IT) THEN
5784 *   Example: S-S
5785            IF (IP.EQ.32) THEN
5786               IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5787 *   Example: Pb-Pb
5788            ELSE
5789               IF (NP.LT.IP-IP/4) IBACK = 1
5790            ENDIF
5791          ELSEIF (ABS(IP-IT).LT.3) THEN
5792             IF (NP.LT.IP-IP/8) IBACK = 1
5793          ENDIF
5794       ENDIF
5795
5796       ICCPRO = ICCPRO+1
5797
5798       RETURN
5799       END
5800
5801 *$ CREATE DT_ININUC.FOR
5802 *COPY DT_ININUC
5803 *
5804 *===ininuc=============================================================*
5805 *
5806       SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5807
5808 ************************************************************************
5809 * Samples initial configuration of nucleons in nucleus with mass NMASS *
5810 * including Fermi-momenta (if reqested).                               *
5811 *          ID             BAMJET-code for hadrons (instead of nuclei)  *
5812 *          NMASS          mass number of nucleus (number of nucleons)  *
5813 *          NCH            charge of nucleus                            *
5814 *          COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5815 *          JS(NMASS) > 0  nucleon undergoes nucleon-nucleon interact.  *
5816 *          IMODE = 1      projectile nucleus                           *
5817 *                = 2      target     nucleus                           *
5818 *                = 3      target     nucleus (E_lab<E_thr for HADRIN)  *
5819 * Adopted from a part of the old KKEVT routine which was written by    *
5820 * J. Ranft/H.-J.Moehring.                                              *
5821 * This version dated 13.01.95 is written by S. Roesler                 *
5822 ************************************************************************
5823
5824       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5825       SAVE
5826
5827       PARAMETER ( LINP = 10 ,
5828      &            LOUT = 6 ,
5829      &            LDAT = 9 )
5830
5831       PARAMETER (FM2MM=1.0D-12)
5832
5833       PARAMETER ( MAXNCL = 260,
5834
5835      &            MAXVQU = MAXNCL,
5836      &            MAXSQU = 20*MAXVQU,
5837      &            MAXINT = MAXVQU+MAXSQU)
5838
5839 * event history
5840
5841       PARAMETER (NMXHKK=200000)
5842
5843       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5844      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5845      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5846
5847 * extended event history
5848       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5849      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5850      &                IHIST(2,NMXHKK)
5851
5852 * flags for input different options
5853       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5854       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5855      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5856
5857 * auxiliary common for chain system storage (DTUNUC 1.x)
5858       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5859
5860 * nuclear potential
5861       LOGICAL LFERMI
5862       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5863      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5864      &                ETACOU(2),ICOUL,LFERMI
5865
5866 * properties of photon/lepton projectiles
5867       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5868
5869 * particle properties (BAMJET index convention)
5870       CHARACTER*8  ANAME
5871       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5872      &                IICH(210),IIBAR(210),K1(210),K2(210)
5873
5874 * Glauber formalism: collision properties
5875       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5876      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
5877      &                NCP,NCT
5878
5879 * flavors of partons (DTUNUC 1.x)
5880       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5881      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5882      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5883      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5884      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5885      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5886      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5887
5888 * interface HADRIN-DPM
5889       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5890
5891       DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5892
5893 * number of neutrons
5894       NNEU = NMASS-NCH
5895 * initializations
5896       NP = 0
5897       NN = 0
5898       DO 1 K=1,4
5899          PFTOT(K) = 0.0D0
5900     1 CONTINUE
5901       MODE   = IMODE
5902       IF (IMODE.GT.2) MODE = 2
5903 **sr 29.5. new NPOINT(1)-definition
5904 C     IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5905 **
5906       NHADRI = 0
5907       NC     = NHKK
5908
5909 * get initial configuration
5910       DO 2 I=1,NMASS
5911          NHKK = NHKK+1
5912          IF (JS(I).GT.0) THEN
5913             ISTHKK(NHKK) = 10+MODE
5914             IF (IMODE.EQ.3) THEN
5915 *   additional treatment if HADRIN-generator is requested
5916                NHADRI = NHADRI+1
5917                IF (NHADRI.EQ.1) IDXTA  = NHKK
5918                IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5919             ENDIF
5920          ELSE
5921             ISTHKK(NHKK) = 12+MODE
5922          ENDIF
5923          IF (NMASS.GE.2) THEN
5924 *   treatment for nuclei
5925             FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5926             RR   = DT_RNDM(FRAC)
5927             IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5928                IDX = 8
5929                NN  = NN+1
5930             ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5931                IDX = 1
5932                NP  = NP+1
5933             ELSEIF (NN.LT.NNEU) THEN
5934                IDX = 8
5935                NN  = NN+1
5936             ELSEIF (NP.LT.NCH)  THEN
5937                IDX = 1
5938                NP  = NP+1
5939             ENDIF
5940             IDHKK(NHKK) = IDT_IPDGHA(IDX)
5941             IDBAM(NHKK) = IDX
5942             IF (MODE.EQ.1) THEN
5943                IPOSP(I)  = NHKK
5944                KKPROJ(I) = IDX
5945             ELSE
5946                IPOST(I)  = NHKK
5947                KKTARG(I) = IDX
5948             ENDIF
5949             IF (IDX.EQ.1) THEN
5950                PFER = PFERMP(MODE)
5951                PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5952             ELSE
5953                PFER = PFERMN(MODE)
5954                PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5955             ENDIF
5956             CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5957             DO 3 K=1,4
5958                PFTOT(K) = PFTOT(K)+PF(K)
5959                PHKK(K,NHKK) = PF(K)
5960     3       CONTINUE
5961             PHKK(5,NHKK) = AAM(IDX)
5962          ELSE
5963 *   treatment for hadrons
5964             IDHKK(NHKK)  = IDT_IPDGHA(ID)
5965             IDBAM(NHKK)  = ID
5966             PHKK(4,NHKK) = AAM(ID)
5967             PHKK(5,NHKK) = AAM(ID)
5968 C* VDM assumption
5969 C            IF (IDHKK(NHKK).EQ.22) THEN
5970 C               PHKK(4,NHKK) = AAM(33)
5971 C               PHKK(5,NHKK) = AAM(33)
5972 C            ENDIF
5973             IF (MODE.EQ.1) THEN
5974                IPOSP(I)  = NHKK
5975                KKPROJ(I) = ID
5976                PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5977             ELSE
5978                IPOST(I)  = NHKK
5979                KKTARG(I) = ID
5980             ENDIF
5981          ENDIF
5982          DO 4 K=1,3
5983             VHKK(K,NHKK) = COORD(K,I)*FM2MM
5984             WHKK(K,NHKK) = COORD(K,I)*FM2MM
5985     4    CONTINUE
5986          IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5987          IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5988          VHKK(4,NHKK) = 0.0D0
5989          WHKK(4,NHKK) = 0.0D0
5990     2 CONTINUE
5991
5992 * balance Fermi-momenta
5993       IF (NMASS.GE.2) THEN
5994          DO 5 I=1,NMASS
5995             NC = NC+1
5996             DO 6 K=1,3
5997                PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5998     6       CONTINUE
5999             PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
6000      &                        PHKK(2,NC)**2+PHKK(3,NC)**2)
6001     5    CONTINUE
6002       ENDIF
6003
6004       RETURN
6005       END
6006
6007 *$ CREATE DT_FER4M.FOR
6008 *COPY DT_FER4M
6009 *
6010 *===fer4m==============================================================*
6011 *
6012       SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
6013
6014 ************************************************************************
6015 * Sampling of nucleon Fermi-momenta from distributions at T=0.         *
6016 *                                   processed by S. Roesler, 17.10.95  *
6017 ************************************************************************
6018
6019       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6020       SAVE
6021
6022       PARAMETER ( LINP = 10 ,
6023      &            LOUT = 6 ,
6024      &            LDAT = 9 )
6025
6026       LOGICAL LSTART
6027
6028 * particle properties (BAMJET index convention)
6029       CHARACTER*8  ANAME
6030       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6031      &                IICH(210),IIBAR(210),K1(210),K2(210)
6032
6033 * nuclear potential
6034       LOGICAL LFERMI
6035       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
6036      &                EBINDP(2),EBINDN(2),EPOT(2,210),
6037      &                ETACOU(2),ICOUL,LFERMI
6038
6039       DATA LSTART /.TRUE./
6040
6041       ILOOP = 0
6042       IF (LFERMI) THEN
6043          IF (LSTART) THEN
6044             WRITE(LOUT,1000)
6045  1000       FORMAT(/,1X,'FER4M:   sampling of Fermi-momenta activated')
6046             LSTART = .FALSE.
6047          ENDIF
6048     1    CONTINUE
6049          CALL DT_DFERMI(PABS)
6050          PABS = PFERM*PABS
6051 C        IF (PABS.GE.PBIND) THEN
6052 C           ILOOP = ILOOP+1
6053 C           IF (MOD(ILOOP,500).EQ.0) THEN
6054 C              WRITE(LOUT,1001) PABS,PBIND,ILOOP
6055 C1001          FORMAT(1X,'FER4M:    Fermi-mom. corr. for binding',
6056 C    &                ' energy ',2E12.3,I6)
6057 C           ENDIF
6058 C           GOTO 1
6059 C        ENDIF
6060          CALL DT_DPOLI(POLC,POLS)
6061          CALL DT_DSFECF(SFE,CFE)
6062          CXTA = POLS*CFE
6063          CYTA = POLS*SFE
6064          CZTA = POLC
6065          ET   = SQRT(PABS*PABS+AAM(KT)**2)
6066          PXT  = CXTA*PABS
6067          PYT  = CYTA*PABS
6068          PZT  = CZTA*PABS
6069       ELSE
6070          ET   = AAM(KT)
6071          PXT  = 0.0D0
6072          PYT  = 0.0D0
6073          PZT  = 0.0D0
6074       ENDIF
6075
6076       RETURN
6077       END
6078
6079 *$ CREATE DT_NUC2CM.FOR
6080 *COPY DT_NUC2CM
6081 *
6082 *===nuc2cm=============================================================*
6083 *
6084       SUBROUTINE DT_NUC2CM
6085
6086 ************************************************************************
6087 * Lorentz-transformation of all wounded nucleons from Lab. to nucl.-   *
6088 * nucl. cms. (This subroutine replaces NUCMOM.)                        *
6089 * This version dated 15.01.95 is written by S. Roesler                 *
6090 ************************************************************************
6091
6092       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6093       SAVE
6094
6095       PARAMETER ( LINP = 10 ,
6096      &            LOUT = 6 ,
6097      &            LDAT = 9 )
6098
6099       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
6100
6101 * event history
6102
6103       PARAMETER (NMXHKK=200000)
6104
6105       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6106      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6107      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6108
6109 * extended event history
6110       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6111      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6112      &                IHIST(2,NMXHKK)
6113
6114 * statistics
6115       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6116      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6117      &                ICEVTG(8,0:30)
6118
6119 * properties of photon/lepton projectiles
6120       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
6121
6122 * particle properties (BAMJET index convention)
6123       CHARACTER*8  ANAME
6124       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6125      &                IICH(210),IIBAR(210),K1(210),K2(210)
6126
6127 * Glauber formalism: collision properties
6128       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
6129      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
6130      &                NCP,NCT
6131 **temporary
6132
6133 * statistics: Glauber-formalism
6134       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
6135 **
6136
6137       ICWP = 0
6138       ICWT = 0
6139       NWTACC = 0
6140       NWAACC = 0
6141       NWBACC = 0
6142
6143       NPOINT(1) = NHKK+1
6144       NEND      = NHKK
6145       DO 1 I=1,NEND
6146          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
6147             IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
6148             IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
6149             MODE = ISTHKK(I)-9
6150 C            IF (IDHKK(I).EQ.22) THEN
6151 C* VDM assumption
6152 C               PEIN = AAM(33)
6153 C               IDB  = 33
6154 C            ELSE
6155 C               PEIN = PHKK(4,I)
6156 C               IDB  = IDBAM(I)
6157 C            ENDIF
6158 C            CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
6159 C     &           PX,PY,PZ,PE,IDB,MODE)
6160             IF (PHKK(5,I).GT.ZERO) THEN
6161                CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
6162      &              PX,PY,PZ,PE,IDBAM(I),MODE)
6163             ELSE
6164                PX = PGAMM(1)
6165                PY = PGAMM(2)
6166                PZ = PGAMM(3)
6167                PE = PGAMM(4)
6168             ENDIF
6169             IST = ISTHKK(I)-2
6170             ID  = IDHKK(I)
6171 C* VDM assumption
6172 C            IF (ID.EQ.22) ID = 113
6173             CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
6174             IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
6175             IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
6176          ENDIF
6177     1 CONTINUE
6178
6179       NWTACC = MAX(NWAACC,NWBACC)
6180       ICDPR  = ICDPR+ICWP
6181       ICDTA  = ICDTA+ICWT
6182 **temporary
6183       IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
6184          CALL DT_EVTOUT(4)
6185          STOP
6186       ENDIF
6187
6188       RETURN
6189       END
6190
6191 *$ CREATE DT_SPLPTN.FOR
6192 *COPY DT_SPLPTN
6193 *
6194 *===splptn=============================================================*
6195 *
6196       SUBROUTINE DT_SPLPTN(NN)
6197
6198 ************************************************************************
6199 * SamPLing of ParToN momenta and flavors.                              *
6200 * This version dated 15.01.95 is written by S. Roesler                 *
6201 ************************************************************************
6202
6203       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6204       SAVE
6205
6206       PARAMETER ( LINP = 10 ,
6207      &            LOUT = 6 ,
6208      &            LDAT = 9 )
6209
6210 * Lorentz-parameters of the current interaction
6211       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
6212      &                UMO,PPCM,EPROJ,PPROJ
6213
6214 * sample flavors of sea-quarks
6215       CALL DT_SPLFLA(NN,1)
6216
6217 * sample x-values of partons at chain ends
6218       ECM = UMO
6219       CALL DT_XKSAMP(NN,ECM)
6220
6221 * samle flavors
6222       CALL DT_SPLFLA(NN,2)
6223
6224       RETURN
6225       END
6226
6227 *$ CREATE DT_SPLFLA.FOR
6228 *COPY DT_SPLFLA
6229 *
6230 *===splfla=============================================================*
6231 *
6232       SUBROUTINE DT_SPLFLA(NN,MODE)
6233
6234 ************************************************************************
6235 * SamPLing of FLAvors of partons at chain ends.                        *
6236 * This subroutine replaces FLKSAA/FLKSAM.                              *
6237 *            NN            number of nucleon-nucleon interactions      *
6238 *            MODE = 1      sea-flavors                                 *
6239 *                 = 2      valence-flavors                             *
6240 * Based on the original version written by J. Ranft/H.-J. Moehring.    *
6241 * This version dated 16.01.95 is written by S. Roesler                 *
6242 ************************************************************************
6243
6244       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6245       SAVE
6246
6247       PARAMETER ( LINP = 10 ,
6248      &            LOUT = 6 ,
6249      &            LDAT = 9 )
6250
6251       PARAMETER ( MAXNCL = 260,
6252
6253      &            MAXVQU = MAXNCL,
6254      &            MAXSQU = 20*MAXVQU,
6255      &            MAXINT = MAXVQU+MAXSQU)
6256
6257 * flavors of partons (DTUNUC 1.x)
6258       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6259      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6260      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
6261      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6262      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
6263      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6264      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
6265
6266 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6267       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6268      &                IXPV,IXPS,IXTV,IXTS,
6269      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
6270      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
6271      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
6272      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
6273      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
6274      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
6275      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
6276      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
6277
6278 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6279       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6280      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6281
6282 * particle properties (BAMJET index convention)
6283       CHARACTER*8  ANAME
6284       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6285      &                IICH(210),IIBAR(210),K1(210),K2(210)
6286
6287 * various options for treatment of partons (DTUNUC 1.x)
6288 * (chain recombination, Cronin,..)
6289       LOGICAL LCO2CR,LINTPT
6290       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6291      &                LCO2CR,LINTPT
6292
6293       IF (MODE.EQ.1) THEN
6294 * sea-flavors
6295          DO 1 I=1,NN
6296             IPSQ(I)  = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
6297             IPSAQ(I) = -IPSQ(I)
6298     1    CONTINUE
6299          DO 2 I=1,NN
6300             ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
6301             ITSAQ(I)= -ITSQ(I)
6302     2    CONTINUE
6303       ELSEIF (MODE.EQ.2) THEN
6304 * valence flavors
6305          DO 3 I=1,IXPV
6306             CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
6307     3    CONTINUE
6308          DO 4 I=1,IXTV
6309             CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
6310     4    CONTINUE
6311       ENDIF
6312
6313       RETURN
6314       END
6315
6316 *$ CREATE DT_GETPTN.FOR
6317 *COPY DT_GETPTN
6318 *
6319 *===getptn=============================================================*
6320 *
6321       SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
6322
6323 ************************************************************************
6324 * This subroutine collects partons at chain ends from temporary        *
6325 * commons and puts them into DTEVT1.                                   *
6326 * This version dated 15.01.95 is written by S. Roesler                 *
6327 ************************************************************************
6328
6329       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6330       SAVE
6331
6332       PARAMETER ( LINP = 10 ,
6333      &            LOUT = 6 ,
6334      &            LDAT = 9 )
6335
6336       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
6337
6338       LOGICAL LCHK
6339
6340       PARAMETER ( MAXNCL = 260,
6341
6342      &            MAXVQU = MAXNCL,
6343      &            MAXSQU = 20*MAXVQU,
6344      &            MAXINT = MAXVQU+MAXSQU)
6345
6346 * event history
6347
6348       PARAMETER (NMXHKK=200000)
6349
6350       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6351      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6352      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6353
6354 * extended event history
6355       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6356      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6357      &                IHIST(2,NMXHKK)
6358
6359 * flags for input different options
6360       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6361       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6362      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6363
6364 * auxiliary common for chain system storage (DTUNUC 1.x)
6365       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
6366
6367 * statistics
6368       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6369      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6370      &                ICEVTG(8,0:30)
6371
6372 * flags for diffractive interactions (DTUNUC 1.x)
6373       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6374
6375 * x-values of partons (DTUNUC 1.x)
6376       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
6377      &                XTVQ(MAXVQU),XTVD(MAXVQU),
6378      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
6379      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
6380
6381 * flavors of partons (DTUNUC 1.x)
6382       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6383      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6384      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
6385      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6386      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
6387      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6388      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
6389
6390 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6391       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6392      &                IXPV,IXPS,IXTV,IXTS,
6393      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
6394      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
6395      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
6396      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
6397      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
6398      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
6399      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
6400      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
6401
6402 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6403       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6404      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6405
6406       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
6407
6408       DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
6409
6410       IREJ      = 0
6411       NCSY      = 0
6412       NPOINT(2) = NHKK+1
6413
6414 * sea-sea chains
6415       DO 10 I=1,NSS
6416          IF (ISKPCH(1,I).EQ.99) GOTO 10
6417          ICCHAI(1,1) = ICCHAI(1,1)+2
6418          IDXP = INTSS1(I)
6419          IDXT = INTSS2(I)
6420          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6421          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6422          DO 11 K=1,4
6423             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6424             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6425             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6426             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6427    11    CONTINUE
6428          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6429      &                                  +(PP1(3)+PT1(3))**2)
6430          ECH   = PP1(4)+PT1(4)
6431          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6432          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6433      &                                  +(PP2(3)+PT2(3))**2)
6434          ECH   = PP2(4)+PT2(4)
6435          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6436          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6437             AM1 = SQRT(AM1)
6438             AM2 = SQRT(AM2)
6439             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6440 C              WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6441  5000          FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6442             ENDIF
6443          ELSE
6444             WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6445          ENDIF
6446          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6447          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6448          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6449          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6450          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6451      &                                                    0,0,1)
6452          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6453      &                                                    0,0,1)
6454          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6455      &                                                    0,0,1)
6456          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6457      &                                                    0,0,1)
6458          NCSY = NCSY+1
6459    10 CONTINUE
6460
6461 * disea-sea chains
6462       DO 20 I=1,NDS
6463          IF (ISKPCH(2,I).EQ.99) GOTO 20
6464          ICCHAI(1,2) = ICCHAI(1,2)+2
6465          IDXP = INTDS1(I)
6466          IDXT = INTDS2(I)
6467          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6468          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6469          DO 21 K=1,4
6470             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6471             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6472             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6473             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6474    21    CONTINUE
6475          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6476      &                                  +(PP1(3)+PT1(3))**2)
6477          ECH   = PP1(4)+PT1(4)
6478          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6479          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6480      &                                  +(PP2(3)+PT2(3))**2)
6481          ECH   = PP2(4)+PT2(4)
6482          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6483          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6484             AM1 = SQRT(AM1)
6485             AM2 = SQRT(AM2)
6486             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6487 C              WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6488  5001          FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6489             ENDIF
6490          ELSE
6491             WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6492          ENDIF
6493          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6494          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6495          IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6496          IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6497          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6498      &                                                    0,0,2)
6499          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6500      &                                                    0,0,2)
6501          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6502      &                                                    0,0,2)
6503          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6504      &                                                    0,0,2)
6505          NCSY = NCSY+1
6506    20 CONTINUE
6507
6508 * sea-disea chains
6509       DO 30 I=1,NSD
6510          IF (ISKPCH(3,I).EQ.99) GOTO 30
6511          ICCHAI(1,3) = ICCHAI(1,3)+2
6512          IDXP = INTSD1(I)
6513          IDXT = INTSD2(I)
6514          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6515          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6516          DO 31 K=1,4
6517             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6518             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6519             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6520             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6521    31    CONTINUE
6522          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6523      &                                  +(PP1(3)+PT1(3))**2)
6524          ECH   = PP1(4)+PT1(4)
6525          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6526          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6527      &                                  +(PP2(3)+PT2(3))**2)
6528          ECH   = PP2(4)+PT2(4)
6529          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6530          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6531             AM1 = SQRT(AM1)
6532             AM2 = SQRT(AM2)
6533             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6534 C              WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6535  5002          FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6536             ENDIF
6537          ELSE
6538             WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6539          ENDIF
6540          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6541          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6542          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6543          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6544          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6545      &                                                    0,0,3)
6546          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6547      &                                                    0,0,3)
6548          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6549      &                                                    0,0,3)
6550          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6551      &                                                    0,0,3)
6552          NCSY = NCSY+1
6553    30 CONTINUE
6554
6555 * disea-valence chains
6556       DO 50 I=1,NDV
6557          IF (ISKPCH(5,I).EQ.99) GOTO 50
6558          ICCHAI(1,5) = ICCHAI(1,5)+2
6559          IDXP = INTDV1(I)
6560          IDXT = INTDV2(I)
6561          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6562          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6563          DO 51 K=1,4
6564             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6565             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6566             PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6567             PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6568    51    CONTINUE
6569          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6570      &                                  +(PP1(3)+PT1(3))**2)
6571          ECH   = PP1(4)+PT1(4)
6572          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6573          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6574      &                                  +(PP2(3)+PT2(3))**2)
6575          ECH   = PP2(4)+PT2(4)
6576          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6577          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6578             AM1 = SQRT(AM1)
6579             AM2 = SQRT(AM2)
6580             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6581 C              WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6582  5003          FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6583             ENDIF
6584          ELSE
6585             WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6586          ENDIF
6587          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6588          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6589          IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6590          IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6591          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6592      &                                                    0,0,5)
6593          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6594      &                                                    0,0,5)
6595          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6596      &                                                    0,0,5)
6597          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6598      &                                                    0,0,5)
6599          NCSY = NCSY+1
6600    50 CONTINUE
6601
6602 * valence-sea chains
6603       DO 60 I=1,NVS
6604          IF (ISKPCH(6,I).EQ.99) GOTO 60
6605          ICCHAI(1,6) = ICCHAI(1,6)+2
6606          IDXP = INTVS1(I)
6607          IDXT = INTVS2(I)
6608          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6609          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6610          DO 61 K=1,4
6611             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6612             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6613             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6614             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6615    61    CONTINUE
6616          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6617          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6618          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6619          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6620          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6621          IF (LCHK) THEN
6622             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6623      &                                                       0,0,6)
6624             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6625      &                                                       0,0,6)
6626             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6627      &                                                       0,0,6)
6628             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6629      &                                                       0,0,6)
6630             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6631      &                                     +(PP1(3)+PT1(3))**2)
6632             ECH   = PP1(4)+PT1(4)
6633             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6634             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6635      &                                     +(PP2(3)+PT2(3))**2)
6636             ECH   = PP2(4)+PT2(4)
6637             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6638          ELSE
6639             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6640      &                                                       0,0,6)
6641             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6642      &                                                       0,0,6)
6643             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6644      &                                                       0,0,6)
6645             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6646      &                                                       0,0,6)
6647             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6648      &                                     +(PP1(3)+PT2(3))**2)
6649             ECH   = PP1(4)+PT2(4)
6650             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6651             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6652      &                                     +(PP2(3)+PT1(3))**2)
6653             ECH   = PP2(4)+PT1(4)
6654             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6655          ENDIF
6656          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6657             AM1 = SQRT(AM1)
6658             AM2 = SQRT(AM2)
6659             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6660 C              WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6661  5004          FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6662             ENDIF
6663          ELSE
6664             WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6665          ENDIF
6666          NCSY = NCSY+1
6667    60 CONTINUE
6668
6669 * sea-valence chains
6670       DO 40 I=1,NSV
6671          IF (ISKPCH(4,I).EQ.99) GOTO 40
6672          ICCHAI(1,4) = ICCHAI(1,4)+2
6673          IDXP = INTSV1(I)
6674          IDXT = INTSV2(I)
6675          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6676          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6677          DO 41 K=1,4
6678             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6679             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6680             PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6681             PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6682    41    CONTINUE
6683          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6684      &                                  +(PP1(3)+PT1(3))**2)
6685          ECH   = PP1(4)+PT1(4)
6686          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6687          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6688      &                                  +(PP2(3)+PT2(3))**2)
6689          ECH   = PP2(4)+PT2(4)
6690          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6691          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6692             AM1 = SQRT(AM1)
6693             AM2 = SQRT(AM2)
6694             IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6695 C              WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6696  5005          FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6697             ENDIF
6698          ELSE
6699             WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6700          ENDIF
6701          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6702          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6703          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6704          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6705          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6706      &                                                    0,0,4)
6707          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6708      &                                                    0,0,4)
6709          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6710      &                                                    0,0,4)
6711          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6712      &                                                    0,0,4)
6713          NCSY = NCSY+1
6714    40 CONTINUE
6715
6716 * valence-disea chains
6717       DO 70 I=1,NVD
6718          IF (ISKPCH(7,I).EQ.99) GOTO 70
6719          ICCHAI(1,7) = ICCHAI(1,7)+2
6720          IDXP = INTVD1(I)
6721          IDXT = INTVD2(I)
6722          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6723          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6724          DO 71 K=1,4
6725             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6726             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6727             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6728             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6729    71    CONTINUE
6730          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6731          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6732          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6733          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6734          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6735          IF (LCHK) THEN
6736             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6737      &                                                       0,0,7)
6738             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6739      &                                                       0,0,7)
6740             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6741      &                                                       0,0,7)
6742             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6743      &                                                       0,0,7)
6744             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6745      &                                     +(PP1(3)+PT1(3))**2)
6746             ECH   = PP1(4)+PT1(4)
6747             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6748             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6749      &                                     +(PP2(3)+PT2(3))**2)
6750             ECH   = PP2(4)+PT2(4)
6751             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6752          ELSE
6753             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6754      &                                                       0,0,7)
6755             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6756      &                                                       0,0,7)
6757             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6758      &                                                       0,0,7)
6759             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6760      &                                                       0,0,7)
6761             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6762      &                                     +(PP1(3)+PT2(3))**2)
6763             ECH   = PP1(4)+PT2(4)
6764             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6765             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6766      &                                     +(PP2(3)+PT1(3))**2)
6767             ECH   = PP2(4)+PT1(4)
6768             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6769          ENDIF
6770          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6771             AM1 = SQRT(AM1)
6772             AM2 = SQRT(AM2)
6773             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6774 C              WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6775  5006          FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6776             ENDIF
6777          ELSE
6778             WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6779          ENDIF
6780          NCSY = NCSY+1
6781    70 CONTINUE
6782
6783 * valence-valence chains
6784       DO 80 I=1,NVV
6785          IF (ISKPCH(8,I).EQ.99) GOTO 80
6786          ICCHAI(1,8) = ICCHAI(1,8)+2
6787          IDXP = INTVV1(I)
6788          IDXT = INTVV2(I)
6789          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6790          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6791          DO 81 K=1,4
6792             PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6793             PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6794             PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6795             PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6796    81    CONTINUE
6797          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6798          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6799          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6800          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6801
6802 * check for diffractive event
6803          IDIFF = 0
6804          IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6805      &        (IP.EQ.1).AND.(NN.EQ.1)) THEN
6806             DO 800 K=1,4
6807                PP(K) = PP1(K)+PP2(K)
6808                PT(K) = PT1(K)+PT2(K)
6809   800       CONTINUE
6810             ISTCK = NHKK
6811             CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6812      &                  IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6813 C           IF (IREJ1.NE.0) GOTO 9999
6814             IF (IREJ1.NE.0) THEN
6815                IDIFF = 0
6816                NHKK  = ISTCK
6817             ENDIF
6818          ELSE
6819             IDIFF = 0
6820          ENDIF
6821
6822          IF (IDIFF.EQ.0) THEN
6823 *   valence-valence chain system
6824             CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6825             IF (LCHK) THEN
6826 *    baryon-baryon
6827                CALL DT_EVTPUT(-21,IFP1,MOP,0,
6828      &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6829                CALL DT_EVTPUT(-22,IFT1,MOT,0,
6830      &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6831                CALL DT_EVTPUT(-21,IFP2,MOP,0,
6832      &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6833                CALL DT_EVTPUT(-22,IFT2,MOT,0,
6834      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6835                PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6836      &                                        +(PP1(3)+PT1(3))**2)
6837                ECH   = PP1(4)+PT1(4)
6838                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6839                PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6840      &                                        +(PP2(3)+PT2(3))**2)
6841                ECH   = PP2(4)+PT2(4)
6842                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6843             ELSE
6844 *    antibaryon-baryon
6845                CALL DT_EVTPUT(-21,IFP1,MOP,0,
6846      &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6847                CALL DT_EVTPUT(-22,IFT2,MOT,0,
6848      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6849                CALL DT_EVTPUT(-21,IFP2,MOP,0,
6850      &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6851                CALL DT_EVTPUT(-22,IFT1,MOT,0,
6852      &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6853                PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6854      &                                        +(PP1(3)+PT2(3))**2)
6855                ECH   = PP1(4)+PT2(4)
6856                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6857                PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6858      &                                        +(PP2(3)+PT1(3))**2)
6859                ECH   = PP2(4)+PT1(4)
6860                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6861             ENDIF
6862             IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6863                AM1 = SQRT(AM1)
6864                AM2 = SQRT(AM2)
6865                IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6866 C                 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6867  5007             FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6868                ENDIF
6869             ELSE
6870                WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6871             ENDIF
6872             NCSY = NCSY+1
6873          ENDIF
6874    80 CONTINUE
6875       IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6876
6877 * energy-momentum & flavor conservation check
6878       IF (ABS(IDIFF).NE.1) THEN
6879          IF (IDIFF.NE.0) THEN
6880             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6881      &                                              1,3,10,IREJ)
6882          ELSE
6883             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6884      &                                              1,3,10,IREJ)
6885          ENDIF
6886          IF (IREJ.NE.0) THEN
6887             CALL DT_EVTOUT(4)
6888             STOP
6889          ENDIF
6890       ENDIF
6891
6892       RETURN
6893
6894  9999 CONTINUE
6895       IREJ  = 1
6896       RETURN
6897       END
6898
6899 *$ CREATE DT_CHKCSY.FOR
6900 *COPY DT_CHKCSY
6901 *
6902 *===chkcsy=============================================================*
6903 *
6904       SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6905
6906 ************************************************************************
6907 * CHeCk Chain SYstem for consistency of partons at chain ends.         *
6908 *            ID1,ID2        PDG-numbers of partons at chain ends       *
6909 *            LCHK = .true.  consistent chain                           *
6910 *                 = .false. inconsistent chain                         *
6911 * This version dated 18.01.95 is written by S. Roesler                 *
6912 ************************************************************************
6913
6914       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6915       SAVE
6916
6917       PARAMETER ( LINP = 10 ,
6918      &            LOUT = 6 ,
6919      &            LDAT = 9 )
6920
6921       LOGICAL LCHK
6922
6923       LCHK = .TRUE.
6924
6925 * q-aq chain
6926       IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6927          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6928 * q-qq, aq-aqaq chain
6929       ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6930      &        ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6931          IF (ID1*ID2.LT.0) LCHK = .FALSE.
6932 * qq-aqaq chain
6933       ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6934          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6935       ENDIF
6936
6937       RETURN
6938       END
6939
6940 *$ CREATE DT_EVENTA.FOR
6941 *COPY DT_EVENTA
6942 *
6943 *===eventa=============================================================*
6944 *
6945       SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6946
6947 ************************************************************************
6948 * Treatment of nucleon-nucleon interactions in a two-chain             *
6949 * approximation.                                                       *
6950 *  (input) ID       BAMJET-index of projectile hadron (in case of      *
6951 *                   h-K scattering)                                    *
6952 *          IP/IT    mass number of projectile/target nucleus           *
6953 *          NCSY     number of two chain systems                        *
6954 *          IREJ     rejection flag                                     *
6955 * This version dated 15.01.95 is written by S. Roesler                 *
6956 ************************************************************************
6957
6958       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6959       SAVE
6960
6961       PARAMETER ( LINP = 10 ,
6962      &            LOUT = 6 ,
6963      &            LDAT = 9 )
6964
6965       PARAMETER (TINY10=1.0D-10)
6966
6967 * event history
6968
6969       PARAMETER (NMXHKK=200000)
6970
6971       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6972      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6973      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6974
6975 * extended event history
6976       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6977      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6978      &                IHIST(2,NMXHKK)
6979
6980 * rejection counter
6981       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6982      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6983      &                IREXCI(3),IRDIFF(2),IRINC
6984
6985 * flags for diffractive interactions (DTUNUC 1.x)
6986       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6987
6988 * particle properties (BAMJET index convention)
6989       CHARACTER*8  ANAME
6990       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6991      &                IICH(210),IIBAR(210),K1(210),K2(210)
6992
6993 * flags for input different options
6994       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6995       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6996      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6997
6998 * various options for treatment of partons (DTUNUC 1.x)
6999 * (chain recombination, Cronin,..)
7000       LOGICAL LCO2CR,LINTPT
7001       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
7002      &                LCO2CR,LINTPT
7003
7004       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
7005
7006       IREJ      = 0
7007       NPOINT(3) = NHKK+1
7008
7009 * skip following treatment for low-mass diffraction
7010       IF (ABS(IFLAGD).EQ.1) THEN
7011          NPOINT(3) = NPOINT(2)
7012          GOTO 5
7013       ENDIF
7014
7015 * multiple scattering of chain ends
7016       IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
7017       IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
7018
7019       NC = NPOINT(2)
7020 * get a two-chain system from DTEVT1
7021       DO 3 I=1,NCSY
7022          IFP1 = IDHKK(NC)
7023          IFT1 = IDHKK(NC+1)
7024          IFP2 = IDHKK(NC+2)
7025          IFT2 = IDHKK(NC+3)
7026          DO 4 K=1,4
7027             PP1(K) = PHKK(K,NC)
7028             PT1(K) = PHKK(K,NC+1)
7029             PP2(K) = PHKK(K,NC+2)
7030             PT2(K) = PHKK(K,NC+3)
7031     4    CONTINUE
7032          MOP1 = NC
7033          MOT1 = NC+1
7034          MOP2 = NC+2
7035          MOT2 = NC+3
7036          CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
7037      &               IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
7038          IF (IREJ1.GT.0) THEN
7039             IRHHA = IRHHA+1
7040             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
7041             GOTO 9999
7042          ENDIF
7043          NC = NC+4
7044     3 CONTINUE
7045
7046 * meson/antibaryon projectile:
7047 * sample single-chain valence-valence systems (Reggeon contrib.)
7048       IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
7049          IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
7050       ENDIF
7051
7052       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7053 * check DTEVT1 for remaining resonance mass corrections
7054          CALL DT_EVTRES(IREJ1)
7055          IF (IREJ1.GT.0) THEN
7056             IRRES(1) = IRRES(1)+1
7057             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
7058             GOTO 9999
7059          ENDIF
7060       ENDIF
7061
7062 * assign p_t to two-"chain" systems consisting of two resonances only
7063 * since only entries for chains will be affected, this is obsolete
7064 * in case of JETSET-fragmetation
7065       CALL DT_RESPT
7066
7067 * combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
7068       IF (LCO2CR) CALL DT_COM2CR
7069
7070     5 CONTINUE
7071
7072 * fragmentation of the complete event
7073 **uncomment for internal phojet-fragmentation
7074 C     CALL DT_EVTFRA(IREJ1)
7075       CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
7076       IF (IREJ1.GT.0) THEN
7077          IRFRAG = IRFRAG+1
7078          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
7079          GOTO 9999
7080       ENDIF
7081
7082 * decay of possible resonances (should be obsolete)
7083       CALL DT_DECAY1
7084
7085       RETURN
7086
7087  9999 CONTINUE
7088       IREVT = IREVT+1
7089       IREJ  = 1
7090       RETURN
7091       END
7092
7093 *$ CREATE DT_GETCSY.FOR
7094 *COPY DT_GETCSY
7095 *
7096 *===getcsy=============================================================*
7097 *
7098       SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
7099      &                  IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
7100
7101 ************************************************************************
7102 * This version dated 15.01.95 is written by S. Roesler                 *
7103 ************************************************************************
7104
7105       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7106       SAVE
7107
7108       PARAMETER ( LINP = 10 ,
7109      &            LOUT = 6 ,
7110      &            LDAT = 9 )
7111
7112       PARAMETER (TINY10=1.0D-10)
7113
7114 * event history
7115
7116       PARAMETER (NMXHKK=200000)
7117
7118       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7119      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7120      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7121
7122 * extended event history
7123       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7124      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7125      &                IHIST(2,NMXHKK)
7126
7127 * rejection counter
7128       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7129      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7130      &                IREXCI(3),IRDIFF(2),IRINC
7131
7132 * flags for input different options
7133       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7134       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7135      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7136
7137 * flags for diffractive interactions (DTUNUC 1.x)
7138       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
7139
7140       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
7141      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
7142
7143       IREJ  = 0
7144
7145 * get quark content of partons
7146       DO 1 I=1,2
7147          IFP1(I) = 0
7148          IFP2(I) = 0
7149          IFT1(I) = 0
7150          IFT2(I) = 0
7151     1 CONTINUE
7152       IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
7153       IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
7154       IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
7155       IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
7156       IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
7157       IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
7158       IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
7159       IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
7160
7161 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
7162       IDCH1 = 2
7163       IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
7164       IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
7165       IDCH2 = 2
7166       IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
7167       IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
7168
7169 * store initial configuration for energy-momentum cons. check
7170       IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
7171
7172 * sample intrinsic p_t at chain-ends
7173       CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
7174      &            PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
7175      &            AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
7176       IF (IREJ1.NE.0) THEN
7177          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
7178          IRPT = IRPT+1
7179          GOTO 9999
7180       ENDIF
7181
7182 C      IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7183 C         IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
7184 C* check second chain for resonance
7185 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7186 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
7187 C            IF (IREJ1.NE.0) GOTO 9999
7188 C            IF (IDR2.NE.0) THEN
7189 C               CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7190 C     &                     AMCH2,AMCH2N,AMCH1,IREJ1)
7191 C               IF (IREJ1.NE.0) GOTO 9999
7192 C            ENDIF
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) IDR1 = 100*IDR1
7198 C         ELSE
7199 C* check first chain for resonance
7200 C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7201 C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
7202 C            IF (IREJ1.NE.0) GOTO 9999
7203 C            IF (IDR1.NE.0) THEN
7204 C               CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7205 C     &                     AMCH1,AMCH1N,AMCH2,IREJ1)
7206 C               IF (IREJ1.NE.0) GOTO 9999
7207 C            ENDIF
7208 C* check second chain for resonance
7209 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7210 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
7211 C            IF (IREJ1.NE.0) GOTO 9999
7212 C            IF (IDR2.NE.0) IDR2 = 100*IDR2
7213 C         ENDIF
7214 C      ENDIF
7215
7216       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7217 * check chains for resonances
7218          CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7219      &               AMCH1,AMCH1N,IDCH1,IREJ1)
7220          IF (IREJ1.NE.0) GOTO 9999
7221          CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7222      &               AMCH2,AMCH2N,IDCH2,IREJ1)
7223          IF (IREJ1.NE.0) GOTO 9999
7224 * change kinematics corresponding to resonance-masses
7225          IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
7226             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7227      &                                 AMCH1,AMCH1N,AMCH2,IREJ1)
7228             IF (IREJ1.GT.0) GOTO 9999
7229             IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
7230             CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7231      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
7232             IF (IREJ1.NE.0) GOTO 9999
7233             IF (IDR2.NE.0) IDR2 = 100*IDR2
7234          ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
7235             CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7236      &                                 AMCH2,AMCH2N,AMCH1,IREJ1)
7237             IF (IREJ1.GT.0) GOTO 9999
7238             IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
7239             CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7240      &                  AMCH1,AMCH1N,IDCH1,IREJ1)
7241             IF (IREJ1.NE.0) GOTO 9999
7242             IF (IDR1.NE.0) IDR1 = 100*IDR1
7243          ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
7244             AMDIF1 = ABS(AMCH1-AMCH1N)
7245             AMDIF2 = ABS(AMCH2-AMCH2N)
7246             IF (AMDIF2.LT.AMDIF1) THEN
7247                CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7248      &                                    AMCH2,AMCH2N,AMCH1,IREJ1)
7249                IF (IREJ1.GT.0) GOTO 9999
7250                IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
7251                CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
7252      &                     IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
7253                IF (IREJ1.NE.0) GOTO 9999
7254                IF (IDR1.NE.0) IDR1 = 100*IDR1
7255             ELSE
7256                CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7257      &                                    AMCH1,AMCH1N,AMCH2,IREJ1)
7258                IF (IREJ1.GT.0) GOTO 9999
7259                IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
7260                CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
7261      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
7262                IF (IREJ1.NE.0) GOTO 9999
7263                IF (IDR2.NE.0) IDR2 = 100*IDR2
7264             ENDIF
7265          ENDIF
7266       ENDIF
7267
7268 * store final configuration for energy-momentum cons. check
7269       IF (LEMCCK) THEN
7270          CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
7271          CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
7272          IF (IREJ1.NE.0) GOTO 9999
7273       ENDIF
7274
7275 * put partons and chains into DTEVT1
7276       DO 10 I=1,4
7277          PCH1(I) = PP1(I)+PT1(I)
7278          PCH2(I) = PP2(I)+PT2(I)
7279    10 CONTINUE
7280       CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
7281      &                                      PP1(3),PP1(4),0,0,0)
7282       CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
7283      &                                      PT1(3),PT1(4),0,0,0)
7284       KCH = 100+IDCH(MOP1)*10+1
7285       CALL DT_EVTPUT(KCH,88888,-2,-1,
7286      &           PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
7287       CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
7288      &                                      PP2(3),PP2(4),0,0,0)
7289       CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
7290      &                                      PT2(3),PT2(4),0,0,0)
7291       KCH = KCH+1
7292       CALL DT_EVTPUT(KCH,88888,-2,-1,
7293      &           PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
7294
7295       RETURN
7296
7297  9999 CONTINUE
7298       IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
7299 * "cancel" sea-sea chains
7300          CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
7301          IF (IREJ1.NE.0) GOTO 9998
7302 **sr 16.5. flag for EVENTB
7303          IREJ = -1
7304          RETURN
7305       ENDIF
7306  9998 CONTINUE
7307       IREJ = 1
7308       RETURN
7309       END
7310
7311 *$ CREATE DT_CHKINE.FOR
7312 *COPY DT_CHKINE
7313 *
7314 *===chkine=============================================================*
7315 *
7316       SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
7317      &                  AMCH1,AMCH1N,AMCH2,IREJ)
7318
7319 ************************************************************************
7320 * This subroutine replaces CORMOM.                                     *
7321 * This version dated 05.01.95 is written by S. Roesler                 *
7322 ************************************************************************
7323
7324       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7325       SAVE
7326
7327       PARAMETER ( LINP = 10 ,
7328      &            LOUT = 6 ,
7329      &            LDAT = 9 )
7330
7331       PARAMETER (TINY10=1.0D-10)
7332
7333 * flags for input different options
7334       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7335       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7336      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7337
7338 * rejection counter
7339       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7340      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7341      &                IREXCI(3),IRDIFF(2),IRINC
7342
7343       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
7344      &          PP1I(4),PP2I(4),PT1I(4),PT2I(4)
7345
7346       IREJ  = 0
7347       JMSHL = IMSHL
7348
7349       SCALE  = AMCH1N/MAX(AMCH1,TINY10)
7350       DO 10 I=1,4
7351          PP1(I) = PP1I(I)
7352          PP2(I) = PP2I(I)
7353          PT1(I) = PT1I(I)
7354          PT2(I) = PT2I(I)
7355          PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
7356          PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
7357          PP1(I) = SCALE*PP1(I)
7358          PT1(I) = SCALE*PT1(I)
7359    10 CONTINUE
7360       IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
7361      &    (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
7362
7363       ECH = PP2(4)+PT2(4)
7364       PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
7365      &                               (PP2(3)+PT2(3))**2 )
7366       AMCH22 = (ECH-PCH)*(ECH+PCH)
7367       IF (AMCH22.LT.0.0D0) THEN
7368          IF (IOULEV(1).GT.0)
7369      &      WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
7370          GOTO 9997
7371       ENDIF
7372
7373       AMCH1 = AMCH1N
7374       AMCH2 = SQRT(AMCH22)
7375
7376 * put partons again on mass shell
7377    13 CONTINUE
7378       XM1 = 0.0D0
7379       XM2 = 0.0D0
7380       IF (JMSHL.EQ.1) THEN
7381
7382          XM1 = PYMASS(IFP1)
7383          XM2 = PYMASS(IFT1)
7384
7385       ENDIF
7386       CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
7387       IF (IREJ1.NE.0) THEN
7388          IF (JMSHL.EQ.0) GOTO 9998
7389          JMSHL = 0
7390          GOTO 13
7391       ENDIF
7392       JMSHL = IMSHL
7393       DO 11 I=1,4
7394          PP1(I) = P1(I)
7395          PT1(I) = P2(I)
7396    11 CONTINUE
7397    14 CONTINUE
7398       XM1 = 0.0D0
7399       XM2 = 0.0D0
7400       IF (JMSHL.EQ.1) THEN
7401
7402          XM1 = PYMASS(IFP2)
7403          XM2 = PYMASS(IFT2)
7404
7405       ENDIF
7406       CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
7407       IF (IREJ1.NE.0) THEN
7408          IF (JMSHL.EQ.0) GOTO 9998
7409          JMSHL = 0
7410          GOTO 14
7411       ENDIF
7412       DO 12 I=1,4
7413          PP2(I) = P1(I)
7414          PT2(I) = P2(I)
7415    12 CONTINUE
7416       DO 15 I=1,4
7417          PP1I(I) = PP1(I)
7418          PP2I(I) = PP2(I)
7419          PT1I(I) = PT1(I)
7420          PT2I(I) = PT2(I)
7421    15 CONTINUE
7422       RETURN
7423
7424  9997 IRCHKI(1) = IRCHKI(1)+1
7425 **sr
7426 C     GOTO 9999
7427       IREJ = -1
7428       RETURN
7429 **
7430  9998 IRCHKI(2) = IRCHKI(2)+1
7431
7432  9999 CONTINUE
7433       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
7434       IREJ = 1
7435       RETURN
7436       END
7437
7438 *$ CREATE DT_CH2RES.FOR
7439 *COPY DT_CH2RES
7440 *
7441 *===ch2res=============================================================*
7442 *
7443       SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7444      &                  AM,AMN,IMODE,IREJ)
7445
7446 ************************************************************************
7447 * Check chains for resonance production.                               *
7448 * This subroutine replaces COMCMA/COBCMA/COMCM2                        *
7449 *    input:                                                            *
7450 *          IF1,2,3,4    input flavors (q,aq in any order)              *
7451 *          AM           chain mass                                     *
7452 *          MODE = 1     check q-aq chain for meson-resonance           *
7453 *               = 2     check q-qq, aq-aqaq chain for baryon-resonance *
7454 *               = 3     check qq-aqaq chain for lower mass cut         *
7455 *    output:                                                           *
7456 *          IDR = 0      no resonances found                            *
7457 *              = -1     pseudoscalar meson/octet baryon                *
7458 *              = 1      vector-meson/decuplet baryon                   *
7459 *          IDXR         BAMJET-index of corresponding resonance        *
7460 *          AMN          mass of corresponding resonance                *
7461 *                                                                      *
7462 *          IREJ         rejection flag                                 *
7463 * This version dated 06.01.95 is written by S. Roesler                 *
7464 ************************************************************************
7465
7466       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7467       SAVE
7468
7469       PARAMETER ( LINP = 10 ,
7470      &            LOUT = 6 ,
7471      &            LDAT = 9 )
7472
7473 * particle properties (BAMJET index convention)
7474       CHARACTER*8  ANAME
7475       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7476      &                IICH(210),IIBAR(210),K1(210),K2(210)
7477
7478 * quark-content to particle index conversion (DTUNUC 1.x)
7479       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7480      &                IA08(6,21),IA10(6,21)
7481
7482 * rejection counter
7483       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7484      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7485      &                IREXCI(3),IRDIFF(2),IRINC
7486
7487 * flags for input different options
7488       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7489       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7490      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7491
7492       DIMENSION IF(4),JF(4)
7493
7494 **sr 4.7. test
7495 C     DATA AMLOM,AMLOB /0.08D0,0.2D0/
7496       DATA AMLOM,AMLOB /0.1D0,0.7D0/
7497 **
7498 C     DATA AMLOM,AMLOB /0.001D0,0.001D0/
7499
7500       MODE = ABS(IMODE)
7501
7502       IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7503          WRITE(LOUT,1000) MODE
7504  1000    FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7505      &          1X,'        program stopped')
7506          STOP
7507       ENDIF
7508
7509       AMX  = AM
7510       IREJ = 0
7511       IDR  = 0
7512       IDXR = 0
7513       AMN  = AMX
7514       IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7515       IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7516
7517       IF(1) = IF1
7518       IF(2) = IF2
7519       IF(3) = IF3
7520       IF(4) = IF4
7521       NF = 0
7522       DO 100 I=1,4
7523          IF (IF(I).NE.0) THEN
7524             NF = NF+1
7525             JF(NF) = IF(I)
7526          ENDIF
7527   100 CONTINUE
7528       IF (NF.LE.MODE) THEN
7529          WRITE(LOUT,1001) MODE,IF
7530  1001    FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7531      &   I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7532          GOTO 9999
7533       ENDIF
7534
7535       GOTO (1,2,3) MODE
7536
7537 * check for meson resonance
7538     1 CONTINUE
7539       IFQ  = JF(1)
7540       IFAQ = ABS(JF(2))
7541       IF (JF(2).GT.0) THEN
7542          IFQ  = JF(2)
7543          IFAQ = ABS(JF(1))
7544       ENDIF
7545       IFPS = IMPS(IFAQ,IFQ)
7546       IFV  = IMVE(IFAQ,IFQ)
7547       AMPS = AAM(IFPS)
7548       AMV  = AAM(IFV)
7549       AMHI = AMV+0.3D0
7550       IF (AMX.LT.AMV) THEN
7551          IF (AMX.LT.AMPS) THEN
7552             IF (IMODE.GT.0) THEN
7553                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7554             ELSE
7555                IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7556             ENDIF
7557             LOMRES = LOMRES+1
7558          ENDIF
7559 *    replace chain by pseudoscalar meson
7560          IDR  = -1
7561          IDXR = IFPS
7562          AMN  = AMPS
7563       ELSEIF (AMX.LT.AMHI) THEN
7564 *    replace chain by vector-meson
7565          IDR  = 1
7566          IDXR = IFV
7567          AMN  = AMV
7568       ENDIF
7569       RETURN
7570
7571 * check for baryon resonance
7572     2 CONTINUE
7573       CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7574       AM8  = AAM(JB8)
7575       AM10 = AAM(JB10)
7576       AMHI = AM10+0.3D0
7577       IF (AMX.LT.AM10) THEN
7578          IF (AMX.LT.AM8) THEN
7579             IF (IMODE.GT.0) THEN
7580                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7581             ELSE
7582                IF (AMX.LT.0.8D0*AM8) GOTO 9999
7583             ENDIF
7584             LOBRES = LOBRES+1
7585          ENDIF
7586 *    replace chain by oktet baryon
7587          IDR  = -1
7588          IDXR = JB8
7589          AMN  = AM8
7590       ELSEIF (AMX.LT.AMHI) THEN
7591          IDR  = 1
7592          IDXR = JB10
7593          AMN  = AM10
7594       ENDIF
7595       RETURN
7596
7597 * check qq-aqaq for lower mass cut
7598     3 CONTINUE
7599 *   empirical definition of AMHI to allow for (b-antib)-pair prod.
7600       AMHI = 2.5D0
7601       IF (AMX.LT.AMHI) GOTO 9999
7602       RETURN
7603
7604  9999 CONTINUE
7605       IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7606      &    WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7607       IREJ = 1
7608       IRRES(2) = IRRES(2)+1
7609       RETURN
7610       END
7611
7612 *$ CREATE DT_RJSEAC.FOR
7613 *COPY DT_RJSEAC
7614 *
7615 *===rjseac=============================================================*
7616 *
7617       SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7618
7619 ************************************************************************
7620 * ReJection of SEA-sea Chains.                                         *
7621 *         MOP1/2       entries of projectile sea-partons in DTEVT1     *
7622 *         MOT1/2       entries of projectile sea-partons in DTEVT1     *
7623 * This version dated 16.01.95 is written by S. Roesler                 *
7624 ************************************************************************
7625
7626       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7627       SAVE
7628
7629       PARAMETER ( LINP = 10 ,
7630      &            LOUT = 6 ,
7631      &            LDAT = 9 )
7632
7633       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7634
7635 * event history
7636
7637       PARAMETER (NMXHKK=200000)
7638
7639       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7640      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7641      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7642
7643 * extended event history
7644       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7645      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7646      &                IHIST(2,NMXHKK)
7647
7648 * statistics
7649       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7650      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7651      &                ICEVTG(8,0:30)
7652
7653       DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7654
7655       IREJ = 0
7656
7657 * projectile sea q-aq-pair
7658 *    indices of sea-pair
7659       IDXSEA(1,1) = MOP1
7660       IDXSEA(1,2) = MOP2
7661 *    index of mother-nucleon
7662       IDXNUC(1)   = JMOHKK(1,MOP1)
7663 *    status of valence quarks to be corrected
7664       ISTVAL(1)   = -21
7665
7666 * target sea q-aq-pair
7667 *    indices of sea-pair
7668       IDXSEA(2,1) = MOT1
7669       IDXSEA(2,2) = MOT2
7670 *    index of mother-nucleon
7671       IDXNUC(2)   = JMOHKK(1,MOT1)
7672 *    status of valence quarks to be corrected
7673       ISTVAL(2)   = -22
7674
7675       DO 1 N=1,2
7676          IDONE = 0
7677          DO 2 I=NPOINT(2),NHKK
7678             IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7679      &          (JMOHKK(1,I).EQ.IDXNUC(N)))   THEN
7680 * valence parton found
7681 *    inrease 4-momentum by sea 4-momentum
7682                DO 3 K=1,4
7683                   PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7684      &                                  PHKK(K,IDXSEA(N,2))
7685     3          CONTINUE
7686                PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7687      &                              PHKK(2,I)**2-PHKK(3,I)**2))
7688 *    "cancel" sea-pair
7689                DO 4 J=1,2
7690                   ISTHKK(IDXSEA(N,J))   = 100
7691                   IDHKK(IDXSEA(N,J))    = 0
7692                   JMOHKK(1,IDXSEA(N,J)) = 0
7693                   JMOHKK(2,IDXSEA(N,J)) = 0
7694                   JDAHKK(1,IDXSEA(N,J)) = 0
7695                   JDAHKK(2,IDXSEA(N,J)) = 0
7696                   DO 5 K=1,4
7697                      PHKK(K,IDXSEA(N,J)) = ZERO
7698                      VHKK(K,IDXSEA(N,J)) = ZERO
7699                      WHKK(K,IDXSEA(N,J)) = ZERO
7700     5             CONTINUE
7701                   PHKK(5,IDXSEA(N,J)) = ZERO
7702     4          CONTINUE
7703                IDONE = 1
7704             ENDIF
7705     2    CONTINUE
7706          IF (IDONE.NE.1) THEN
7707             WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7708  1000       FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7709      &                '-record!',/,1X,'        sea-quark pairs   ',
7710      &                2I5,4X,2I5,'   could not be canceled!')
7711             GOTO 9999
7712          ENDIF
7713     1 CONTINUE
7714       ICRJSS = ICRJSS+1
7715       RETURN
7716
7717  9999 CONTINUE
7718       IREJ = 1
7719       RETURN
7720       END
7721
7722 *$ CREATE DT_VV2SCH.FOR
7723 *COPY DT_VV2SCH
7724 *
7725 *===vv2sch=============================================================*
7726 *
7727       SUBROUTINE DT_VV2SCH
7728
7729 ************************************************************************
7730 * Change Valence-Valence chain systems to Single CHain systems for     *
7731 * hadron-nucleus collisions with meson or antibaryon projectile.       *
7732 * (Reggeon contribution)                                               *
7733 * The single chain system is approximately treated as one chain and a  *
7734 * meson at rest.                                                       *
7735 * This version dated 18.01.95 is written by S. Roesler                 *
7736 ************************************************************************
7737
7738       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7739       SAVE
7740
7741       PARAMETER ( LINP = 10 ,
7742      &            LOUT = 6 ,
7743      &            LDAT = 9 )
7744
7745       PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7746
7747       LOGICAL LSTART
7748
7749 * event history
7750
7751       PARAMETER (NMXHKK=200000)
7752
7753       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7754      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7755      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7756
7757 * extended event history
7758       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7759      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7760      &                IHIST(2,NMXHKK)
7761
7762 * flags for input different options
7763       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7764       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7765      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7766
7767 * statistics
7768       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7769      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7770      &                ICEVTG(8,0:30)
7771
7772       DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7773      &          PCH2(4)
7774
7775       DATA LSTART /.TRUE./
7776
7777       IFSC  = 0
7778       IF (LSTART) THEN
7779          WRITE(LOUT,1000)
7780  1000    FORMAT(/,1X,'VV2SCH:  Reggeon contribution to valance-',
7781      &          'valence chains treated')
7782          LSTART = .FALSE.
7783       ENDIF
7784
7785       NSTOP = NHKK
7786
7787 * get index of first chain
7788       DO 1 I=NPOINT(3),NHKK
7789          IF (IDHKK(I).EQ.88888) THEN
7790             NC = I
7791             GOTO 2
7792          ENDIF
7793     1 CONTINUE
7794
7795     2 CONTINUE
7796       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7797      &                        .AND.(NC.LT.NSTOP)) THEN
7798 * get valence-valence chains
7799          IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7800 *   get "mother"-hadron indices
7801             MO1   = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7802             MO2   = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7803             KPROJ = IDT_ICIHAD(IDHKK(MO1))
7804             KTARG = IDT_ICIHAD(IDHKK(MO2))
7805 *   Lab momentum of projectile hadron
7806             CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7807             PTOT  = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7808      &                                  PHKK(3,MO1)**2)
7809
7810             SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7811             IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7812                ICVV2S = ICVV2S+1
7813 *   single chain requested
7814 *      get flavors of chain-end partons
7815                MO(1) = JMOHKK(1,NC)
7816                MO(2) = JMOHKK(2,NC)
7817                MO(3) = JMOHKK(1,NC+3)
7818                MO(4) = JMOHKK(2,NC+3)
7819                DO 3 I=1,4
7820                   IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7821                   IF(I,2) = 0
7822                   IF (ABS(IDHKK(MO(I))).GE.1000)
7823      &               IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7824     3          CONTINUE
7825 *      which one is the q-aq chain?
7826 *        N1,N1+1 - DTEVT1-entries for q-aq system
7827 *        N2,N2+1 - DTEVT1-entries for the other chain
7828                IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7829                   K1 = 1
7830                   K2 = 3
7831                   N1 = NC-2
7832                   N2 = NC+1
7833                ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7834                   K1 = 3
7835                   K2 = 1
7836                   N1 = NC+1
7837                   N2 = NC-2
7838                ELSE
7839                   GOTO 10
7840                ENDIF
7841                DO 4 K=1,4
7842                   PP1(K) = PHKK(K,N1)
7843                   PT1(K) = PHKK(K,N1+1)
7844                   PP2(K) = PHKK(K,N2)
7845                   PT2(K) = PHKK(K,N2+1)
7846     4          CONTINUE
7847                AMCH1 = PHKK(5,N1+2)
7848                AMCH2 = PHKK(5,N2+2)
7849 *      get meson-identity corresponding to flavors of q-aq chain
7850                ITMP   = IRESRJ
7851                IRESRJ = 0
7852                CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7853      &                     ZERO,AMCH1N,1,IDUM)
7854                IRESRJ = ITMP
7855 *      change kinematics of chains
7856                CALL DT_CHKINE(PP1,IDHKK(N1),  PP2,IDHKK(N2),
7857      &                     PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7858      &                     AMCH1,AMCH1N,AMCH2,IREJ1)
7859                IF (IREJ1.NE.0) GOTO 10
7860 *      check second chain for resonance
7861                IDCHAI = 2
7862                IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7863                CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7864      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7865                IF (IREJ1.NE.0) GOTO 10
7866                IF (IDR2.NE.0) IDR2 = 100*IDR2
7867 *      add partons and chains to DTEVT1
7868                DO 5 K=1,4
7869                   PCH1(K) = PP1(K)+PT1(K)
7870                   PCH2(K) = PP2(K)+PT2(K)
7871     5          CONTINUE
7872                CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7873      &                                             PP1(3),PP1(4),0,0,0)
7874                CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7875      &                                      PT1(2),PT1(3),PT1(4),0,0,0)
7876                KCH = ISTHKK(N1+2)+100
7877                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7878      &                     PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7879                IDHKK(N1+2) = 22222
7880                CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7881      &                                             PP2(3),PP2(4),0,0,0)
7882                CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7883      &                                      PT2(2),PT2(3),PT2(4),0,0,0)
7884                KCH = ISTHKK(N2+2)+100
7885                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7886      &                     PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7887                IDHKK(N2+2) = 22222
7888             ENDIF
7889          ENDIF
7890       ELSE
7891          GOTO 11
7892       ENDIF
7893    10 CONTINUE
7894       NC = NC+6
7895       GOTO 2
7896
7897    11 CONTINUE
7898
7899       RETURN
7900       END
7901
7902 *$ CREATE DT_PHNSCH.FOR
7903 *COPY DT_PHNSCH
7904 *
7905 *=== phnsch ===========================================================*
7906 *
7907       DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7908
7909 *----------------------------------------------------------------------*
7910 *                                                                      *
7911 *     Probability for Hadron Nucleon Single CHain interactions:        *
7912 *                                                                      *
7913 *     Created on 30 december 1993  by    Alfredo Ferrari & Paola Sala  *
7914 *                                                   Infn - Milan       *
7915 *                                                                      *
7916 *     Last change on 04-jan-94     by    Alfredo Ferrari               *
7917 *                                                                      *
7918 *             modified by J.R.for use in DTUNUC  6.1.94                *
7919 *                                                                      *
7920 *     Input variables:                                                 *
7921 *                      Kp = hadron projectile index (Part numbering    *
7922 *                           scheme)                                    *
7923 *                   Ktarg = target nucleon index (1=proton, 8=neutron) *
7924 *                    Plab = projectile laboratory momentum (GeV/c)     *
7925 *     Output variable:                                                 *
7926 *                  Phnsch = probability per single chain (particle     *
7927 *                           exchange) interactions                     *
7928 *                                                                      *
7929 *----------------------------------------------------------------------*
7930
7931       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7932       SAVE
7933
7934       PARAMETER ( LUNOUT = 6  )
7935       PARAMETER ( LUNERR = 6  )
7936       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
7937       PARAMETER ( ZERZER = 0.D+00 )
7938       PARAMETER ( ONEONE = 1.D+00 )
7939       PARAMETER ( TWOTWO = 2.D+00 )
7940       PARAMETER ( FIVFIV = 5.D+00 )
7941       PARAMETER ( HLFHLF = 0.5D+00 )
7942
7943       PARAMETER ( NALLWP = 39   )
7944       PARAMETER ( IDMAXP = 210  )
7945
7946       DIMENSION ICHRGE(39),AM(39)
7947
7948 * particle properties (BAMJET index convention)
7949       CHARACTER*8  ANAME
7950       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7951      &                IICH(210),IIBAR(210),K1(210),K2(210)
7952
7953       DIMENSION KPTOIP(210)
7954
7955 * auxiliary common for reggeon exchange (DTUNUC 1.x)
7956       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7957      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7958      &                IQTCHR(-6:6),MQUARK(3,39)
7959
7960       DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7961       DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7962       EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7963       EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7964       EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7965
7966 * Conversion from part to paprop numbering
7967       DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7968      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7969      & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7970
7971 *  1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7972       DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7973      &    2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7974 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7975       DATA  SGTCO1  /
7976 * 1st reaction: gamma p total
7977      &0.147 D+00, ZERZER  , ZERZER   , 0.0022D+00, -0.0170D+00,
7978 * 2nd reaction: gamma d total
7979      &0.300 D+00, ZERZER  , ZERZER   , 0.0095D+00, -0.057 D+00,
7980 * 3rd reaction: pi+ p total
7981      &16.4  D+00, 19.3D+00, -0.42D+00, 0.19  D+00, ZERZER     ,
7982 * 4th reaction: pi- p total
7983      &33.0  D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03  D+00,
7984 * 5th reaction: pi+/- d total
7985      &56.8  D+00, 42.2D+00, -1.45D+00, 0.65  D+00, -5.39  D+00,
7986 * 6th reaction: K+ p total
7987      &18.1  D+00, ZERZER  , ZERZER   , 0.26  D+00, -1.0   D+00,
7988 * 7th reaction: K+ n total
7989      &18.7  D+00, ZERZER  , ZERZER   , 0.21  D+00, -0.89  D+00,
7990 * 8th reaction: K+ d total
7991      &34.2  D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99  D+00,
7992 * 9th reaction: K- p total
7993      &32.1  D+00, ZERZER  , ZERZER   , 0.66  D+00, -5.6   D+00,
7994 * 10th reaction: K- n total
7995      &25.2  D+00, ZERZER  , ZERZER   , 0.38  D+00, -2.9   D+00/
7996 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7997       DATA  SGTCO2  /
7998 * 11th reaction: K- d total
7999      &57.6  D+00, ZERZER  , ZERZER   , 1.17  D+00, -9.5   D+00,
8000 * 12th reaction: p p total
8001      &48.0  D+00, ZERZER  , ZERZER   , 0.522 D+00, -4.51  D+00,
8002 * 13th reaction: p n total
8003      &47.30 D+00, ZERZER  , ZERZER   , 0.513 D+00, -4.27  D+00,
8004 * 14th reaction: p d total
8005      &91.3  D+00, ZERZER  , ZERZER   , 1.05  D+00, -8.8   D+00,
8006 * 15th reaction: pbar p total
8007      &38.4  D+00, 77.6D+00, -0.64D+00, 0.26  D+00, -1.2   D+00,
8008 * 16th reaction: pbar n total
8009      &ZERZER    ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7   D+00,
8010 * 17th reaction: pbar d total
8011      &112.  D+00, 125.D+00, -1.08D+00, 1.14  D+00, -12.4  D+00,
8012 * 18th reaction: Lamda p total
8013      &30.4  D+00, ZERZER  , ZERZER   , ZERZER    , 1.6    D+00/
8014 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
8015       DATA SGTCO3  /
8016 * 19th reaction: pi+ p elastic
8017      &ZERZER    , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER     ,
8018 * 20th reaction: pi- p elastic
8019      &1.76  D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER     ,
8020 * 21st reaction: K+ p elastic
8021      &5.0   D+00, 8.1 D+00, -1.8 D+00, 0.16  D+00, -1.3   D+00,
8022 * 22nd reaction: K- p elastic
8023      &7.3   D+00, ZERZER  , ZERZER   , 0.29  D+00, -2.40  D+00,
8024 * 23rd reaction: p p elastic
8025      &11.9  D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85  D+00,
8026 * 24th reaction: p d elastic
8027      &16.1  D+00, ZERZER  , ZERZER   , 0.32  D+00, -3.4   D+00,
8028 * 25th reaction: pbar p elastic
8029      &10.2  D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28  D+00,
8030 * 26th reaction: pbar p elastic bis
8031      &10.6  D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41  D+00,
8032 * 27th reaction: pbar n elastic
8033      &36.5  D+00, ZERZER  , ZERZER   , ZERZER    , -11.9  D+00,
8034 * 28th reaction: Lamda p elastic
8035      &12.3  D+00, ZERZER  , ZERZER   , ZERZER    , -2.4   D+00,
8036 * 29th reaction: K- p ela bis
8037      &7.24  D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35  D+00,
8038 * 30th reaction: pi- p cx
8039      &ZERZER    ,0.912D+00, -1.22D+00, ZERZER    , ZERZER     ,
8040 * 31st reaction: K- p cx
8041      &ZERZER    , 3.39D+00, -1.75D+00, ZERZER    , ZERZER     ,
8042 * 32nd reaction: K+ n cx
8043      &ZERZER    , 7.18D+00, -2.01D+00, ZERZER    , ZERZER     ,
8044 * 33rd reaction: pbar p cx
8045      &ZERZER    , 18.8D+00, -2.01D+00, ZERZER    , ZERZER     /
8046 *
8047 *  +-------------------------------------------------------------------*
8048          ICHRGE(KTARG)=IICH(KTARG)
8049          AM    (KTARG)=AAM (KTARG)
8050 *  |  Check for pi0 (d-dbar)
8051       IF ( KP .NE. 26 ) THEN
8052          IP  = KPTOIP (KP)
8053          IF(IP.EQ.0)IP=1
8054          ICHRGE(IP)=IICH(KP)
8055          AM    (IP)=AAM (KP)
8056 *  |
8057 *  +-------------------------------------------------------------------*
8058 *  |
8059       ELSE
8060          IP = 23
8061          ICHRGE(IP)=0
8062       END IF
8063 *  |
8064 *  +-------------------------------------------------------------------*
8065 *  +-------------------------------------------------------------------*
8066 *  |  No such interactions for baryon-baryon
8067       IF ( IIBAR (KP) .GT. 0 ) THEN
8068          DT_PHNSCH = ZERZER
8069          RETURN
8070 *  |
8071 *  +-------------------------------------------------------------------*
8072 *  |  No "annihilation" diagram possible for K+ p/n
8073       ELSE IF ( IP .EQ. 15 ) THEN
8074          DT_PHNSCH = ZERZER
8075          RETURN
8076 *  |
8077 *  +-------------------------------------------------------------------*
8078 *  |  No "annihilation" diagram possible for K0 p/n
8079       ELSE IF ( IP .EQ. 24 ) THEN
8080          DT_PHNSCH = ZERZER
8081          RETURN
8082 *  |
8083 *  +-------------------------------------------------------------------*
8084 *  |  No "annihilation" diagram possible for Omebar p/n
8085       ELSE IF ( IP .GE. 38 ) THEN
8086          DT_PHNSCH = ZERZER
8087          RETURN
8088       END IF
8089 *  |
8090 *  +-------------------------------------------------------------------*
8091 *  +-------------------------------------------------------------------*
8092 *  |  If the momentum is larger than 50 GeV/c, compute the single
8093 *  |  chain probability at 50 GeV/c and extrapolate to the present
8094 *  |  momentum according to 1/sqrt(s)
8095 *  |  sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
8096 *  |  P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
8097 *  |  sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
8098 *  |  sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
8099 *  |                        x sqrt(s/s(50))
8100 *  |  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8101       IF ( PLAB .GT. 50.D+00 ) THEN
8102          PLA    = 50.D+00
8103          AMPSQ  = AM (IP)**2
8104          AMTSQ  = AM (KTARG)**2
8105          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
8106          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8107          EPROJ  = SQRT ( PLA**2 + AMPSQ )
8108          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8109          UMORAT = SQRT ( UMOSQ / UMO50 )
8110 *  |
8111 *  +-------------------------------------------------------------------*
8112 *  |  P < 3 GeV/c
8113       ELSE IF ( PLAB .LT. 3.D+00 ) THEN
8114          PLA    = 3.D+00
8115          AMPSQ  = AM (IP)**2
8116          AMTSQ  = AM (KTARG)**2
8117          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
8118          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8119          EPROJ  = SQRT ( PLA**2 + AMPSQ )
8120          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8121          UMORAT = SQRT ( UMOSQ / UMO50 )
8122 *  |
8123 *  +-------------------------------------------------------------------*
8124 *  |  P < 50 GeV/c
8125       ELSE
8126          PLA    = PLAB
8127          UMORAT = ONEONE
8128       END IF
8129 *  |
8130 *  +-------------------------------------------------------------------*
8131       ALGPLA = LOG (PLA)
8132 *  +-------------------------------------------------------------------*
8133 *  |  Pions:
8134       IF ( IHLP (IP) .EQ. 2 ) THEN
8135          ACOF = SGTCOE (1,3)
8136          BCOF = SGTCOE (2,3)
8137          ENNE = SGTCOE (3,3)
8138          CCOF = SGTCOE (4,3)
8139          DCOF = SGTCOE (5,3)
8140 *  |  Compute the pi+ p total cross section:
8141          SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8142      &          + DCOF * ALGPLA
8143          ACOF = SGTCOE (1,19)
8144          BCOF = SGTCOE (2,19)
8145          ENNE = SGTCOE (3,19)
8146          CCOF = SGTCOE (4,19)
8147          DCOF = SGTCOE (5,19)
8148 *  |  Compute the pi+ p elastic cross section:
8149          SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8150      &          + DCOF * ALGPLA
8151 *  |  Compute the pi+ p inelastic cross section:
8152          SPPPIN = SPPPTT - SPPPEL
8153          ACOF = SGTCOE (1,4)
8154          BCOF = SGTCOE (2,4)
8155          ENNE = SGTCOE (3,4)
8156          CCOF = SGTCOE (4,4)
8157          DCOF = SGTCOE (5,4)
8158 *  |  Compute the pi- p total cross section:
8159          SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8160      &          + DCOF * ALGPLA
8161          ACOF = SGTCOE (1,20)
8162          BCOF = SGTCOE (2,20)
8163          ENNE = SGTCOE (3,20)
8164          CCOF = SGTCOE (4,20)
8165          DCOF = SGTCOE (5,20)
8166 *  |  Compute the pi- p elastic cross section:
8167          SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8168      &          + DCOF * ALGPLA
8169 *  |  Compute the pi- p inelastic cross section:
8170          SPMPIN = SPMPTT - SPMPEL
8171          SIGDIA = SPMPIN - SPPPIN
8172 *  |  +----------------------------------------------------------------*
8173 *  |  |  Charged pions: besides isospin consideration it is supposed
8174 *  |  |                 that (pi+ n)el is almost equal to (pi- p)el
8175 *  |  |                 and  (pi+ p)el "    "     "    "  (pi- n)el
8176 *  |  |                 and all are almost equal among each others
8177 *  |  |                 (reasonable above 5 GeV/c)
8178          IF ( ICHRGE (IP) .NE. 0 ) THEN
8179             KHELP = KTARG / 8
8180             JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
8181             ACOF = SGTCOE (1,JREAC)
8182             BCOF = SGTCOE (2,JREAC)
8183             ENNE = SGTCOE (3,JREAC)
8184             CCOF = SGTCOE (4,JREAC)
8185             DCOF = SGTCOE (5,JREAC)
8186 *  |  |  Compute the total cross section:
8187             SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8188      &             + DCOF * ALGPLA
8189             JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
8190             ACOF = SGTCOE (1,JREAC)
8191             BCOF = SGTCOE (2,JREAC)
8192             ENNE = SGTCOE (3,JREAC)
8193             CCOF = SGTCOE (4,JREAC)
8194             DCOF = SGTCOE (5,JREAC)
8195 *  |  |  Compute the elastic cross section:
8196             SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8197      &             + DCOF * ALGPLA
8198 *  |  |  Compute the inelastic cross section:
8199             SHNCIN = SHNCTT - SHNCEL
8200 *  |  |  Number of diagrams:
8201             NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
8202 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8203             IQFSC1 = 1 + IP - 13
8204             IQFSC2 = 0
8205             IQBSC1 = 1 + KHELP
8206             IQBSC2 = 1 + IP - 13
8207 *  |  |
8208 *  |  +----------------------------------------------------------------*
8209 *  |  |  pi0: besides isospin consideration it is supposed that the
8210 *  |  |       elastic cross section is not very different from
8211 *  |  |       pi+ p and/or pi- p (reasonable above 5 GeV/c)
8212          ELSE
8213             KHELP  = KTARG / 8
8214             K2HLP  = ( KP - 23 ) / 3
8215 *  |  |  Number of diagrams:
8216 *  |  |  For u ubar (k2hlp=0):
8217 *           NDIAGR = 2 - KHELP
8218 *  |  |  For d dbar (k2hlp=1):
8219 *           NDIAGR = 2 + KHELP - K2HLP
8220             NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
8221             SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
8222 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8223             IQFSC1 = 1 + K2HLP
8224             IQFSC2 = 0
8225             IQBSC1 = 1 + KHELP
8226             IQBSC2 = 2 - K2HLP
8227          END IF
8228 *  |  |
8229 *  |  +----------------------------------------------------------------*
8230 *  |                                                   end pi's
8231 *  +-------------------------------------------------------------------*
8232 *  |  Kaons:
8233       ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
8234          ACOF = SGTCOE (1,6)
8235          BCOF = SGTCOE (2,6)
8236          ENNE = SGTCOE (3,6)
8237          CCOF = SGTCOE (4,6)
8238          DCOF = SGTCOE (5,6)
8239 *  |  Compute the K+ p total cross section:
8240          SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8241      &          + DCOF * ALGPLA
8242          ACOF = SGTCOE (1,21)
8243          BCOF = SGTCOE (2,21)
8244          ENNE = SGTCOE (3,21)
8245          CCOF = SGTCOE (4,21)
8246          DCOF = SGTCOE (5,21)
8247 *  |  Compute the K+ p elastic cross section:
8248          SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8249      &          + DCOF * ALGPLA
8250 *  |  Compute the K+ p inelastic cross section:
8251          SKPPIN = SKPPTT - SKPPEL
8252          ACOF = SGTCOE (1,9)
8253          BCOF = SGTCOE (2,9)
8254          ENNE = SGTCOE (3,9)
8255          CCOF = SGTCOE (4,9)
8256          DCOF = SGTCOE (5,9)
8257 *  |  Compute the K- p total cross section:
8258          SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8259      &          + DCOF * ALGPLA
8260          ACOF = SGTCOE (1,22)
8261          BCOF = SGTCOE (2,22)
8262          ENNE = SGTCOE (3,22)
8263          CCOF = SGTCOE (4,22)
8264          DCOF = SGTCOE (5,22)
8265 *  |  Compute the K- p elastic cross section:
8266          SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8267      &          + DCOF * ALGPLA
8268 *  |  Compute the K- p inelastic cross section:
8269          SKMPIN = SKMPTT - SKMPEL
8270          SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
8271 *  |  +----------------------------------------------------------------*
8272 *  |  |  Charged Kaons: actually only K-
8273          IF ( ICHRGE (IP) .NE. 0 ) THEN
8274             KHELP = KTARG / 8
8275 *  |  |  +-------------------------------------------------------------*
8276 *  |  |  |  Proton target:
8277             IF ( KHELP .EQ. 0 ) THEN
8278                SHNCIN = SKMPIN
8279 *  |  |  |  Number of diagrams:
8280                NDIAGR = 2
8281 *  |  |  |
8282 *  |  |  +-------------------------------------------------------------*
8283 *  |  |  |  Neutron target: besides isospin consideration it is supposed
8284 *  |  |  |              that (K- n)el is almost equal to (K- p)el
8285 *  |  |  |              (reasonable above 5 GeV/c)
8286             ELSE
8287                ACOF = SGTCOE (1,10)
8288                BCOF = SGTCOE (2,10)
8289                ENNE = SGTCOE (3,10)
8290                CCOF = SGTCOE (4,10)
8291                DCOF = SGTCOE (5,10)
8292 *  |  |  |  Compute the total cross section:
8293                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8294      &                + DCOF * ALGPLA
8295 *  |  |  |  Compute the elastic cross section:
8296                SHNCEL = SKMPEL
8297 *  |  |  |  Compute the inelastic cross section:
8298                SHNCIN = SHNCTT - SHNCEL
8299 *  |  |  |  Number of diagrams:
8300                NDIAGR = 1
8301             END IF
8302 *  |  |  |
8303 *  |  |  +-------------------------------------------------------------*
8304 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8305             IQFSC1 = 3
8306             IQFSC2 = 0
8307             IQBSC1 = 1 + KHELP
8308             IQBSC2 = 2
8309 *  |  |
8310 *  |  +----------------------------------------------------------------*
8311 *  |  |  K0's: (actually only K0bar)
8312          ELSE
8313             KHELP  = KTARG / 8
8314 *  |  |  +-------------------------------------------------------------*
8315 *  |  |  |  Proton target: (K0bar p)in supposed to be given by
8316 *  |  |  |                 (K- p)in - Sig_diagr
8317             IF ( KHELP .EQ. 0 ) THEN
8318                SHNCIN = SKMPIN - SIGDIA
8319 *  |  |  |  Number of diagrams:
8320                NDIAGR = 1
8321 *  |  |  |
8322 *  |  |  +-------------------------------------------------------------*
8323 *  |  |  |  Neutron target: (K0bar n)in supposed to be given by
8324 *  |  |  |                 (K- n)in + Sig_diagr
8325 *  |  |  |              besides isospin consideration it is supposed
8326 *  |  |  |              that (K- n)el is almost equal to (K- p)el
8327 *  |  |  |              (reasonable above 5 GeV/c)
8328             ELSE
8329                ACOF = SGTCOE (1,10)
8330                BCOF = SGTCOE (2,10)
8331                ENNE = SGTCOE (3,10)
8332                CCOF = SGTCOE (4,10)
8333                DCOF = SGTCOE (5,10)
8334 *  |  |  |  Compute the total cross section:
8335                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8336      &                + DCOF * ALGPLA
8337 *  |  |  |  Compute the elastic cross section:
8338                SHNCEL = SKMPEL
8339 *  |  |  |  Compute the inelastic cross section:
8340                SHNCIN = SHNCTT - SHNCEL + SIGDIA
8341 *  |  |  |  Number of diagrams:
8342                NDIAGR = 2
8343             END IF
8344 *  |  |  |
8345 *  |  |  +-------------------------------------------------------------*
8346 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8347             IQFSC1 = 3
8348             IQFSC2 = 0
8349             IQBSC1 = 1
8350             IQBSC2 = 1 + KHELP
8351          END IF
8352 *  |  |
8353 *  |  +----------------------------------------------------------------*
8354 *  |                                                   end Kaon's
8355 *  +-------------------------------------------------------------------*
8356 *  |  Antinucleons:
8357       ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
8358 *  |  For momenta between 3 and 5 GeV/c the use of tabulated data
8359 *  |  should be implemented!
8360          ACOF = SGTCOE (1,15)
8361          BCOF = SGTCOE (2,15)
8362          ENNE = SGTCOE (3,15)
8363          CCOF = SGTCOE (4,15)
8364          DCOF = SGTCOE (5,15)
8365 *  |  Compute the pbar p total cross section:
8366          SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8367      &          + DCOF * ALGPLA
8368          IF ( PLA .LT. FIVFIV ) THEN
8369             JREAC = 26
8370          ELSE
8371             JREAC = 25
8372          END IF
8373          ACOF = SGTCOE (1,JREAC)
8374          BCOF = SGTCOE (2,JREAC)
8375          ENNE = SGTCOE (3,JREAC)
8376          CCOF = SGTCOE (4,JREAC)
8377          DCOF = SGTCOE (5,JREAC)
8378 *  |  Compute the pbar p elastic cross section:
8379          SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8380      &          + DCOF * ALGPLA
8381 *  |  Compute the pbar p inelastic cross section:
8382          SAPPIN = SAPPTT - SAPPEL
8383          ACOF = SGTCOE (1,12)
8384          BCOF = SGTCOE (2,12)
8385          ENNE = SGTCOE (3,12)
8386          CCOF = SGTCOE (4,12)
8387          DCOF = SGTCOE (5,12)
8388 *  |  Compute the p p total cross section:
8389          SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8390      &          + DCOF * ALGPLA
8391          ACOF = SGTCOE (1,23)
8392          BCOF = SGTCOE (2,23)
8393          ENNE = SGTCOE (3,23)
8394          CCOF = SGTCOE (4,23)
8395          DCOF = SGTCOE (5,23)
8396 *  |  Compute the p p elastic cross section:
8397          SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8398      &          + DCOF * ALGPLA
8399 *  |  Compute the K- p inelastic cross section:
8400          SPPINE = SPPTOT - SPPELA
8401          SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
8402          KHELP  = KTARG / 8
8403 *  |  +----------------------------------------------------------------*
8404 *  |  |  Pbar:
8405          IF ( ICHRGE (IP) .NE. 0 ) THEN
8406             NDIAGR = 5 - KHELP
8407 *  |  |  +-------------------------------------------------------------*
8408 *  |  |  |  Proton target:
8409             IF ( KHELP .EQ. 0 ) THEN
8410 *  |  |  |  Number of diagrams:
8411                SHNCIN = SAPPIN
8412                PUUBAR = 0.8D+00
8413 *  |  |  |
8414 *  |  |  +-------------------------------------------------------------*
8415 *  |  |  |  Neutron target: it is supposed that (ap n)el is almost equal
8416 *  |  |  |                  to (ap p)el (reasonable above 5 GeV/c)
8417             ELSE
8418                ACOF = SGTCOE (1,16)
8419                BCOF = SGTCOE (2,16)
8420                ENNE = SGTCOE (3,16)
8421                CCOF = SGTCOE (4,16)
8422                DCOF = SGTCOE (5,16)
8423 *  |  |  |  Compute the total cross section:
8424                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8425      &                + DCOF * ALGPLA
8426 *  |  |  |  Compute the elastic cross section:
8427                SHNCEL = SAPPEL
8428 *  |  |  |  Compute the inelastic cross section:
8429                SHNCIN = SHNCTT - SHNCEL
8430                PUUBAR = HLFHLF
8431             END IF
8432 *  |  |  |
8433 *  |  |  +-------------------------------------------------------------*
8434 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8435 *  |  |  there are different possibilities, make a random choiche:
8436             IQFSC1 = -1
8437             RNCHEN = DT_RNDM(PUUBAR)
8438             IF ( RNCHEN .LT. PUUBAR ) THEN
8439                IQFSC2 = -2
8440             ELSE
8441                IQFSC2 = -1
8442             END IF
8443             IQBSC1 = -IQFSC1 + KHELP
8444             IQBSC2 = -IQFSC2
8445 *  |  |
8446 *  |  +----------------------------------------------------------------*
8447 *  |  |  nbar:
8448          ELSE
8449             NDIAGR = 4 + KHELP
8450 *  |  |  +-------------------------------------------------------------*
8451 *  |  |  |  Proton target: (nbar p)in supposed to be given by
8452 *  |  |  |                 (pbar p)in - Sig_diagr
8453             IF ( KHELP .EQ. 0 ) THEN
8454                SHNCIN = SAPPIN - SIGDIA
8455                PDDBAR = HLFHLF
8456 *  |  |  |
8457 *  |  |  +-------------------------------------------------------------*
8458 *  |  |  |  Neutron target: (nbar n)el is supposed to be equal to
8459 *  |  |  |                  (pbar p)el (reasonable above 5 GeV/c)
8460             ELSE
8461 *  |  |  |  Compute the total cross section:
8462                SHNCTT = SAPPTT
8463 *  |  |  |  Compute the elastic cross section:
8464                SHNCEL = SAPPEL
8465 *  |  |  |  Compute the inelastic cross section:
8466                SHNCIN = SHNCTT - SHNCEL
8467                PDDBAR = 0.8D+00
8468             END IF
8469 *  |  |  |
8470 *  |  |  +-------------------------------------------------------------*
8471 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8472 *  |  |  there are different possibilities, make a random choiche:
8473             IQFSC1 = -2
8474             RNCHEN = DT_RNDM(RNCHEN)
8475             IF ( RNCHEN .LT. PDDBAR ) THEN
8476                IQFSC2 = -1
8477             ELSE
8478                IQFSC2 = -2
8479             END IF
8480             IQBSC1 = -IQFSC1 + KHELP - 1
8481             IQBSC2 = -IQFSC2
8482          END IF
8483 *  |  |
8484 *  |  +----------------------------------------------------------------*
8485 *  |
8486 *  +-------------------------------------------------------------------*
8487 *  |  Others: not yet implemented
8488       ELSE
8489          SIGDIA = ZERZER
8490          SHNCIN = ONEONE
8491          NDIAGR = 0
8492          DT_PHNSCH = ZERZER
8493          RETURN
8494       END IF
8495 *  |                                                   end others
8496 *  +-------------------------------------------------------------------*
8497       DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8498       IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8499      &       + IQECHR (IQBSC2)
8500       IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8501      &       + IQBCHR (IQBSC2)
8502       IQECHC = IQECHC / 3
8503       IQBCHC = IQBCHC / 3
8504       IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8505      &       + IQSCHR (IQBSC2)
8506       IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8507      &       + IQSCHR (MQUARK(3,IP))
8508 *  +-------------------------------------------------------------------*
8509 *  |  Consistency check:
8510       IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8511          WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8512      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8513          WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8514      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8515          DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8516          DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8517       END IF
8518 *  |
8519 *  +-------------------------------------------------------------------*
8520 *  +-------------------------------------------------------------------*
8521 *  |  Consistency check:
8522       IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8523      &     .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8524          WRITE (LUNOUT,*)
8525      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8526      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8527          WRITE (LUNERR,*)
8528      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8529      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8530       END IF
8531 *  |
8532 *  +-------------------------------------------------------------------*
8533 *  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8534       IF ( UMORAT .GT. ONEPLS )
8535      &   DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8536      &                                 - ONEONE ) * UMORAT + ONEONE )
8537       RETURN
8538 *
8539       ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8540       DT_SCHQUA = ONEONE
8541       JQFSC1 = IQFSC1
8542       JQFSC2 = IQFSC2
8543       JQBSC1 = IQBSC1
8544       JQBSC2 = IQBSC2
8545 *=== End of function Phnsch ===========================================*
8546       RETURN
8547       END
8548
8549 *$ CREATE DT_RESPT.FOR
8550 *COPY DT_RESPT
8551 *
8552 *===respt==============================================================*
8553 *
8554       SUBROUTINE DT_RESPT
8555
8556 ************************************************************************
8557 * Check DTEVT1 for two-resonance systems and sample intrinsic p_t.     *
8558 * This version dated 18.01.95 is written by S. Roesler                 *
8559 ************************************************************************
8560
8561       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8562       SAVE
8563
8564       PARAMETER ( LINP = 10 ,
8565      &            LOUT = 6 ,
8566      &            LDAT = 9 )
8567
8568       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8569
8570 * event history
8571
8572       PARAMETER (NMXHKK=200000)
8573
8574       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8575      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8576      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8577
8578 * extended event history
8579       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8580      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8581      &                IHIST(2,NMXHKK)
8582
8583 * get index of first chain
8584       DO 1 I=NPOINT(3),NHKK
8585          IF (IDHKK(I).EQ.88888) THEN
8586             NC = I
8587             GOTO 2
8588          ENDIF
8589     1 CONTINUE
8590
8591     2 CONTINUE
8592       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8593 C        WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8594 * skip VV-,SS- systems
8595          IF ((IDCH(NC  ).NE.1).AND.(IDCH(NC  ).NE.8).AND.
8596      &       (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8597 * check if both "chains" are resonances
8598             IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8599                CALL DT_SAPTRE(NC,NC+3)
8600             ENDIF
8601          ENDIF
8602       ELSE
8603          GOTO 3
8604       ENDIF
8605       NC = NC+6
8606       GOTO 2
8607
8608     3 CONTINUE
8609
8610       RETURN
8611       END
8612
8613 *$ CREATE DT_EVTRES.FOR
8614 *COPY DT_EVTRES
8615 *
8616 *===evtres=============================================================*
8617 *
8618       SUBROUTINE DT_EVTRES(IREJ)
8619
8620 ************************************************************************
8621 * This version dated 14.12.94 is written by S. Roesler                 *
8622 ************************************************************************
8623
8624       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8625       SAVE
8626
8627       PARAMETER ( LINP = 10 ,
8628      &            LOUT = 6 ,
8629      &            LDAT = 9 )
8630
8631       PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8632
8633 * event history
8634
8635       PARAMETER (NMXHKK=200000)
8636
8637       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8638      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8639      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8640
8641 * extended event history
8642       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8643      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8644      &                IHIST(2,NMXHKK)
8645
8646 * flags for input different options
8647       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8648       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8649      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8650
8651 * particle properties (BAMJET index convention)
8652       CHARACTER*8  ANAME
8653       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8654      &                IICH(210),IIBAR(210),K1(210),K2(210)
8655
8656       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8657
8658       IREJ = 0
8659
8660       DO 1 I=NPOINT(3),NHKK
8661          IF (ABS(IDRES(I)).GE.100) THEN
8662             AMMX = 0.0D0
8663             DO 2 J=NPOINT(3),NHKK
8664                IF (IDHKK(J).EQ.88888) THEN
8665                   IF (PHKK(5,J).GT.AMMX) THEN
8666                      AMMX = PHKK(5,J)
8667                      IMMX = J
8668                   ENDIF
8669                ENDIF
8670     2       CONTINUE
8671             IF (IDRES(IMMX).NE.0) THEN
8672                IF (IOULEV(3).GT.0) THEN
8673                   WRITE(LOUT,'(1X,A)')
8674      &               'EVTRES: no chain for correc. found'
8675 C                 GOTO 6
8676                   GOTO 9999
8677                ELSE
8678                   GOTO 9999
8679                ENDIF
8680             ENDIF
8681             IMO11  = JMOHKK(1,I)
8682             IMO12  = JMOHKK(2,I)
8683             IF (PHKK(3,IMO11).LT.0.0D0) THEN
8684                IMO11 = JMOHKK(2,I)
8685                IMO12 = JMOHKK(1,I)
8686             ENDIF
8687             IMO21  = JMOHKK(1,IMMX)
8688             IMO22  = JMOHKK(2,IMMX)
8689             IF (PHKK(3,IMO21).LT.0.0D0) THEN
8690                IMO21 = JMOHKK(2,IMMX)
8691                IMO22 = JMOHKK(1,IMMX)
8692             ENDIF
8693             AMCH1  = PHKK(5,I)
8694             AMCH1N = AAM(IDXRES(I))
8695
8696             IFPR1 = IDHKK(IMO11)
8697             IFPR2 = IDHKK(IMO21)
8698             IFTA1 = IDHKK(IMO12)
8699             IFTA2 = IDHKK(IMO22)
8700             DO 4 J=1,4
8701                PP1(J) = PHKK(J,IMO11)
8702                PP2(J) = PHKK(J,IMO21)
8703                PT1(J) = PHKK(J,IMO12)
8704                PT2(J) = PHKK(J,IMO22)
8705     4       CONTINUE
8706 * store initial configuration for energy-momentum cons. check
8707             IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8708 * correct kinematics of second chain
8709             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8710      &                  AMCH1,AMCH1N,AMCH2,IREJ1)
8711             IF (IREJ1.NE.0) GOTO 9999
8712 * check now this chain for resonance mass
8713             IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8714             IFP(2) = 0
8715             IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8716             IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8717             IFT(2) = 0
8718             IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8719             IDCH2 = 2
8720             IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8721             IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8722             CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8723      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
8724             IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8725                IF (IOULEV(1).GT.0)
8726      &            WRITE(LOUT,*) ' correction for resonance not poss.'
8727 **sr test
8728 C              GOTO 1
8729 C              GOTO 9999
8730 **
8731             ENDIF
8732 * store final configuration for energy-momentum cons. check
8733             IF (LEMCCK) THEN
8734                CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8735                CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8736                IF (IREJ1.NE.0) GOTO 9999
8737             ENDIF
8738             DO 5 J=1,4
8739                PHKK(J,IMO11) = PP1(J)
8740                PHKK(J,IMO21) = PP2(J)
8741                PHKK(J,IMO12) = PT1(J)
8742                PHKK(J,IMO22) = PT2(J)
8743     5       CONTINUE
8744 * correct entries of chains
8745             DO 3 K=1,4
8746                PHKK(K,I)    = PHKK(K,IMO11)+PHKK(K,IMO12)
8747                PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8748     3       CONTINUE
8749             AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8750             AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8751      &            PHKK(3,IMMX)**2
8752 * ?? the following should now be obsolete
8753 **sr test
8754 C           IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8755             IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8756 **
8757                WRITE(LOUT,'(1X,A,4G10.3)')
8758      &          'EVTRES: inonsistent mass-corr.',AM1,AM2
8759 C              GOTO 9999
8760                GOTO 1
8761             ENDIF
8762             PHKK(5,I)    = SQRT(AM1)
8763             PHKK(5,IMMX) = SQRT(AM2)
8764             IDRES(I)     = IDRES(I)/100
8765             IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8766      &          (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8767                WRITE(LOUT,'(1X,A,4G10.3)')
8768      &          'EVTRES: inconsistent chain-masses',
8769      &          PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8770                GOTO 9999
8771             ENDIF
8772          ENDIF
8773     1 CONTINUE
8774     6 CONTINUE
8775       RETURN
8776
8777  9999 CONTINUE
8778       IREJ = 1
8779       RETURN
8780       END
8781
8782 *$ CREATE DT_GETSPT.FOR
8783 *COPY DT_GETSPT
8784 *
8785 *===getspt=============================================================*
8786 *
8787       SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8788      &                  PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8789      &                  AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8790
8791 ************************************************************************
8792 * This version dated 12.12.94 is written by S. Roesler                 *
8793 ************************************************************************
8794
8795       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8796       SAVE
8797
8798       PARAMETER ( LINP = 10 ,
8799      &            LOUT = 6 ,
8800      &            LDAT = 9 )
8801
8802       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8803
8804 * various options for treatment of partons (DTUNUC 1.x)
8805 * (chain recombination, Cronin,..)
8806       LOGICAL LCO2CR,LINTPT
8807       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8808      &                LCO2CR,LINTPT
8809
8810 * flags for input different options
8811       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8812       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8813      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8814
8815 * flags for diffractive interactions (DTUNUC 1.x)
8816       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8817
8818       DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8819      &          PT2(4),PT2I(4),P1(4),P2(4),
8820      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8821      &          PTOTI(4),PTOTF(4),DIFF(4)
8822
8823       IC   = 0
8824       IREJ = 0
8825 C     B33P = 4.0D0
8826 C     B33T = 4.0D0
8827 C     IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8828 C     IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8829       REDU = 1.0D0
8830 C     B33P = 3.5D0
8831 C     B33T = 3.5D0
8832       B33P = 4.0D0
8833       B33T = 4.0D0
8834       IF (IDIFF.NE.0) THEN
8835          B33P = 16.0D0
8836          B33T = 16.0D0
8837       ENDIF
8838
8839       DO 1 I=1,4
8840          PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8841          PP1(I)   = PP1I(I)
8842          PP2(I)   = PP2I(I)
8843          PT1(I)   = PT1I(I)
8844          PT2(I)   = PT2I(I)
8845     1 CONTINUE
8846 * get initial chain masses
8847       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8848      &                               +(PP1(3)+PT1(3))**2)
8849       ECH   = PP1(4)+PT1(4)
8850       AM1   = (ECH+PTOCH)*(ECH-PTOCH)
8851       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8852      &                               +(PP2(3)+PT2(3))**2)
8853       ECH   = PP2(4)+PT2(4)
8854       AM2   = (ECH+PTOCH)*(ECH-PTOCH)
8855       IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8856          IF (IOULEV(1).GT.0)
8857      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8858      &                              AM1,AM2
8859          GOTO 9999
8860       ENDIF
8861       AM1  = SQRT(AM1)
8862       AM2  = SQRT(AM2)
8863       AM1N = ZERO
8864       AM2N = ZERO
8865
8866       MODE = 0
8867 C      IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8868 C        MODE = 0
8869 C      ELSE
8870 C         MODE = 1
8871 C         IF (AM1.LT.0.6) THEN
8872 C            B33P = 10.0D0
8873 C         ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8874 CC           B33P = 4.0D0
8875 C         ENDIF
8876 C         IF (AM2.LT.0.6) THEN
8877 C            B33T = 10.0D0
8878 C         ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8879 CC           B33T = 4.0D0
8880 C         ENDIF
8881 C      ENDIF
8882
8883 * check chain masses for very low mass chains
8884 C     CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8885 C    &            AM1,DUM,-IDCH1,IREJ1)
8886 C     CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8887 C    &            AM2,DUM,-IDCH2,IREJ2)
8888 C     IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8889 C        B33P = 20.0D0
8890 C        B33T = 20.0D0
8891 C     ENDIF
8892
8893       JMSHL = IMSHL
8894
8895     2 CONTINUE
8896       IC = IC+1
8897       IF (MOD(IC,15).EQ.0) B33P  = 2.0D0*B33P
8898       IF (MOD(IC,15).EQ.0) B33T  = 2.0D0*B33T
8899       IF (MOD(IC,18).EQ.0) REDU  = 0.0D0
8900 C     IF (MOD(IC,19).EQ.0) JMSHL = 0
8901       IF (MOD(IC,20).EQ.0) GOTO 7
8902 C        WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8903 C        RETURN
8904 C        GOTO 9999
8905 C     ENDIF
8906
8907 * get transverse momentum
8908       IF (LINTPT) THEN
8909          ES   = -2.0D0/(B33P**2)
8910      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8911          HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8912          HPSP = HPSP*REDU
8913          ES   = -2.0D0/(B33T**2)
8914      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8915          HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8916          HPST = HPST*REDU
8917       ELSE
8918          HPSP = ZERO
8919          HPST = ZERO
8920       ENDIF
8921       CALL DT_DSFECF(SFE1,CFE1)
8922       CALL DT_DSFECF(SFE2,CFE2)
8923       IF (MODE.EQ.0) THEN
8924          PP1(1) = PP1I(1)+HPSP*CFE1
8925          PP1(2) = PP1I(2)+HPSP*SFE1
8926          PP2(1) = PP2I(1)-HPSP*CFE1
8927          PP2(2) = PP2I(2)-HPSP*SFE1
8928          PT1(1) = PT1I(1)+HPST*CFE2
8929          PT1(2) = PT1I(2)+HPST*SFE2
8930          PT2(1) = PT2I(1)-HPST*CFE2
8931          PT2(2) = PT2I(2)-HPST*SFE2
8932       ELSE
8933          PP1(1) = PP1I(1)+HPSP*CFE1
8934          PP1(2) = PP1I(2)+HPSP*SFE1
8935          PT1(1) = PT1I(1)-HPSP*CFE1
8936          PT1(2) = PT1I(2)-HPSP*SFE1
8937          PP2(1) = PP2I(1)+HPST*CFE2
8938          PP2(2) = PP2I(2)+HPST*SFE2
8939          PT2(1) = PT2I(1)-HPST*CFE2
8940          PT2(2) = PT2I(2)-HPST*SFE2
8941       ENDIF
8942
8943 * put partons on mass shell
8944       XMP1 = 0.0D0
8945       XMT1 = 0.0D0
8946       IF (JMSHL.EQ.1) THEN
8947
8948          XMP1 = PYMASS(IFPR1)
8949          XMT1 = PYMASS(IFTA1)
8950
8951       ENDIF
8952       CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8953       IF (IREJ1.NE.0) GOTO 2
8954       DO 3 I=1,4
8955          PTOTF(I) = P1(I)+P2(I)
8956          PP1(I)   = P1(I)
8957          PT1(I)   = P2(I)
8958     3 CONTINUE
8959       XMP2 = 0.0D0
8960       XMT2 = 0.0D0
8961       IF (JMSHL.EQ.1) THEN
8962
8963          XMP2 = PYMASS(IFPR2)
8964          XMT2 = PYMASS(IFTA2)
8965
8966       ENDIF
8967       CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8968       IF (IREJ1.NE.0) GOTO 2
8969       DO 4 I=1,4
8970          PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8971          PP2(I)   = P1(I)
8972          PT2(I)   = P2(I)
8973     4 CONTINUE
8974
8975 * check consistency
8976       DO 5 I=1,4
8977          DIFF(I) = PTOTI(I)-PTOTF(I)
8978     5 CONTINUE
8979       IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8980      &    (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8981          WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8982          GOTO 9999
8983       ENDIF
8984       PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8985       AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8986       PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8987       AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8988       PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8989       AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8990       PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8991       AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8992       IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8993      &    (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8994      &                                                           THEN
8995          WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8996      &     'GETSPT: inconsistent masses',
8997      &     AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8998 * sr 22.11.00: commented. It should only have inconsistent masses for
8999 * ultrahigh energies due to rounding problems
9000 C        GOTO 9999
9001       ENDIF
9002
9003 * get chain masses
9004       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
9005      &                               +(PP1(3)+PT1(3))**2)
9006       ECH   = PP1(4)+PT1(4)
9007       AM1N  = (ECH+PTOCH)*(ECH-PTOCH)
9008       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
9009      &                               +(PP2(3)+PT2(3))**2)
9010       ECH   = PP2(4)+PT2(4)
9011       AM2N  = (ECH+PTOCH)*(ECH-PTOCH)
9012       IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
9013          IF (IOULEV(1).GT.0)
9014      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
9015      &                              AM1N,AM2N
9016          GOTO 2
9017       ENDIF
9018       AM1N = SQRT(AM1N)
9019       AM2N = SQRT(AM2N)
9020
9021 * check chain masses for very low mass chains
9022       CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
9023      &            AM1N,DUM,-IDCH1,IREJ1)
9024       IF (IREJ1.NE.0) GOTO 2
9025       CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
9026      &            AM2N,DUM,-IDCH2,IREJ2)
9027       IF (IREJ2.NE.0) GOTO 2
9028
9029     7 CONTINUE
9030       IF (AM1N.GT.ZERO) THEN
9031          AM1 = AM1N
9032          AM2 = AM2N
9033       ENDIF
9034       DO 6 I=1,4
9035          PP1I(I)   = PP1(I)
9036          PP2I(I)   = PP2(I)
9037          PT1I(I)   = PT1(I)
9038          PT2I(I)   = PT2(I)
9039     6 CONTINUE
9040
9041       RETURN
9042
9043  9999 CONTINUE
9044       IREJ = 1
9045       RETURN
9046       END
9047
9048 *$ CREATE DT_SAPTRE.FOR
9049 *COPY DT_SAPTRE
9050 *
9051 *===saptre=============================================================*
9052 *
9053       SUBROUTINE DT_SAPTRE(IDX1,IDX2)
9054
9055 ************************************************************************
9056 * p-t sampling for two-resonance systems. ("BAMJET-like" method)       *
9057 *        IDX1,IDX2       indices of resonances ("chains") in DTEVT1    *
9058 * Adopted from the original SAPTRE written by J. Ranft.                *
9059 * This version dated 18.01.95 is written by S. Roesler                 *
9060 ************************************************************************
9061
9062       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9063       SAVE
9064
9065       PARAMETER ( LINP = 10 ,
9066      &            LOUT = 6 ,
9067      &            LDAT = 9 )
9068
9069       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
9070
9071 * event history
9072
9073       PARAMETER (NMXHKK=200000)
9074
9075       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9076      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9077      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9078
9079 * extended event history
9080       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9081      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9082      &                IHIST(2,NMXHKK)
9083
9084 * flags for input different options
9085       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9086       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9087      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9088
9089       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
9090
9091       DATA B3 /4.0D0/
9092
9093       ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
9094       ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
9095       ESMAX  = MIN(ESMAX1,ESMAX2)
9096       IF (ESMAX.LE.0.05D0) RETURN
9097
9098       HMA    = PHKK(5,IDX1)
9099       DO 1 K=1,4
9100          PA1(K) = PHKK(K,IDX1)
9101          PA2(K) = PHKK(K,IDX2)
9102     1 CONTINUE
9103
9104       IF (LEMCCK) THEN
9105          CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
9106          CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
9107       ENDIF
9108
9109       EXEB   = 0.0D0
9110       IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
9111       BEXP   = HMA*(1.0D0-EXEB)/B3
9112       AXEXP  = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
9113       WA     = AXEXP/(BEXP+AXEXP)
9114       XAB    = DT_RNDM(WA)
9115    10 CONTINUE
9116 * ES is the transverse kinetic energy
9117       IF (XAB.LT.WA)THEN
9118         X  = DT_RNDM(WA)
9119         Y  = DT_RNDM(WA)
9120         ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
9121       ELSE
9122         X  = DT_RNDM(Y)
9123         ES = ABS(-LOG(X+TINY7)/B3)
9124       ENDIF
9125       IF (ES.GT.ESMAX) GOTO 10
9126       ES  = ES+HMA
9127 * transverse momentum
9128       HPS = SQRT((ES-HMA)*(ES+HMA))
9129
9130       CALL DT_DSFECF(SFE,CFE)
9131       HPX = HPS*CFE
9132       HPY = HPS*SFE
9133       PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
9134       PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
9135       IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
9136
9137 C     PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
9138 C     PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
9139       PA1(1) = PA1(1)+HPX
9140       PA1(2) = PA1(2)+HPY
9141       PA2(1) = PA2(1)-HPX
9142       PA2(2) = PA2(2)-HPY
9143
9144 * put resonances on mass-shell again
9145       XM1 = PHKK(5,IDX1)
9146       XM2 = PHKK(5,IDX2)
9147       CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
9148       IF (IREJ1.NE.0) RETURN
9149
9150       IF (LEMCCK) THEN
9151          CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
9152          CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
9153          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
9154          IF (IREJ1.NE.0) RETURN
9155       ENDIF
9156
9157       DO 2 K=1,4
9158          PHKK(K,IDX1) = P1(K)
9159          PHKK(K,IDX2) = P2(K)
9160     2 CONTINUE
9161
9162       RETURN
9163       END
9164
9165 *$ CREATE DT_CRONIN.FOR
9166 *COPY DT_CRONIN
9167 *
9168 *===cronin=============================================================*
9169 *
9170       SUBROUTINE DT_CRONIN(INCL)
9171
9172 ************************************************************************
9173 * Cronin-Effect. Multiple scattering of partons at chain ends.         *
9174 *             INCL = 1     multiple sc. in projectile                  *
9175 *                  = 2     multiple sc. in target                      *
9176 * This version dated 05.01.96 is written by S. Roesler.                *
9177 ************************************************************************
9178
9179       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9180       SAVE
9181
9182       PARAMETER ( LINP = 10 ,
9183      &            LOUT = 6 ,
9184      &            LDAT = 9 )
9185
9186       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
9187
9188 * event history
9189
9190       PARAMETER (NMXHKK=200000)
9191
9192       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9193      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9194      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9195
9196 * extended event history
9197       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9198      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9199      &                IHIST(2,NMXHKK)
9200
9201 * rejection counter
9202       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
9203      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
9204      &                IREXCI(3),IRDIFF(2),IRINC
9205
9206 * Glauber formalism: collision properties
9207       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
9208      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
9209      &                NCP,NCT
9210       DIMENSION R(3),PIN(4),POUT(4),DEV(4)
9211
9212       DO 1 K=1,4
9213          DEV(K) = ZERO
9214     1 CONTINUE
9215
9216       DO 2 I=NPOINT(2),NHKK
9217          IF (ISTHKK(I).LT.0) THEN
9218 * get z-position of the chain
9219             R(1) = VHKK(1,I)*1.0D12
9220             IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
9221             R(2) = VHKK(2,I)*1.0D12
9222             IDXNU = JMOHKK(1,I)
9223             IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
9224      &                             IDXNU = JMOHKK(1,I-1)
9225             IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
9226      &                             IDXNU = JMOHKK(1,I+1)
9227             R(3) = VHKK(3,IDXNU)*1.0D12
9228 * position of target parton the chain is connected to
9229             DO 3 K=1,4
9230                PIN(K) = PHKK(K,I)
9231     3       CONTINUE
9232 * multiple scattering of parton with DTEVT1-index I
9233             CALL DT_CROMSC(PIN,R,POUT,INCL)
9234 **testprint
9235 C           IF (NEVHKK.EQ.5) THEN
9236 C              AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
9237 C              AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
9238 C              AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
9239 C              AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
9240 C              WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
9241 C              WRITE(6,'(A,4E15.5)')'PIN:       ',PIN
9242 C              WRITE(6,'(A,4E15.5)')'POUT:      ',POUT
9243 C           ENDIF
9244 **
9245 * increase accumulator by energy-momentum difference
9246             DO 4 K=1,4
9247                DEV(K)    = DEV(K)+POUT(K)-PIN(K)
9248                PHKK(K,I) = POUT(K)
9249     4       CONTINUE
9250             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
9251      &                           PHKK(2,I)**2-PHKK(3,I)**2))
9252          ENDIF
9253     2 CONTINUE
9254
9255 * dump accumulator to momenta of valence partons
9256       NVAL = 0
9257       ETOT = 0.0D0
9258       DO 5 I=NPOINT(2),NHKK
9259          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
9260             NVAL = NVAL+1
9261             ETOT = ETOT+PHKK(4,I)
9262          ENDIF
9263     5 CONTINUE
9264 C     WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
9265  1000 FORMAT(1X,'CRONIN :  number of val. partons ',I4,/,
9266      &       9X,4E12.4)
9267       DO 6 I=NPOINT(2),NHKK
9268          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
9269             E = PHKK(4,I)
9270             DO 7 K=1,4
9271 C              PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
9272                PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
9273     7       CONTINUE
9274             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
9275      &                           PHKK(2,I)**2-PHKK(3,I)**2))
9276          ENDIF
9277     6 CONTINUE
9278
9279       RETURN
9280       END
9281
9282 *$ CREATE DT_CROMSC.FOR
9283 *COPY DT_CROMSC
9284 *
9285 *===cromsc=============================================================*
9286 *
9287       SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
9288
9289 ************************************************************************
9290 * Cronin-Effect. Multiple scattering of one parton passing through     *
9291 * nuclear matter.                                                      *
9292 *            PIN(4)       input 4-momentum of parton                   *
9293 *            POUT(4)      4-momentum of parton after mult. scatt.      *
9294 *            R(3)         spatial position of parton in target nucleus *
9295 *            INCL = 1     multiple sc. in projectile                   *
9296 *                 = 2     multiple sc. in target                       *
9297 * This is a revised version of the original version written by J. Ranft*
9298 * This version dated 17.01.95 is written by S. Roesler.                *
9299 ************************************************************************
9300
9301       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9302       SAVE
9303
9304       PARAMETER ( LINP = 10 ,
9305      &            LOUT = 6 ,
9306      &            LDAT = 9 )
9307
9308       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
9309
9310       LOGICAL LSTART
9311
9312 * rejection counter
9313       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
9314      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
9315      &                IREXCI(3),IRDIFF(2),IRINC
9316
9317 * Glauber formalism: collision properties
9318       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
9319      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
9320      &                NCP,NCT
9321
9322 * various options for treatment of partons (DTUNUC 1.x)
9323 * (chain recombination, Cronin,..)
9324       LOGICAL LCO2CR,LINTPT
9325       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9326      &                LCO2CR,LINTPT
9327
9328       DIMENSION PIN(4),POUT(4),R(3)
9329
9330       DATA LSTART /.TRUE./
9331
9332       IRCRON(1) = IRCRON(1)+1
9333
9334       IF (LSTART) THEN
9335          WRITE(LOUT,1000) CRONCO
9336  1000    FORMAT(/,1X,'CROMSC:  multiple scattering of chain ends',
9337      &          ' treated',/,10X,'with parameter CRONCO = ',F5.2)
9338          LSTART = .FALSE.
9339       ENDIF
9340
9341       NCBACK = 0
9342       RNCL   = RPROJ
9343       IF (INCL.EQ.2) RNCL = RTARG
9344
9345 * Lorentz-transformation into Lab.
9346       MODE = -(INCL+1)
9347       CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
9348
9349       PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
9350       IF (PTOT.LE.8.0D0) GOTO 9997
9351
9352 * direction cosines of parton before mult. scattering
9353       COSX = PIN(1)/PTOT
9354       COSY = PIN(2)/PTOT
9355       COSZ = PZ/PTOT
9356
9357       RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
9358       IF (RTESQ.GE.-TINY3) GOTO 9999
9359
9360 * calculate distance (DIST) from R to surface of nucleus (radius RNCL)
9361 * in the direction of particle motion
9362
9363       A    = COSX*R(1)+COSY*R(2)+COSZ*R(3)
9364       TMP  = A**2-RTESQ
9365       IF (TMP.LT.ZERO) GOTO 9998
9366       DIST = -A+SQRT(TMP)
9367
9368 * multiple scattering angle
9369       THETO = CRONCO*SQRT(DIST)/PTOT
9370       IF (THETO.GT.0.1D0) THETO=0.1D0
9371
9372     1 CONTINUE
9373 * Gaussian sampling of spatial angle
9374       CALL DT_RANNOR(R1,R2)
9375       THETA = ABS(R1*THETO)
9376       IF (THETA.GT.0.3D0) GOTO 9997
9377       CALL DT_DSFECF(SFE,CFE)
9378       COSTH = COS(THETA)
9379       SINTH = SIN(THETA)
9380
9381 * new direction cosines
9382       CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
9383      &                               COSXN,COSYN,COSZN)
9384
9385       POUT(1) = COSXN*PTOT
9386       POUT(2) = COSYN*PTOT
9387       PZ      = COSZN*PTOT
9388 * Lorentz-transformation into nucl.-nucl. cms
9389       MODE = INCL+1
9390       CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
9391
9392 C     IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
9393 C     IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
9394       IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
9395          THETO = THETO/2.0D0
9396          NCBACK = NCBACK+1
9397          IF (MOD(NCBACK,200).EQ.0) THEN
9398             WRITE(LOUT,1001) THETO,PIN,POUT
9399  1001       FORMAT(1X,'CROMSC: inconsistent scattering angle ',
9400      &             E12.4,/,1X,'        PIN :',4E12.4,/,
9401      &             1X,'       POUT:',4E12.4)
9402             GOTO 9997
9403          ENDIF
9404          GOTO 1
9405       ENDIF
9406
9407       RETURN
9408
9409  9997 IRCRON(2) = IRCRON(2)+1
9410       GOTO 9999
9411  9998 IRCRON(3) = IRCRON(3)+1
9412
9413  9999 CONTINUE
9414       DO 100 K=1,4
9415          POUT(K) = PIN(K)
9416   100 CONTINUE
9417       RETURN
9418       END
9419
9420 *$ CREATE DT_COM2CR.FOR
9421 *COPY DT_COM2CR
9422 *
9423 *===com2sr=============================================================*
9424 *
9425       SUBROUTINE DT_COM2CR
9426
9427 ************************************************************************
9428 * COMbine q-aq chains to Color Ropes (qq-aqaq).                        *
9429 *        CUTOF      parameter determining minimum number of not        *
9430 *                   combined q-aq chains                               *
9431 * This subroutine replaces KKEVCC etc.                                 *
9432 * This version dated 11.01.95 is written by S. Roesler.                *
9433 ************************************************************************
9434
9435       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9436       SAVE
9437
9438       PARAMETER ( LINP = 10 ,
9439      &            LOUT = 6 ,
9440      &            LDAT = 9 )
9441
9442 * event history
9443
9444       PARAMETER (NMXHKK=200000)
9445
9446       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9447      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9448      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9449
9450 * extended event history
9451       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9452      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9453      &                IHIST(2,NMXHKK)
9454
9455 * statistics
9456       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9457      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9458      &                ICEVTG(8,0:30)
9459
9460 * various options for treatment of partons (DTUNUC 1.x)
9461 * (chain recombination, Cronin,..)
9462       LOGICAL LCO2CR,LINTPT
9463       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9464      &                LCO2CR,LINTPT
9465
9466       DIMENSION IDXQA(248),IDXAQ(248)
9467
9468       ICCHAI(1,9) = ICCHAI(1,9)+1
9469       NQA = 0
9470       NAQ = 0
9471 * scan DTEVT1 for q-aq, aq-q chains
9472       DO 10 I=NPOINT(3),NHKK
9473 * skip "chains" which are resonances
9474          IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
9475             MO1 = JMOHKK(1,I)
9476             MO2 = JMOHKK(2,I)
9477             IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
9478 * q-aq, aq-q chain found, keep index
9479                IF (IDHKK(MO1).GT.0) THEN
9480                   NQA = NQA+1
9481                   IDXQA(NQA) = I
9482                ELSE
9483                   NAQ = NAQ+1
9484                   IDXAQ(NAQ) = I
9485                ENDIF
9486             ENDIF
9487          ENDIF
9488    10 CONTINUE
9489
9490 * minimum number of q-aq chains requested for the same projectile/
9491 * target
9492       NCHMIN = IDT_NPOISS(CUTOF)
9493
9494 * combine q-aq chains of the same projectile
9495       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
9496 * combine q-aq chains of the same target
9497       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
9498 * combine aq-q chains of the same projectile
9499       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
9500 * combine aq-q chains of the same target
9501       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
9502
9503       RETURN
9504       END
9505
9506 *$ CREATE DT_SCN4CR.FOR
9507 *COPY DT_SCN4CR
9508 *
9509 *===scn4cr=============================================================*
9510 *
9511       SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9512
9513 ************************************************************************
9514 * SCan q-aq chains for Color Ropes.                                    *
9515 * This version dated 11.01.95 is written by S. Roesler.                *
9516 ************************************************************************
9517
9518       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9519       SAVE
9520
9521       PARAMETER ( LINP = 10 ,
9522      &            LOUT = 6 ,
9523      &            LDAT = 9 )
9524
9525 * event history
9526
9527       PARAMETER (NMXHKK=200000)
9528
9529       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9530      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9531      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9532
9533 * extended event history
9534       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9535      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9536      &                IHIST(2,NMXHKK)
9537
9538       DIMENSION IDXCH(248),IDXJN(248)
9539
9540       DO 1 I=1,NCH
9541          IF (IDXCH(I).GT.0) THEN
9542             NJOIN = 1
9543             IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9544             IDXJN(NJOIN) = I
9545             IF (I.LT.NCH) THEN
9546                DO 2 J=I+1,NCH
9547                   IF (IDXCH(J).GT.0) THEN
9548                      IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9549                      IF (IDXMO.EQ.IDXMO1) THEN
9550                         NJOIN = NJOIN+1
9551                         IDXJN(NJOIN) = J
9552                      ENDIF
9553                   ENDIF
9554     2          CONTINUE
9555             ENDIF
9556             IF (NJOIN.GE.NCHMIN+2) THEN
9557                NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9558                DO 3 J=1,2*NJ,2
9559                   CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9560                   IF (IREJ1.NE.0) GOTO 3
9561                   IDXCH(IDXJN(J))   = 0
9562                   IDXCH(IDXJN(J+1)) = 0
9563     3          CONTINUE
9564             ENDIF
9565          ENDIF
9566     1 CONTINUE
9567
9568       RETURN
9569       END
9570
9571 *$ CREATE DT_JOIN.FOR
9572 *COPY DT_JOIN
9573 *
9574 *===join===============================================================*
9575 *
9576       SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9577
9578 ************************************************************************
9579 * This subroutine joins two q-aq chains to one qq-aqaq chain.          *
9580 *     IDX1, IDX2       DTEVT1 indices of chains to be joined           *
9581 * This version dated 11.01.95 is written by S. Roesler.                *
9582 ************************************************************************
9583
9584       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9585       SAVE
9586
9587       PARAMETER ( LINP = 10 ,
9588      &            LOUT = 6 ,
9589      &            LDAT = 9 )
9590
9591 * event history
9592
9593       PARAMETER (NMXHKK=200000)
9594
9595       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9596      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9597      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9598
9599 * extended event history
9600       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9601      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9602      &                IHIST(2,NMXHKK)
9603
9604 * flags for input different options
9605       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9606       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9607      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9608
9609 * statistics
9610       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9611      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9612      &                ICEVTG(8,0:30)
9613
9614       DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9615
9616       IREJ   = 0
9617
9618       IDX(1) = IDX1
9619       IDX(2) = IDX2
9620       DO 1 I=1,2
9621          DO 2 J=1,2
9622             MO(I,J) = JMOHKK(J,IDX(I))
9623             ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9624     2    CONTINUE
9625     1 CONTINUE
9626
9627 * check consistency
9628       IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9629      &    (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9630      &    ((ID(1,1)*ID(2,1)).LT.0).OR.
9631      &    ((ID(1,2)*ID(2,2)).LT.0)) THEN
9632          WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9633      &                    MO(2,2)
9634  1000    FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9635      &             2I5,' chain ',I4,':',2I5)
9636       ENDIF
9637
9638 * join chains
9639       DO 3 K=1,4
9640          PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9641          PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9642     3 CONTINUE
9643       IF1  = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9644       IF2  = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9645       IST1 = ISTHKK(MO(1,1))
9646       IST2 = ISTHKK(MO(1,2))
9647
9648 * put partons again on mass shell
9649       XM1 = 0.0D0
9650       XM2 = 0.0D0
9651       IF (IMSHL.EQ.1) THEN
9652
9653          XM1 = PYMASS(IF1)
9654          XM2 = PYMASS(IF2)
9655
9656       ENDIF
9657       CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9658       IF (IREJ1.NE.0) GOTO 9999
9659       DO 4 I=1,4
9660          PP(I) = P1(I)
9661          PT(I) = P2(I)
9662     4 CONTINUE
9663
9664 * store new partons in DTEVT1
9665       CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9666      &                                                       0,0,0)
9667       CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9668      &                                                       0,0,0)
9669       DO 5 K=1,4
9670          PCH(K) = PP(K)+PT(K)
9671     5 CONTINUE
9672
9673 * check new chain for lower mass limit
9674       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9675          AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9676          CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9677      &               AMCH,AMCHN,3,IREJ1)
9678          IF (IREJ1.NE.0) THEN
9679             NHKK = NHKK-2
9680             GOTO 9999
9681          ENDIF
9682       ENDIF
9683
9684       ICCHAI(2,9) = ICCHAI(2,9)+1
9685 * store new chain in DTEVT1
9686       KCH = 191
9687       CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9688       IDHKK(IDX(1)) = 22222
9689       IDHKK(IDX(2)) = 22222
9690 * special treatment for space-time coordinates
9691       DO 6 K=1,4
9692          VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9693          WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9694     6 CONTINUE
9695       RETURN
9696
9697  9999 CONTINUE
9698       IREJ = 1
9699       RETURN
9700       END
9701 *$ CREATE DT_XSGLAU.FOR
9702 *COPY DT_XSGLAU
9703 *
9704 *===xsglau=============================================================*
9705 *
9706       SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9707
9708 ************************************************************************
9709 * Total, elastic, quasi-elastic, inelastic cross sections according to *
9710 * Glauber's approach.                                                  *
9711 *  NA / NB     mass numbers of proj./target nuclei                     *
9712 *  JJPROJ      bamjet-index of projectile (=1 in case of proj.nucleus) *
9713 *  XI,Q2I,ECMI kinematical variables x, Q^2, E_cm                      *
9714 *  IE,IQ       indices of energy and virtuality (the latter for gamma  *
9715 *              projectiles only)                                       *
9716 *  NIDX        index of projectile/target nucleus                      *
9717 * This version dated 17.3.98  is written by S. Roesler                 *
9718 ************************************************************************
9719
9720       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9721       SAVE
9722
9723       PARAMETER ( LINP = 10 ,
9724      &            LOUT = 6 ,
9725      &            LDAT = 9 )
9726
9727       COMPLEX*16 CZERO,CONE,CTWO
9728       CHARACTER*12 CFILE
9729       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9730      &           ONETHI=ONE/THREE,TINY25=1.0D-25)
9731       PARAMETER (TWOPI  = 6.283185307179586454D+00,
9732      &           PI     = TWOPI/TWO,
9733      &           GEV2MB = 0.38938D0,
9734      &           GEV2FM = 0.1972D0,
9735      &           ALPHEM = ONE/137.0D0,
9736 * proton mass
9737      &           AMP    = 0.938D0,
9738      &           AMP2   = AMP**2,
9739 * approx. nucleon radius
9740      &           RNUCLE = 1.12D0)
9741
9742 * particle properties (BAMJET index convention)
9743       CHARACTER*8  ANAME
9744       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9745      &                IICH(210),IIBAR(210),K1(210),K2(210)
9746
9747       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9748
9749       PARAMETER ( MAXNCL = 260,
9750
9751      &            MAXVQU = MAXNCL,
9752      &            MAXSQU = 20*MAXVQU,
9753      &            MAXINT = MAXVQU+MAXSQU)
9754
9755 * Glauber formalism: parameters
9756       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9757      &                BMAX(NCOMPX),BSTEP(NCOMPX),
9758      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9759      &                NSITEB,NSTATB
9760
9761 * Glauber formalism: cross sections
9762       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9763      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9764      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9765      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9766      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9767      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9768      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9769      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9770      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9771      &                BSLOPE,NEBINI,NQBINI
9772
9773 * Glauber formalism: flags and parameters for statistics
9774       LOGICAL LPROD
9775       CHARACTER*8 CGLB
9776       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9777
9778 * nucleon-nucleon event-generator
9779       CHARACTER*8 CMODEL
9780       LOGICAL LPHOIN
9781       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9782
9783 * VDM parameter for photon-nucleus interactions
9784       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9785
9786 * parameters for hA-diffraction
9787       COMMON /DTDIHA/ DIBETA,DIALPH
9788
9789       COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9790      &           OMPP11,OMPP12,OMPP21,OMPP22,
9791      &           DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9792      &           PPTMP1,PPTMP2
9793       COMPLEX*16 C,CA,CI
9794       DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9795      &          COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9796      &          BPROD(KSITEB)
9797
9798       PARAMETER (NPOINT=16)
9799       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9800
9801       LOGICAL LFIRST,LOPEN
9802       DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9803
9804       NTARG = ABS(NIDX)
9805 * for quasi-elastic neutrino scattering set projectile to proton
9806 * it should not have an effect since the whole Glauber-formalism is
9807 * not needed for these interactions..
9808       IF (MCGENE.EQ.4) THEN
9809          IJPROJ = 1
9810       ELSE
9811          IJPROJ = JJPROJ
9812       ENDIF
9813
9814       IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9815          I = INDEX(CGLB,' ')
9816          IF (I.EQ.0) THEN
9817             CFILE = CGLB//'.glb'
9818             OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9819          ELSEIF (I.GT.1) THEN
9820             CFILE = CGLB(1:I-1)//'.glb'
9821             OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9822          ELSE
9823             STOP 'XSGLAU 1'
9824          ENDIF
9825          LOPEN = .TRUE.
9826       ENDIF
9827
9828       CZERO  = DCMPLX(ZERO,ZERO)
9829       CONE   = DCMPLX(ONE,ZERO)
9830       CTWO   = DCMPLX(TWO,ZERO)
9831       NEBINI = IE
9832       NQBINI = IQ
9833
9834 * re-define kinematics
9835       S  = ECMI**2
9836       Q2 = Q2I
9837       X  = XI
9838 *  g(Q2=0)-A, h-A, A-A scattering
9839       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9840          Q2 = 0.0001D0
9841          X  = Q2/(S+Q2-AMP2)
9842 *  g(Q2>0)-A scattering
9843       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9844          X  = Q2/(S+Q2-AMP2)
9845       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9846          Q2 = (S-AMP2)*X/(ONE-X)
9847       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9848          S  = Q2*(ONE-X)/X+AMP2
9849       ELSE
9850          WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9851          STOP
9852       ENDIF
9853       ECMNN(IE) = SQRT(S)
9854       Q2G(IQ)   = Q2
9855       XNU = (S+Q2-AMP2)/(TWO*AMP)
9856
9857 * parameters determining statistics in evaluating Glauber-xsection
9858       NSTATB = JSTATB
9859       NSITEB = JBINSB
9860       IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9861
9862 * set up interaction geometry (common /DTGLAM/)
9863 *  projectile/target radii
9864       RPRNCL = DT_RNCLUS(NA)
9865       RTANCL = DT_RNCLUS(NB)
9866       IF (IJPROJ.EQ.7) THEN
9867          RASH(1) = ZERO
9868          RBSH(NTARG) = RTANCL
9869          BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9870       ELSE
9871          IF (NIDX.LE.-1) THEN
9872             RASH(1)     = RPRNCL
9873             RBSH(NTARG) = RTANCL
9874             BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9875          ELSE
9876             RASH(NTARG) = RPRNCL
9877             RBSH(1)     = RTANCL
9878             BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9879          ENDIF
9880       ENDIF
9881 *  maximum impact-parameter
9882       BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9883
9884 * slope, rho ( Re(f(0))/Im(f(0)) )
9885       IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9886          IF (MCGENE.EQ.2) THEN
9887             ZERO1 = ZERO
9888             CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9889      &                                                   BSLOPE,0)
9890          ELSE
9891             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9892          ENDIF
9893          IF (ECMNN(IE).LE.3.0D0) THEN
9894             ROSH = -0.43D0
9895          ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9896             ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9897          ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9898             ROSH = 0.1D0
9899          ENDIF
9900       ELSEIF (IJPROJ.EQ.7) THEN
9901          ROSH = 0.1D0
9902       ELSE
9903          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9904          ROSH   = 0.01D0
9905       ENDIF
9906
9907 * projectile-nucleon xsection (in fm)
9908       IF (IJPROJ.EQ.7) THEN
9909          SIGSH = DT_SIGVP(X,Q2)/10.0D0
9910       ELSE
9911          ELAB  = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9912          PLAB  = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9913 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9914          DUMZER = ZERO
9915          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9916          SIGSH = SIGSH/10.0D0
9917       ENDIF
9918
9919 * parameters for projectile diffraction (hA scattering only)
9920       IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9921      &                               .AND.(DIBETA.GE.ZERO)) THEN
9922          ZERO1 = ZERO
9923          CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9924 C        DIBETA = SDIF1/STOT
9925          DIBETA = 0.2D0
9926          DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9927          IF (DIBETA.LE.ZERO) THEN
9928             ALPGAM = ONE
9929          ELSE
9930             ALPGAM = DIALPH/DIGAMM
9931          ENDIF
9932          FACDI1 = ONE-ALPGAM
9933          FACDI2 = ONE+ALPGAM
9934          FACDI  = SQRT(FACDI1*FACDI2)
9935          WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9936       ELSE
9937          DIBETA = -1.0D0
9938          DIALPH = ZERO
9939          DIGAMM = ZERO
9940          FACDI1 = ZERO
9941          FACDI2 = 2.0D0
9942          FACDI  = ZERO
9943       ENDIF
9944
9945 * initializations
9946       DO 10 I=1,NSITEB
9947          BSITE( 0,IQ,NTARG,I) = ZERO
9948          BSITE(IE,IQ,NTARG,I) = ZERO
9949          BPROD(I) = ZERO
9950    10 CONTINUE
9951       STOT  = ZERO
9952       STOT2 = ZERO
9953       SELA  = ZERO
9954       SELA2 = ZERO
9955       SQEP  = ZERO
9956       SQEP2 = ZERO
9957       SQET  = ZERO
9958       SQET2 = ZERO
9959       SQE2  = ZERO
9960       SQE22 = ZERO
9961       SPRO  = ZERO
9962       SPRO2 = ZERO
9963       SDEL  = ZERO
9964       SDEL2 = ZERO
9965       SDQE  = ZERO
9966       SDQE2 = ZERO
9967       FACN   = ONE/DBLE(NSTATB)
9968
9969       IPNT = 0
9970       RPNT = ZERO
9971
9972 *  initialize Gauss-integration for photon-proj.
9973       JPOINT = 1
9974       IF (IJPROJ.EQ.7) THEN
9975          IF (INTRGE(1).EQ.1) THEN
9976             AMLO2 = (3.0D0*AAM(13))**2
9977          ELSEIF (INTRGE(1).EQ.2) THEN
9978             AMLO2 = AAM(33)**2
9979          ELSE
9980             AMLO2 = AAM(96)**2
9981          ENDIF
9982          IF (INTRGE(2).EQ.1) THEN
9983             AMHI2 = S/TWO
9984          ELSEIF (INTRGE(2).EQ.2) THEN
9985             AMHI2 = S/4.0D0
9986          ELSE
9987             AMHI2 = S
9988          ENDIF
9989          AMHI20 = (ECMNN(IE)-AMP)**2
9990          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9991          XAMLO = LOG( AMLO2+Q2 )
9992          XAMHI = LOG( AMHI2+Q2 )
9993 **PHOJET105a
9994 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9995 **PHOJET112
9996
9997          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9998
9999 **
10000          JPOINT = NPOINT
10001 * ratio direct/total photon-nucleon xsection
10002          CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
10003       ENDIF
10004
10005 * read pre-initialized profile-function from file
10006       IF (IOGLB.EQ.1) THEN
10007          READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
10008          IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
10009             WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
10010      &                             NA,NB,NSTATB,NSITEB
10011  1000       FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
10012      &             ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
10013      &             ' (NA,NB,NSTATB,NSITEB) ',4I10)
10014             STOP
10015          ENDIF
10016          IF (LFIRST) WRITE(LOUT,1001) CFILE
10017  1001    FORMAT(/,' XSGLAU: impact parameter distribution read from ',
10018      &          'file ',A12,/)
10019          READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
10020      &                         XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
10021      &                         XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
10022          READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
10023      &                         XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
10024      &                         XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
10025          NLINES = INT(DBLE(NSITEB)/7.0D0)
10026          IF (NLINES.GT.0) THEN
10027             DO 21 I=1,NLINES
10028                ISTART = 7*I-6
10029                READ(LDAT,'(7E11.4)')
10030      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
10031    21       CONTINUE
10032          ENDIF
10033          ISTART = 7*NLINES+1
10034          IF (ISTART.LE.NSITEB) THEN
10035             READ(LDAT,'(7E11.4)')
10036      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
10037          ENDIF
10038          LFIRST = .FALSE.
10039          GOTO 100
10040 * variable projectile/target/energy runs:
10041 * read pre-initialized profile-functions from file
10042       ELSEIF (IOGLB.EQ.100) THEN
10043          CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
10044          GOTO 100
10045       ENDIF
10046
10047 * cross sections averaged over NSTATB nucleon configurations
10048       DO 11 IS=1,NSTATB
10049 C        IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
10050          STOTN = ZERO
10051          SELAN = ZERO
10052          SQEPN = ZERO
10053          SQETN = ZERO
10054          SQE2N = ZERO
10055          SPRON = ZERO
10056          SDELN = ZERO
10057          SDQEN = ZERO
10058
10059          IF (NIDX.LE.-1) THEN
10060             CALL DT_CONUCL(COOP1,NA,RASH(1),0)
10061             CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
10062             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10063                CALL DT_CONUCL(COOP2,NA,RASH(1),0)
10064                CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
10065             ENDIF
10066          ELSE
10067             CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
10068             CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
10069             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10070                CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
10071                CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
10072             ENDIF
10073          ENDIF
10074
10075 *  integration over impact parameter B
10076          DO 12 IB=1,NSITEB-1
10077             STOTB = ZERO
10078             SELAB = ZERO
10079             SQEPB = ZERO
10080             SQETB = ZERO
10081             SQE2B = ZERO
10082             SPROB = ZERO
10083             SDIR  = ZERO
10084             SDELB = ZERO
10085             SDQEB = ZERO
10086             B     = DBLE(IB)*BSTEP(NTARG)
10087             FACB  = 10.0D0*TWOPI*B*BSTEP(NTARG)
10088
10089 *   integration over M_V^2 for photon-proj.
10090             DO 14 IM=1,JPOINT
10091                PP11(1) = CONE
10092                PP12(1) = CONE
10093                PP21(1) = CONE
10094                PP22(1) = CONE
10095                IF (IJPROJ.EQ.7) THEN
10096                   DO 13 K=2,NB
10097                      PP11(K) = CONE
10098                      PP12(K) = CONE
10099                      PP21(K) = CONE
10100                      PP22(K) = CONE
10101    13             CONTINUE
10102                ENDIF
10103                SHI  = ZERO
10104                FACM = ONE
10105                DCOH = 1.0D10
10106
10107                IF (IJPROJ.EQ.7) THEN
10108                   AMV2 = EXP(ABSZX(IM))-Q2
10109                   AMV  = SQRT(AMV2)
10110                   IF (AMV2.LT.16.0D0) THEN
10111                      R = TWO
10112                   ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
10113                      R = 10.0D0/3.0D0
10114                   ELSE
10115                      R = 11.0D0/3.0D0
10116                   ENDIF
10117 *    define M_V dependent properties of nucleon scattering amplitude
10118 *     V_M-nucleon xsection
10119                   SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
10120                   SIGMV  = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
10121 *     slope-parametrisation a la Kaidalov
10122                   BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
10123      &                           +0.25D0*LOG(S/(AMV2+Q2)))
10124 *    coherence length
10125                   IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
10126 *    integration weight factor
10127                   FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
10128      &                  R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
10129                ENDIF
10130                GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
10131                GAM = GSH
10132                IF (IJPROJ.EQ.7) THEN
10133                   RCA = GAM*SIGMV/TWOPI
10134                ELSE
10135                   RCA = GAM*SIGSH/TWOPI
10136                ENDIF
10137                FCA = -ROSH*RCA
10138                CA  = DCMPLX(RCA,FCA)
10139                CI  = CONE
10140
10141                DO 15 INA=1,NA
10142                   KK1  = 1
10143                   INT1 = 1
10144                   KK2  = 1
10145                   INT2 = 1
10146                   DO 16 INB=1,NB
10147 *    photon-projectile: check for supression by coherence length
10148                      IF (IJPROJ.EQ.7) THEN
10149                         IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
10150                            KK1  = INB
10151                            INT1 = INT1+1
10152                         ENDIF
10153                         IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
10154                            KK2  = INB
10155                            INT2 = INT2+1
10156                         ENDIF
10157                      ENDIF
10158
10159                      X11 = B+COOT1(1,INB)-COOP1(1,INA)
10160                      Y11 =   COOT1(2,INB)-COOP1(2,INA)
10161                      XY11 = GAM*(X11*X11+Y11*Y11)
10162                      IF (XY11.LE.15.0D0) THEN
10163                         C = CONE-CA*EXP(-XY11)
10164                         AR = DBLE(PP11(INT1))
10165                         AI = DIMAG(PP11(INT1))
10166                         IF (ABS(AR).LT.TINY25) AR = ZERO
10167                         IF (ABS(AI).LT.TINY25) AI = ZERO
10168                         PP11(INT1) = DCMPLX(AR,AI)
10169                         PP11(INT1) = PP11(INT1)*C
10170                         AR  = DBLE(C)
10171                         AI  = DIMAG(C)
10172                         SHI = SHI+LOG(AR*AR+AI*AI)
10173                      ENDIF
10174                      IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10175                         X12 = B+COOT2(1,INB)-COOP1(1,INA)
10176                         Y12 =   COOT2(2,INB)-COOP1(2,INA)
10177                         XY12 = GAM*(X12*X12+Y12*Y12)
10178                         IF (XY12.LE.15.0D0) THEN
10179                            C = CONE-CA*EXP(-XY12)
10180                            AR = DBLE(PP12(INT2))
10181                            AI = DIMAG(PP12(INT2))
10182                            IF (ABS(AR).LT.TINY25) AR = ZERO
10183                            IF (ABS(AI).LT.TINY25) AI = ZERO
10184                            PP12(INT2) = DCMPLX(AR,AI)
10185                            PP12(INT2) = PP12(INT2)*C
10186                         ENDIF
10187                         X21 = B+COOT1(1,INB)-COOP2(1,INA)
10188                         Y21 =   COOT1(2,INB)-COOP2(2,INA)
10189                         XY21 = GAM*(X21*X21+Y21*Y21)
10190                         IF (XY21.LE.15.0D0) THEN
10191                            C = CONE-CA*EXP(-XY21)
10192                            AR = DBLE(PP21(INT1))
10193                            AI = DIMAG(PP21(INT1))
10194                            IF (ABS(AR).LT.TINY25) AR = ZERO
10195                            IF (ABS(AI).LT.TINY25) AI = ZERO
10196                            PP21(INT1) = DCMPLX(AR,AI)
10197                            PP21(INT1) = PP21(INT1)*C
10198                         ENDIF
10199                         X22 = B+COOT2(1,INB)-COOP2(1,INA)
10200                         Y22 =   COOT2(2,INB)-COOP2(2,INA)
10201                         XY22 = GAM*(X22*X22+Y22*Y22)
10202                         IF (XY22.LE.15.0D0) THEN
10203                            C = CONE-CA*EXP(-XY22)
10204                            AR = DBLE(PP22(INT2))
10205                            AI = DIMAG(PP22(INT2))
10206                            IF (ABS(AR).LT.TINY25) AR = ZERO
10207                            IF (ABS(AI).LT.TINY25) AI = ZERO
10208                            PP22(INT2) = DCMPLX(AR,AI)
10209                            PP22(INT2) = PP22(INT2)*C
10210                         ENDIF
10211                      ENDIF
10212    16             CONTINUE
10213    15          CONTINUE
10214
10215                OMPP11 = CZERO
10216                OMPP21 = CZERO
10217                DIPP11 = CZERO
10218                DIPP21 = CZERO
10219                DO 17 K=1,INT1
10220                   IF (PP11(K).EQ.CZERO) THEN
10221                      PPTMP1 = CZERO
10222                      PPTMP2 = CZERO
10223                   ELSE
10224                      PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
10225                      PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
10226                   ENDIF
10227                   AVDIPP = 0.5D0*
10228      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10229                   OMPP11 = OMPP11+AVDIPP
10230 C                 OMPP11 = OMPP11+(CONE-PP11(K))
10231                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10232                   DIPP11 = DIPP11+AVDIPP
10233                   IF (PP21(K).EQ.CZERO) THEN
10234                      PPTMP1 = CZERO
10235                      PPTMP2 = CZERO
10236                   ELSE
10237                      PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
10238                      PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
10239                   ENDIF
10240                   AVDIPP = 0.5D0*
10241      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10242                   OMPP21 = OMPP21+AVDIPP
10243 C                 OMPP21 = OMPP21+(CONE-PP21(K))
10244                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10245                   DIPP21 = DIPP21+AVDIPP
10246    17          CONTINUE
10247                OMPP12 = CZERO
10248                OMPP22 = CZERO
10249                DIPP12 = CZERO
10250                DIPP22 = CZERO
10251                DO 18 K=1,INT2
10252                   IF (PP12(K).EQ.CZERO) THEN
10253                      PPTMP1 = CZERO
10254                      PPTMP2 = CZERO
10255                   ELSE
10256                      PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
10257                      PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
10258                   ENDIF
10259                   AVDIPP = 0.5D0*
10260      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10261                   OMPP12 = OMPP12+AVDIPP
10262 C                 OMPP12 = OMPP12+(CONE-PP12(K))
10263                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10264                   DIPP12 = DIPP12+AVDIPP
10265                   IF (PP22(K).EQ.CZERO) THEN
10266                      PPTMP1 = CZERO
10267                      PPTMP2 = CZERO
10268                   ELSE
10269                      PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
10270                      PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
10271                   ENDIF
10272                   AVDIPP = 0.5D0*
10273      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10274                   OMPP22 = OMPP22+AVDIPP
10275 C                 OMPP22 = OMPP22+(CONE-PP22(K))
10276                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10277                   DIPP22 = DIPP22+AVDIPP
10278    18          CONTINUE
10279
10280                SPROM = ONE-EXP(SHI)
10281                SPROB = SPROB+FACM*SPROM
10282                IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10283                   STOTM = DBLE(OMPP11+OMPP22)
10284                   SELAM = DBLE(OMPP11*DCONJG(OMPP22))
10285                   SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
10286                   SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
10287                   SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
10288                   SDELM = DBLE(DIPP11*DCONJG(DIPP22))
10289                   SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
10290                   STOTB = STOTB+FACM*STOTM
10291                   SELAB = SELAB+FACM*SELAM
10292                   SDELB = SDELB+FACM*SDELM
10293                   IF (NB.GT.1) THEN
10294                      SQEPB = SQEPB+FACM*SQEPM
10295                      SDQEB = SDQEB+FACM*SDQEM
10296                   ENDIF
10297                   IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
10298                   IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
10299                   IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
10300                ENDIF
10301
10302    14       CONTINUE
10303
10304             STOTN = STOTN+FACB*STOTB
10305             SELAN = SELAN+FACB*SELAB
10306             SQEPN = SQEPN+FACB*SQEPB
10307             SQETN = SQETN+FACB*SQETB
10308             SQE2N = SQE2N+FACB*SQE2B
10309             SPRON = SPRON+FACB*SPROB
10310             SDELN = SDELN+FACB*SDELB
10311             SDQEN = SDQEN+FACB*SDQEB
10312
10313             IF (IJPROJ.EQ.7) THEN
10314                BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
10315             ELSE
10316                IF (DIBETA.GT.ZERO) THEN
10317                   BPROD(IB+1)= BPROD(IB+1)
10318      &                        +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
10319                ELSE
10320                   BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
10321                ENDIF
10322             ENDIF
10323
10324    12    CONTINUE
10325
10326          STOT  = STOT +FACN*STOTN
10327          STOT2 = STOT2+FACN*STOTN**2
10328          SELA  = SELA +FACN*SELAN
10329          SELA2 = SELA2+FACN*SELAN**2
10330          SQEP  = SQEP +FACN*SQEPN
10331          SQEP2 = SQEP2+FACN*SQEPN**2
10332          SQET  = SQET +FACN*SQETN
10333          SQET2 = SQET2+FACN*SQETN**2
10334          SQE2  = SQE2 +FACN*SQE2N
10335          SQE22 = SQE22+FACN*SQE2N**2
10336          SPRO  = SPRO +FACN*SPRON
10337          SPRO2 = SPRO2+FACN*SPRON**2
10338          SDEL  = SDEL +FACN*SDELN
10339          SDEL2 = SDEL2+FACN*SDELN**2
10340          SDQE  = SDQE +FACN*SDQEN
10341          SDQE2 = SDQE2+FACN*SDQEN**2
10342
10343    11 CONTINUE
10344
10345 * final cross sections
10346 * 1) total
10347       XSTOT(IE,IQ,NTARG) = STOT
10348       IF (IJPROJ.EQ.7)
10349      &   XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
10350 * 2) elastic
10351       XSELA(IE,IQ,NTARG) = SELA
10352 * 3) quasi-el.: A+B-->A+X (excluding 2)
10353       XSQEP(IE,IQ,NTARG) = SQEP
10354 * 4) quasi-el.: A+B-->X+B (excluding 2)
10355       XSQET(IE,IQ,NTARG) = SQET
10356 * 5) quasi-el.: A+B-->X (excluding 2-4)
10357       XSQE2(IE,IQ,NTARG) = SQE2
10358 * 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
10359       IF (SDEL.GT.ZERO) THEN
10360          XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
10361       ELSE
10362          XSPRO(IE,IQ,NTARG) = SPRO
10363       ENDIF
10364 * 7) projectile diffraction (el. scatt. off target)
10365       XSDEL(IE,IQ,NTARG) = SDEL
10366 * 8) projectile diffraction (quasi-el. scatt. off target)
10367       XSDQE(IE,IQ,NTARG) = SDQE
10368 *  stat. errors
10369       XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
10370       XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
10371       XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
10372       XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
10373       XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
10374       XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
10375       XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
10376       XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
10377
10378       IF (IJPROJ.EQ.7) THEN
10379          BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
10380      &          -XSQEP(IE,IQ,NTARG)
10381       ELSE
10382          BNORM = XSPRO(IE,IQ,NTARG)
10383       ENDIF
10384       DO 19 I=2,NSITEB
10385          BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
10386          IF ((IE.EQ.1).AND.(IQ.EQ.1))
10387      &      BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
10388    19 CONTINUE
10389
10390 * write profile function data into file
10391       IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
10392          WRITE(LDAT,'(5I10,1P,E15.5)')
10393      &      IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
10394          WRITE(LDAT,'(1P,6E12.5)')
10395      &      XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
10396      &      XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
10397          WRITE(LDAT,'(1P,6E12.5)')
10398      &      XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
10399      &      XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
10400          NLINES = INT(DBLE(NSITEB)/7.0D0)
10401          IF (NLINES.GT.0) THEN
10402             DO 20 I=1,NLINES
10403                ISTART = 7*I-6
10404                WRITE(LDAT,'(1P,7E11.4)')
10405      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
10406    20       CONTINUE
10407          ENDIF
10408          ISTART = 7*NLINES+1
10409          IF (ISTART.LE.NSITEB) THEN
10410             WRITE(LDAT,'(1P,7E11.4)')
10411      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
10412          ENDIF
10413       ENDIF
10414
10415   100 CONTINUE
10416
10417 C     IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
10418
10419       RETURN
10420       END
10421
10422 *$ CREATE DT_GETBXS.FOR
10423 *COPY DT_GETBXS
10424 *
10425 *===getbxs=============================================================*
10426 *
10427       SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
10428
10429 ************************************************************************
10430 * Biasing in impact parameter space.                                   *
10431 *     XSFRAC = 0 :  BLO    - minimum impact parameter  (input)         *
10432 *                   BHI    - maximum impact parameter  (input)         *
10433 *                   XSFRAC - fraction of cross section corresponding   *
10434 *                            to impact parameter range (BLO,BHI)       *
10435 *                                                      (output)        *
10436 *     XSFRAC > 0 :  XSFRAC - fraction of cross section (input)         *
10437 *                   BHI    - maximum impact parameter giving requested *
10438 *                            fraction of cross section in impact       *
10439 *                            parameter range (0,BMAX)  (output)        *
10440 * This version dated 17.03.00  is written by S. Roesler                *
10441 ************************************************************************
10442
10443       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10444       SAVE
10445
10446       PARAMETER ( LINP = 10 ,
10447      &            LOUT = 6 ,
10448      &            LDAT = 9 )
10449
10450       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10451
10452 * Glauber formalism: parameters
10453       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10454      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10455      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10456      &                NSITEB,NSTATB
10457
10458       NTARG = ABS(NIDX)
10459       IF (XSFRAC.LE.0.0D0) THEN
10460          ILO    = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
10461          IHI    = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
10462          IF (ILO.GE.IHI) THEN
10463             XSFRAC = 0.0D0
10464             RETURN
10465          ENDIF
10466          IF (ILO.EQ.NSITEB-1) THEN
10467             FRCLO = BSITE(0,1,NTARG,NSITEB)
10468          ELSE
10469             FRCLO = BSITE(0,1,NTARG,ILO+1)
10470      &              +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
10471      &              *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
10472          ENDIF
10473          IF (IHI.EQ.NSITEB-1) THEN
10474             FRCHI = BSITE(0,1,NTARG,NSITEB)
10475          ELSE
10476             FRCHI = BSITE(0,1,NTARG,IHI+1)
10477      &              +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
10478      &              *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
10479          ENDIF
10480          XSFRAC = FRCHI-FRCLO
10481       ELSE
10482          BLO = 0.0D0
10483          BHI = BMAX(NTARG)
10484          DO 1 I=1,NSITEB-1
10485             IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
10486                FAC = (XSFRAC              -BSITE(0,1,NTARG,I))/
10487      &               (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
10488                BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
10489                GOTO 2
10490             ENDIF
10491     1    CONTINUE
10492     2    CONTINUE
10493       ENDIF
10494
10495       RETURN
10496       END
10497
10498 *$ CREATE DT_CONUCL.FOR
10499 *COPY DT_CONUCL
10500 *
10501 *===conucl=============================================================*
10502 *
10503       SUBROUTINE DT_CONUCL(X,N,R,MODE)
10504
10505 ************************************************************************
10506 * Calculation of coordinates of nucleons within nuclei.                *
10507 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
10508 *        N / R    number of nucleons / radius of nucleus   (input)     *
10509 *        MODE = 0 coordinates not sorted                               *
10510 *             = 1 coordinates sorted with increasing X(3,i)            *
10511 *             = 2 coordinates sorted with decreasing X(3,i)            *
10512 * This version dated 26.10.95 is revised by S. Roesler                 *
10513 ************************************************************************
10514
10515       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10516       SAVE
10517
10518       PARAMETER ( LINP = 10 ,
10519      &            LOUT = 6 ,
10520      &            LDAT = 9 )
10521
10522       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10523      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10524
10525       PARAMETER (TWOPI = 6.283185307179586454D+00 )
10526
10527       PARAMETER (NSRT=10)
10528       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10529       DIMENSION X(3,N),XTMP(3,260)
10530
10531       CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10532
10533       IF ((MODE.NE.0).AND.(N.GT.4)) THEN
10534          K = 0
10535          DO 1 I=1,NSRT
10536             IF (MODE.EQ.2) THEN
10537                ISRT = NSRT+1-I
10538             ELSE
10539                ISRT = I
10540             ENDIF
10541             K1 = K
10542             DO 2 J=1,ICSRT(ISRT)
10543                K = K+1
10544                X(1,K) = XTMP(1,IDXSRT(ISRT,J))
10545                X(2,K) = XTMP(2,IDXSRT(ISRT,J))
10546                X(3,K) = XTMP(3,IDXSRT(ISRT,J))
10547     2       CONTINUE
10548             IF (ICSRT(ISRT).GT.1) THEN
10549                I0 = K1+1
10550                I1 = K
10551                CALL DT_SORT(X,N,I0,I1,MODE)
10552             ENDIF
10553     1    CONTINUE
10554       ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
10555          DO 3 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     3    CONTINUE
10560          CALL DT_SORT(X,N,1,N,MODE)
10561       ELSE
10562          DO 4 I=1,N
10563             X(1,I) = XTMP(1,I)
10564             X(2,I) = XTMP(2,I)
10565             X(3,I) = XTMP(3,I)
10566     4    CONTINUE
10567       ENDIF
10568
10569       RETURN
10570       END
10571
10572 *$ CREATE DT_COORDI.FOR
10573 *COPY DT_COORDI
10574 *
10575 *===coordi=============================================================*
10576 *
10577       SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10578
10579 ************************************************************************
10580 * Calculation of coordinates of nucleons within nuclei.                *
10581 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
10582 *        N / R    number of nucleons / radius of nucleus   (input)     *
10583 * Based on the original version by Shmakov et al.                      *
10584 * This version dated 26.10.95 is revised by S. Roesler                 *
10585 ************************************************************************
10586
10587       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10588       SAVE
10589
10590       PARAMETER ( LINP = 10 ,
10591      &            LOUT = 6 ,
10592      &            LDAT = 9 )
10593
10594       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10595      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10596
10597       PARAMETER (TWOPI = 6.283185307179586454D+00 )
10598
10599       LOGICAL LSTART
10600
10601       PARAMETER (NSRT=10)
10602       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10603       DIMENSION X(3,260),WD(4),RD(3)
10604
10605       DATA PDIF/0.545D0/,R2MIN/0.16D0/
10606       DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10607       DATA RD /2.09D0, 0.935D0, 0.697D0/
10608
10609       X1SUM = ZERO
10610       X2SUM = ZERO
10611       X3SUM = ZERO
10612
10613       IF (N.EQ.1) THEN
10614          X(1,1) = ZERO
10615          X(2,1) = ZERO
10616          X(3,1) = ZERO
10617       ELSEIF (N.EQ.2) THEN
10618          EPS = DT_RNDM(RD(1))
10619          DO 30 I=1,3
10620             IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10621    30    CONTINUE
10622    40    CONTINUE
10623          DO 50 J=1,3
10624             CALL DT_RANNOR(X1,X2)
10625             X(J,1) = RD(I)*X1
10626             X(J,2) = -X(J,1)
10627    50    CONTINUE
10628       ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10629          SIGMA = R/SQRTWO
10630          LSTART = .TRUE.
10631          CALL DT_RANNOR(X3,X4)
10632          DO 100 I=1,N
10633             CALL DT_RANNOR(X1,X2)
10634             X(1,I) = SIGMA*X1
10635             X(2,I) = SIGMA*X2
10636             IF (LSTART) GOTO 80
10637             X(3,I) = SIGMA*X4
10638             CALL DT_RANNOR(X3,X4)
10639             GOTO 90
10640    80       CONTINUE
10641             X(3,I) = SIGMA*X3
10642    90       CONTINUE
10643             LSTART = .NOT.LSTART
10644             X1SUM = X1SUM+X(1,I)
10645             X2SUM = X2SUM+X(2,I)
10646             X3SUM = X3SUM+X(3,I)
10647   100    CONTINUE
10648          X1SUM = X1SUM/DBLE(N)
10649          X2SUM = X2SUM/DBLE(N)
10650          X3SUM = X3SUM/DBLE(N)
10651          DO 101 I=1,N
10652             X(1,I) = X(1,I)-X1SUM
10653             X(2,I) = X(2,I)-X2SUM
10654             X(3,I) = X(3,I)-X3SUM
10655   101    CONTINUE
10656       ELSE
10657
10658 * maximum nuclear radius for coordinate sampling
10659          RMAX = R+4.605D0*PDIF
10660
10661 * initialize pre-sorting
10662          DO 121 I=1,NSRT
10663             ICSRT(I) = 0
10664   121    CONTINUE
10665          DR = TWO*RMAX/DBLE(NSRT)
10666
10667 * sample coordinates for N nucleons
10668          DO 140 I=1,N
10669   120       CONTINUE
10670             RAD = RMAX*(DT_RNDM(DR))**ONETHI
10671             F   = DT_DENSIT(N,RAD,R)
10672             IF (DT_RNDM(RAD).GT.F) GOTO 120
10673 *   theta, phi uniformly distributed
10674             CT  = ONE-TWO*DT_RNDM(F)
10675             ST  = SQRT((ONE-CT)*(ONE+CT))
10676             CALL DT_DSFECF(SFE,CFE)
10677             X(1,I) = RAD*ST*CFE
10678             X(2,I) = RAD*ST*SFE
10679             X(3,I) = RAD*CT
10680 *   ensure that distance between two nucleons is greater than R2MIN
10681             IF (I.LT.2) GOTO 122
10682             I1 = I-1
10683             DO 130 I2=1,I1
10684                DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10685      &                 (X(3,I)-X(3,I2))**2
10686                IF (DIST2.LE.R2MIN) GOTO 120
10687   130       CONTINUE
10688   122       CONTINUE
10689 *   save index according to z-bin
10690             IDXZ        = INT( (X(3,I)+RMAX)/DR )+1
10691             ICSRT(IDXZ) = ICSRT(IDXZ)+1
10692             IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10693             X1SUM = X1SUM+X(1,I)
10694             X2SUM = X2SUM+X(2,I)
10695             X3SUM = X3SUM+X(3,I)
10696   140    CONTINUE
10697          X1SUM = X1SUM/DBLE(N)
10698          X2SUM = X2SUM/DBLE(N)
10699          X3SUM = X3SUM/DBLE(N)
10700          DO 141 I=1,N
10701             X(1,I) = X(1,I)-X1SUM
10702             X(2,I) = X(2,I)-X2SUM
10703             X(3,I) = X(3,I)-X3SUM
10704   141    CONTINUE
10705
10706       ENDIF
10707
10708       RETURN
10709       END
10710
10711 *$ CREATE DT_DENSIT.FOR
10712 *COPY DT_DENSIT
10713 *
10714 *===densit=============================================================*
10715 *
10716       DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10717
10718       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10719       SAVE
10720
10721       PARAMETER ( LINP = 10 ,
10722      &            LOUT = 6 ,
10723      &            LDAT = 9 )
10724
10725       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10726       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10727      &           PI    = TWOPI/TWO)
10728
10729       DIMENSION R0(18),FNORM(18)
10730       DATA R0 /  ZERO,   ZERO,   ZERO,   ZERO, 2.12D0,
10731      &         2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10732      &         2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10733      &         2.72D0, 2.66D0, 2.79D0/
10734       DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10735      &            .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10736      &            .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10737      &            .1214D+01,.1265D+01,.1318D+01/
10738       DATA PDIF /0.545D0/
10739
10740       DT_DENSIT = ZERO
10741 * shell model
10742       IF (NA.LE.4) THEN
10743          STOP 'DT_DENSIT-0'
10744       ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10745          R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10746          DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10747      &            *EXP(-(R/R1)**2)/FNORM(NA)
10748 * Woods-Saxon
10749       ELSEIF (NA.GT.18) THEN
10750          DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10751       ENDIF
10752
10753       RETURN
10754       END
10755
10756 *$ CREATE DT_RNCLUS.FOR
10757 *COPY DT_RNCLUS
10758 *
10759 *===rnclus=============================================================*
10760 *
10761       DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10762
10763 ************************************************************************
10764 * Nuclear radius for nucleus with mass number N.                       *
10765 * This version dated 26.9.00  is written by S. Roesler                 *
10766 ************************************************************************
10767
10768       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10769       SAVE
10770
10771       PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10772
10773 * nucleon radius
10774       PARAMETER (RNUCLE = 1.12D0)
10775
10776 * nuclear radii for selected nuclei
10777       DIMENSION RADNUC(18)
10778       DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10779      &               2.58D0,2.71D0,2.66D0,2.71D0/
10780
10781       IF (N.LE.18) THEN
10782          IF (RADNUC(N).GT.0.0D0) THEN
10783             DT_RNCLUS = RADNUC(N)
10784          ELSE
10785             DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10786          ENDIF
10787       ELSE
10788          DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10789       ENDIF
10790
10791       RETURN
10792       END
10793
10794 *$ CREATE DT_DENTST.FOR
10795 *COPY DT_DENTST
10796 *
10797 *===dentst=============================================================*
10798 *
10799 C      PROGRAM DT_DENTST
10800       SUBROUTINE DT_DENTST
10801
10802       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10803       SAVE
10804
10805       OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10806       OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10807
10808       RMIN  = 0.0D0
10809       RMAX  = 8.0D0
10810       NBINS = 500.0D0
10811       DR    = (RMAX-RMIN)/DBLE(NBINS)
10812       DO 1 IA=5,18
10813          FMAX = 0.0D0
10814          DO 2 IR=1,NBINS+1
10815             R = RMIN+DBLE(IR-1)*DR
10816             F = DT_DENSIT(IA,R,R)
10817             IF (F.GT.FMAX) FMAX = F
10818             WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10819     2    CONTINUE
10820          WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10821     1 CONTINUE
10822
10823       CLOSE(40)
10824       CLOSE(41)
10825
10826       END
10827
10828 *$ CREATE DT_SHMAKI.FOR
10829 *COPY DT_SHMAKI
10830 *
10831 *===shmaki=============================================================*
10832 *
10833       SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10834
10835 ************************************************************************
10836 * Initialisation of Glauber formalism. This subroutine has to be       *
10837 * called once (in case of target emulsions as often as many different  *
10838 * target nuclei are considered) before events are sampled.             *
10839 *         NA / NCA   mass number/charge of projectile nucleus          *
10840 *         NB / NCB   mass number/charge of target     nucleus          *
10841 *         IJP        identity of projectile (hadrons/leptons/photons)  *
10842 *         PPN        projectile momentum (for projectile nuclei:       *
10843 *                    momentum per nucleon) in target rest system       *
10844 *         MODE = 0   Glauber formalism invoked                         *
10845 *              = 1   fitted results are loaded from data-file          *
10846 *              = 99  NTARG is forced to be 1                           *
10847 *                    (used in connection with GLAUBERI-card only)      *
10848 * This version dated 22.03.96 is based on the original SHMAKI-routine  *
10849 * and revised by S. Roesler.                                           *
10850 ************************************************************************
10851
10852       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10853       SAVE
10854
10855       PARAMETER ( LINP = 10 ,
10856      &            LOUT = 6 ,
10857      &            LDAT = 9 )
10858
10859       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10860      &           THREE=3.0D0)
10861
10862       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10863
10864 * Glauber formalism: parameters
10865       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10866      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10867      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10868      &                NSITEB,NSTATB
10869
10870 * Lorentz-parameters of the current interaction
10871       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10872      &                UMO,PPCM,EPROJ,PPROJ
10873
10874 * properties of photon/lepton projectiles
10875       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10876
10877 * kinematical cuts for lepton-nucleus interactions
10878       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10879      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10880
10881 * Glauber formalism: cross sections
10882       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10883      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10884      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10885      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10886      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10887      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10888      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10889      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10890      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10891      &                BSLOPE,NEBINI,NQBINI
10892
10893 * cuts for variable energy runs
10894       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10895
10896 * nucleon-nucleon event-generator
10897       CHARACTER*8 CMODEL
10898       LOGICAL LPHOIN
10899       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10900
10901 * Glauber formalism: flags and parameters for statistics
10902       LOGICAL LPROD
10903       CHARACTER*8 CGLB
10904       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10905
10906       DATA NTARG,ICOUT,IVEOUT /0,0,0/
10907
10908 C     CALL DT_HISHAD
10909 C     STOP
10910
10911       NTARG = NTARG+1
10912       IF (MODE.EQ.99) NTARG = 1
10913       NIDX = -NTARG
10914       IF (MODE.EQ.-1) NIDX = NTARG
10915
10916       IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10917       IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10918  1000    FORMAT(//,1X,'SHMAKI:    Glauber formalism (Shmakov et. al) -',
10919      &          ' initialization',/,12X,'--------------------------',
10920      &          '-------------------------',/)
10921
10922       IF (MODE.EQ.2) THEN
10923          CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10924          CALL DT_SHFAST(MODE,PPN,IBACK)
10925          STOP ' Glauber pre-initialization done'
10926       ENDIF
10927       IF (MODE.EQ.1) THEN
10928          CALL DT_PROFBI(NA,NB,PPN,NTARG)
10929       ELSE
10930          IBACK = 1
10931          IF (MODE.EQ.3)  CALL DT_SHFAST(MODE,PPN,IBACK)
10932          IF (IBACK.EQ.1) THEN
10933 * lepton-nucleus (variable energy runs)
10934             IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10935      &          (IJP.EQ.10).OR.(IJP.EQ.11))   THEN
10936                IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10937      &            WRITE(LOUT,1002) NB,NCB
10938  1002          FORMAT(1X,'variable energy run:     projectile-id:  7',
10939      &                '    target A/Z: ',I3,' /',I3,/,/,8X,
10940      &                'E_cm (GeV)    Q^2 (GeV^2)',
10941      &                '    Sigma_tot (mb)     Sigma_in (mb)',/,7X,
10942      &                '--------------------------------',
10943      &                '------------------------------')
10944                AECMLO = LOG10(MIN(UMO,ECMLI))
10945                AECMHI = LOG10(MIN(UMO,ECMHI))
10946                IESTEP = NEB-1
10947                DAECM  = (AECMHI-AECMLO)/DBLE(IESTEP)
10948                IF (AECMLO.EQ.AECMHI) IESTEP = 0
10949                DO 1 I=1,IESTEP+1
10950                   ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10951                   IF (Q2HI.GT.0.1D0) THEN
10952                      IF (Q2LI.LT.0.01D0) THEN
10953                         CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10954                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10955      &                     WRITE(LOUT,1003)
10956      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10957                         Q2LI = 0.01D0
10958                         IBIN = 2
10959                      ELSE
10960                         IBIN = 1
10961                      ENDIF
10962                      IQSTEP = NQB-IBIN
10963                      AQ2LO  = LOG10(Q2LI)
10964                      AQ2HI  = LOG10(Q2HI)
10965                      DAQ2   = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10966                      DO 2 J=IBIN,IQSTEP+IBIN
10967                         Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10968                         CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10969                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10970      &                     WRITE(LOUT,1003) ECMNN(I),
10971      &                     Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10972     2                CONTINUE
10973                   ELSE
10974                      CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10975                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10976      &                  WRITE(LOUT,1003)
10977      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10978                   ENDIF
10979  1003             FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10980     1          CONTINUE
10981                IVEOUT = 1
10982             ELSE
10983 * hadron/photon/nucleus-nucleus
10984                IF ((ABS(VAREHI).GT.ZERO).AND.
10985      &             (ABS(VAREHI).GT.ABS(VARELO))) THEN
10986                   IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10987                      WRITE(LOUT,1004) NA,NB,NCB
10988  1004                FORMAT(1X,'variable energy run:    projectile-id:',
10989      &                      I3,'    target A/Z: ',I3,' /',I3,/)
10990                      WRITE(LOUT,1005)
10991  1005                FORMAT('  E_cm (GeV)  E_Lab (GeV)  sig_tot^pp (mb)'
10992      &                      ,'  Sigma_tot (mb)  Sigma_prod (mb)',/,
10993      &                      ' -------------------------------------',
10994      &                      '--------------------------------------')
10995                   ENDIF
10996                   AECMLO = LOG10(VARCLO)
10997                   AECMHI = LOG10(VARCHI)
10998                   IESTEP = NEB-1
10999                   DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
11000                   IF (AECMLO.EQ.AECMHI) IESTEP = 0
11001                   DO 3 I=1,IESTEP+1
11002                      ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
11003                      AMP = 0.938D0
11004                      AMT = 0.938D0
11005                      AMP2 = AMP**2
11006                      AMT2 = AMT**2
11007                      ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
11008                      PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
11009                      CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
11010                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
11011      &                 WRITE(LOUT,1006)
11012      &                 ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
11013  1006             FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
11014     3             CONTINUE
11015                   IVEOUT = 1
11016                ELSE
11017                   CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
11018                ENDIF
11019             ENDIF
11020          ENDIF
11021       ENDIF
11022
11023       IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
11024      &    (IOGLB.NE.100)) THEN
11025          WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
11026      &                    BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
11027  1001    FORMAT(38X,'projectile',
11028      &          '      target',/,1X,'Mass number / charge',
11029      &          17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
11030      &          'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
11031      &          'Parameters of elastic scattering amplitude:',/,5X,
11032      &          'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
11033      &          F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
11034      &          'statistics at each b-step',4X,I5,/,/,1X,
11035      &          'Prod. cross section  ',5X,F10.4,' mb',/)
11036       ENDIF
11037
11038       RETURN
11039       END
11040
11041 *$ CREATE DT_PROFBI.FOR
11042 *COPY DT_PROFBI
11043 *
11044 *===profbi=============================================================*
11045 *
11046       SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
11047
11048 ************************************************************************
11049 * Integral over profile function (to be used for impact-parameter      *
11050 * sampling during event generation).                                   *
11051 * Fitted results are used.                                             *
11052 *         NA / NB    mass numbers of proj./target nuclei               *
11053 *         PPN        projectile momentum (for projectile nuclei:       *
11054 *                    momentum per nucleon) in target rest system       *
11055 *         NTARG      index of target material (i.e. kind of nucleus)   *
11056 * This version dated 31.05.95 is revised by S. Roesler                 *
11057 ************************************************************************
11058
11059       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11060       SAVE
11061
11062       PARAMETER ( LINP = 10 ,
11063      &            LOUT = 6 ,
11064      &            LDAT = 9 )
11065
11066       SAVE
11067
11068       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
11069
11070       LOGICAL LSTART
11071       CHARACTER CNAME*80
11072
11073       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11074
11075 * Glauber formalism: parameters
11076       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11077      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11078      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11079      &                NSITEB,NSTATB
11080
11081 * Glauber formalism: cross sections
11082       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11083      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11084      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11085      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11086      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11087      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11088      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11089      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11090      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11091      &                BSLOPE,NEBINI,NQBINI
11092
11093       PARAMETER (NGLMAX=8000)
11094       DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
11095      &          GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
11096
11097       DATA LSTART /.TRUE./
11098
11099       IF (LSTART) THEN
11100 * read fit-parameters from file
11101          OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
11102          I = 0
11103     1    CONTINUE
11104          READ(47,'(A80)') CNAME
11105          IF (CNAME.EQ.'STOP') GOTO 2
11106          I = I+1
11107          READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
11108      &                 GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
11109      &                 GLAFIT(4,I),GLAFIT(5,I)
11110          IF (I+1.GT.NGLMAX) THEN
11111             WRITE(LOUT,1000)
11112  1000       FORMAT(1X,'PROFBI:    warning! array size exceeded - ',
11113      &             'program stopped')
11114             STOP
11115          ENDIF
11116          GOTO 1
11117     2    CONTINUE
11118          NGLPAR = I
11119          LSTART = .FALSE.
11120       ENDIF
11121
11122       NNA = NA
11123       NNB = NB
11124       IF (NA.GT.NB) THEN
11125          NNA = NB
11126          NNB = NA
11127       ENDIF
11128       IDXGLA = 0
11129       DO 3 J=1,NGLPAR
11130          IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
11131             IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
11132             DO 4 K=1,J-1
11133                IPOINT = J-K
11134                IF (J.EQ.NGLPAR) IPOINT = J+1-K
11135                IF ((NNA.GT.NGLIP(IPOINT)).OR.
11136      &             (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
11137                   IF (IPOINT.EQ.1) IPOINT = 0
11138                   NATMP = NGLIP(IPOINT+1)
11139                   IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
11140                      IDXGLA = IPOINT+1
11141                      GOTO 6
11142                   ELSE
11143                      J1BEG = IPOINT+1
11144                      J1END = J
11145 C                    IF (J.EQ.NGLPAR) THEN
11146 C                       J1BEG = IPOINT
11147 C                       J1END = J
11148 C                    ENDIF
11149                      DO 5 J1=J1BEG,J1END
11150                         IF (NGLIP(J1).EQ.NATMP) THEN
11151                            IF (PPN.LT.GLAPPN(J1)) THEN
11152                               IDXGLA = J1
11153                               GOTO 6
11154                            ENDIF
11155                         ELSE
11156                            IDXGLA = J1-1
11157                            GOTO 6
11158                         ENDIF
11159     5                CONTINUE
11160                      IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
11161      &                  IDXGLA = NGLPAR
11162                   ENDIF
11163                ENDIF
11164     4       CONTINUE
11165          ENDIF
11166     3 CONTINUE
11167
11168     6 CONTINUE
11169       IF (IDXGLA.EQ.0) THEN
11170          WRITE(LOUT,1001) NNA,NNB,PPN
11171  1001    FORMAT(1X,'PROFBI:   configuration (NA,NB,PPN = ',
11172      &          2I4,F6.0,') not found ')
11173          STOP
11174       ENDIF
11175
11176 * no interpolation yet available
11177       XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
11178
11179       BSITE(1,1,NTARG,1) = ZERO
11180       DO 10 I=2,NSITEB
11181          XX = DBLE(I)
11182          POLY  = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
11183      &           GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
11184      &           GLAFIT(5,IDXGLA)*XX**4
11185          IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
11186          BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
11187          IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
11188    10 CONTINUE
11189
11190       RETURN
11191       END
11192
11193 *$ CREATE DT_GLAUBE.FOR
11194 *COPY DT_GLAUBE
11195 *
11196 *===glaube=============================================================*
11197 *
11198       SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
11199
11200 ************************************************************************
11201 * Calculation of configuartion of interacting nucleons for one event.  *
11202 *    NB / NB    mass numbers of proj./target nuclei           (input)  *
11203 *    B          impact parameter                              (output) *
11204 *    INTT       total number of wounded nucleons                 "     *
11205 *    INTA / INTB number of wounded nucleons in proj. / target    "     *
11206 *    JS / JT(i) number of collisions proj. / target nucleon i is       *
11207 *                                                   involved  (output) *
11208 *    NIDX       index of projectile/target material            (input) *
11209 *               = -2 call within FLUKA transport calculation           *
11210 * This is an update of the original routine SHMAKO by J.Ranft/HJM      *
11211 * This version dated 22.03.96 is revised by S. Roesler                 *
11212 *                                                                      *
11213 * Last change 27.12.2006 by S. Roesler.                                *
11214 ************************************************************************
11215
11216       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11217       SAVE
11218
11219       PARAMETER ( LINP = 10 ,
11220      &            LOUT = 6 ,
11221      &            LDAT = 9 )
11222
11223       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
11224      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
11225
11226       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11227
11228       PARAMETER ( MAXNCL = 260,
11229
11230      &            MAXVQU = MAXNCL,
11231      &            MAXSQU = 20*MAXVQU,
11232      &            MAXINT = MAXVQU+MAXSQU)
11233
11234 * Glauber formalism: parameters
11235       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11236      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11237      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11238      &                NSITEB,NSTATB
11239
11240 * Glauber formalism: cross sections
11241       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11242      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11243      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11244      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11245      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11246      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11247      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11248      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11249      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11250      &                BSLOPE,NEBINI,NQBINI
11251
11252 * Lorentz-parameters of the current interaction
11253       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
11254      &                UMO,PPCM,EPROJ,PPROJ
11255
11256 * properties of photon/lepton projectiles
11257       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
11258
11259 * Glauber formalism: collision properties
11260       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
11261      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
11262      &                NCP,NCT
11263 * Glauber formalism: flags and parameters for statistics
11264       LOGICAL LPROD
11265       CHARACTER*8 CGLB
11266       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11267
11268       DIMENSION JS(MAXNCL),JT(MAXNCL)
11269
11270       NTARG = ABS(NIDX)
11271
11272 * get actual energy from /DTLTRA/
11273       ECMNOW = UMO
11274       Q2     = VIRT
11275 *
11276 * new patch for pre-initialized variable projectile/target/energy runs,
11277 * bypassed for use within FLUKA (Nidx=-2)
11278       IF (IOGLB.EQ.100) THEN
11279          IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
11280 *
11281 * variable energy run, interpolate profile function
11282       ELSE
11283          I1   = 1
11284          I2   = 1
11285          RATE = ONE
11286          IF (NEBINI.GT.1) THEN
11287             IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
11288                I1   = NEBINI
11289                I2   = NEBINI
11290                RATE = ONE
11291             ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
11292                DO 1 I=2,NEBINI
11293                   IF (ECMNOW.LT.ECMNN(I)) THEN
11294                      I1   = I-1
11295                      I2   = I
11296                      RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
11297                      GOTO 2
11298                   ENDIF
11299     1          CONTINUE
11300     2          CONTINUE
11301             ENDIF
11302          ENDIF
11303          J1   = 1
11304          J2   = 1
11305          RATQ = ONE
11306          IF (NQBINI.GT.1) THEN
11307             IF (Q2.GE.Q2G(NQBINI)) THEN
11308                J1   = NQBINI
11309                J2   = NQBINI
11310                RATQ = ONE
11311             ELSEIF (Q2.GT.Q2G(1)) THEN
11312                DO 3 I=2,NQBINI
11313                   IF (Q2.LT.Q2G(I)) THEN
11314                      J1   = I-1
11315                      J2   = I
11316                      RATQ = LOG10(     Q2/MAX(Q2G(J1),TINY14))/
11317      &                      LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11318 C                    RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
11319                      GOTO 4
11320                   ENDIF
11321     3          CONTINUE
11322     4          CONTINUE
11323             ENDIF
11324          ENDIF
11325
11326          DO 5 I=1,KSITEB
11327             BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
11328      &         RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
11329      &         RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
11330      &         RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
11331      &                    BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
11332     5    CONTINUE
11333       ENDIF
11334
11335       CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
11336       IF (NIDX.LE.-1) THEN
11337          RPROJ = RASH(1)
11338          RTARG = RBSH(NTARG)
11339       ELSE
11340          RPROJ = RASH(NTARG)
11341          RTARG = RBSH(1)
11342       ENDIF
11343
11344       RETURN
11345       END
11346
11347 *$ CREATE DT_DIAGR.FOR
11348 *COPY DT_DIAGR
11349 *
11350 *===diagr==============================================================*
11351 *
11352       SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
11353      &                                                         NIDX)
11354
11355 ************************************************************************
11356 * Based on the original version by Shmakov et al.                      *
11357 * This version dated 21.04.95 is revised by S. Roesler                 *
11358 ************************************************************************
11359
11360       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11361       SAVE
11362
11363       PARAMETER ( LINP = 10 ,
11364      &            LOUT = 6 ,
11365      &            LDAT = 9 )
11366
11367       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
11368       PARAMETER (TWOPI  = 6.283185307179586454D+00,
11369      &           PI     = TWOPI/TWO,
11370      &           GEV2MB = 0.38938D0,
11371      &           GEV2FM = 0.1972D0,
11372      &           ALPHEM = ONE/137.0D0,
11373 * proton mass
11374      &           AMP    = 0.938D0,
11375      &           AMP2   = AMP**2,
11376 * rho0 mass
11377      &           AMRHO0 = 0.77D0)
11378
11379       COMPLEX*16 C,CA,CI
11380
11381       PARAMETER ( MAXNCL = 260,
11382
11383      &            MAXVQU = MAXNCL,
11384      &            MAXSQU = 20*MAXVQU,
11385      &            MAXINT = MAXVQU+MAXSQU)
11386
11387 * particle properties (BAMJET index convention)
11388       CHARACTER*8  ANAME
11389       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11390      &                IICH(210),IIBAR(210),K1(210),K2(210)
11391
11392       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11393
11394 * emulsion treatment
11395       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11396      &                NCOMPO,IEMUL
11397
11398 * Glauber formalism: parameters
11399       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11400      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11401      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11402      &                NSITEB,NSTATB
11403
11404 * Glauber formalism: cross sections
11405       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11406      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11407      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11408      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11409      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11410      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11411      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11412      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11413      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11414      &                BSLOPE,NEBINI,NQBINI
11415
11416 * VDM parameter for photon-nucleus interactions
11417       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11418
11419 * nucleon-nucleon event-generator
11420       CHARACTER*8 CMODEL
11421       LOGICAL LPHOIN
11422       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
11423 **PHOJET105a
11424 C     COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
11425 **PHOJET112
11426
11427 C  obsolete cut-off information
11428       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
11429       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
11430 **
11431
11432 * coordinates of nucleons
11433       COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
11434
11435 * interface between Glauber formalism and DPM
11436       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
11437      &                INTER1(MAXINT),INTER2(MAXINT)
11438
11439 * statistics: Glauber-formalism
11440       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
11441
11442 * n-n cross section fluctuations
11443       PARAMETER (NBINS = 1000)
11444       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
11445
11446       DIMENSION JS(MAXNCL),JT(MAXNCL),
11447      &          JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
11448      &          JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
11449       DIMENSION NWA(0:210),NWB(0:210)
11450
11451       LOGICAL LFIRST
11452       DATA LFIRST /.TRUE./
11453
11454       DATA NTARGO,ICNT /0,0/
11455
11456       NTARG = ABS(NIDX)
11457
11458       IF (LFIRST) THEN
11459          LFIRST = .FALSE.
11460          IF (NCOMPO.EQ.0) THEN
11461             NCALL  = 0
11462             NWAMAX = NA
11463             NWBMAX = NB
11464             DO 17 I=0,210
11465                NWA(I) = 0
11466                NWB(I) = 0
11467    17       CONTINUE
11468          ENDIF
11469       ENDIF
11470       IF (NTARG.EQ.-1) THEN
11471          IF (NCOMPO.EQ.0) THEN
11472             WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
11473             WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
11474      &                                NCALL,NWAMAX,NWBMAX
11475             DO 18 I=1,MAX(NWAMAX,NWBMAX)
11476                WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
11477      &                          I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
11478      &                            NWB(I),DBLE(NWB(I))/DBLE(NCALL)
11479    18       CONTINUE
11480          ENDIF
11481          RETURN
11482       ENDIF
11483
11484       DCOH   = 1.0D10
11485       IPNT   = 0
11486
11487       SQ2  = Q2
11488       IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
11489       S   = ECMNOW**2
11490       X   = SQ2/(S+SQ2-AMP2)
11491       XNU = (S+SQ2-AMP2)/(TWO*AMP)
11492 * photon projectiles: recalculate photon-nucleon amplitude
11493       IF (IJPROJ.EQ.7) THEN
11494    15    CONTINUE
11495 *  VDM assumption: mass of V-meson
11496          AMV2   = DT_SAM2(SQ2,ECMNOW)
11497          AMV    = SQRT(AMV2)
11498          IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
11499 *  check for pointlike interaction
11500          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
11501 **sr 27.10.
11502 C        SIGSH  = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11503          SIGSH  = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11504 **
11505          ROSH   = 0.1D0
11506          BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
11507      &                   +0.25D0*LOG(S/(AMV2+SQ2)))
11508 *  coherence length
11509          IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
11510       ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
11511          IF (MCGENE.EQ.2) THEN
11512             ZERO1 = ZERO
11513             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
11514      &                                                BSLOPE,0)
11515          ELSE
11516             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
11517          ENDIF
11518          IF (ECMNOW.LE.3.0D0) THEN
11519             ROSH = -0.43D0
11520          ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
11521             ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
11522          ELSEIF (ECMNOW.GT.50.0D0) THEN
11523             ROSH = 0.1D0
11524          ENDIF
11525          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11526          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11527          IF (MCGENE.EQ.2) THEN
11528             ZERO1 = ZERO
11529             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
11530      &                                                  BDUM,0)
11531             SIGSH = SIGSH/10.0D0
11532          ELSE
11533 C           SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11534             DUMZER = ZERO
11535             CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11536             SIGSH = SIGSH/10.0D0
11537          ENDIF
11538       ELSE
11539          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
11540          ROSH   = 0.01D0
11541          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11542          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11543 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11544          DUMZER = ZERO
11545          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11546          SIGSH = SIGSH/10.0D0
11547       ENDIF
11548       GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
11549       GAM = GSH
11550       RCA = GAM*SIGSH/TWOPI
11551       FCA = -ROSH*RCA
11552       CA  = DCMPLX(RCA,FCA)
11553       CI  = DCMPLX(ONE,ZERO)
11554
11555    16 CONTINUE
11556 * impact parameter
11557       IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
11558
11559       NTRY = 0
11560     3 CONTINUE
11561       NTRY = NTRY+1
11562 * initializations
11563       JNT  = 0
11564       DO 1 I=1,NA
11565          JS(I) = 0
11566     1 CONTINUE
11567       DO 2 I=1,NB
11568          JT(I) = 0
11569     2 CONTINUE
11570       IF (IJPROJ.EQ.7) THEN
11571          DO 8 I=1,MAXNCL
11572             JS0(I) = 0
11573             JNT0(I)= 0
11574             DO 9 J=1,NB
11575                JT0(I,J) = 0
11576     9       CONTINUE
11577     8    CONTINUE
11578       ENDIF
11579
11580 * nucleon configuration
11581 C     IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11582       IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11583 C        CALL DT_CONUCL(PKOO,NA,RASH,2)
11584 C        CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
11585          IF (NIDX.LE.-1) THEN
11586             CALL DT_CONUCL(PKOO,NA,RASH(1),0)
11587             CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
11588          ELSE
11589             CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11590             CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11591          ENDIF
11592          NTARGO = NTARG
11593       ENDIF
11594       ICNT = ICNT+1
11595
11596 * LEPTO: pick out one struck nucleon
11597       IF (MCGENE.EQ.3) THEN
11598          JNT     = 1
11599          JS(1)   = 1
11600          IDX     = INT(DT_RNDM(X)*NB)+1
11601          JT(IDX) = 1
11602          B       = ZERO
11603          GOTO 19
11604       ENDIF
11605
11606       DO 4 INA=1,NA
11607 * cross section fluctuations
11608          AFLUC = ONE
11609          IF (IFLUCT.EQ.1) THEN
11610             IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11611             AFLUC = FLUIXX(IFLUK)
11612          ENDIF
11613          KK1  = 1
11614          KINT = 1
11615          DO 5 INB=1,NB
11616 * photon-projectile: check for supression by coherence length
11617             IF (IJPROJ.EQ.7) THEN
11618                IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11619                   KK1  = INB
11620                   KINT = KINT+1
11621                ENDIF
11622             ENDIF
11623             QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11624             QQ2 =   TKOO(2,INB)-PKOO(2,INA)
11625             XY  = GAM*(QQ1*QQ1+QQ2*QQ2)
11626             IF (XY.LE.15.0D0) THEN
11627                C  = CI-CA*AFLUC*EXP(-XY)
11628                AR = DBLE(C)
11629                AI = DIMAG(C)
11630                P  = AR*AR+AI*AI
11631                IF (DT_RNDM(XY).GE.P) THEN
11632                   JNT = JNT+1
11633                   IF (IJPROJ.EQ.7) THEN
11634                      JNT0(KINT) = JNT0(KINT)+1
11635                      IF (JNT0(KINT).GT.MAXNCL) THEN
11636                         WRITE(LOUT,1001) MAXNCL
11637  1001                   FORMAT(1X,
11638      &                        'DIAGR:  no. of requested interactions',
11639      &                        ' exceeds array dimensions ',I4)
11640                         STOP
11641                      ENDIF
11642                      JS0(KINT)      = JS0(KINT)+1
11643                      JT0(KINT,INB)  = JT0(KINT,INB)+1
11644                      JI1(KINT,JNT0(KINT)) = INA
11645                      JI2(KINT,JNT0(KINT)) = INB
11646                   ELSE
11647                      IF (JNT.GT.MAXINT) THEN
11648                         WRITE(LOUT,1000) JNT, MAXINT
11649  1000                   FORMAT(1X,
11650      &                        'DIAGR:  no. of requested interactions ('
11651      &                        ,I4,') exceeds array dimensions (',I4,')')
11652                         STOP
11653                      ENDIF
11654                      JS(INA) = JS(INA)+1
11655                      JT(INB) = JT(INB)+1
11656                      INTER1(JNT) = INA
11657                      INTER2(JNT) = INB
11658                   ENDIF
11659                ENDIF
11660             ENDIF
11661     5    CONTINUE
11662     4 CONTINUE
11663
11664       IF (JNT.EQ.0) THEN
11665          IF (NTRY.LT.500) THEN
11666             GOTO 3
11667          ELSE
11668 C           WRITE(6,*) ' new impact parameter required (old= ',B,')'
11669             GOTO 16
11670          ENDIF
11671       ENDIF
11672
11673       IDIREC = 0
11674       IF (IJPROJ.EQ.7) THEN
11675          K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11676    10    CONTINUE
11677          IF (JNT0(K).EQ.0) THEN
11678             K = K+1
11679             IF (K.GT.KINT) K = 1
11680             GOTO 10
11681          ENDIF
11682 * supress Glauber-cascade by direct photon processes
11683          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11684          IF (IPNT.GT.0) THEN
11685             JNT   = 1
11686             JS(1) = 1
11687             DO 11 INB=1,NB
11688                JT(INB) = JT0(K,INB)
11689                IF (JT(INB).GT.0) GOTO 12
11690    11       CONTINUE
11691    12       CONTINUE
11692             INTER1(1) = 1
11693             INTER2(1) = INB
11694             IDIREC    = IPNT
11695          ELSE
11696             JNT   = JNT0(K)
11697             JS(1) = JS0(K)
11698             DO 13 INB=1,NB
11699                JT(INB) = JT0(K,INB)
11700    13       CONTINUE
11701             DO 14 I=1,JNT
11702                INTER1(I) = JI1(K,I)
11703                INTER2(I) = JI2(K,I)
11704    14       CONTINUE
11705          ENDIF
11706       ENDIF
11707
11708    19 CONTINUE
11709       INTA = 0
11710       INTB = 0
11711       DO 6 I=1,NA
11712         IF (JS(I).NE.0) INTA=INTA+1
11713     6 CONTINUE
11714       DO 7 I=1,NB
11715         IF (JT(I).NE.0) INTB=INTB+1
11716     7 CONTINUE
11717       ICWPG = INTA
11718       ICWTG = INTB
11719       ICIG  = JNT
11720       IPGLB = IPGLB+INTA
11721       ITGLB = ITGLB+INTB
11722       NGLB = NGLB+1
11723
11724       IF (NCOMPO.EQ.0) THEN
11725          NCALL = NCALL+1
11726          NWA(INTA) = NWA(INTA)+1
11727          NWB(INTB) = NWB(INTB)+1
11728       ENDIF
11729
11730       RETURN
11731       END
11732
11733 *$ CREATE DT_MODB.FOR
11734 *COPY DT_MODB
11735 *
11736 *===modb===============================================================*
11737 *
11738       SUBROUTINE DT_MODB(B,NIDX)
11739
11740 ************************************************************************
11741 * Sampling of impact parameter of collision.                           *
11742 *    B          impact parameter    (output)                           *
11743 *    NIDX       index of projectile/target material             (input)*
11744 * Based on the original version by Shmakov et al.                      *
11745 * This version dated 21.04.95 is revised by S. Roesler                 *
11746 *                                                                      *
11747 * Last change 27.12.2006 by S. Roesler.                                *
11748 ************************************************************************
11749
11750       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11751       SAVE
11752
11753       PARAMETER ( LINP = 10 ,
11754      &            LOUT = 6 ,
11755      &            LDAT = 9 )
11756
11757       PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11758
11759       LOGICAL LEFT,LFIRST
11760
11761 * central particle production, impact parameter biasing
11762       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11763
11764       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11765
11766 * Glauber formalism: parameters
11767       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11768      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11769      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11770      &                NSITEB,NSTATB
11771
11772 * Glauber formalism: cross sections
11773       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11774      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11775      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11776      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11777      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11778      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11779      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11780      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11781      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11782      &                BSLOPE,NEBINI,NQBINI
11783
11784       DATA LFIRST /.TRUE./
11785
11786       NTARG = ABS(NIDX)
11787       IF (NIDX.LE.-1) THEN
11788          RA = RASH(1)
11789          RB = RBSH(NTARG)
11790       ELSE
11791          RA = RASH(NTARG)
11792          RB = RBSH(1)
11793       ENDIF
11794
11795       IF (ICENTR.EQ.2) THEN
11796          IF (RA.EQ.RB) THEN
11797             BB = DT_RNDM(B)*(0.3D0*RA)**2
11798             B  = SQRT(BB)
11799          ELSEIF(RA.LT.RB)THEN
11800             BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11801             B  = SQRT(BB)
11802          ELSEIF(RA.GT.RB)THEN
11803             BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11804             B  = SQRT(BB)
11805          ENDIF
11806       ELSE
11807     9    CONTINUE
11808          Y  = DT_RNDM(BB)
11809          I0 = 1
11810          I2 = NSITEB
11811    10    CONTINUE
11812          I1 = (I0+I2)/2
11813          LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11814      &          *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11815          IF (LEFT) GOTO 20
11816          I0 = I1
11817          GOTO 30
11818    20    CONTINUE
11819          I2 = I1
11820    30    CONTINUE
11821          IF (I2-I0-2) 40,50,60
11822    40    CONTINUE
11823          I1 = I2+1
11824          IF (I1.GT.NSITEB) I1 = I0-1
11825          GOTO 70
11826    50    CONTINUE
11827          I1 = I0+1
11828          GOTO 70
11829    60    CONTINUE
11830          GOTO 10
11831    70    CONTINUE
11832          X0 = DBLE(I0-1)*BSTEP(NTARG)
11833          X1 = DBLE(I1-1)*BSTEP(NTARG)
11834          X2 = DBLE(I2-1)*BSTEP(NTARG)
11835          Y0 = BSITE(0,1,NTARG,I0)
11836          Y1 = BSITE(0,1,NTARG,I1)
11837          Y2 = BSITE(0,1,NTARG,I2)
11838    80    CONTINUE
11839          B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11840      &       X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11841      &       X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11842 **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11843          B = B+0.5D0*BSTEP(NTARG)
11844          IF (B.LT.ZERO) B = X1
11845          IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11846          IF (ICENTR.LT.0) THEN
11847             IF (LFIRST) THEN
11848                LFIRST = .FALSE.
11849                IF (ICENTR.LE.-100) THEN
11850                   BIMIN  = 0.0D0
11851                ELSE
11852                   XSFRAC = 0.0D0
11853                ENDIF
11854                CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11855                WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11856      &                          BIMIN,BIMAX,XSFRAC*100.0D0,
11857      &                          XSFRAC*XSPRO(1,1,NTARG)
11858  10000         FORMAT(/,1X,'DT_MODB:      Biasing in impact parameter',
11859      &                /,15X,'---------------------------'/,/,4X,
11860      &                'average radii of proj / targ :',F10.3,' fm /',
11861      &                F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11862      &                F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11863      &                F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11864      &                ' cross section :',F10.3,' %',/,5X,
11865      &                'corresponding cross section :',F10.3,' mb',/)
11866             ENDIF
11867             IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11868                B = BIMIN
11869             ELSE
11870                IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11871             ENDIF
11872          ENDIF
11873       ENDIF
11874
11875       RETURN
11876       END
11877
11878 *$ CREATE DT_SHFAST.FOR
11879 *COPY DT_SHFAST
11880 *
11881 *===shfast=============================================================*
11882 *
11883       SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11884
11885       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11886       SAVE
11887
11888       PARAMETER ( LINP = 10 ,
11889      &            LOUT = 6 ,
11890      &            LDAT = 9 )
11891
11892       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11893      &           ONE=1.0D0,TWO=2.0D0)
11894
11895       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11896
11897 * Glauber formalism: parameters
11898       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11899      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11900      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11901      &                NSITEB,NSTATB
11902
11903 * properties of interacting particles
11904       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11905
11906 * Glauber formalism: cross sections
11907       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11908      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11909      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11910      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11911      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11912      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11913      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11914      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11915      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11916      &                BSLOPE,NEBINI,NQBINI
11917
11918       IBACK = 0
11919
11920       IF (MODE.EQ.2) THEN
11921          OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11922          WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11923  1000    FORMAT(1X,8I5,E15.5)
11924          WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11925  1001    FORMAT(1X,4E15.5)
11926          WRITE(47,1002) SIGSH,ROSH,GSH
11927  1002    FORMAT(1X,3E15.5)
11928          DO 10 I=1,100
11929             WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11930    10    CONTINUE
11931          WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11932  1003    FORMAT(1X,2I10,3E15.5)
11933          CLOSE(47)
11934       ELSE
11935          OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11936          READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11937          IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11938      &       (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11939      &       .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11940      &       (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11941             READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11942             READ(47,1002) SIGSH,ROSH,GSH
11943             DO 11 I=1,100
11944                READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11945    11       CONTINUE
11946             READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11947          ELSE
11948             IBACK = 1
11949          ENDIF
11950          CLOSE(47)
11951       ENDIF
11952
11953       RETURN
11954       END
11955
11956 *$ CREATE DT_POILIK.FOR
11957 *COPY DT_POILIK
11958 *
11959 *===poilik=============================================================*
11960 *
11961       SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11962
11963       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11964       SAVE
11965
11966       PARAMETER ( LINP = 10 ,
11967      &            LOUT = 6 ,
11968      &            LDAT = 9 )
11969
11970       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11971       PARAMETER (NE = 8)
11972
11973 **PHOJET105a
11974 C     CHARACTER*8 MDLNA
11975 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11976 C     PARAMETER (IEETAB=10)
11977 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11978 **PHOJET110
11979
11980 C  model switches and parameters
11981       CHARACTER*8 MDLNA
11982       INTEGER ISWMDL,IPAMDL
11983       DOUBLE PRECISION PARMDL
11984       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11985
11986 C  energy-interpolation table
11987       INTEGER IEETA2
11988       PARAMETER ( IEETA2 = 20 )
11989       INTEGER ISIMAX
11990       DOUBLE PRECISION SIGTAB,SIGECM
11991       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11992 **
11993
11994 * VDM parameter for photon-nucleus interactions
11995       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11996 **sr 22.7.97
11997
11998       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11999
12000 * Glauber formalism: cross sections
12001       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
12002      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
12003      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
12004      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
12005      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
12006      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
12007      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
12008      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
12009      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
12010      &                BSLOPE,NEBINI,NQBINI
12011 **
12012
12013       DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
12014
12015       IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
12016
12017 * load cross sections from interpolation table
12018       IP = 1
12019       IF(ECM.LE.SIGECM(IP,1)) THEN
12020         I1 = 1
12021         I2 = 1
12022       ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
12023         DO 50 I=2,ISIMAX
12024           IF(ECM.LE.SIGECM(IP,I)) GOTO 200
12025   50    CONTINUE
12026  200    CONTINUE
12027         I1 = I-1
12028         I2 = I
12029       ELSE
12030         WRITE(LOUT,'(/1X,A,2E12.3)')
12031      &    'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
12032         I1 = ISIMAX
12033         I2 = ISIMAX
12034       ENDIF
12035       FAC2 = ZERO
12036       IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
12037      &                     /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
12038       FAC1 = ONE-FAC2
12039
12040       SIGANO = DT_SANO(ECM)
12041
12042 * cross section dependence on photon virtuality
12043       FSUP1 = ZERO
12044       DO  150 I=1,3
12045          FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
12046      &                             /(ONE+VIRT/PARMDL(30+I))**2
12047  150  CONTINUE
12048       FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
12049       FAC1  = FAC1*FSUP1
12050       FAC2  = FAC2*FSUP1
12051       FSUP2 = ONE
12052
12053       ECMOLD = ECM
12054       Q2OLD  = VIRT
12055
12056     3 CONTINUE
12057
12058 C     SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
12059       CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
12060       IF (ISHAD(1).EQ.1) THEN
12061          SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
12062       ELSE
12063          SIGDIR = ZERO
12064       ENDIF
12065       SIGANO = FSUP1*FSUP2*SIGANO
12066       SIGTOT = SIGTOT-SIGDIR-SIGANO
12067       SIGDIR = SIGDIR/(FSUP1*FSUP2)
12068       SIGANO = SIGANO/(FSUP1*FSUP2)
12069       SIGTOT = SIGTOT+SIGDIR+SIGANO
12070
12071       RR = DT_RNDM(SIGTOT)
12072       IF (RR.LT.SIGDIR/SIGTOT) THEN
12073          IPNT = 1
12074       ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
12075      &        (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
12076          IPNT = 2
12077       ELSE
12078          IPNT = 0
12079       ENDIF
12080       RPNT = (SIGDIR+SIGANO)/SIGTOT
12081 C     WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
12082 C     WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
12083 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
12084 C     WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
12085       IF (MODE.EQ.1) RETURN
12086
12087 **sr 22.7.97
12088       K1   = 1
12089       K2   = 1
12090       RATE = ZERO
12091       IF (ECM.GE.ECMNN(NEBINI)) THEN
12092          K1   = NEBINI
12093          K2   = NEBINI
12094          RATE = ONE
12095       ELSEIF (ECM.GT.ECMNN(1)) THEN
12096          DO 10 I=2,NEBINI
12097             IF (ECM.LT.ECMNN(I)) THEN
12098                K1   = I-1
12099                K2   = I
12100                RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
12101                GOTO 11
12102             ENDIF
12103    10    CONTINUE
12104    11    CONTINUE
12105       ENDIF
12106       J1   = 1
12107       J2   = 1
12108       RATQ = ZERO
12109       IF (NQBINI.GT.1) THEN
12110          IF (VIRT.GE.Q2G(NQBINI)) THEN
12111             J1   = NQBINI
12112             J2   = NQBINI
12113             RATQ = ONE
12114          ELSEIF (VIRT.GT.Q2G(1)) THEN
12115             DO 12 I=2,NQBINI
12116                IF (VIRT.LT.Q2G(I)) THEN
12117                   J1   = I-1
12118                   J2   = I
12119                   RATQ = LOG10(   VIRT/MAX(Q2G(J1),TINY14))/
12120      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
12121                   GOTO 13
12122                ENDIF
12123    12       CONTINUE
12124    13       CONTINUE
12125          ENDIF
12126       ENDIF
12127       SGA = XSPRO(K1,J1,NTARG)+
12128      &      RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
12129      &      RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
12130      &      RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
12131      &                 XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
12132       SDI = DBLE(NB)*SIGDIR
12133       SAN = DBLE(NB)*SIGANO
12134       SPL = SDI+SAN
12135       RR = DT_RNDM(SPL)
12136       IF (RR.LT.SDI/SGA) THEN
12137          IPNT = 1
12138       ELSEIF ((RR.GE.SDI/SGA).AND.
12139      &        (RR.LT.SPL/SGA)) THEN
12140          IPNT = 2
12141       ELSE
12142          IPNT = 0
12143       ENDIF
12144       RPNT = SPL/SGA
12145 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
12146 **
12147
12148       RETURN
12149       END
12150
12151 *$ CREATE DT_GLBINI.FOR
12152 *COPY DT_GLBINI
12153 *
12154 *===glbini=============================================================*
12155 *
12156       SUBROUTINE DT_GLBINI(WHAT)
12157
12158 ************************************************************************
12159 * Pre-initialization of profile function                               *
12160 * This version dated 28.11.00 is written by S. Roesler.                *
12161 *                                                                      *
12162 * Last change 27.12.2006 by S. Roesler.                                *
12163 ************************************************************************
12164
12165       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12166       SAVE
12167
12168       PARAMETER ( LINP = 10 ,
12169      &            LOUT = 6 ,
12170      &            LDAT = 9 )
12171
12172       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
12173
12174       LOGICAL LCMS
12175
12176 * particle properties (BAMJET index convention)
12177       CHARACTER*8  ANAME
12178       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12179      &                IICH(210),IIBAR(210),K1(210),K2(210)
12180
12181 * properties of interacting particles
12182       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12183
12184       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12185
12186 * emulsion treatment
12187       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
12188      &                NCOMPO,IEMUL
12189
12190 * Glauber formalism: flags and parameters for statistics
12191       LOGICAL LPROD
12192       CHARACTER*8 CGLB
12193       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
12194
12195 * number of data sets other than protons and nuclei
12196 * at the moment = 2 (pions and kaons)
12197       PARAMETER (MAXOFF=2)
12198       DIMENSION IJPINI(5),IOFFST(25)
12199       DATA IJPINI / 13, 15,  0,  0,  0/
12200 * Glauber data-set to be used for hadron projectiles
12201 * (0=proton, 1=pion, 2=kaon)
12202       DATA (IOFFST(K),K=1,25) /
12203      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
12204      &  0, 0, 1, 2, 2/
12205 * Acceptance interval for target nucleus mass
12206       PARAMETER (KBACC = 6)
12207
12208 * flags for input different options
12209       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12210       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12211      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12212
12213       PARAMETER (MAXMSS = 100)
12214       DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
12215       DIMENSION WHAT(6)
12216
12217       DATA JPEACH,JPSTEP / 18, 5 /
12218
12219 * temporary patch until fix has been implemented in phojet:
12220 *  maximum energy for pion projectile
12221       DATA ECMXPI / 100000.0D0 /
12222 *
12223 *--------------------------------------------------------------------------
12224 * general initializations
12225 *
12226 *  steps in projectile mass number for initialization
12227       IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
12228       IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
12229 *
12230 *  energy range and binning
12231       ELO  = ABS(WHAT(1))
12232       EHI  = ABS(WHAT(2))
12233       IF (ELO.GT.EHI) ELO = EHI
12234       NEBIN = MAX(INT(WHAT(3)),1)
12235       IF (ELO.EQ.EHI) NEBIN = 0
12236       LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
12237       IF (LCMS) THEN
12238          ECMINI = EHI
12239       ELSE
12240          ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
12241      &                 +2.0D0*AAM(IJTARG)*EHI)
12242       ENDIF
12243 *
12244 *  default arguments for Glauber-routine
12245       XI  = ZERO
12246       Q2I = ZERO
12247 *
12248 *  initialize nuclear parameters, etc.
12249
12250 *  initialize evaporation if the code is not used as Fluka event generator
12251       IF (ITRSPT.NE.1) THEN
12252          CALL NCDTRD
12253          CALL INCINI
12254       ENDIF
12255
12256 *
12257 *  open Glauber-data output file
12258       IDX = INDEX(CGLB,' ')
12259       K   = 12
12260       IF (IDX.GT.1) K = IDX-1
12261       OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12262 *
12263 *--------------------------------------------------------------------------
12264 * Glauber-initialization for proton and nuclei projectiles
12265 *
12266 *  initialize phojet for proton-proton interactions
12267       ELAB = ZERO
12268       PLAB = ZERO
12269       CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
12270       CALL DT_PHOINI
12271 *
12272 *  record projectile masses
12273       NASAV = 0
12274       NPROJ = MIN(IP,JPEACH)
12275       DO 10 KPROJ=1,NPROJ
12276          NASAV = NASAV+1
12277          IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12278          IASAV(NASAV) = KPROJ
12279    10 CONTINUE
12280       IF (IP.GT.JPEACH) THEN
12281          NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
12282          IF (NPROJ.EQ.0) THEN
12283             NASAV = NASAV+1
12284             IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12285             IASAV(NASAV) = IP
12286          ELSE
12287             DO 11 IPROJ=1,NPROJ
12288                KPROJ = JPEACH+IPROJ*JPSTEP
12289                NASAV = NASAV+1
12290                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12291                IASAV(NASAV) = KPROJ
12292    11       CONTINUE
12293             IF (KPROJ.LT.IP) THEN
12294                NASAV = NASAV+1
12295                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12296                IASAV(NASAV) = IP
12297             ENDIF
12298          ENDIF
12299       ENDIF
12300 *
12301 *  record target masses
12302       NBSAV = 0
12303       NTARG = 1
12304       IF (NCOMPO.GT.0) NTARG = NCOMPO
12305       DO 12 ITARG=1,NTARG
12306          NBSAV = NBSAV+1
12307          IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
12308          IF (NCOMPO.GT.0) THEN
12309             IBSAV(NBSAV) = IEMUMA(ITARG)
12310          ELSE
12311             IBSAV(NBSAV) = IT
12312          ENDIF
12313    12 CONTINUE
12314 *
12315 *  print masses
12316       WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
12317  1000 FORMAT(I4,A,1P,2E13.5)
12318       NLINES = DBLE(NASAV)/18.0D0
12319       IF (NLINES.GT.0) THEN
12320          DO 13 I=1,NLINES
12321             IF (I.EQ.1) THEN
12322                WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
12323             ELSE
12324                WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
12325             ENDIF
12326    13    CONTINUE
12327       ENDIF
12328       I0 = 18*NLINES+1
12329       IF (I0.LE.NASAV) THEN
12330          IF (I0.EQ.1) THEN
12331             WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
12332          ELSE
12333             WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
12334          ENDIF
12335       ENDIF
12336       NLINES = DBLE(NBSAV)/18.0D0
12337       IF (NLINES.GT.0) THEN
12338          DO 14 I=1,NLINES
12339             IF (I.EQ.1) THEN
12340                WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
12341             ELSE
12342                WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
12343             ENDIF
12344    14    CONTINUE
12345       ENDIF
12346       I0 = 18*NLINES+1
12347       IF (I0.LE.NBSAV) THEN
12348          IF (I0.EQ.1) THEN
12349             WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
12350          ELSE
12351             WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
12352          ENDIF
12353       ENDIF
12354 *
12355 *  calculate Glauber-data for each energy and mass combination
12356 *
12357 *   loop over energy bins
12358       ELO = LOG10(ELO)
12359       EHI = LOG10(EHI)
12360       DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
12361       DO 1 IE=1,NEBIN+1
12362          E = ELO+DBLE(IE-1)*DEBIN
12363          E = 10**E
12364          IF (LCMS) THEN
12365             E   = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
12366             ECM = E
12367          ELSE
12368             PLAB = ZERO
12369             ECM  = ZERO
12370             E    = MAX(AAM(IJPROJ)+0.1D0,E)
12371             CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
12372          ENDIF
12373 *
12374 *   loop over projectile and target masses
12375          DO 2 ITARG=1,NBSAV
12376             DO 3 IPROJ=1,NASAV
12377                CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
12378      &                                       XI,Q2I,ECM,1,1,-1)
12379     3       CONTINUE
12380     2    CONTINUE
12381 *
12382     1 CONTINUE
12383 *
12384 *--------------------------------------------------------------------------
12385 * Glauber-initialization for pion, kaon, ... projectiles
12386 *
12387       DO 6 IJ=1,MAXOFF
12388 *
12389 *  initialize phojet for this interaction
12390          ELAB = ZERO
12391          PLAB = ZERO
12392          IJPROJ = IJPINI(IJ)
12393          IP     = 1
12394          IPZ    = 1
12395 *
12396 *   temporary patch until fix has been implemented in phojet:
12397          IF (ECMINI.GT.ECMXPI) THEN
12398             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
12399          ELSE
12400             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
12401          ENDIF
12402          CALL DT_PHOINI
12403 *
12404 *  calculate Glauber-data for each energy and mass combination
12405 *
12406 *   loop over energy bins
12407          DO 4 IE=1,NEBIN+1
12408             E = ELO+DBLE(IE-1)*DEBIN
12409             E = 10**E
12410             IF (LCMS) THEN
12411                E   = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
12412                ECM = E
12413             ELSE
12414                PLAB = ZERO
12415                ECM  = ZERO
12416                E    = MAX(AAM(IJPROJ)+TINY14,E)
12417                CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
12418             ENDIF
12419 *
12420 *   loop over projectile and target masses
12421             DO 5 ITARG=1,NBSAV
12422                CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
12423     5       CONTINUE
12424 *
12425     4    CONTINUE
12426 *
12427     6 CONTINUE
12428
12429 *--------------------------------------------------------------------------
12430 * close output unit(s), etc.
12431 *
12432       CLOSE(LDAT)
12433
12434       RETURN
12435       END
12436
12437 *$ CREATE DT_GLBSET.FOR
12438 *COPY DT_GLBSET
12439 *
12440 *===glbset=============================================================*
12441 *
12442       SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
12443 ************************************************************************
12444 * Interpolation of pre-initialized profile functions                   *
12445 * This version dated 28.11.00 is written by S. Roesler.                *
12446 ************************************************************************
12447
12448       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12449       SAVE
12450
12451       PARAMETER ( LINP = 10 ,
12452      &            LOUT = 6 ,
12453      &            LDAT = 9 )
12454
12455       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
12456
12457       LOGICAL LCMS,LREAD,LFRST1,LFRST2
12458
12459 * particle properties (BAMJET index convention)
12460       CHARACTER*8  ANAME
12461       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12462      &                IICH(210),IIBAR(210),K1(210),K2(210)
12463
12464 * Glauber formalism: flags and parameters for statistics
12465       LOGICAL LPROD
12466       CHARACTER*8 CGLB
12467       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
12468
12469       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12470
12471 * Glauber formalism: parameters
12472       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
12473      &                BMAX(NCOMPX),BSTEP(NCOMPX),
12474      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
12475      &                NSITEB,NSTATB
12476
12477 * Glauber formalism: cross sections
12478       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
12479      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
12480      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
12481      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
12482      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
12483      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
12484      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
12485      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
12486      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
12487      &                BSLOPE,NEBINI,NQBINI
12488
12489 * number of data sets other than protons and nuclei
12490 * at the moment = 2 (pions and kaons)
12491       PARAMETER (MAXOFF=2)
12492       DIMENSION IJPINI(5),IOFFST(25)
12493       DATA IJPINI / 13, 15,  0,  0,  0/
12494 * Glauber data-set to be used for hadron projectiles
12495 * (0=proton, 1=pion, 2=kaon)
12496       DATA (IOFFST(K),K=1,25) /
12497      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
12498      &  0, 0, 1, 2, 2/
12499 * Acceptance interval for target nucleus mass
12500       PARAMETER (KBACC = 6)
12501
12502 * emulsion treatment
12503       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
12504      &                NCOMPO,IEMUL
12505
12506       PARAMETER (MAXSET=5000,
12507      &           MAXBIN=100)
12508       DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
12509       DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
12510      &          BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
12511      &          IAIDX(10)
12512
12513       DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
12514 *
12515 * read data from file
12516 *
12517       IF (MODE.EQ.0) THEN
12518
12519          IF (LREAD) RETURN
12520
12521          DO 1 I=1,MAXSET
12522             DO 2 J=1,6
12523                XSIG(I,J) = ZERO
12524                XERR(I,J) = ZERO
12525     2       CONTINUE
12526             DO 3 J=1,KSITEB
12527                BPROFL(I,J) = ZERO
12528     3       CONTINUE
12529     1    CONTINUE
12530          DO 4 I=1,MAXBIN
12531             IABIN(I) = 0
12532             IBBIN(I) = 0
12533     4    CONTINUE
12534          DO 5 I=1,KSITEB
12535             BPRO0(I) = ZERO
12536             BPRO1(I) = ZERO
12537             BPRO(I)  = ZERO
12538     5    CONTINUE
12539
12540          IDX = INDEX(CGLB,' ')
12541          K   = 12
12542          IF (IDX.GT.1) K = IDX-1
12543          OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12544          WRITE(LOUT,1000) CGLB(1:K)//'.glb'
12545  1000    FORMAT(/,' GLBSET: impact parameter distributions read from ',
12546      &          'file ',A12,/)
12547 *
12548 *  read binning information
12549          READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
12550 *  return lower energy threshold to Fluka-interface
12551          ELAB = ELO
12552          LCMS = ELO.LT.ZERO
12553          WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
12554          IF (LCMS) THEN
12555             WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
12556          ELSE
12557             WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
12558          ENDIF
12559  1001    FORMAT(2X,A5,'  E_lo = ',1P,E9.3,'  E_hi = ',1P,E9.3,4X,
12560      &          'No. of bins:',I5,/)
12561          ELO  = LOG10(ABS(ELO))
12562          EHI  = LOG10(ABS(EHI))
12563          DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
12564          WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
12565          READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
12566          IF (NABIN.LT.18) THEN
12567             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
12568          ELSE
12569             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
12570          ENDIF
12571          IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
12572          IF (NABIN.GT.18) THEN
12573             NLINES = DBLE(NABIN-18)/18.0D0
12574             IF (NLINES.GT.0) THEN
12575                DO 7 I=1,NLINES
12576                   I0 = 18*(I+1)-17
12577                   READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12578                   WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12579     7          CONTINUE
12580             ENDIF
12581             I0 = 18*(NLINES+1)+1
12582             IF (I0.LE.NABIN) THEN
12583                READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12584                WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12585             ENDIF
12586          ENDIF
12587          WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
12588          READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
12589          IF (NBBIN.LT.18) THEN
12590             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
12591          ELSE
12592             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
12593          ENDIF
12594          IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
12595          IF (NBBIN.GT.18) THEN
12596             NLINES = DBLE(NBBIN-18)/18.0D0
12597             IF (NLINES.GT.0) THEN
12598                DO 8 I=1,NLINES
12599                   I0 = 18*(I+1)-17
12600                   READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12601                   WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12602     8          CONTINUE
12603             ENDIF
12604             I0 = 18*(NLINES+1)+1
12605             IF (I0.LE.NBBIN) THEN
12606                READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12607                WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12608             ENDIF
12609          ENDIF
12610 *  number of data sets to follow in the Glauber data file
12611 *   this variable is used for checks of consistency of projectile
12612 *   and target mass configurations given in header of Glauber data
12613 *   file and the data-sets which follow in this file
12614          NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
12615 *
12616 *  read profile function data
12617          NSET  = 0
12618          NAIDX = 0
12619          IPOLD = 0
12620    10    CONTINUE
12621          NSET = NSET+1
12622          IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
12623          READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
12624  1002    FORMAT(5I10,E15.5)
12625          IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12626             NAIDX = NAIDX+1
12627             IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12628             IAIDX(NAIDX) = IP
12629             IPOLD = IP
12630          ENDIF
12631          READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12632          READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12633          NLINES = INT(DBLE(ISITEB)/7.0D0)
12634          IF (NLINES.GT.0) THEN
12635             DO 11 I=1,NLINES
12636                READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12637    11       CONTINUE
12638          ENDIF
12639          I0 = 7*NLINES+1
12640          IF (I0.LE.ISITEB)
12641      &      READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12642          GOTO 10
12643   100    CONTINUE
12644          NSET = NSET-1
12645          IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12646          WRITE(LOUT,'(/,1X,A)')
12647      &   ' projectiles other than protons and nuclei: (particle index)'
12648          IF (NAIDX.GT.0) THEN
12649             WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12650          ELSE
12651             WRITE(LOUT,'(6X,A)') 'none'
12652          ENDIF
12653 *
12654          CLOSE(LDAT)
12655          WRITE(LOUT,*)
12656          LREAD = .TRUE.
12657
12658          IF (NCOMPO.EQ.0) THEN
12659             DO 12 J=1,NBBIN
12660                NCOMPO = NCOMPO+1
12661                IEMUMA(NCOMPO) = IBBIN(J)
12662                IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12663                EMUFRA(NCOMPO) = 1.0D0
12664    12       CONTINUE
12665             IEMUL = 1
12666          ENDIF
12667 *
12668 * calculate profile function for certain set of parameters
12669 *
12670       ELSE
12671
12672 c        write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12673 *
12674 * check for type of projectile and set index-offset to entry in
12675 * Glauber data array correspondingly
12676          IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12677          IF (IOFFST(IDPROJ).EQ.-1) THEN
12678             STOP ' GLBSET: no data for this projectile !'
12679          ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12680             IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12681          ELSE
12682             IDXOFF = 0
12683          ENDIF
12684 *
12685 * get energy bin and interpolation factor
12686          IF (LCMS) THEN
12687             E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12688          ELSE
12689             E = ELAB
12690          ENDIF
12691          E = LOG10(E)
12692          IF (E.LT.ELO) THEN
12693             IF (LFRST1) THEN
12694                WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12695                LFRST1 = .FALSE.
12696             ENDIF
12697             E = ELO
12698          ENDIF
12699          IF (E.GT.EHI) THEN
12700             IF (LFRST2) THEN
12701                WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12702                LFRST2 = .FALSE.
12703             ENDIF
12704             E = EHI
12705          ENDIF
12706          IE0  = (E-ELO)/DEBIN+1
12707          IE1  = IE0+1
12708          FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12709 *
12710 * get target nucleus index
12711          KB = 0
12712          NBACC = KBACC
12713          DO 20 I=1,NBBIN
12714             NBDIFF = ABS(NB-IBBIN(I))
12715             IF (NB.EQ.IBBIN(I)) THEN
12716                KB = I
12717                GOTO 21
12718             ELSEIF (NBDIFF.LE.NBACC) THEN
12719                KB = I
12720                NBACC = NBDIFF
12721             ENDIF
12722    20    CONTINUE
12723          IF (KB.NE.0) GOTO 21
12724          WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12725          STOP
12726    21    CONTINUE
12727 *
12728 * get projectile nucleus bin and interpolation factor
12729          KA0 = 0
12730          KA1 = 0
12731          FACNA = 0
12732          IF (IDXOFF.GT.0) THEN
12733             KA0 = 1
12734             KA1 = 1
12735             KABIN = 1
12736          ELSE
12737             IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12738             DO 22 I=1,NABIN
12739                IF (NA.EQ.IABIN(I)) THEN
12740                   KA0 = I
12741                   KA1 = I
12742                   GOTO 23
12743                ELSEIF (NA.LT.IABIN(I)) THEN
12744                   KA0 = I-1
12745                   KA1 = I
12746                   GOTO 23
12747                ENDIF
12748    22       CONTINUE
12749             WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12750             STOP
12751    23       CONTINUE
12752             IF (KA0.NE.KA1)
12753      &         FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12754             KABIN = NABIN
12755          ENDIF
12756 *
12757 * interpolate profile functions for interactions ka0-kb and ka1-kb
12758 * for energy E separately
12759          IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12760          IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12761          IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12762          IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12763          DO 30 I=1,ISITEB
12764             BPRO0(I) = BPROFL(IDX0,I)
12765      &                 +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12766             BPRO1(I) = BPROFL(IDY0,I)
12767      &                 +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12768    30    CONTINUE
12769          RADB  = DT_RNCLUS(NB)
12770          BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12771          BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12772 *
12773 * interpolate cross sections for energy E and projectile mass
12774          DO 31 I=1,6
12775             XS0   = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12776             XS1   = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12777             XS(I) = XS0+FACNA*(XS1-XS0)
12778             XE0   = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12779             XE1   = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12780             XE(I) = XE0+FACNA*(XE1-XE0)
12781    31    CONTINUE
12782 *
12783 * interpolate between ka0 and ka1
12784          RADA = DT_RNCLUS(NA)
12785          BMX  = 2.0D0*(RADA+RADB)
12786          BSTP = BMX/DBLE(ISITEB-1)
12787          BPRO(1) = ZERO
12788          DO 32 I=1,ISITEB-1
12789             B = DBLE(I)*BSTP
12790 *
12791 *   calculate values of profile functions at B
12792             IDX0 = B/BSTP0+1
12793             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12794             IDX1 = MIN(IDX0+1,ISITEB)
12795             FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12796             BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12797             IDX0 = B/BSTP1+1
12798             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12799             IDX1 = MIN(IDX0+1,ISITEB)
12800             FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12801             BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12802 *
12803             BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12804    32    CONTINUE
12805 *
12806 * fill common dtglam
12807          NSITEB   = ISITEB
12808          RASH(1)  = RADA
12809          RBSH(1)  = RADB
12810          BMAX(1)  = BMX
12811          BSTEP(1) = BSTP
12812          DO 33 I=1,KSITEB
12813             BSITE(0,1,1,I) = BPRO(I)
12814    33    CONTINUE
12815 *
12816 * fill common dtglxs
12817          XSTOT(1,1,1) = XS(1)
12818          XSELA(1,1,1) = XS(2)
12819          XSQEP(1,1,1) = XS(3)
12820          XSQET(1,1,1) = XS(4)
12821          XSQE2(1,1,1) = XS(5)
12822          XSPRO(1,1,1) = XS(6)
12823          XETOT(1,1,1) = XE(1)
12824          XEELA(1,1,1) = XE(2)
12825          XEQEP(1,1,1) = XE(3)
12826          XEQET(1,1,1) = XE(4)
12827          XEQE2(1,1,1) = XE(5)
12828          XEPRO(1,1,1) = XE(6)
12829
12830       ENDIF
12831
12832       RETURN
12833       END
12834 *$ CREATE DT_XKSAMP.FOR
12835 *COPY DT_XKSAMP
12836 *
12837 *===xksamp=============================================================*
12838 *
12839       SUBROUTINE DT_XKSAMP(NN,ECM)
12840
12841 ************************************************************************
12842 * Sampling of parton x-values and chain system for one interaction.    *
12843 *                                   processed by S. Roesler, 9.8.95    *
12844 ************************************************************************
12845
12846       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12847       SAVE
12848
12849       PARAMETER ( LINP = 10 ,
12850      &            LOUT = 6 ,
12851      &            LDAT = 9 )
12852
12853       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12854       SAVE
12855
12856       PARAMETER (
12857 * lower cuts for (valence-sea/sea-valence) chain masses
12858 *   antiquark-quark (u/d-sea quark)    (s-sea quark)
12859      &               AMIU = 0.5D0,      AMIS = 0.8D0,
12860 *   quark-diquark   (u/d-sea quark)    (s-sea quark)
12861      &               AMAU = 2.6D0,      AMAS = 2.6D0,
12862 * maximum lower valence-x threshold
12863      &           XVMAX  = 0.98D0,
12864 * fraction of sea-diquarks sampled out of sea-partons
12865 **test
12866 C    &           FRCDIQ = 0.9D0,
12867 **
12868 *
12869      &           SQMA   = 0.7D0,
12870 *
12871 * maximum number of trials to generate x's for the required number
12872 * of sea quark pairs for a given hadron
12873      &           NSEATY = 12
12874 C    &           NSEATY = 3
12875      &          )
12876
12877       LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12878
12879       PARAMETER ( MAXNCL = 260,
12880
12881      &            MAXVQU = MAXNCL,
12882      &            MAXSQU = 20*MAXVQU,
12883      &            MAXINT = MAXVQU+MAXSQU)
12884
12885 * event history
12886
12887       PARAMETER (NMXHKK=200000)
12888
12889       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12890      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12891      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12892
12893 * particle properties (BAMJET index convention)
12894       CHARACTER*8  ANAME
12895       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12896      &                IICH(210),IIBAR(210),K1(210),K2(210)
12897
12898 * interface between Glauber formalism and DPM
12899       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12900      &                INTER1(MAXINT),INTER2(MAXINT)
12901
12902 * properties of interacting particles
12903       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12904
12905 * threshold values for x-sampling (DTUNUC 1.x)
12906       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12907      &                SSMIMQ,VVMTHR
12908
12909 * x-values of partons (DTUNUC 1.x)
12910       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12911      &                XTVQ(MAXVQU),XTVD(MAXVQU),
12912      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
12913      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
12914
12915 * flavors of partons (DTUNUC 1.x)
12916       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12917      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12918      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
12919      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12920      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
12921      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12922      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
12923
12924 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12925       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12926      &                IXPV,IXPS,IXTV,IXTS,
12927      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
12928      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
12929      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
12930      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
12931      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
12932      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
12933      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
12934      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
12935
12936 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12937       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12938      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12939
12940 * auxiliary common for chain system storage (DTUNUC 1.x)
12941       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12942
12943 * flags for input different options
12944       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12945       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12946      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12947
12948 * various options for treatment of partons (DTUNUC 1.x)
12949 * (chain recombination, Cronin,..)
12950       LOGICAL LCO2CR,LINTPT
12951       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12952      &                LCO2CR,LINTPT
12953
12954       DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12955      &          INTLO(MAXINT)
12956
12957 * (1) initializations
12958 *-----------------------------------------------------------------------
12959
12960 **test
12961       IF (ECM.LT.4.5D0) THEN
12962 C        FRCDIQ = 0.6D0
12963          FRCDIQ = 0.4D0
12964       ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12965 C        FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12966          FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12967       ELSE
12968 C        FRCDIQ = 0.9D0
12969          FRCDIQ = 0.7D0
12970       ENDIF
12971 **
12972       DO 30 I=1,MAXSQU
12973          ZUOSP(I) = .FALSE.
12974          ZUOST(I) = .FALSE.
12975          IF (I.LE.MAXVQU) THEN
12976             ZUOVP(I) = .FALSE.
12977             ZUOVT(I) = .FALSE.
12978          ENDIF
12979    30 CONTINUE
12980
12981 * lower thresholds for x-selection
12982 *  sea-quarks       (default: CSEA=0.2)
12983       IF (ECM.LT.10.0D0) THEN
12984 **!!test
12985          XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12986 C        XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12987          NSEA  = NSEATY
12988 C        XSTHR = ONE/ECM**2
12989       ELSE
12990 **sr 30.3.98
12991 C        XSTHR = CSEA/ECM
12992          XSTHR = CSEA/ECM**2
12993 C        XSTHR = ONE/ECM**2
12994 **
12995          IF ((IP.GE.150).AND.(IT.GE.150))
12996      &      XSTHR = 2.5D0/(ECM*SQRT(ECM))
12997          NSEA  = NSEATY
12998       ENDIF
12999 *                   (default: SSMIMA=0.14) used for sea-diquarks (?)
13000       XSSTHR = SSMIMA/ECM
13001       BSQMA  = SQMA/ECM
13002 *  valence-quarks   (default: CVQ=1.0)
13003       XVTHR  = CVQ/ECM
13004 *  valence-diquarks (default: CDQ=2.0)
13005       XDTHR  = CDQ/ECM
13006
13007 * maximum-x for sea-quarks
13008       XVCUT  = XVTHR+XDTHR
13009       IF (XVCUT.GT.XVMAX) THEN
13010          XVCUT = XVMAX
13011          XVTHR = XVCUT/3.0D0
13012          XDTHR = XVCUT-XVTHR
13013       ENDIF
13014       XXSEAM = ONE-XVCUT
13015 **sr 18.4. test: DPMJET
13016 C     XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
13017 C    &            - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
13018 C    &             -0.01*(1.D0+1.5D0*DT_RNDM(V3))
13019 **
13020 * maximum number of sea-pairs allowed kinematically
13021 C     NSMAX  = INT(OHALF*XXSEAM/XSTHR)
13022       RNSMAX = OHALF*XXSEAM/XSTHR
13023       IF (RNSMAX.GT.10000.0D0) THEN
13024          NSMAX = 10000
13025       ELSE
13026          NSMAX = INT(OHALF*XXSEAM/XSTHR)
13027       ENDIF
13028 * check kinematical limit for valence-x thresholds
13029 * (should be obsolete now)
13030       IF (XVCUT.GT.XVMAX) THEN
13031          WRITE(LOUT,1000) XVCUT,ECM
13032  1000    FORMAT(' XKSAMP:    kin. limit for valence-x',
13033      &          '  thresholds not allowed (',2E9.3,')')
13034 C        XVTHR = XVMAX-XDTHR
13035 C        IF (XVTHR.LT.ZERO) STOP
13036          STOP
13037       ENDIF
13038
13039 * set eta for valence-x sampling (BETREJ)
13040 *   (UNON per default, UNOM used for projectile mesons only)
13041       IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
13042          UNOPRV = UNOM
13043       ELSE
13044          UNOPRV = UNON
13045       ENDIF
13046
13047 * (2) select parton x-values of interacting projectile nucleons
13048 *-----------------------------------------------------------------------
13049
13050       IXPV = 0
13051       IXPS = 0
13052
13053       DO 100 IPP=1,IP
13054 *   get interacting projectile nucleon as sampled by Glauber
13055          IF (JSSH(IPP).NE.0) THEN
13056             IXSTMP = IXPS
13057             IXVTMP = IXPV
13058    99       CONTINUE
13059             IXPS   = IXSTMP
13060             IXPV   = IXVTMP
13061 *     JIPP is the actual number of sea-pairs sampled for this nucleon
13062             JIPP   = MIN(JSSH(IPP)-1,NSMAX)
13063    41       CONTINUE
13064             XXSEA  = ZERO
13065             IF (JIPP.GT.0) THEN
13066                XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
13067 *???
13068                IF (XSTHR.GE.XSMAX) THEN
13069                   JIPP = JIPP-1
13070                   GOTO 41
13071                ENDIF
13072
13073 *>>>get x-values of sea-quark pairs
13074                NSCOUN = 0
13075                PLW = 0.5D0
13076    40          CONTINUE
13077 *     accumulator for sea x-values
13078                XXSEA  = ZERO
13079                NSCOUN = NSCOUN+1
13080                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
13081                IF (NSCOUN.GT.NSEA) THEN
13082 *     decrease the number of interactions after NSEA trials
13083                   JIPP   = JIPP-1
13084                   NSCOUN = 0
13085                ENDIF
13086                DO 70 ISQ=1,JIPP
13087 *     sea-quarks
13088                   IF (IPSQ(IXPS+1).LE.2) THEN
13089 **sr 8.4.98 (1/sqrt(x))
13090 C                    XPSQI = DT_SAMPEX(XSTHR,XSMAX)
13091 C                    XPSQI = DT_SAMSQX(XSTHR,XSMAX)
13092                      XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13093 **
13094                   ELSE
13095                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
13096                         XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13097                      ELSE
13098 **sr 8.4.98 (1/sqrt(x))
13099 C                       XPSQI = DT_SAMPEX(XSTHR,XSMAX)
13100 C                       XPSQI = DT_SAMSQX(XSTHR,XSMAX)
13101                         XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13102 **
13103                      ENDIF
13104                   ENDIF
13105 *     sea-antiquarks
13106                   IF (IPSAQ(IXPS+1).GE.-2) THEN
13107 **sr 8.4.98 (1/sqrt(x))
13108 C                    XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
13109 C                    XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
13110                      XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13111 **
13112                   ELSE
13113                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
13114                         XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13115                      ELSE
13116 **sr 8.4.98 (1/sqrt(x))
13117 C                       XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
13118 C                       XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
13119                         XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13120 **
13121                      ENDIF
13122                   ENDIF
13123                   XXSEA = XXSEA+XPSQI+XPSAQI
13124 *     check for maximum allowed sea x-value
13125                   IF (XXSEA.GE.XXSEAM) THEN
13126                      IXPS = IXPS-ISQ+1
13127                      GOTO 40
13128                   ENDIF
13129 *     accept this sea-quark pair
13130                   IXPS         = IXPS+1
13131                   XPSQ(IXPS)   = XPSQI
13132                   XPSAQ(IXPS)  = XPSAQI
13133                   IFROSP(IXPS) = IPP
13134                   ZUOSP(IXPS)  = .TRUE.
13135    70          CONTINUE
13136             ENDIF
13137
13138 *>>>get x-values of valence partons
13139 *     valence quark
13140             IF (XVTHR.GT.0.05D0) THEN
13141                XVHI  = ONE-XXSEA-XDTHR
13142                XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
13143             ELSE
13144    90          CONTINUE
13145                XPVQI = DT_DBETAR(OHALF,UNOPRV)
13146                IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
13147      &                                                     GOTO 90
13148             ENDIF
13149 *     valence diquark
13150             XPVDI = ONE-XPVQI-XXSEA
13151 *       reject according to x**1.5
13152             XDTMP = XPVDI**1.5D0
13153             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
13154 *     accept these valence partons
13155             IXPV         = IXPV+1
13156             XPVQ(IXPV)   = XPVQI
13157             XPVD(IXPV)   = XPVDI
13158             IFROVP(IXPV) = IPP
13159             ITOVP(IPP)   = IXPV
13160             ZUOVP(IXPV)  = .TRUE.
13161
13162          ENDIF
13163   100 CONTINUE
13164
13165 * (3) select parton x-values of interacting target nucleons
13166 *-----------------------------------------------------------------------
13167
13168       IXTV = 0
13169       IXTS = 0
13170
13171       DO 170 ITT=1,IT
13172 *   get interacting target nucleon as sampled by Glauber
13173          IF (JTSH(ITT).NE.0) THEN
13174             IXSTMP = IXTS
13175             IXVTMP = IXTV
13176   169       CONTINUE
13177             IXTS   = IXSTMP
13178             IXTV   = IXVTMP
13179 *     JITT is the actual number of sea-pairs sampled for this nucleon
13180             JITT   = MIN(JTSH(ITT)-1,NSMAX)
13181   111       CONTINUE
13182             XXSEA  = ZERO
13183             IF (JITT.GT.0) THEN
13184                XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
13185 *???
13186                IF (XSTHR.GE.XSMAX) THEN
13187                   JITT = JITT-1
13188                   GOTO 111
13189                ENDIF
13190
13191 *>>>get x-values of sea-quark pairs
13192                NSCOUN = 0
13193                PLW = 0.5D0
13194   110          CONTINUE
13195 *     accumulator for sea x-values
13196                XXSEA  = ZERO
13197                NSCOUN = NSCOUN+1
13198                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
13199                IF (NSCOUN.GT.NSEA)THEN
13200 *     decrease the number of interactions after NSEA trials
13201                   JITT   = JITT-1
13202                   NSCOUN = 0
13203                ENDIF
13204                DO 140 ISQ=1,JITT
13205 *     sea-quarks
13206                   IF (ITSQ(IXTS+1).LE.2) THEN
13207 **sr 8.4.98 (1/sqrt(x))
13208 C                    XTSQI = DT_SAMPEX(XSTHR,XSMAX)
13209 C                    XTSQI = DT_SAMSQX(XSTHR,XSMAX)
13210                      XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13211 **
13212                   ELSE
13213                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
13214                         XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13215                      ELSE
13216 **sr 8.4.98 (1/sqrt(x))
13217 C                       XTSQI = DT_SAMPEX(XSTHR,XSMAX)
13218 C                       XTSQI = DT_SAMSQX(XSTHR,XSMAX)
13219                         XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13220 **
13221                      ENDIF
13222                   ENDIF
13223 *     sea-antiquarks
13224                   IF (ITSAQ(IXTS+1).GE.-2) THEN
13225 **sr 8.4.98 (1/sqrt(x))
13226 C                    XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
13227 C                    XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
13228                      XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13229 **
13230                   ELSE
13231                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
13232                         XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13233                      ELSE
13234 **sr 8.4.98 (1/sqrt(x))
13235 C                       XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
13236 C                       XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
13237                         XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13238 **
13239                      ENDIF
13240                   ENDIF
13241                   XXSEA = XXSEA+XTSQI+XTSAQI
13242 *     check for maximum allowed sea x-value
13243                   IF (XXSEA.GE.XXSEAM) THEN
13244                      IXTS = IXTS-ISQ+1
13245                      GOTO 110
13246                   ENDIF
13247 *     accept this sea-quark pair
13248                   IXTS         = IXTS+1
13249                   XTSQ(IXTS)   = XTSQI
13250                   XTSAQ(IXTS)  = XTSAQI
13251                   IFROST(IXTS) = ITT
13252                   ZUOST(IXTS)  = .TRUE.
13253   140          CONTINUE
13254             ENDIF
13255
13256 *>>>get x-values of valence partons
13257 *     valence quark
13258             IF (XVTHR.GT.0.05D0) THEN
13259                XVHI  = ONE-XXSEA-XDTHR
13260                XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
13261             ELSE
13262   160          CONTINUE
13263                XTVQI = DT_DBETAR(OHALF,UNON)
13264                IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
13265      &                                                    GOTO 160
13266             ENDIF
13267 *     valence diquark
13268             XTVDI = ONE-XTVQI-XXSEA
13269 *       reject according to x**1.5
13270             XDTMP = XTVDI**1.5D0
13271             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
13272 *     accept these valence partons
13273             IXTV         = IXTV+1
13274             XTVQ(IXTV)   = XTVQI
13275             XTVD(IXTV)   = XTVDI
13276             IFROVT(IXTV) = ITT
13277             ITOVT(ITT)   = IXTV
13278             ZUOVT(IXTV)  = .TRUE.
13279
13280          ENDIF
13281   170 CONTINUE
13282
13283 * (4) get valence-valence chains
13284 *-----------------------------------------------------------------------
13285
13286       NVV = 0
13287       DO 240 I=1,NN
13288          INTLO(I) = .TRUE.
13289          IPVAL    = ITOVP(INTER1(I))
13290          ITVAL    = ITOVT(INTER2(I))
13291          IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
13292             INTLO(I)      = .FALSE.
13293             ZUOVP(IPVAL)  = .FALSE.
13294             ZUOVT(ITVAL)  = .FALSE.
13295             NVV           = NVV+1
13296             ISKPCH(8,NVV) = 0
13297             INTVV1(NVV)   = IPVAL
13298             INTVV2(NVV)   = ITVAL
13299          ENDIF
13300   240 CONTINUE
13301
13302 * (5) get sea-valence chains
13303 *-----------------------------------------------------------------------
13304
13305       NSV = 0
13306       NDV = 0
13307       PLW = 0.5D0
13308       DO 270 I=1,NN
13309          IF (INTLO(I)) THEN
13310             IPVAL = ITOVP(INTER1(I))
13311             ITVAL = ITOVT(INTER2(I))
13312             DO 250 J=1,IXPS
13313                IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
13314      &                                ZUOVT(ITVAL)) THEN
13315                   ZUOSP(J)     = .FALSE.
13316                   ZUOVT(ITVAL) = .FALSE.
13317                   INTLO(I)     = .FALSE.
13318                   IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
13319 *   sample sea-diquark pair
13320                      CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
13321                      IF (IREJ1.EQ.0) GOTO 260
13322                   ENDIF
13323                   NSV           = NSV+1
13324                   ISKPCH(4,NSV) = 0
13325                   INTSV1(NSV)   = J
13326                   INTSV2(NSV)   = ITVAL
13327
13328 *>>>correct chain kinematics according to minimum chain masses
13329 *     the actual chain masses
13330                   AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
13331                   AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
13332 *     get lower mass cuts
13333                   IF (IPSQ(J).EQ.3) THEN
13334 *       q being s-quark
13335                      AMCHK1 = AMAS
13336                      AMCHK2 = AMIS
13337                   ELSE
13338 *       q being u/d-quark
13339                      AMCHK1 = AMAU
13340                      AMCHK2 = AMIU
13341                   ENDIF
13342 *       q-qq chain
13343 *         chain mass above minimum - resampling of sea-q x-value
13344                   IF (AMSVQ1.GT.AMCHK1) THEN
13345                      XPSQTH      = AMCHK1/(XTVD(ITVAL)*ECM**2)
13346 **sr 8.4.98 (1/sqrt(x))
13347 C                    XPSQXX      = DT_SAMPEX(XPSQTH,XPSQ(J))
13348 C                    XPSQXX      = DT_SAMSQX(XPSQTH,XPSQ(J))
13349                      XPSQXX      = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
13350 **
13351                      XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
13352                      XPSQ(J)     = XPSQXX
13353 *         chain mass below minimum - reset sea-q x-value and correct
13354 *                                    diquark-x of the same nucleon
13355                   ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13356                      XPSQW       = AMCHK1/(XTVD(ITVAL)*ECM**2)
13357                      DXPSQ       = XPSQW-XPSQ(J)
13358                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
13359                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
13360                         XPSQ(J)     = XPSQW
13361                      ENDIF
13362                   ENDIF
13363 *       aq-q chain
13364 *         chain mass below minimum - reset sea-aq x-value and correct
13365 *                                    diquark-x of the same nucleon
13366                   IF (AMSVQ2.LT.AMCHK2) THEN
13367                      XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
13368                      DXPSQ = XPSQW-XPSAQ(J)
13369                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
13370                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
13371                         XPSAQ(J)    = XPSQW
13372                      ENDIF
13373                   ENDIF
13374 *>>>end of chain mass correction
13375
13376                   GOTO 260
13377                ENDIF
13378   250       CONTINUE
13379          ENDIF
13380   260    CONTINUE
13381   270 CONTINUE
13382
13383 * (6) get valence-sea chains
13384 *-----------------------------------------------------------------------
13385
13386       NVS = 0
13387       NVD = 0
13388       DO 300 I=1,NN
13389          IF (INTLO(I)) THEN
13390             IPVAL = ITOVP(INTER1(I))
13391             ITVAL = ITOVT(INTER2(I))
13392             DO 280 J=1,IXTS
13393                IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
13394      &                  (IFROST(J).EQ.INTER2(I))) THEN
13395                   ZUOST(J)     = .FALSE.
13396                   ZUOVP(IPVAL) = .FALSE.
13397                   INTLO(I)     = .FALSE.
13398                   IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13399 *   sample sea-diquark pair
13400                      CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
13401                      IF (IREJ1.EQ.0) GOTO 290
13402                   ENDIF
13403                   NVS           = NVS + 1
13404                   ISKPCH(6,NVS) = 0
13405                   INTVS1(NVS)   = IPVAL
13406                   INTVS2(NVS)   = J
13407
13408 *>>>correct chain kinematics according to minimum chain masses
13409 *     the actual chain masses
13410                   AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
13411                   AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
13412 *     get lower mass cuts
13413                   IF (ITSQ(J).EQ.3) THEN
13414 *       q being s-quark
13415                      AMCHK1 = AMIS
13416                      AMCHK2 = AMAS
13417                   ELSE
13418 *       q being u/d-quark
13419                      AMCHK1 = AMIU
13420                      AMCHK2 = AMAU
13421                   ENDIF
13422 *       q-aq chain
13423 *         chain mass below minimum - reset sea-aq x-value and correct
13424 *                                    diquark-x of the same nucleon
13425                   IF (AMVSQ1.LT.AMCHK1) THEN
13426                      XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
13427                      DXTSQ = XTSQW-XTSAQ(J)
13428                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
13429                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
13430                         XTSAQ(J)    = XTSQW
13431                      ENDIF
13432                   ENDIF
13433 *       qq-q chain
13434 *         chain mass above minimum - resampling of sea-q x-value
13435                   IF (AMVSQ2.GT.AMCHK2) THEN
13436                      XTSQTH      = AMCHK2/(XPVD(IPVAL)*ECM**2)
13437 **sr 8.4.98 (1/sqrt(x))
13438 C                    XTSQXX      = DT_SAMPEX(XTSQTH,XTSQ(J))
13439 C                    XTSQXX      = DT_SAMSQX(XTSQTH,XTSQ(J))
13440                      XTSQXX      = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13441 **
13442                      XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
13443                      XTSQ(J)     = XTSQXX
13444 *         chain mass below minimum - reset sea-q x-value and correct
13445 *                                    diquark-x of the same nucleon
13446                   ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13447                      XTSQW       = AMCHK2/(XPVD(IPVAL)*ECM**2)
13448                      DXTSQ       = XTSQW-XTSQ(J)
13449                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
13450                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
13451                         XTSQ(J)     = XTSQW
13452                      ENDIF
13453                   ENDIF
13454 *>>>end of chain mass correction
13455
13456                   GOTO 290
13457                ENDIF
13458   280       CONTINUE
13459          ENDIF
13460   290    CONTINUE
13461   300 CONTINUE
13462
13463 * (7) get sea-sea chains
13464 *-----------------------------------------------------------------------
13465
13466       NSS = 0
13467       NDS = 0
13468       NSD = 0
13469       DO 420 I=1,NN
13470          IF (INTLO(I)) THEN
13471             IPVAL = ITOVP(INTER1(I))
13472             ITVAL = ITOVT(INTER2(I))
13473 *   loop over target partons not yet matched
13474             DO 400 J=1,IXTS
13475                IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
13476 *   loop over projectile partons not yet matched
13477                   DO 390 JJ=1,IXPS
13478                      IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
13479                         ZUOSP(JJ)     = .FALSE.
13480                         ZUOST(J)      = .FALSE.
13481                         INTLO(I)      = .FALSE.
13482                         NSS           = NSS+1
13483                         ISKPCH(1,NSS) = 0
13484                         INTSS1(NSS)   = JJ
13485                         INTSS2(NSS)   = J
13486
13487 *---->chain recombination option
13488                         VALFRA        = DBLE(NVV/(NVV+IXPS+IXTS))
13489                         IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
13490      &                                                             THEN
13491 *       sea-sea chains may recombine with valence-valence chains
13492 *       only if they have the same projectile or target nucleon
13493                            DO 4201 IVV=1,NVV
13494                               IF (ISKPCH(8,IVV).NE.99) THEN
13495                                  IXVPR = INTVV1(IVV)
13496                                  IXVTA = INTVV2(IVV)
13497                                  IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
13498      &                               (INTER2(I).EQ.IFROVT(IXVTA))) THEN
13499 *         recombination possible, drop old v-v and s-s chains
13500                                     ISKPCH(1,NSS) = 99
13501                                     ISKPCH(8,IVV) = 99
13502
13503 *         (a) assign new s-v chains
13504 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
13505                                     IF (LSEADI.AND.
13506      &                                  (DT_RNDM(VALFRA).GT.FRCDIQ))
13507      &                                                             THEN
13508 *           sample sea-diquark pair
13509                                        CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
13510      &                                                      IREJ1)
13511                                        IF (IREJ1.EQ.0) GOTO 4202
13512                                     ENDIF
13513                                     NSV           = NSV+1
13514                                     ISKPCH(4,NSV) = 0
13515                                     INTSV1(NSV)   = JJ
13516                                     INTSV2(NSV)   = IXVTA
13517 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13518 *           the actual chain masses
13519                                     AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
13520      &                                                     *ECM**2
13521                                     AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
13522      &                                                     *ECM**2
13523 *           get lower mass cuts
13524                                     IF (IPSQ(JJ).EQ.3) THEN
13525 *             q being s-quark
13526                                        AMCHK1 = AMAS
13527                                        AMCHK2 = AMIS
13528                                     ELSE
13529 *             q being u/d-quark
13530                                        AMCHK1 = AMAU
13531                                        AMCHK2 = AMIU
13532                                     ENDIF
13533 *           q-qq chain
13534 *             chain mass above minimum - resampling of sea-q x-value
13535                                     IF (AMSVQ1.GT.AMCHK1) THEN
13536                                        XPSQTH      =
13537      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
13538 **sr 8.4.98 (1/sqrt(x))
13539                                        XPSQXX      =
13540      &                                    DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
13541 C    &                                    DT_SAMSQX(XPSQTH,XPSQ(JJ))
13542 C    &                                    DT_SAMPEX(XPSQTH,XPSQ(JJ))
13543 **
13544                                        XPVD(IPVAL) =
13545      &                                    XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
13546                                        XPSQ(JJ)    = XPSQXX
13547 *             chain mass below minimum - reset sea-q x-value and correct
13548 *                                        diquark-x of the same nucleon
13549                                     ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13550                                        XPSQW =
13551      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
13552                                        DXPSQ = XPSQW-XPSQ(JJ)
13553                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13554      &                                                            THEN
13555                                           XPVD(IPVAL) =
13556      &                                       XPVD(IPVAL)-DXPSQ
13557                                           XPSQ(JJ)    = XPSQW
13558                                        ENDIF
13559                                     ENDIF
13560 *           aq-q chain
13561 *             chain mass below minimum - reset sea-aq x-value and correct
13562 *                                        diquark-x of the same nucleon
13563                                     IF (AMSVQ2.LT.AMCHK2) THEN
13564                                        XPSQW =
13565      &                                    AMCHK2/(XTVQ(IXVTA)*ECM**2)
13566                                        DXPSQ = XPSQW-XPSAQ(JJ)
13567                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13568      &                                                            THEN
13569                                           XPVD(IPVAL) =
13570      &                                       XPVD(IPVAL)-DXPSQ
13571                                           XPSAQ(JJ)   = XPSQW
13572                                        ENDIF
13573                                     ENDIF
13574 *>>>>>>>>>>>end of chain mass correction
13575  4202                               CONTINUE
13576
13577 *         (b) assign new v-s chains
13578 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
13579                                     IF (LSEADI.AND.(
13580      &                                  DT_RNDM(AMSVQ2).GT.FRCDIQ))
13581      &                                                             THEN
13582 *           sample sea-diquark pair
13583                                        CALL DT_SAMSDQ(ECM,IXVPR,J,1,
13584      &                                                      IREJ1)
13585                                        IF (IREJ1.EQ.0) GOTO 4203
13586                                     ENDIF
13587                                     NVS           = NVS+1
13588                                     ISKPCH(6,NVS) = 0
13589                                     INTVS1(NVS)   = IXVPR
13590                                     INTVS2(NVS)   = J
13591 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13592 *           the actual chain masses
13593                                     AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
13594                                     AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
13595 *           get lower mass cuts
13596                                     IF (ITSQ(J).EQ.3) THEN
13597 *             q being s-quark
13598                                        AMCHK1 = AMIS
13599                                        AMCHK2 = AMAS
13600                                     ELSE
13601 *             q being u/d-quark
13602                                        AMCHK1 = AMIU
13603                                        AMCHK2 = AMAU
13604                                     ENDIF
13605 *           q-aq chain
13606 *             chain mass below minimum - reset sea-aq x-value and correct
13607 *                                        diquark-x of the same nucleon
13608                                     IF (AMVSQ1.LT.AMCHK1) THEN
13609                                        XTSQW =
13610      &                                    AMCHK1/(XPVQ(IXVPR)*ECM**2)
13611                                        DXTSQ = XTSQW-XTSAQ(J)
13612                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13613      &                                                            THEN
13614                                           XTVD(ITVAL) =
13615      &                                       XTVD(ITVAL)-DXTSQ
13616                                           XTSAQ(J)    = XTSQW
13617                                        ENDIF
13618                                     ENDIF
13619                                     IF (AMVSQ2.GT.AMCHK2) THEN
13620                                        XTSQTH      =
13621      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
13622 **sr 8.4.98 (1/sqrt(x))
13623                                        XTSQXX      =
13624      &                                    DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13625 C    &                                    DT_SAMSQX(XTSQTH,XTSQ(J))
13626 C    &                                    DT_SAMPEX(XTSQTH,XTSQ(J))
13627 **
13628                                        XTVD(ITVAL) =
13629      &                                    XTVD(ITVAL)+XTSQ(J)-XTSQXX
13630                                        XTSQ(J)     = XTSQXX
13631                                     ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13632                                        XTSQW =
13633      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
13634                                        DXTSQ = XTSQW-XTSQ(J)
13635                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13636      &                                                            THEN
13637                                           XTVD(ITVAL) =
13638      &                                       XTVD(ITVAL)-DXTSQ
13639                                           XTSQ(J)     = XTSQW
13640                                        ENDIF
13641                                     ENDIF
13642 *>>>>>>>>>end of chain mass correction
13643  4203                               CONTINUE
13644 *       jump out of s-s chain loop
13645                                     GOTO 420
13646                                  ENDIF
13647                               ENDIF
13648  4201                      CONTINUE
13649                         ENDIF
13650 *---->end of chain recombination option
13651
13652 *     sample sea-diquark pair (projectile)
13653                         IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13654                            CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13655                            IF (IREJ1.EQ.0) THEN
13656                               ISKPCH(1,NSS) = 99
13657                               GOTO 410
13658                            ENDIF
13659                         ENDIF
13660 *     sample sea-diquark pair (target)
13661                         IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13662                            CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13663                            IF (IREJ1.EQ.0) THEN
13664                               ISKPCH(1,NSS) = 99
13665                               GOTO 410
13666                            ENDIF
13667                         ENDIF
13668 *>>>>>correct chain kinematics according to minimum chain masses
13669 *     the actual chain masses
13670                         SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13671                         SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13672 *     check for lower mass cuts
13673                         IF ((SSMA1Q.LT.SSMIMQ).OR.
13674      &                      (SSMA2Q.LT.SSMIMQ)) THEN
13675                            IPVAL = ITOVP(INTER1(I))
13676                            ITVAL = ITOVT(INTER2(I))
13677                            IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13678      &                         (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13679 *       maximum allowed x values for sea quarks
13680                               XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13681      &                                           1.2D0*XSSTHR
13682                               XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13683      &                                           1.2D0*XSSTHR
13684 *       resampling of x values not possible - skip sea-sea chains
13685                               IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13686      &                            (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13687 *       resampling of x for projectile sea quark pair
13688                               ICOUS = 0
13689   310                         CONTINUE
13690                               ICOUS = ICOUS+1
13691                               IF (XSSTHR.GT.0.05D0) THEN
13692                                  XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13693      &                                                         XSPMAX)
13694                                  XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13695      &                                                         XSPMAX)
13696                               ELSE
13697   320                            CONTINUE
13698                                  XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13699                                  IF ((XPSQI.LT.XSSTHR).OR.
13700      &                               (XPSQI.GT.XSPMAX))  GOTO 320
13701   330                            CONTINUE
13702                                  XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13703                                  IF ((XPSAQI.LT.XSSTHR).OR.
13704      &                               (XPSAQI.GT.XSPMAX)) GOTO 330
13705                               ENDIF
13706 *       final test of remaining x for projectile diquark
13707                               XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13708      &                                            +XPSQ(JJ)+XPSAQ(JJ)
13709                               IF (XPVDCO.LE.XDTHR) THEN
13710 *!!!
13711 C                                IF (ICOUS.LT.5) GOTO 310
13712                                  IF (ICOUS.LT.0.5D0) GOTO 310
13713                                  GOTO 380
13714                               ENDIF
13715 *       resampling of x for target sea quark pair
13716                               ICOUS = 0
13717   350                         CONTINUE
13718                               ICOUS = ICOUS+1
13719                               IF (XSSTHR.GT.0.05D0) THEN
13720                                  XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13721      &                                                         XSTMAX)
13722                                  XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13723      &                                                         XSTMAX)
13724                               ELSE
13725   360                            CONTINUE
13726                                  XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13727                                  IF ((XTSQI.LT.XSSTHR).OR.
13728      &                               (XTSQI.GT.XSTMAX))  GOTO 360
13729   370                            CONTINUE
13730                                  XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13731                                  IF ((XTSAQI.LT.XSSTHR).OR.
13732      &                               (XTSAQI.GT.XSTMAX)) GOTO 370
13733                               ENDIF
13734 *       final test of remaining x for target diquark
13735                               XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13736      &                                            +XTSQ(J)+XTSAQ(J)
13737                               IF (XTVDCO.LT.XDTHR) THEN
13738                                  IF (ICOUS.LT.5) GOTO 350
13739                                  GOTO 380
13740                               ENDIF
13741                               XPVD(IPVAL) = XPVDCO
13742                               XTVD(ITVAL) = XTVDCO
13743                               XPSQ(JJ)    = XPSQI
13744                               XPSAQ(JJ)   = XPSAQI
13745                               XTSQ(J)     = XTSQI
13746                               XTSAQ(J)    = XTSAQI
13747 *>>>>>end of chain mass correction
13748                               GOTO 410
13749                            ENDIF
13750 *     come here to discard s-s interaction
13751 *     resampling of x values not allowed or unsuccessful
13752   380                      CONTINUE
13753                            INTLO(I)  = .FALSE.
13754                            ZUOST(J)  = .TRUE.
13755                            ZUOSP(JJ) = .TRUE.
13756                            NSS       = NSS-1
13757                         ENDIF
13758 *   consider next s-s interaction
13759                         GOTO 410
13760                      ENDIF
13761   390             CONTINUE
13762                ENDIF
13763   400       CONTINUE
13764          ENDIF
13765   410    CONTINUE
13766   420 CONTINUE
13767
13768 * correct x-values of valence quarks for non-matching sea quarks
13769       DO 430 I=1,IXPS
13770          IF (ZUOSP(I)) THEN
13771             IPVAL       = ITOVP(IFROSP(I))
13772             XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13773             XPSQ(I)     = ZERO
13774             XPSAQ(I)    = ZERO
13775             ZUOSP(I)    = .FALSE.
13776          ENDIF
13777   430 CONTINUE
13778       DO 440 I=1,IXTS
13779          IF (ZUOST(I)) THEN
13780             ITVAL       = ITOVT(IFROST(I))
13781             XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13782             XTSQ(I)     = ZERO
13783             XTSAQ(I)    = ZERO
13784             ZUOST(I)    = .FALSE.
13785          ENDIF
13786   440 CONTINUE
13787       DO 450 I=1,IXPV
13788          IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13789   450 CONTINUE
13790       DO 460 I=1,IXTV
13791          IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13792   460 CONTINUE
13793
13794       RETURN
13795       END
13796
13797 *$ CREATE DT_SAMSDQ.FOR
13798 *COPY DT_SAMSDQ
13799 *
13800 *===samsdq=============================================================*
13801 *
13802       SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13803
13804 ************************************************************************
13805 * SAMpling of Sea-DiQuarks                                             *
13806 *              ECM        cm-energy of the nucleon-nucleon system      *
13807 *              IDX1,2     indices of x-values of the participating     *
13808 *                         partons (IDX2 is always the sea-q-pair to be *
13809 *                         changed to sea-qq-pair)                      *
13810 *              MODE       = 1  valence-q - sea-diq                     *
13811 *                         = 2  sea-diq   - valence-q                   *
13812 *                         = 3  sea-q     - sea-diq                     *
13813 *                         = 4  sea-diq   - sea-q                       *
13814 * Based on DIQVS, DIQSV, DIQSSD, DIQDSS.                               *
13815 * This version dated 17.10.95 is written by S. Roesler                 *
13816 ************************************************************************
13817
13818       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13819       SAVE
13820
13821       PARAMETER (ZERO=0.0D0)
13822
13823 * threshold values for x-sampling (DTUNUC 1.x)
13824       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13825      &                SSMIMQ,VVMTHR
13826
13827 * various options for treatment of partons (DTUNUC 1.x)
13828 * (chain recombination, Cronin,..)
13829       LOGICAL LCO2CR,LINTPT
13830       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13831      &                LCO2CR,LINTPT
13832
13833       PARAMETER ( MAXNCL = 260,
13834
13835      &            MAXVQU = MAXNCL,
13836      &            MAXSQU = 20*MAXVQU,
13837      &            MAXINT = MAXVQU+MAXSQU)
13838
13839 * x-values of partons (DTUNUC 1.x)
13840       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13841      &                XTVQ(MAXVQU),XTVD(MAXVQU),
13842      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
13843      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
13844
13845 * flavors of partons (DTUNUC 1.x)
13846       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13847      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13848      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
13849      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13850      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
13851      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13852      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
13853
13854 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13855       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13856      &                IXPV,IXPS,IXTV,IXTS,
13857      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
13858      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
13859      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
13860      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
13861      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
13862      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
13863      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
13864      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
13865
13866 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13867       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13868      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13869
13870 * auxiliary common for chain system storage (DTUNUC 1.x)
13871       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13872
13873       IREJ = 0
13874 *  threshold-x for valence diquarks
13875       XDTHR = CDQ/ECM
13876
13877       GOTO (1,2,3,4) MODE
13878
13879 *---------------------------------------------------------------------
13880 * proj. valence partons - targ. sea partons
13881 * get x-values and flavors for target sea-diquark pair
13882
13883     1 CONTINUE
13884       IDXVP = IDX1
13885       IDXST = IDX2
13886
13887 *  index of corr. val-diquark-x in target nucleon
13888       IDXVT = ITOVT(IFROST(IDXST))
13889 *  available x above diquark thresholds for valence- and sea-diquarks
13890       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13891
13892       IF (XXD.GE.ZERO) THEN
13893 *  x-values for the three diquarks of the target nucleon
13894          RR1    = DT_RNDM(XXD)
13895          RR2    = DT_RNDM(RR1)
13896          RR3    = DT_RNDM(RR2)
13897          SR123  = RR1+RR2+RR3
13898          XXTV   = XDTHR+RR1*XXD/SR123
13899          XXTSQ  = XDTHR+RR2*XXD/SR123
13900          XXTSAQ = XDTHR+RR3*XXD/SR123
13901       ELSE
13902          XXTV   = XTVD(IDXVT)
13903          XXTSQ  = XTSQ(IDXST)
13904          XXTSAQ = XTSAQ(IDXST)
13905       ENDIF
13906 *  flavor of the second quarks in the sea-diquark pair
13907       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13908       ITSAQ2(IDXST) = -ITSQ2(IDXST)
13909 *  check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13910       AM1    = XXTSQ *XPVQ(IDXVP)*ECM**2
13911       AM2    = XXTSAQ*XPVD(IDXVP)*ECM**2
13912       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13913 *    ss-asas pair
13914      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13915          IREJ = 1
13916          RETURN
13917       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13918 *    at least one strange quark
13919      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13920          IREJ = 1
13921          RETURN
13922       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13923          IREJ = 1
13924          RETURN
13925       ENDIF
13926 *  accept the new sea-diquark
13927       XTVD(IDXVT)   = XXTV
13928       XTSQ(IDXST)   = XXTSQ
13929       XTSAQ(IDXST)  = XXTSAQ
13930       NVD           = NVD+1
13931       INTVD1(NVD)   = IDXVP
13932       INTVD2(NVD)   = IDXST
13933       ISKPCH(7,NVD) = 0
13934       RETURN
13935
13936 *---------------------------------------------------------------------
13937 * proj. sea partons - targ. valence partons
13938 * get x-values and flavors for projectile sea-diquark pair
13939
13940     2 CONTINUE
13941       IDXSP = IDX2
13942       IDXVT = IDX1
13943
13944 *  index of corr. val-diquark-x in projectile nucleon
13945       IDXVP = ITOVP(IFROSP(IDXSP))
13946 *  available x above diquark thresholds for valence- and sea-diquarks
13947       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13948
13949       IF (XXD.GE.ZERO) THEN
13950 *  x-values for the three diquarks of the projectile nucleon
13951          RR1    = DT_RNDM(XXD)
13952          RR2    = DT_RNDM(RR1)
13953          RR3    = DT_RNDM(RR2)
13954          SR123  = RR1+RR2+RR3
13955          XXPV   = XDTHR+RR1*XXD/SR123
13956          XXPSQ  = XDTHR+RR2*XXD/SR123
13957          XXPSAQ = XDTHR+RR3*XXD/SR123
13958       ELSE
13959          XXPV   = XPVD(IDXVP)
13960          XXPSQ  = XPSQ(IDXSP)
13961          XXPSAQ = XPSAQ(IDXSP)
13962       ENDIF
13963 *  flavor of the second quarks in the sea-diquark pair
13964       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13965       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13966 *  check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13967       AM1    = XXPSQ *XTVQ(IDXVT)*ECM**2
13968       AM2    = XXPSAQ*XTVD(IDXVT)*ECM**2
13969       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13970 *    ss-asas pair
13971      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13972          IREJ = 1
13973          RETURN
13974       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13975 *    at least one strange quark
13976      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13977          IREJ = 1
13978          RETURN
13979       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13980          IREJ = 1
13981          RETURN
13982       ENDIF
13983 *  accept the new sea-diquark
13984       XPVD(IDXVP)   = XXPV
13985       XPSQ(IDXSP)   = XXPSQ
13986       XPSAQ(IDXSP)  = XXPSAQ
13987       NDV           = NDV+1
13988       INTDV1(NDV)   = IDXSP
13989       INTDV2(NDV)   = IDXVT
13990       ISKPCH(5,NDV) = 0
13991       RETURN
13992
13993 *---------------------------------------------------------------------
13994 * proj. sea partons - targ. sea partons
13995 * get x-values and flavors for target sea-diquark pair
13996
13997     3 CONTINUE
13998       IDXSP = IDX1
13999       IDXST = IDX2
14000
14001 *  index of corr. val-diquark-x in target nucleon
14002       IDXVT = ITOVT(IFROST(IDXST))
14003 *  available x above diquark thresholds for valence- and sea-diquarks
14004       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
14005
14006       IF (XXD.GE.ZERO) THEN
14007 *  x-values for the three diquarks of the target nucleon
14008          RR1    = DT_RNDM(XXD)
14009          RR2    = DT_RNDM(RR1)
14010          RR3    = DT_RNDM(RR2)
14011          SR123  = RR1+RR2+RR3
14012          XXTV   = XDTHR+RR1*XXD/SR123
14013          XXTSQ  = XDTHR+RR2*XXD/SR123
14014          XXTSAQ = XDTHR+RR3*XXD/SR123
14015       ELSE
14016          XXTV   = XTVD(IDXVT)
14017          XXTSQ  = XTSQ(IDXST)
14018          XXTSAQ = XTSAQ(IDXST)
14019       ENDIF
14020 *  flavor of the second quarks in the sea-diquark pair
14021       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
14022       ITSAQ2(IDXST) = -ITSQ2(IDXST)
14023 *  check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
14024       AM1    = XXTSQ *XPSQ(IDXSP)*ECM**2
14025       AM2    = XXTSAQ*XPSAQ(IDXSP)*ECM**2
14026       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
14027 *    ss-asas pair
14028      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
14029          IREJ = 1
14030          RETURN
14031       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
14032 *    at least one strange quark
14033      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
14034          IREJ = 1
14035          RETURN
14036       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
14037          IREJ = 1
14038          RETURN
14039       ENDIF
14040 *  accept the new sea-diquark
14041       XTVD(IDXVT)   = XXTV
14042       XTSQ(IDXST)   = XXTSQ
14043       XTSAQ(IDXST)  = XXTSAQ
14044       NSD           = NSD+1
14045       INTSD1(NSD)   = IDXSP
14046       INTSD2(NSD)   = IDXST
14047       ISKPCH(3,NSD) = 0
14048       RETURN
14049
14050 *---------------------------------------------------------------------
14051 * proj. sea partons - targ. sea partons
14052 * get x-values and flavors for projectile sea-diquark pair
14053
14054     4 CONTINUE
14055       IDXSP = IDX2
14056       IDXST = IDX1
14057
14058 *  index of corr. val-diquark-x in projectile nucleon
14059       IDXVP = ITOVP(IFROSP(IDXSP))
14060 *  available x above diquark thresholds for valence- and sea-diquarks
14061       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
14062
14063       IF (XXD.GE.ZERO) THEN
14064 *  x-values for the three diquarks of the projectile nucleon
14065          RR1    = DT_RNDM(XXD)
14066          RR2    = DT_RNDM(RR1)
14067          RR3    = DT_RNDM(RR2)
14068          SR123  = RR1+RR2+RR3
14069          XXPV   = XDTHR+RR1*XXD/SR123
14070          XXPSQ  = XDTHR+RR2*XXD/SR123
14071          XXPSAQ = XDTHR+RR3*XXD/SR123
14072       ELSE
14073          XXPV   = XPVD(IDXVP)
14074          XXPSQ  = XPSQ(IDXSP)
14075          XXPSAQ = XPSAQ(IDXSP)
14076       ENDIF
14077 *  flavor of the second quarks in the sea-diquark pair
14078       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
14079       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
14080 *  check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
14081       AM1    = XXPSQ *XTSQ(IDXST)*ECM**2
14082       AM2    = XXPSAQ*XTSAQ(IDXST)*ECM**2
14083       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
14084 *    ss-asas pair
14085      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
14086          IREJ = 1
14087          RETURN
14088       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
14089 *    at least one strange quark
14090      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
14091          IREJ = 1
14092          RETURN
14093       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
14094          IREJ = 1
14095          RETURN
14096       ENDIF
14097 *  accept the new sea-diquark
14098       XPVD(IDXVP)   = XXPV
14099       XPSQ(IDXSP)   = XXPSQ
14100       XPSAQ(IDXSP)  = XXPSAQ
14101       NDS           = NDS+1
14102       INTDS1(NDS)   = IDXSP
14103       INTDS2(NDS)   = IDXST
14104       ISKPCH(2,NDS) = 0
14105       RETURN
14106       END
14107 *$ CREATE DT_DIFEVT.FOR
14108 *COPY DT_DIFEVT
14109 *
14110 *===difevt=============================================================*
14111 *
14112       SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
14113      &                  IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
14114
14115 ************************************************************************
14116 * Interface to treatment of diffractive interactions.                  *
14117 *  (input)          IFP1/2        PDG-indizes of projectile partons    *
14118 *                                 (baryon: IFP2 - adiquark)            *
14119 *                   PP(4)         projectile 4-momentum                *
14120 *                   IFT1/2        PDG-indizes of target partons        *
14121 *                                 (baryon: IFT1 - adiquark)            *
14122 *                   PT(4)         target 4-momentum                    *
14123 *  (output)         JDIFF = 0     no diffraction                       *
14124 *                         = 1/-1  LMSD/LMDD                            *
14125 *                         = 2/-2  HMSD/HMDD                            *
14126 *                   NCSY          counter for two-chain systems        *
14127 *                                 dumped to DTEVT1                     *
14128 * This version dated 14.02.95 is written by S. Roesler                 *
14129 ************************************************************************
14130
14131       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14132       SAVE
14133
14134       PARAMETER ( LINP = 10 ,
14135      &            LOUT = 6 ,
14136      &            LDAT = 9 )
14137
14138       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
14139      &           OHALF=0.5D0)
14140
14141 * event history
14142
14143       PARAMETER (NMXHKK=200000)
14144
14145       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14146      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14147      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14148
14149 * extended event history
14150       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14151      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14152      &                IHIST(2,NMXHKK)
14153
14154 * flags for diffractive interactions (DTUNUC 1.x)
14155       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14156
14157       DIMENSION PP(4),PT(4)
14158
14159       LOGICAL LFIRST
14160       DATA LFIRST /.TRUE./
14161
14162       IREJ   = 0
14163       JDIFF  = 0
14164       IFLAGD = JDIFF
14165
14166 * cm. energy
14167       XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
14168      &          (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
14169 * identities of projectile hadron / target nucleon
14170       KPROJ = IDT_ICIHAD(IDHKK(MOP))
14171       KTARG = IDT_ICIHAD(IDHKK(MOT))
14172
14173 * single diffractive xsections
14174       CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
14175 * double diffractive xsections
14176 **!! no double diff yet
14177 C     CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
14178       DDTOT = 0.0D0
14179       DDHM  = 0.0D0
14180 **!!
14181 * total inelastic xsection
14182 C     SIGIN  = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
14183       DUMZER = ZERO
14184       CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
14185       SIGIN  = MAX(SIGTO-SIGEL,ZERO)
14186
14187 * fraction of diffractive processes
14188       FRADIF = (SDTOT+DDTOT)/SIGIN
14189
14190       IF (LFIRST) THEN
14191          WRITE(LOUT,1000) XM,SDTOT,SIGIN
14192  1000    FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
14193      &          F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
14194      &          F5.1,' mb',/)
14195          LFIRST = .FALSE.
14196       ENDIF
14197
14198       IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
14199      &    (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
14200 * diffractive interaction requested by x-section or by user
14201          FRASD  = SDTOT/(SDTOT+DDTOT)
14202          FRASDH = SDHM/SDTOT
14203 **sr needs to be specified!!
14204 C        FRADDH = DDHM/DDTOT
14205          FRADDH = 1.0D0
14206 **
14207          IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
14208 *   single diffraction
14209             KDIFF = 1
14210             IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
14211                KP = 2
14212                KT = 0
14213                IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
14214      &               ISINGD.NE.3) THEN
14215                   KP = 0
14216                   KT = 2
14217                ENDIF
14218             ELSE
14219                KP = 1
14220                KT = 0
14221                IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
14222      &               ISINGD.NE.3) THEN
14223                   KP = 0
14224                   KT = 1
14225                ENDIF
14226             ENDIF
14227          ELSE
14228 *   double diffraction
14229             KDIFF = -1
14230             IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
14231                KP = 2
14232                KT = 2
14233             ELSE
14234                KP = 1
14235                KT = 1
14236             ENDIF
14237          ENDIF
14238          CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
14239      &               IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
14240          IF (IREJ1.EQ.0) THEN
14241             IFLAGD = 2*KDIFF
14242             IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
14243          ELSE
14244             GOTO 9999
14245          ENDIF
14246       ENDIF
14247       JDIFF = IFLAGD
14248
14249       RETURN
14250
14251  9999 CONTINUE
14252       IREJ  = 1
14253       RETURN
14254       END
14255
14256 *$ CREATE DT_DIFFKI.FOR
14257 *COPY DT_DIFFKI
14258 *
14259 *===difkin=============================================================*
14260 *
14261       SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
14262      &                  IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
14263
14264 ************************************************************************
14265 * Kinematics of diffractive nucleon-nucleon interaction.               *
14266 *          IFP1/2   PDG-indizes of projectile partons                  *
14267 *                   (baryon: IFP2 - adiquark)                          *
14268 *          PP(4)    projectile 4-momentum                              *
14269 *          IFT1/2   PDG-indizes of target partons                      *
14270 *                   (baryon: IFT1 - adiquark)                          *
14271 *          PT(4)    target 4-momentum                                  *
14272 *          KP   = 0 projectile quasi-elastically scattered             *
14273 *               = 1            excited to low-mass diff. state         *
14274 *               = 2            excited to high-mass diff. state        *
14275 *          KT   = 0 target     quasi-elastically scattered             *
14276 *               = 1            excited to low-mass diff. state         *
14277 *               = 2            excited to high-mass diff. state        *
14278 * This version dated 12.02.95 is written by S. Roesler                 *
14279 ************************************************************************
14280
14281       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14282       SAVE
14283
14284       PARAMETER ( LINP = 10 ,
14285      &            LOUT = 6 ,
14286      &            LDAT = 9 )
14287
14288       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
14289
14290       LOGICAL LSTART
14291
14292 * particle properties (BAMJET index convention)
14293       CHARACTER*8  ANAME
14294       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14295      &                IICH(210),IIBAR(210),K1(210),K2(210)
14296
14297 * flags for input different options
14298       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14299       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14300      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14301
14302 * rejection counter
14303       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14304      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14305      &                IREXCI(3),IRDIFF(2),IRINC
14306
14307 * kinematics of diffractive interactions (DTUNUC 1.x)
14308       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14309      &                PPF(4),PTF(4),
14310      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14311      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14312
14313       DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
14314      &          PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
14315
14316       DATA LSTART /.TRUE./
14317
14318       IF (LSTART) THEN
14319          WRITE(LOUT,2000)
14320  2000    FORMAT(/,1X,'DIFEVT:  diffractive interactions treated ')
14321          LSTART = .FALSE.
14322       ENDIF
14323
14324       IREJ = 0
14325
14326 * initialize common /DTDIKI/
14327       CALL DT_DIFINI
14328 * store momenta of initial incoming particles for emc-check
14329       IF (LEMCCK) THEN
14330          CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
14331          CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
14332       ENDIF
14333
14334 * masses of initial particles
14335       XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
14336       XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
14337       IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
14338       XMP  = SQRT(XMP2)
14339       XMT  = SQRT(XMT2)
14340 * check quark-input (used to adjust coherence cond. for M-selection)
14341       IBP  = 0
14342       IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
14343       IBT  = 0
14344       IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
14345
14346 * parameter for Lorentz-transformation into nucleon-nucleon cms
14347       DO 3 K=1,4
14348          PITOT(K) = PP(K)+PT(K)
14349     3 CONTINUE
14350       XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
14351       IF (XMTOT2.LE.ZERO) THEN
14352          WRITE(LOUT,1000) XMTOT2
14353  1000    FORMAT(1X,'DIFEVT:   negative cm. energy!  ',
14354      &          'XMTOT2 = ',E12.3)
14355          GOTO 9999
14356       ENDIF
14357       XMTOT = SQRT(XMTOT2)
14358       DO 4 K=1,4
14359          BGTOT(K) = PITOT(K)/XMTOT
14360     4 CONTINUE
14361 * transformation of nucleons into cms
14362       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
14363      &            PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
14364       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
14365      &            PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
14366 * rotation angles
14367       COD = PP1(3)/PPTOT
14368 C     SID = SQRT((ONE-COD)*(ONE+COD))
14369       PPT = SQRT(PP1(1)**2+PP1(2)**2)
14370       SID = PPT/PPTOT
14371       COF = ONE
14372       SIF = ZERO
14373       IF(PPTOT*SID.GT.TINY10) THEN
14374          COF   = PP1(1)/(SID*PPTOT)
14375          SIF   = PP1(2)/(SID*PPTOT)
14376          ANORF = SQRT(COF*COF+SIF*SIF)
14377          COF   = COF/ANORF
14378          SIF   = SIF/ANORF
14379       ENDIF
14380 * check consistency
14381       DO 5 K=1,4
14382          DEV1(K) = ABS(PP1(K)+PT1(K))
14383     5 CONTINUE
14384       DEV1(4) = ABS(DEV1(4)-XMTOT)
14385       IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
14386      &    (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10))     THEN
14387          WRITE(LOUT,1001) DEV1
14388  1001    FORMAT(1X,'DIFEVT:   inconsitent Lorentz-transformation! ',
14389      &          /,8X,4E12.3)
14390          GOTO 9999
14391       ENDIF
14392
14393 * select x-fractions in high-mass diff. interactions
14394       IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
14395
14396 * select diffractive masses
14397 * - projectile
14398       IF (KP.EQ.1) THEN
14399          XMPF = DT_XMLMD(XMTOT)
14400          CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
14401          IF (IREJ1.GT.0) GOTO 9999
14402       ELSEIF (KP.EQ.2) THEN
14403          XMPF = DT_XMHMD(XMTOT,IBP,1)
14404       ELSE
14405          XMPF = XMP
14406       ENDIF
14407 * - target
14408       IF (KT.EQ.1) THEN
14409          XMTF = DT_XMLMD(XMTOT)
14410          CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
14411          IF (IREJ1.GT.0) GOTO 9999
14412       ELSEIF (KT.EQ.2) THEN
14413          XMTF = DT_XMHMD(XMTOT,IBT,2)
14414       ELSE
14415          XMTF = XMT
14416       ENDIF
14417
14418 * kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
14419       XMPF2 = XMPF**2
14420       XMTF2 = XMTF**2
14421       PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
14422       PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
14423
14424 * select momentum transfer (all t-values used here are <0)
14425 *   minimum absolute value to produce diffractive masses
14426       TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
14427       TT   = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
14428       IF (IREJ1.GT.0) GOTO 9999
14429
14430 * longitudinal momentum of excited/elastically scattered projectile
14431       PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
14432 * total transverse momentum due to t-selection
14433       PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
14434       IF (PPBLT2.LT.ZERO) THEN
14435          WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
14436  1002    FORMAT(1X,'DIFEVT:   inconsistent transverse momentum! ',
14437      &          E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
14438          GOTO 9999
14439       ENDIF
14440       CALL DT_DSFECF(SINPHI,COSPHI)
14441       PPBLT     = SQRT(PPBLT2)
14442       PPBLOB(1) = COSPHI*PPBLT
14443       PPBLOB(2) = SINPHI*PPBLT
14444
14445 * rotate excited/elastically scattered projectile into n-n cms.
14446       CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
14447      &                                                    XX,YY,ZZ)
14448       PPBLOB(1) = XX
14449       PPBLOB(2) = YY
14450       PPBLOB(3) = ZZ
14451
14452 * 4-momentum of excited/elastically scattered target and of exchanged
14453 * Pomeron
14454       DO 6 K=1,4
14455          IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
14456          PPOM1(K) = PP1(K)-PPBLOB(K)
14457     6 CONTINUE
14458       PTBLOB(4) = XMTOT-PPBLOB(4)
14459
14460 * Lorentz-transformation back into system of initial diff. collision
14461       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14462      &            PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
14463      &            PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
14464       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14465      &            PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
14466      &            PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
14467       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14468      &            PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
14469      &            PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
14470
14471 * store 4-momentum of elastically scattered particle (in single diff.
14472 * events)
14473       IF (KP.EQ.0) THEN
14474          DO 7 K=1,4
14475             PSC(K) = PPF(K)
14476     7    CONTINUE
14477       ELSEIF (KT.EQ.0) THEN
14478          DO 8 K=1,4
14479             PSC(K) = PTF(K)
14480     8    CONTINUE
14481       ENDIF
14482
14483 * check consistency of kinematical treatment so far
14484       IF (LEMCCK) THEN
14485          CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
14486          CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
14487          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
14488          IF (IREJ1.NE.0) GOTO 9999
14489       ENDIF
14490       DO 9 K=1,4
14491          DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
14492          DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
14493     9 CONTINUE
14494       IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
14495      &    (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
14496      &    (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
14497      &    (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5))     THEN
14498          WRITE(LOUT,1003) DEV1,DEV2
14499  1003    FORMAT(1X,'DIFEVT:   inconsitent kinematical treatment!  ',
14500      &          2(/,8X,4E12.3))
14501          GOTO 9999
14502       ENDIF
14503
14504 * kinematical treatment for low-mass diffraction
14505       CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
14506       IF (IREJ1.NE.0) GOTO 9999
14507
14508 * dump diffractive chains into DTEVT1
14509       CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
14510       IF (IREJ1.NE.0) GOTO 9999
14511
14512       RETURN
14513
14514  9999 CONTINUE
14515       IRDIFF(1) = IRDIFF(1)+1
14516       IREJ      = 1
14517       RETURN
14518       END
14519
14520 *$ CREATE DT_XMHMD.FOR
14521 *COPY DT_XMHMD
14522 *
14523 *===xmhmd==============================================================*
14524 *
14525       DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
14526
14527 ************************************************************************
14528 * Diffractive mass in high mass single/double diffractive events.      *
14529 * This version dated 11.02.95 is written by S. Roesler                 *
14530 ************************************************************************
14531
14532       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14533       SAVE
14534
14535       PARAMETER ( LINP = 10 ,
14536      &            LOUT = 6 ,
14537      &            LDAT = 9 )
14538
14539       PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
14540
14541 * kinematics of diffractive interactions (DTUNUC 1.x)
14542       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14543      &                PPF(4),PTF(4),
14544      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14545      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14546
14547 C     DATA XCOLOW /0.05D0/
14548       DATA XCOLOW /0.15D0/
14549
14550       DT_XMHMD = ZERO
14551       XH = XPH(2)
14552       IF (MODE.EQ.2) XH = XTH(2)
14553
14554 * minimum Pomeron-x for high-mass diffraction
14555 * (adjusted to get a smooth transition between HM and LM component)
14556       R = DT_RNDM(XH)
14557       XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
14558       IF (ECM.LE.300.0D0) THEN
14559          RR     = (1.0D0-EXP(-((ECM/140.0D0)**4)))
14560          XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
14561       ENDIF
14562 * maximum Pomeron-x for high-mass diffraction
14563 * (coherence condition, adjusted to fit to experimental data)
14564       IF (IB.NE.0) THEN
14565 *   baryon-diffraction
14566          XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
14567       ELSE
14568 *   meson-diffraction
14569          XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
14570       ENDIF
14571 * check boundaries
14572       IF (XDIMIN.GE.XDIMAX) THEN
14573          XDIMIN = OHALF*XDIMAX
14574       ENDIF
14575
14576       KLOOP = 0
14577     1 CONTINUE
14578       KLOOP = KLOOP+1
14579       IF (KLOOP.GT.20) RETURN
14580 * sample Pomeron-x from 1/x-distribution (critical Pomeron)
14581       XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
14582 * corr. diffr. mass
14583       DT_XMHMD = ECM*SQRT(XDIFF)
14584       IF (DT_XMHMD.LT.2.5D0) GOTO 1
14585
14586       RETURN
14587       END
14588
14589 *$ CREATE DT_XMLMD.FOR
14590 *COPY DT_XMLMD
14591 *
14592 *===xmlmd==============================================================*
14593 *
14594       DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
14595
14596 ************************************************************************
14597 * Diffractive mass in high mass single/double diffractive events.      *
14598 * This version dated 11.02.95 is written by S. Roesler                 *
14599 ************************************************************************
14600
14601       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14602       SAVE
14603
14604       PARAMETER ( LINP = 10 ,
14605      &            LOUT = 6 ,
14606      &            LDAT = 9 )
14607
14608 * minimum Pomeron-x for low-mass diffraction
14609 C     AMO = 1.5D0
14610       AMO = 2.0D0
14611 * maximum Pomeron-x for low-mass diffraction
14612 * (adjusted to get a smooth transition between HM and LM component)
14613       R   = DT_RNDM(AMO)
14614       SAM = 1.0D0
14615       IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
14616       R   = DT_RNDM(AMO)*SAM
14617       AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
14618       AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
14619
14620 * selection of diffractive mass
14621 * (adjusted to get a smooth transition between HM and LM component)
14622       R   = DT_RNDM(AMU)
14623       IF (ECM.LE.50.0D0) THEN
14624          DT_XMLMD = AMO*(AMU/AMO)**R
14625       ELSE
14626          A = 0.7D0
14627          IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
14628          DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
14629       ENDIF
14630
14631       RETURN
14632       END
14633
14634 *$ CREATE DT_TDIFF.FOR
14635 *COPY DT_TDIFF
14636 *
14637 *===tdiff==============================================================*
14638 *
14639       DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
14640
14641 ************************************************************************
14642 * t-selection for single/double diffractive interactions.              *
14643 *          ECM      cm. energy                                         *
14644 *          TMIN     minimum momentum transfer to produce diff. masses  *
14645 *          XM1/XM2  diffractively produced masses                      *
14646 *                   (for single diffraction XM2 is obsolete)           *
14647 *          K1/K2= 0 not excited                                        *
14648 *               = 1 low-mass excitation                                *
14649 *               = 2 high-mass excitation                               *
14650 * This version dated 11.02.95 is written by S. Roesler                 *
14651 ************************************************************************
14652
14653       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14654       SAVE
14655
14656       PARAMETER ( LINP = 10 ,
14657      &            LOUT = 6 ,
14658      &            LDAT = 9 )
14659
14660       PARAMETER (ZERO=0.0D0)
14661
14662       PARAMETER ( BTP0   = 3.7D0,
14663      &            ALPHAP = 0.24D0 )
14664
14665       IREJ   = 0
14666       NCLOOP = 0
14667       DT_TDIFF  = ZERO
14668
14669       IF (K1.GT.0) THEN
14670          XM1 = XM1I
14671          XM2 = XM2I
14672       ELSE
14673          XM1 = XM2I
14674       ENDIF
14675       XDI = (XM1/ECM)**2
14676       IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14677 * slope for single diffraction
14678          SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14679       ELSE
14680 * slope for double diffraction
14681          SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14682       ENDIF
14683
14684     1 CONTINUE
14685       NCLOOP = NCLOOP+1
14686       IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14687       Y = DT_RNDM(XDI)
14688       T = -LOG(1.0D0-Y)/SLOPE
14689       IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14690       DT_TDIFF = -ABS(T)
14691
14692       RETURN
14693
14694  9999 CONTINUE
14695       WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14696  1000 FORMAT(1X,'DT_TDIFF:   t-selection rejected!',/,
14697      &       1X,'ECM  = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14698      &       E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14699       IREJ = 1
14700       RETURN
14701       END
14702
14703 *$ CREATE DT_XVALHM.FOR
14704 *COPY DT_XVALHM
14705 *
14706 *===xvalhm=============================================================*
14707 *
14708       SUBROUTINE DT_XVALHM(KP,KT)
14709
14710 ************************************************************************
14711 * Sampling of parton x-values in high-mass diffractive interactions.   *
14712 * This version dated 12.02.95 is written by S. Roesler                 *
14713 ************************************************************************
14714
14715       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14716       SAVE
14717
14718       PARAMETER ( LINP = 10 ,
14719      &            LOUT = 6 ,
14720      &            LDAT = 9 )
14721
14722       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14723
14724 * kinematics of diffractive interactions (DTUNUC 1.x)
14725       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14726      &                PPF(4),PTF(4),
14727      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14728      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14729
14730 * various options for treatment of partons (DTUNUC 1.x)
14731 * (chain recombination, Cronin,..)
14732       LOGICAL LCO2CR,LINTPT
14733       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14734      &                LCO2CR,LINTPT
14735
14736       DATA UNON,XVQTHR /2.0D0,0.8D0/
14737
14738       IF (KP.EQ.2) THEN
14739 * x-fractions of projectile valence partons
14740     1    CONTINUE
14741          XPH(1) = DT_DBETAR(OHALF,UNON)
14742          IF (XPH(1).GE.XVQTHR) GOTO 1
14743          XPH(2) = ONE-XPH(1)
14744 * x-fractions of Pomeron q-aq-pair
14745          XPOLO = TINY2
14746          XPOHI = ONE-TINY2
14747          XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14748          XPPO(2) = ONE-XPPO(1)
14749 * flavors of Pomeron q-aq-pair
14750          IFLAV    = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14751          IFPPO(1) = IFLAV
14752          IFPPO(2) = -IFLAV
14753          IF (DT_RNDM(UNON).GT.OHALF) THEN
14754             IFPPO(1) = -IFLAV
14755             IFPPO(2) = IFLAV
14756          ENDIF
14757       ENDIF
14758
14759       IF (KT.EQ.2) THEN
14760 * x-fractions of projectile target partons
14761     2    CONTINUE
14762          XTH(1) = DT_DBETAR(OHALF,UNON)
14763          IF (XTH(1).GE.XVQTHR) GOTO 2
14764          XTH(2) = ONE-XTH(1)
14765 * x-fractions of Pomeron q-aq-pair
14766          XPOLO = TINY2
14767          XPOHI = ONE-TINY2
14768          XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14769          XTPO(2) = ONE-XTPO(1)
14770 * flavors of Pomeron q-aq-pair
14771          IFLAV    = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14772          IFTPO(1) = IFLAV
14773          IFTPO(2) = -IFLAV
14774          IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14775             IFTPO(1) = -IFLAV
14776             IFTPO(2) = IFLAV
14777          ENDIF
14778       ENDIF
14779
14780       RETURN
14781       END
14782
14783 *$ CREATE DT_LM2RES.FOR
14784 *COPY DT_LM2RES
14785 *
14786 *===lm2res=============================================================*
14787 *
14788       SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14789
14790 ************************************************************************
14791 * Check low-mass diffractive excitation for resonance mass.            *
14792 *   (input)   IF1/2    PDG-indizes of valence partons                  *
14793 *   (in/out)  XM       diffractive mass requested/corrected            *
14794 *   (output)  IDR/IDXR id./BAMJET-index of resonance                   *
14795 * This version dated 12.02.95 is written by S. Roesler                 *
14796 ************************************************************************
14797
14798       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14799       SAVE
14800
14801       PARAMETER ( LINP = 10 ,
14802      &            LOUT = 6 ,
14803      &            LDAT = 9 )
14804
14805       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14806
14807 * kinematics of diffractive interactions (DTUNUC 1.x)
14808       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14809      &                PPF(4),PTF(4),
14810      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14811      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14812
14813       IREJ = 0
14814       IF1B = 0
14815       IF2B = 0
14816       XMI  = XM
14817
14818 * BAMJET indices of partons
14819       IF1A = IDT_IPDG2B(IF1,1,2)
14820       IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14821       IF2A = IDT_IPDG2B(IF2,1,2)
14822       IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14823
14824 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14825       IDCH = 2
14826       IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14827
14828 * check for resonance mass
14829       CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14830       IF (IREJ1.NE.0) GOTO 9999
14831
14832       XM = XMN
14833       RETURN
14834
14835  9999 CONTINUE
14836       IREJ = 1
14837       RETURN
14838       END
14839
14840 *$ CREATE DT_LMKINE.FOR
14841 *COPY DT_LMKINE
14842 *
14843 *===lmkine=============================================================*
14844 *
14845       SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14846
14847 ************************************************************************
14848 * Kinematical treatment of low-mass excitations.                       *
14849 * This version dated 12.02.95 is written by S. Roesler                 *
14850 ************************************************************************
14851
14852       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14853       SAVE
14854
14855       PARAMETER ( LINP = 10 ,
14856      &            LOUT = 6 ,
14857      &            LDAT = 9 )
14858
14859       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14860
14861 * flags for input different options
14862       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14863       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14864      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14865
14866 * kinematics of diffractive interactions (DTUNUC 1.x)
14867       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14868      &                PPF(4),PTF(4),
14869      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14870      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14871
14872       DIMENSION P1(4),P2(4)
14873
14874       IREJ = 0
14875
14876       IF (KP.EQ.1) THEN
14877          PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14878          POE  = PPF(4)/PABS
14879          FAC1 = OHALF*(POE+ONE)
14880          FAC2 = -OHALF*(POE-ONE)
14881          DO 1 K=1,3
14882             PPLM1(K) = FAC1*PPF(K)
14883             PPLM2(K) = FAC2*PPF(K)
14884     1    CONTINUE
14885          PPLM1(4) = FAC1*PABS
14886          PPLM2(4) = -FAC2*PABS
14887          IF (IMSHL.EQ.1) THEN
14888
14889             XM1 = PYMASS(IFP1)
14890             XM2 = PYMASS(IFP2)
14891
14892             CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14893             IF (IREJ1.NE.0) GOTO 9999
14894             DO 2 K=1,4
14895                PPLM1(K) = P1(K)
14896                PPLM2(K) = P2(K)
14897     2       CONTINUE
14898          ENDIF
14899       ENDIF
14900
14901       IF (KT.EQ.1) THEN
14902          PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14903          POE  = PTF(4)/PABS
14904          FAC1 = OHALF*(POE+ONE)
14905          FAC2 = -OHALF*(POE-ONE)
14906          DO 3 K=1,3
14907             PTLM2(K) = FAC1*PTF(K)
14908             PTLM1(K) = FAC2*PTF(K)
14909     3    CONTINUE
14910          PTLM2(4) = FAC1*PABS
14911          PTLM1(4) = -FAC2*PABS
14912          IF (IMSHL.EQ.1) THEN
14913
14914             XM1 = PYMASS(IFT1)
14915             XM2 = PYMASS(IFT2)
14916
14917             CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14918             IF (IREJ1.NE.0) GOTO 9999
14919             DO 4 K=1,4
14920                PTLM1(K) = P1(K)
14921                PTLM2(K) = P2(K)
14922     4       CONTINUE
14923          ENDIF
14924       ENDIF
14925
14926       RETURN
14927
14928  9999 CONTINUE
14929       WRITE(LOUT,'(A)') 'LMKINE:   kinematical treatment rejected'
14930       IREJ = 1
14931       RETURN
14932       END
14933
14934 *$ CREATE DT_DIFINI.FOR
14935 *COPY DT_DIFINI
14936 *
14937 *===difini=============================================================*
14938 *
14939       SUBROUTINE DT_DIFINI
14940
14941 ************************************************************************
14942 * Initialization of common /DTDIKI/                                    *
14943 * This version dated 12.02.95 is written by S. Roesler                 *
14944 ************************************************************************
14945
14946       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14947       SAVE
14948
14949       PARAMETER ( LINP = 10 ,
14950      &            LOUT = 6 ,
14951      &            LDAT = 9 )
14952
14953       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14954
14955 * kinematics of diffractive interactions (DTUNUC 1.x)
14956       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14957      &                PPF(4),PTF(4),
14958      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14959      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14960
14961       DO 1 K=1,4
14962          PPOM(K)  = ZERO
14963          PSC(K)   = ZERO
14964          PPF(K)   = ZERO
14965          PTF(K)   = ZERO
14966          PPLM1(K) = ZERO
14967          PPLM2(K) = ZERO
14968          PTLM1(K) = ZERO
14969          PTLM2(K) = ZERO
14970     1 CONTINUE
14971       DO 2 K=1,2
14972          XPH(K)   = ZERO
14973          XPPO(K)  = ZERO
14974          XTH(K)   = ZERO
14975          XTPO(K)  = ZERO
14976          IFPPO(K) = 0
14977          IFTPO(K) = 0
14978     2 CONTINUE
14979       IDPR  = 0
14980       IDXPR = 0
14981       IDTR  = 0
14982       IDXTR = 0
14983
14984       RETURN
14985       END
14986
14987 *$ CREATE DT_DIFPUT.FOR
14988 *COPY DT_DIFPUT
14989 *
14990 *===difput=============================================================*
14991 *
14992       SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14993      &                                                          IREJ)
14994
14995 ************************************************************************
14996 * Dump diffractive chains into DTEVT1                                  *
14997 * This version dated 12.02.95 is written by S. Roesler                 *
14998 ************************************************************************
14999
15000       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15001       SAVE
15002
15003       PARAMETER ( LINP = 10 ,
15004      &            LOUT = 6 ,
15005      &            LDAT = 9 )
15006
15007       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
15008
15009       LOGICAL LCHK
15010
15011 * kinematics of diffractive interactions (DTUNUC 1.x)
15012       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
15013      &                PPF(4),PTF(4),
15014      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
15015      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
15016
15017 * event history
15018
15019       PARAMETER (NMXHKK=200000)
15020
15021       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15022      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15023      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15024
15025 * extended event history
15026       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15027      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15028      &                IHIST(2,NMXHKK)
15029
15030 * rejection counter
15031       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
15032      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
15033      &                IREXCI(3),IRDIFF(2),IRINC
15034
15035       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
15036      &          P1(4),P2(4),P3(4),P4(4)
15037
15038       IREJ = 0
15039
15040       IF (KP.EQ.1) THEN
15041          DO 1 K=1,4
15042             PCH(K) = PPLM1(K)+PPLM2(K)
15043     1    CONTINUE
15044          ID1 = IFP1
15045          ID2 = IFP2
15046          IF (DT_RNDM(PT).GT.OHALF) THEN
15047             ID1 = IFP2
15048             ID2 = IFP1
15049          ENDIF
15050          CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
15051      &                                        PPLM1(4),0,0,0)
15052          CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
15053      &                                        PPLM2(4),0,0,0)
15054          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
15055      &                                              IDPR,IDXPR,8)
15056       ELSEIF (KP.EQ.2) THEN
15057          DO 2 K=1,4
15058             PP1(K) = XPH(1)*PP(K)
15059             PP2(K) = XPH(2)*PP(K)
15060             PT1(K) = -XPPO(1)*PPOM(K)
15061             PT2(K) = -XPPO(2)*PPOM(K)
15062     2    CONTINUE
15063          CALL  DT_CHKCSY(IFP1,IFPPO(1),LCHK)
15064          XM1 = ZERO
15065          XM2 = ZERO
15066          IF (LCHK) THEN
15067             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
15068             IF (IREJ1.NE.0) GOTO 9999
15069             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
15070             IF (IREJ1.NE.0) GOTO 9999
15071             DO 3 K=1,4
15072                PP1(K) = P1(K)
15073                PT1(K) = P2(K)
15074                PP2(K) = P3(K)
15075                PT2(K) = P4(K)
15076     3       CONTINUE
15077             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
15078      &                                                       0,0,8)
15079             CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
15080      &                                             PT1(4),0,0,8)
15081             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
15082      &                                                       0,0,8)
15083             CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
15084      &                                             PT2(4),0,0,8)
15085          ELSE
15086             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
15087             IF (IREJ1.NE.0) GOTO 9999
15088             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
15089             IF (IREJ1.NE.0) GOTO 9999
15090             DO 4 K=1,4
15091                PP1(K) = P1(K)
15092                PT2(K) = P2(K)
15093                PP2(K) = P3(K)
15094                PT1(K) = P4(K)
15095     4       CONTINUE
15096             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
15097      &                                                       0,0,8)
15098             CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
15099      &                                                PT2(4),0,0,8)
15100             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
15101      &                                                       0,0,8)
15102             CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
15103      &                                                PT1(4),0,0,8)
15104          ENDIF
15105          NCSY = NCSY+1
15106       ELSE
15107          CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
15108      &                                                        0,0,0)
15109       ENDIF
15110
15111       IF (KT.EQ.1) THEN
15112          DO 5 K=1,4
15113             PCH(K) = PTLM1(K)+PTLM2(K)
15114     5    CONTINUE
15115          ID1 = IFT1
15116          ID2 = IFT2
15117          IF (DT_RNDM(PT).GT.OHALF) THEN
15118             ID1 = IFT2
15119             ID2 = IFT1
15120          ENDIF
15121          CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
15122      &                                              PTLM1(4),0,0,0)
15123          CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
15124      &                                              PTLM2(4),0,0,0)
15125          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
15126      &                                              IDTR,IDXTR,8)
15127       ELSEIF (KT.EQ.2) THEN
15128          DO 6 K=1,4
15129             PP1(K) = XTPO(1)*PPOM(K)
15130             PP2(K) = XTPO(2)*PPOM(K)
15131             PT1(K) = XTH(2)*PT(K)
15132             PT2(K) = XTH(1)*PT(K)
15133     6    CONTINUE
15134          CALL  DT_CHKCSY(IFTPO(1),IFT1,LCHK)
15135          XM1 = ZERO
15136          XM2 = ZERO
15137          IF (LCHK) THEN
15138             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
15139             IF (IREJ1.NE.0) GOTO 9999
15140             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
15141             IF (IREJ1.NE.0) GOTO 9999
15142             DO 7 K=1,4
15143                PP1(K) = P1(K)
15144                PT1(K) = P2(K)
15145                PP2(K) = P3(K)
15146                PT2(K) = P4(K)
15147     7       CONTINUE
15148             CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
15149      &                                                PP1(4),0,0,8)
15150             CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
15151      &                                                       0,0,8)
15152             CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
15153      &                                                PP2(4),0,0,8)
15154             CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
15155      &                                                       0,0,8)
15156          ELSE
15157             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
15158             IF (IREJ1.NE.0) GOTO 9999
15159             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
15160             IF (IREJ1.NE.0) GOTO 9999
15161             DO 8 K=1,4
15162                PP1(K) = P1(K)
15163                PT2(K) = P2(K)
15164                PP2(K) = P3(K)
15165                PT1(K) = P4(K)
15166     8       CONTINUE
15167             CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
15168      &                                                PP1(4),0,0,8)
15169             CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
15170      &                                                       0,0,8)
15171             CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
15172      &                                                PP2(4),0,0,8)
15173             CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
15174      &                                                       0,0,8)
15175          ENDIF
15176          NCSY = NCSY+1
15177       ELSE
15178          CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
15179      &                                                        0,0,0)
15180       ENDIF
15181
15182       RETURN
15183
15184  9999 CONTINUE
15185       IRDIFF(2) = IRDIFF(2)+1
15186       IREJ      = 1
15187       RETURN
15188       END
15189 *$ CREATE DT_EVTFRG.FOR
15190 *COPY DT_EVTFRG
15191 *
15192 *===evtfrg=============================================================*
15193 *
15194       SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
15195
15196 ************************************************************************
15197 * Hadronization of chains in DTEVT1.                                   *
15198 *                                                                      *
15199 * Input:                                                               *
15200 *   KMODE = 1   hadronization of PHOJET-chains (id=77xxx)              *
15201 *         = 2   hadronization of DTUNUC-chains (id=88xxx)              *
15202 *   NFRG  if KMODE = 1 : upper index of PHOJET-scatterings to be       *
15203 *                        hadronized with one PYEXEC call               *
15204 *         if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
15205 *                        with one PYEXEC call                          *
15206 * Output:                                                              *
15207 *   NPYMEM      number of entries in JETSET-common after hadronization *
15208 *   IREJ        rejection flag                                         *
15209 *                                                                      *
15210 * This version dated 17.09.00 is written by S. Roesler                 *
15211 ************************************************************************
15212
15213       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15214       SAVE
15215
15216       PARAMETER ( LINP = 10 ,
15217      &            LOUT = 6 ,
15218      &            LDAT = 9 )
15219
15220       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
15221       PARAMETER (ONE=1.0D0,ZERO=0.0D0)
15222
15223       LOGICAL LACCEP
15224
15225       PARAMETER (MXJOIN=200)
15226
15227 * event history
15228
15229       PARAMETER (NMXHKK=200000)
15230
15231       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15232      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15233      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15234
15235 * extended event history
15236       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15237      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15238      &                IHIST(2,NMXHKK)
15239
15240 * flags for input different options
15241       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15242       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15243      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15244
15245 * statistics
15246       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
15247      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
15248      &                ICEVTG(8,0:30)
15249
15250 * flags for diffractive interactions (DTUNUC 1.x)
15251       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
15252
15253 * nucleon-nucleon event-generator
15254       CHARACTER*8 CMODEL
15255       LOGICAL LPHOIN
15256       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
15257 * phojet
15258
15259 C  model switches and parameters
15260       CHARACTER*8 MDLNA
15261       INTEGER ISWMDL,IPAMDL
15262       DOUBLE PRECISION PARMDL
15263       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15264 * jetset
15265
15266       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15267       PARAMETER (MAXLND=4000)
15268       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15269
15270       INTEGER PYK
15271
15272       DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
15273
15274       MODE = KMODE
15275       ISTSTG = 7
15276       IF (MODE.NE.1) ISTSTG = 8
15277       IREJ = 0
15278
15279       IP     = 0
15280       ISH    = 0
15281       INIEMC = 1
15282       NEND   = NHKK
15283       NACCEP = 0
15284       IFRG   = 0
15285       IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
15286       DO 10 I=NPOINT(3),NEND
15287 * sr 14.02.00: seems to be not necessary anymore, commented
15288 C        LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
15289 C    &            ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
15290          LACCEP = .TRUE.
15291 * pick up chains from dtevt1
15292          IDCHK = IDHKK(I)/10000
15293          IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
15294             IF (IDCHK.EQ.7) THEN
15295                IPJE = IDHKK(I)-IDCHK*10000
15296                IF (IPJE.NE.IFRG) THEN
15297                   IFRG = IPJE
15298                   IF (IFRG.GT.NFRG) GOTO 16
15299                ENDIF
15300             ELSE
15301                IPJE = 1
15302                IFRG = IFRG+1
15303                IF (IFRG.GT.NFRG) THEN
15304                   NFRG = -1
15305                   GOTO 16
15306                ENDIF
15307             ENDIF
15308 *   statistics counter
15309 c           IF (IDCH(I).LE.8)
15310 c    &         ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
15311 c           IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
15312 * special treatment for small chains already corrected to hadrons
15313             IF (IDRES(I).NE.0) THEN
15314                IF (IDRES(I).EQ.11) THEN
15315                   ID = IDXRES(I)
15316                ELSE
15317                   ID = IDT_IPDGHA(IDXRES(I))
15318                ENDIF
15319                IF (LEMCCK) THEN
15320                   CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15321      &                              PHKK(4,I),INIEMC,IDUM,IDUM)
15322                   INIEMC = 2
15323                ENDIF
15324                IP = IP+1
15325                IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
15326                P(IP,1) = PHKK(1,I)
15327                P(IP,2) = PHKK(2,I)
15328                P(IP,3) = PHKK(3,I)
15329                P(IP,4) = PHKK(4,I)
15330                P(IP,5) = PHKK(5,I)
15331                K(IP,1) = 1
15332                K(IP,2) = ID
15333                K(IP,3) = 0
15334                K(IP,4) = 0
15335                K(IP,5) = 0
15336                IHIST(2,I) = 10000*IPJE+IP
15337                IF (IHIST(1,I).LE.-100) THEN
15338                   ISH = ISH+1
15339                   IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
15340                   ISJOIN(ISH) = I
15341                ENDIF
15342                N = IP
15343                IHISMO(IP) = I
15344             ELSE
15345                IJ  = 0
15346                DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
15347                   IF (LEMCCK) THEN
15348                      CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
15349      &                                   PHKK(4,KK),INIEMC,IDUM,IDUM)
15350                      CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
15351                      INIEMC = 2
15352                   ENDIF
15353                   ID = IDHKK(KK)
15354                   IF (ID.EQ.0) ID = 21
15355 c                  PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
15356 c                  AM0  = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
15357
15358 c                  AMRQ   = PYMASS(ID)
15359
15360 c                  AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
15361 c                  IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
15362 c     &                (ABS(IDIFF).EQ.0)) THEN
15363 cC                    WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
15364 c                     DELTA      = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
15365 c                     PHKK(4,KK) = PHKK(4,KK)+DELTA
15366 c                     PTOT1      = PTOT-DELTA
15367 c                     PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
15368 c                     PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
15369 c                     PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
15370 c                     PHKK(5,KK) = AMRQ
15371 c                  ENDIF
15372                   IP = IP+1
15373                   IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
15374                   P(IP,1) = PHKK(1,KK)
15375                   P(IP,2) = PHKK(2,KK)
15376                   P(IP,3) = PHKK(3,KK)
15377                   P(IP,4) = PHKK(4,KK)
15378                   P(IP,5) = PHKK(5,KK)
15379                   K(IP,1) = 1
15380                   K(IP,2) = ID
15381                   K(IP,3) = 0
15382                   K(IP,4) = 0
15383                   K(IP,5) = 0
15384                   IHIST(2,KK) = 10000*IPJE+IP
15385                   IF (IHIST(1,KK).LE.-100) THEN
15386                      ISH = ISH+1
15387                      IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
15388                      ISJOIN(ISH) = KK
15389                   ENDIF
15390                   IJ = IJ+1
15391                   IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
15392                   IJOIN(IJ)  = IP
15393                   IHISMO(IP) = I
15394    11          CONTINUE
15395                N = IP
15396 * join the two-parton system
15397
15398                CALL PYJOIN(IJ,IJOIN)
15399
15400             ENDIF
15401             IDHKK(I) = 99999
15402          ENDIF
15403    10 CONTINUE
15404    16 CONTINUE
15405       N = IP
15406
15407       IF (IP.GT.0) THEN
15408
15409 * final state parton shower
15410          DO 136 NPJE=1,IPJE
15411             IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
15412                IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
15413                   DO 130 K1=1,ISH
15414                      IF (ISJOIN(K1).EQ.0) GOTO 130
15415                      I = ISJOIN(K1)
15416                      IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
15417      &                                                       GOTO 130
15418                      IH1 = IHIST(2,I)/10000
15419                      IF (IH1.NE.NPJE) GOTO 130
15420                      IH1 = IHIST(2,I)-IH1*10000
15421                      DO 135 K2=K1+1,ISH
15422                         IF (ISJOIN(K2).EQ.0) GOTO 135
15423                         II = ISJOIN(K2)
15424                         IH2 = IHIST(2,II)/10000
15425                         IF (IH2.NE.NPJE) GOTO 135
15426                         IH2 = IHIST(2,II)-IH2*10000
15427                         IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
15428                            PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
15429                            PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
15430
15431                            RQLUN = MIN(PT1,PT2)
15432                            CALL PYSHOW(IH1,IH2,RQLUN)
15433
15434                            ISJOIN(K1) = 0
15435                            ISJOIN(K2) = 0
15436                            GOTO 130
15437                         ENDIF
15438  135                 CONTINUE
15439  130              CONTINUE
15440                ENDIF
15441             ENDIF
15442  136     CONTINUE
15443
15444          CALL DT_INITJS(MODE)
15445 * hadronization
15446
15447          CALL PYEXEC
15448
15449          IF (MSTU(24).NE.0) THEN
15450             WRITE(LOUT,*) ' JETSET-reject at event',
15451      &                    NEVHKK,MSTU(24),KMODE
15452 C           CALL DT_EVTOUT(4)
15453
15454 C           CALL PYLIST(2)
15455
15456             GOTO 9999
15457          ENDIF
15458
15459 *   number of entries in LUJETS
15460
15461          NLINES = PYK(0,1)
15462
15463          NPYMEM = NLINES
15464
15465          DO 12 I=1,NLINES
15466             IFLG(I) = 0
15467    12    CONTINUE
15468
15469          DO 13 II=1,NLINES
15470
15471             IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
15472
15473 *  pick up mother resonance if possible and put it together with
15474 *  their decay-products into the common
15475                IDXMOR = K(II,3)
15476                IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
15477                   KFMOR = K(IDXMOR,2)
15478                   ISMOR = K(IDXMOR,1)
15479                ELSE
15480                   KFMOR = 91
15481                   ISMOR = 1
15482                ENDIF
15483                IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
15484      &             (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
15485                   ID = K(IDXMOR,2)
15486                   MO = IHISMO(PYK(IDXMOR,15))
15487                   PX = PYP(IDXMOR,1)
15488                   PY = PYP(IDXMOR,2)
15489                   PZ = PYP(IDXMOR,3)
15490                   PE = PYP(IDXMOR,4)
15491
15492                   CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15493                   IFLG(IDXMOR) = 1
15494                   MO = NHKK
15495                   DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
15496                      IF (PYK(JDAUG,7).EQ.1) THEN
15497                         ID = PYK(JDAUG,8)
15498                         PX = PYP(JDAUG,1)
15499                         PY = PYP(JDAUG,2)
15500                         PZ = PYP(JDAUG,3)
15501                         PE = PYP(JDAUG,4)
15502
15503                         CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15504                         IF (LEMCCK) THEN
15505                            PX = -PYP(JDAUG,1)
15506                            PY = -PYP(JDAUG,2)
15507                            PZ = -PYP(JDAUG,3)
15508                            PE = -PYP(JDAUG,4)
15509
15510                            CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
15511                         ENDIF
15512                         IFLG(JDAUG) = 1
15513                      ENDIF
15514    15             CONTINUE
15515                ELSE
15516 *  there was no mother resonance
15517                   MO = IHISMO(PYK(II,15))
15518                   ID = PYK(II,8)
15519                   PX = PYP(II,1)
15520                   PY = PYP(II,2)
15521                   PZ = PYP(II,3)
15522                   PE = PYP(II,4)
15523
15524                   CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15525                   IF (LEMCCK) THEN
15526                      PX = -PYP(II,1)
15527                      PY = -PYP(II,2)
15528                      PZ = -PYP(II,3)
15529                      PE = -PYP(II,4)
15530
15531                      CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
15532                   ENDIF
15533                ENDIF
15534             ENDIF
15535    13    CONTINUE
15536          IF (LEMCCK) THEN
15537             CHKLEV = TINY1
15538             CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
15539 C           IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
15540          ENDIF
15541
15542 * global energy-momentum & flavor conservation check
15543 **sr 16.5. this check is skipped in case of phojet-treatment
15544          IF (MCGENE.EQ.1)
15545      &      CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
15546
15547 * update statistics-counter for diffraction
15548 c        IF (IFLAGD.NE.0) THEN
15549 c           ICDIFF(1) = ICDIFF(1)+1
15550 c           IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
15551 c           IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
15552 c           IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
15553 c           IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
15554 c        ENDIF
15555
15556       ENDIF
15557
15558       RETURN
15559
15560  9999 CONTINUE
15561       IREJ = 1
15562       RETURN
15563       END
15564
15565 *$ CREATE DT_DECAYS.FOR
15566 *COPY DT_DECAYS
15567 *
15568 *===decay==============================================================*
15569 *
15570       SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15571
15572 ************************************************************************
15573 * Resonance-decay.                                                     *
15574 * This subroutine replaces DDECAY/DECHKK.                              *
15575 *             PIN(4)      4-momentum of resonance          (input)     *
15576 *             IDXIN       BAMJET-index of resonance        (input)     *
15577 *             POUT(20,4)  4-momenta of decay-products      (output)    *
15578 *             IDXOUT(20)  BAMJET-indices of decay-products (output)    *
15579 *             NSEC        number of secondaries            (output)    *
15580 * Adopted from the original version DECHKK.                            *
15581 * This version dated 09.01.95 is written by S. Roesler                 *
15582 ************************************************************************
15583
15584       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15585       SAVE
15586
15587       PARAMETER ( LINP = 10 ,
15588      &            LOUT = 6 ,
15589      &            LDAT = 9 )
15590
15591       PARAMETER (TINY17=1.0D-17)
15592
15593 * HADRIN: decay channel information
15594       PARAMETER (IDMAX9=602)
15595       CHARACTER*8 ZKNAME
15596       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15597
15598 * particle properties (BAMJET index convention)
15599       CHARACTER*8  ANAME
15600       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15601      &                IICH(210),IIBAR(210),K1(210),K2(210)
15602
15603 * flags for input different options
15604       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15605       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15606      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15607
15608       DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
15609      &          EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
15610      &          CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
15611
15612 * ISTAB = 1 strong and weak decays
15613 *       = 2 strong decays only
15614 *       = 3 strong decays, weak decays for charmed particles and tau
15615 *           leptons only
15616       DATA ISTAB /2/
15617
15618       IREJ = 0
15619       NSEC = 0
15620 * put initial resonance to stack
15621       NSTK = 1
15622       IDXSTK(NSTK) = IDXIN
15623       DO 5 I=1,4
15624          PI(NSTK,I) = PIN(I)
15625     5 CONTINUE
15626
15627 * store initial configuration for energy-momentum cons. check
15628       IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
15629      &                                   PI(NSTK,4),1,IDUM,IDUM)
15630
15631   100 CONTINUE
15632 * get particle from stack
15633       IDXI = IDXSTK(NSTK)
15634 * skip stable particles
15635       IF (ISTAB.EQ.1) THEN
15636          IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
15637          IF ((IDXI.GE.  1).AND.(IDXI.LE.  7)) GOTO 10
15638       ELSEIF (ISTAB.EQ.2) THEN
15639          IF ((IDXI.GE.  1).AND.(IDXI.LE. 30)) GOTO 10
15640          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15641          IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
15642          IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
15643          IF ( IDXI.EQ.109)                    GOTO 10
15644          IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
15645       ELSEIF (ISTAB.EQ.3) THEN
15646          IF ((IDXI.GE.  1).AND.(IDXI.LE. 23)) GOTO 10
15647          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15648          IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
15649          IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
15650       ENDIF
15651
15652 * calculate direction cosines and Lorentz-parameter of decaying part.
15653       PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
15654       PTOT = MAX(PTOT,TINY17)
15655       DO 1 I=1,3
15656          DCOS(I) = PI(NSTK,I)/PTOT
15657     1 CONTINUE
15658       GAM  = PI(NSTK,4)/AAM(IDXI)
15659       BGAM = PTOT/AAM(IDXI)
15660
15661 * get decay-channel
15662       KCHAN = K1(IDXI)-1
15663     2 CONTINUE
15664       KCHAN = KCHAN+1
15665       IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
15666
15667 * identities of secondaries
15668       IDX(1) = NZK(KCHAN,1)
15669       IDX(2) = NZK(KCHAN,2)
15670       IF (IDX(2).LT.1) GOTO 9999
15671       IDX(3) = NZK(KCHAN,3)
15672
15673 * handle decay in rest system of decaying particle
15674       IF (IDX(3).EQ.0) THEN
15675 *   two-particle decay
15676          NDEC = 2
15677          CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
15678      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15679      &               AAM(IDX(1)),AAM(IDX(2)))
15680       ELSE
15681 *   three-particle decay
15682          NDEC = 3
15683          CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
15684      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15685      &               CODF(3),COFF(3),SIFF(3),
15686      &               AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
15687       ENDIF
15688       NSTK = NSTK-1
15689
15690 * transform decay products back
15691       DO 3 I=1,NDEC
15692          NSTK = NSTK+1
15693          CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
15694      &               CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
15695      &               PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
15696 * add particle to stack
15697          IDXSTK(NSTK) = IDX(I)
15698          DO 4 J=1,3
15699             PI(NSTK,J) = DCOSF(J)*PFF(I)
15700     4    CONTINUE
15701     3 CONTINUE
15702       GOTO 100
15703
15704    10 CONTINUE
15705 * stable particle, put to output-arrays
15706       NSEC = NSEC+1
15707       DO 6 I=1,4
15708          POUT(NSEC,I) = PI(NSTK,I)
15709     6 CONTINUE
15710       IDXOUT(NSEC) = IDXSTK(NSTK)
15711 * store secondaries for energy-momentum conservation check
15712       IF (LEMCCK)
15713      &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15714      &            -POUT(NSEC,4),2,IDUM,IDUM)
15715       NSTK = NSTK-1
15716       IF (NSTK.GT.0) GOTO 100
15717
15718 * check energy-momentum conservation
15719       IF (LEMCCK) THEN
15720          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15721          IF (IREJ1.NE.0) GOTO 9999
15722       ENDIF
15723
15724       RETURN
15725
15726  9999 CONTINUE
15727       IREJ = 1
15728       RETURN
15729       END
15730
15731 *$ CREATE DT_DECAY1.FOR
15732 *COPY DT_DECAY1
15733 *
15734 *===decay1=============================================================*
15735 *
15736       SUBROUTINE DT_DECAY1
15737
15738 ************************************************************************
15739 * Decay of resonances stored in DTEVT1.                                *
15740 * This version dated 20.01.95 is written by S. Roesler                 *
15741 ************************************************************************
15742
15743       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15744       SAVE
15745
15746       PARAMETER ( LINP = 10 ,
15747      &            LOUT = 6 ,
15748      &            LDAT = 9 )
15749
15750 * event history
15751
15752       PARAMETER (NMXHKK=200000)
15753
15754       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15755      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15756      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15757
15758 * extended event history
15759       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15760      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15761      &                IHIST(2,NMXHKK)
15762
15763       DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15764
15765       NEND = NHKK
15766 C     DO 1 I=NPOINT(5),NEND
15767       DO 1 I=NPOINT(4),NEND
15768          IF (ABS(ISTHKK(I)).EQ.1) THEN
15769             DO 2 K=1,4
15770                PIN(K) = PHKK(K,I)
15771     2       CONTINUE
15772             IDXIN = IDBAM(I)
15773             CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15774             IF (NSEC.GT.1) THEN
15775                DO 3 N=1,NSEC
15776                   IDHAD = IDT_IPDGHA(IDXOUT(N))
15777                   CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15778      &                               POUT(N,3),POUT(N,4),0,0,0)
15779     3          CONTINUE
15780             ENDIF
15781          ENDIF
15782     1 CONTINUE
15783
15784       RETURN
15785       END
15786
15787 *$ CREATE DT_DECPI0.FOR
15788 *COPY DT_DECPI0
15789 *
15790 *===decpi0=============================================================*
15791 *
15792       SUBROUTINE DT_DECPI0
15793
15794 ************************************************************************
15795 * Decay of pi0 handled with JETSET.                                    *
15796 * This version dated 18.02.96 is written by S. Roesler                 *
15797 ************************************************************************
15798
15799       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15800       SAVE
15801
15802       PARAMETER ( LINP = 10 ,
15803      &            LOUT = 6 ,
15804      &            LDAT = 9 )
15805
15806       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15807
15808 * event history
15809
15810       PARAMETER (NMXHKK=200000)
15811
15812       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15813      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15814      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15815
15816 * extended event history
15817       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15818      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15819      &                IHIST(2,NMXHKK)
15820
15821       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15822       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15823       PARAMETER (MAXLND=4000)
15824       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15825
15826 * flags for input different options
15827       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15828       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15829      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15830
15831       INTEGER PYCOMP,PYK
15832
15833       DIMENSION IHISMO(NMXHKK),P1(4)
15834
15835       TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15836
15837       CALL DT_INITJS(2)
15838 * allow pi0 decay
15839
15840       KC = PYCOMP(111)
15841
15842       MDCY(KC,1) = 1
15843
15844       NN  = 0
15845       INI = 0
15846       DO 1 I=1,NHKK
15847          IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15848             IF (INI.EQ.0) THEN
15849                INI = 1
15850             ELSE
15851                INI = 2
15852             ENDIF
15853             IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15854      &                                    PHKK(4,I),INI,IDUM,IDUM)
15855             PT    = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15856             PTOT  = SQRT(PT**2+PHKK(3,I)**2)
15857             COSTH = PHKK(3,I)/(PTOT+TINY10)
15858             IF (COSTH.GT.ONE) THEN
15859                THETA = ZERO
15860             ELSEIF (COSTH.LT.-ONE) THEN
15861                THETA = TWOPI/2.0D0
15862             ELSE
15863                THETA = ACOS(COSTH)
15864             ENDIF
15865             PHI     = ASIN(PHKK(2,I)/(PT  +TINY10))
15866             IF (PHKK(1,I).LT.0.0D0)
15867
15868      &         PHI  = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15869
15870             ENER    = PHKK(4,I)
15871             NN      = NN+1
15872             KTEMP   = MSTU(10)
15873             MSTU(10)= 1
15874             P(NN,5) = PHKK(5,I)
15875
15876             CALL PY1ENT(NN,111,ENER,THETA,PHI)
15877
15878             MSTU(10)  = KTEMP
15879             IHISMO(NN)= I
15880          ENDIF
15881     1 CONTINUE
15882       IF (NN.GT.0) THEN
15883
15884          CALL PYEXEC
15885
15886          NLINES = PYK(0,1)
15887
15888          DO 2 II=1,NLINES
15889
15890             IF (PYK(II,7).EQ.1) THEN
15891
15892                DO 3 KK=1,4
15893
15894                   P1(KK) = PYP(II,KK)
15895
15896     3          CONTINUE
15897
15898                ID = PYK(II,8)
15899                MO = IHISMO(PYK(II,15))
15900
15901                CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15902                IF (LEMCCK)
15903      &            CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15904      &                                            IDUM,IDUM)
15905 *sr: flag with neg. sign (for HELIOS p/A-W jobs)
15906                ISTHKK(MO) = -2
15907             ENDIF
15908     2    CONTINUE
15909          IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15910       ENDIF
15911       MDCY(KC,1) = 0
15912
15913       RETURN
15914       END
15915
15916 *$ CREATE DT_DTWOPD.FOR
15917 *COPY DT_DTWOPD
15918 *
15919 *===dtwopd=============================================================*
15920 *
15921       SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15922      &                                            COF2,SIF2,AM1,AM2)
15923
15924 ************************************************************************
15925 * Two-particle decay.                                                  *
15926 *  UMO                 cm-energy of the decaying system       (input)  *
15927 *  AM1/AM2             masses of the decay products           (input)  *
15928 *  ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15929 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15930 * Revised by S. Roesler, 20.11.95                                      *
15931 ************************************************************************
15932
15933       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15934       SAVE
15935
15936       PARAMETER ( LINP = 10 ,
15937      &            LOUT = 6 ,
15938      &            LDAT = 9 )
15939
15940       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15941
15942       IF (UMO.LT.(AM1+AM2)) THEN
15943          WRITE(LOUT,1000) UMO,AM1,AM2
15944  1000    FORMAT(1X,'DTWOPD:    inconsistent kinematics - UMO,AM1,AM2 ',
15945      &          3E12.3)
15946          STOP
15947       ENDIF
15948
15949       ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15950       ECM2 = UMO-ECM1
15951       PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15952       PCM2 = PCM1
15953       CALL DT_DSFECF(SIF1,COF1)
15954       COD1 = TWO*DT_RNDM(PCM2)-ONE
15955       COD2 = -COD1
15956       COF2 = -COF1
15957       SIF2 = -SIF1
15958
15959       RETURN
15960       END
15961
15962 *$ CREATE DT_DTHREP.FOR
15963 *COPY DT_DTHREP
15964 *
15965 *===dthrep=============================================================*
15966 *
15967       SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15968      &                  SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15969
15970 ************************************************************************
15971 * Three-particle decay.                                                *
15972 *  UMO                 cm-energy of the decaying system       (input)  *
15973 *  AM1/2/3             masses of the decay products           (input)  *
15974 *  ECM1/2/2,PCM1/2/3   cm-energies/momenta of the decay prod. (output) *
15975 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15976 *                                                                      *
15977 * Threpd89: slight revision by A. Ferrari                              *
15978 * Last change on   11-oct-93   by    Alfredo Ferrari, INFN - Milan     *
15979 * Revised by S. Roesler, 20.11.95                                      *
15980 ************************************************************************
15981
15982       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15983       SAVE
15984
15985       PARAMETER ( LINP = 10 ,
15986      &            LOUT = 6 ,
15987      &            LDAT = 9 )
15988
15989       PARAMETER ( ANGLSQ = 2.5D-31 )
15990       PARAMETER ( AZRZRZ = 1.0D-30 )
15991       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
15992       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
15993       PARAMETER ( ONEONE = 1.D+00 )
15994       PARAMETER ( TWOTWO = 2.D+00 )
15995       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15996
15997       COMMON /HNGAMR/ REDU,AMO,AMM(15)
15998
15999 * flags for input different options
16000       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16001       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16002      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16003
16004       DIMENSION F(5),XX(5)
16005       DATA EPS /AZRZRZ/
16006
16007       UMOO=UMO+UMO
16008 C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
16009 C***J. VON NEUMANN - RANDOM - SELECTION OF S2
16010 C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
16011       UUMO=UMO
16012       AAM1=AM1
16013       AAM2=AM2
16014       AAM3=AM3
16015       GU=(AM2+AM3)**2
16016       GO=(UMO-AM1)**2
16017 *     UFAK=1.0000000000001D0
16018 *     IF (GU.GT.GO) UFAK=0.9999999999999D0
16019       IF (GU.GT.GO) THEN
16020          UFAK=ONEMNS
16021       ELSE
16022          UFAK=ONEPLS
16023       END IF
16024       OFAK=2.D0-UFAK
16025       GU=GU*UFAK
16026       GO=GO*OFAK
16027       DS2=(GO-GU)/99.D0
16028       AM11=AM1*AM1
16029       AM22=AM2*AM2
16030       AM33=AM3*AM3
16031       UMO2=UMO*UMO
16032       RHO2=0.D0
16033       S22=GU
16034       DO 124 I=1,100
16035          S21=S22
16036          S22=GU+(I-1.D0)*DS2
16037          RHO1=RHO2
16038          RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
16039      *                                             (S22+EPS)
16040          IF(RHO2.LT.RHO1) GO TO 125
16041   124 CONTINUE
16042   125 S2SUP=(S22-S21)*.5D0+S21
16043       SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
16044      *                                           (S2SUP+EPS)
16045       SUPRHO=SUPRHO*1.05D0
16046       XO=S21-DS2
16047       IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
16048       IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
16049       XX(1)=XO
16050       XX(3)=S22
16051       X1=(XO+S22)*0.5D0
16052       XX(2)=X1
16053       F(3)=RHO2
16054       F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
16055       F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
16056       DO 126 I=1,16
16057          X4=(XX(1)+XX(2))*0.5D0
16058          X5=(XX(2)+XX(3))*0.5D0
16059          F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
16060      *                                               (X4+EPS)
16061          F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
16062      *                                               (X5+EPS)
16063          XX(4)=X4
16064          XX(5)=X5
16065          DO 128 II=1,5
16066             IA=II
16067             DO 128 III=IA,5
16068                IF (F (II).GE.F (III)) GO TO 128
16069                FH=F(II)
16070                F(II)=F(III)
16071                F(III)=FH
16072                FH=XX(II)
16073                XX(II)=XX(III)
16074                XX(III)=FH
16075 128      CONTINUE
16076          SUPRHO=F(1)
16077          S2SUP=XX(1)
16078          DO 129 II=1,3
16079             IA=II
16080             DO 129 III=IA,3
16081                IF (XX(II).GE.XX(III)) GO TO 129
16082                FH=F(II)
16083                F(II)=F(III)
16084                F(III)=FH
16085                FH=XX(II)
16086                XX(II)=XX(III)
16087                XX(III)=FH
16088 129      CONTINUE
16089 126   CONTINUE
16090       AM23=(AM2+AM3)**2
16091       ITH=0
16092       REDU=2.D0
16093     1 CONTINUE
16094       ITH=ITH+1
16095       IF (ITH.GT.200) REDU=-9.D0
16096       IF (ITH.GT.200) GO TO 400
16097       C=DT_RNDM(REDU)
16098 *     S2=AM23+C*((UMO-AM1)**2-AM23)
16099       S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
16100       Y=DT_RNDM(S2)
16101       Y=Y*SUPRHO
16102       RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
16103       IF(Y.GT.RHO) GO TO 1
16104 C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
16105       S1=DT_RNDM(S2)
16106       S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
16107      &RHO*.5D0
16108       S3=UMO2+AM11+AM22+AM33-S1-S2
16109       ECM1=(UMO2+AM11-S2)/UMOO
16110       ECM2=(UMO2+AM22-S3)/UMOO
16111       ECM3=(UMO2+AM33-S1)/UMOO
16112       PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
16113       PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
16114       PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
16115       CALL DT_DSFECF(SFE,CFE)
16116 C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
16117 C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
16118       PCM12 = PCM1 * PCM2
16119       IF ( PCM12 .LT. ANGLSQ ) GO TO 200
16120       COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
16121       GO TO 300
16122  200  CONTINUE
16123          UW=DT_RNDM(S1)
16124          COSTH=(UW-0.5D+00)*2.D+00
16125  300  CONTINUE
16126 *     IF(ABS(COSTH).GT.0.9999999999999999D0)
16127 *    &COSTH=SIGN(0.9999999999999999D0,COSTH)
16128       IF(ABS(COSTH).GT.ONEONE)
16129      &COSTH=SIGN(ONEONE,COSTH)
16130       IF (REDU.LT.1.D+00) RETURN
16131       COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
16132 *     IF(ABS(COSTH2).GT.0.9999999999999999D0)
16133 *    &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
16134       IF(ABS(COSTH2).GT.ONEONE)
16135      &COSTH2=SIGN(ONEONE,COSTH2)
16136       SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
16137       SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
16138       SINTH1=COSTH2*SINTH-COSTH*SINTH2
16139       COSTH1=COSTH*COSTH2+SINTH2*SINTH
16140 C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
16141 C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
16142 C***THE DIRECTION OF PARTICLE 3
16143 C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
16144       CX11=-COSTH1
16145       CY11=SINTH1*CFE
16146       CZ11=SINTH1*SFE
16147       CX22=-COSTH2
16148       CY22=-SINTH2*CFE
16149       CZ22=-SINTH2*SFE
16150       CALL DT_DSFECF(SIF3,COF3)
16151       COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
16152       SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
16153     2 FORMAT(5F20.15)
16154       COD1=CX11*COD3+CZ11*SID3
16155       CHLP=(ONEONE-COD1)*(ONEONE+COD1)
16156       IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
16157      &CX11,CZ11
16158       SID1=SQRT(CHLP)
16159       COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
16160       SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
16161       COD2=CX22*COD3+CZ22*SID3
16162       SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
16163       COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
16164       SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
16165  400  CONTINUE
16166 * === Energy conservation check: === *
16167       EOCHCK = UMO - ECM1 - ECM2 - ECM3
16168 *     SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
16169 *     SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
16170 *     SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
16171       PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
16172       PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
16173      &       + PCM3 * COF3 * SID3
16174       PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
16175      &       + PCM3 * SIF3 * SID3
16176       EOCMPR = 1.D-12 * UMO
16177       IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
16178      &     .GT. EOCMPR ) THEN
16179 **sr 5.5.95 output-unit changed
16180          IF (IOULEV(1).GT.0) THEN
16181             WRITE(LOUT,*)
16182      &      ' *** Threpd: energy/momentum conservation failure! ***',
16183      &      EOCHCK,PXCHCK,PYCHCK,PZCHCK
16184             WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
16185          ENDIF
16186 **
16187       END IF
16188       RETURN
16189       END
16190
16191 *$ CREATE DT_DBKLAS.FOR
16192 *COPY DT_DBKLAS
16193 *
16194 *===dbklas=============================================================*
16195 *
16196       SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
16197
16198       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16199       SAVE
16200
16201       PARAMETER ( LINP = 10 ,
16202      &            LOUT = 6 ,
16203      &            LDAT = 9 )
16204
16205 * quark-content to particle index conversion (DTUNUC 1.x)
16206       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
16207      &                IA08(6,21),IA10(6,21)
16208
16209       IF (I) 20,20,10
16210 * baryons
16211    10 CONTINUE
16212       CALL DT_INDEXD(J,K,IND)
16213       I8  = IB08(I,IND)
16214       I10 = IB10(I,IND)
16215       IF (I8.LE.0) I8 = I10
16216       RETURN
16217 * antibaryons
16218    20 CONTINUE
16219       II = IABS(I)
16220       JJ = IABS(J)
16221       KK = IABS(K)
16222       CALL DT_INDEXD(JJ,KK,IND)
16223       I8  = IA08(II,IND)
16224       I10 = IA10(II,IND)
16225       IF (I8.LE.0) I8 = I10
16226
16227       RETURN
16228       END
16229
16230 *$ CREATE DT_INDEXD.FOR
16231 *COPY DT_INDEXD
16232 *
16233 *===indexd=============================================================*
16234 *
16235       SUBROUTINE DT_INDEXD(KA,KB,IND)
16236
16237       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16238       SAVE
16239
16240       PARAMETER ( LINP = 10 ,
16241      &            LOUT = 6 ,
16242      &            LDAT = 9 )
16243
16244       KP = KA*KB
16245       KS = KA+KB
16246       IF (KP.EQ.1) IND=1
16247       IF (KP.EQ.2) IND=2
16248       IF (KP.EQ.3) IND=3
16249       IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
16250       IF (KP.EQ.5) IND=5
16251       IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
16252       IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
16253       IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
16254       IF (KP.EQ.8)  IND=9
16255       IF (KP.EQ.10) IND=10
16256       IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
16257       IF (KP.EQ.9)  IND=12
16258       IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
16259       IF (KP.EQ.15) IND=14
16260       IF (KP.EQ.18) IND=15
16261       IF (KP.EQ.16) IND=16
16262       IF (KP.EQ.20) IND=17
16263       IF (KP.EQ.24) IND=18
16264       IF (KP.EQ.25) IND=19
16265       IF (KP.EQ.30) IND=20
16266       IF (KP.EQ.36) IND=21
16267
16268       RETURN
16269       END
16270
16271 *$ CREATE DT_DCHANT.FOR
16272 *COPY DT_DCHANT
16273 *
16274 *===dchant=============================================================*
16275 *
16276       SUBROUTINE DT_DCHANT
16277
16278       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16279       SAVE
16280
16281       PARAMETER ( LINP = 10 ,
16282      &            LOUT = 6 ,
16283      &            LDAT = 9 )
16284
16285       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16286
16287 * HADRIN: decay channel information
16288       PARAMETER (IDMAX9=602)
16289       CHARACTER*8 ZKNAME
16290       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
16291
16292 * particle properties (BAMJET index convention)
16293       CHARACTER*8  ANAME
16294       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16295      &                IICH(210),IIBAR(210),K1(210),K2(210)
16296
16297       DIMENSION HWT(IDMAX9)
16298
16299 * change of weights wt from absolut values into the sum of wt of a dec.
16300       DO 10 J=1,IDMAX9
16301          HWT(J) = ZERO
16302    10 CONTINUE
16303 C     DO 999 KKK=1,210
16304 C        WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
16305 C    &      ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
16306 C    &      K1(KKK),K2(KKK)
16307 C 999 CONTINUE
16308 C     STOP
16309       DO 30 I=1,210
16310          IK1 = K1(I)
16311          IK2 = K2(I)
16312          HV  = ZERO
16313          DO 20 J=IK1,IK2
16314             HV     = HV+WT(J)
16315             HWT(J) = HV
16316 **sr 13.1.95
16317             IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
16318  1000       FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
16319    20    CONTINUE
16320    30 CONTINUE
16321       DO 40 J=1,IDMAX9
16322          WT(J) = HWT(J)
16323    40 CONTINUE
16324
16325       RETURN
16326       END
16327
16328 *$ CREATE DT_DDATAR.FOR
16329 *COPY DT_DDATAR
16330 *
16331 *===ddatar=============================================================*
16332 *
16333       SUBROUTINE DT_DDATAR
16334
16335       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16336       SAVE
16337
16338       PARAMETER ( LINP = 10 ,
16339      &            LOUT = 6 ,
16340      &            LDAT = 9 )
16341
16342       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16343
16344 * quark-content to particle index conversion (DTUNUC 1.x)
16345       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
16346      &                IA08(6,21),IA10(6,21)
16347
16348       DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
16349
16350       DATA IV/ 33, 34, 38,123,  0,  0, 32, 33, 39,124,
16351      &          0,  0, 36, 37, 96,127,  0,  0,126,125,
16352      &        128,129,14*0/
16353       DATA IP/ 23, 14, 16,116,  0,  0, 13, 23, 25,117,
16354      &          0,  0, 15, 24, 31,120,  0,  0,119,118,
16355      &        121,122,14*0/
16356       DATA IB/  0,  1, 21,140,  0,  0,  8, 22,137,  0,
16357      &          0, 97,138,  0,  0,146,  0,  0,  0,  0,
16358      &          0,  1,  8, 22,137,  0,  0,  0, 20,142,
16359      &          0,  0, 98,139,  0,  0,147,  0,  0,  0,
16360      &          0,  0, 21, 22, 97,138,  0,  0, 20, 98,
16361      &        139,  0,  0,  0,145,  0,  0,148,  0,  0,
16362      &          0,  0,  0,140,137,138,146,  0,  0,142,
16363      &        139,147,  0,  0,145,148,           50*0/
16364       DATA IBB/53, 54,104,161,  0,  0, 55,105,162,  0,
16365      &          0,107,164,  0,  0,167,  0,  0,  0,  0,
16366      &          0, 54, 55,105,162,  0,  0, 56,106,163,
16367      &          0,  0,108,165,  0,  0,168,  0,  0,  0,
16368      &          0,  0,104,105,107,164,  0,  0,106,108,
16369      &        165,  0,  0,109,166,  0,  0,169,  0,  0,
16370      &          0,  0,  0,161,162,164,167,  0,  0,163,
16371      &        165,168,  0,  0,166,169,  0,  0,170,47*0/
16372       DATA IA/  0,  2, 99,152,  0,  0,  9,100,149,  0,
16373      &          0,102,150,  0,  0,158,  0,  0,  0,  0,
16374      &          0,  2,  9,100,149,  0,  0,  0,101,154,
16375      &          0,  0,103,151,  0,  0,159,  0,  0,  0,
16376      &          0,  0, 99,100,102,150,  0,  0,101,103,
16377      &        151,  0,  0,  0,157,  0,  0,160,  0,  0,
16378      &          0,  0,  0,152,149,150,158,  0,  0,154,
16379      &        151,159,  0,  0,157,160,           50*0/
16380       DATA IAA/67, 68,110,171,  0,  0, 69,111,172,  0,
16381      &          0,113,174,  0,  0,177,  0,  0,  0,  0,
16382      &          0, 68, 69,111,172,  0,  0, 70,112,173,
16383      &          0,  0,114,175,  0,  0,178,  0,  0,  0,
16384      &          0,  0,110,111,113,174,  0,  0,112,114,
16385      &        175,  0,  0,115,176,  0,  0,179,  0,  0,
16386      &          0,  0,  0,171,172,174,177,  0,  0,173,
16387      &        175,178,  0,  0,176,179,  0,  0,180,47*0/
16388
16389       L=0
16390       DO 2 I=1,6
16391          DO 1 J=1,6
16392             L = L+1
16393             IMPS(I,J) = IP(L)
16394             IMVE(I,J) = IV(L)
16395     1    CONTINUE
16396     2 CONTINUE
16397       L=0
16398       DO 4 I=1,6
16399          DO 3 J=1,21
16400             L = L+1
16401             IB08(I,J) = IB(L)
16402             IB10(I,J) = IBB(L)
16403             IA08(I,J) = IA(L)
16404             IA10(I,J) = IAA(L)
16405     3    CONTINUE
16406     4 CONTINUE
16407 C     A1  = 0.88D0
16408 C     B1  = 3.0D0
16409 C     B2  = 3.0D0
16410 C     B3  = 8.0D0
16411 C     LT  = 0
16412 C     LB  = 0
16413 C     BET = 12.0D0
16414 C     AS  = 0.25D0
16415 C     B8  = 0.33D0
16416 C     AME = 0.95D0
16417 C     DIQ = 0.375D0
16418 C     ISU = 4
16419
16420       RETURN
16421       END
16422
16423 *$ CREATE DT_INITJS.FOR
16424 *COPY DT_INITJS
16425 *
16426 *===initjs=============================================================*
16427 *
16428       SUBROUTINE DT_INITJS(MODE)
16429
16430 ************************************************************************
16431 * Initialize JETSET paramters.                                         *
16432 *           MODE = 0 default settings                                  *
16433 *                = 1 PHOJET settings                                   *
16434 *                = 2 DTUNUC settings                                   *
16435 * This version dated 16.02.96 is written by S. Roesler                 *
16436 *                                                                      *
16437 * Last change 27.12.2006 by S. Roesler.                                *
16438 ************************************************************************
16439
16440       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16441       SAVE
16442
16443       PARAMETER ( LINP = 10 ,
16444      &            LOUT = 6 ,
16445      &            LDAT = 9 )
16446
16447       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16448
16449       LOGICAL LFIRST,LFIRDT,LFIRPH
16450
16451 *      INCLUDE '(DIMPAR)'
16452 *     DIMPAR taken from FLUKA
16453       PARAMETER ( MXXRGN =20000 )
16454       PARAMETER ( MXXMDF =  710 )
16455       PARAMETER ( MXXMDE =  702 )
16456       PARAMETER ( MFSTCK =40000 )
16457       PARAMETER ( MESTCK =  100 )
16458       PARAMETER ( MOSTCK = 2000 )
16459       PARAMETER ( MXPRSN =  100 )
16460       PARAMETER ( MXPDPM =  800 )
16461       PARAMETER ( MXPSCS =30000 )
16462       PARAMETER ( MXGLWN =  300 )
16463       PARAMETER ( MXOUTU =   50 )
16464       PARAMETER ( NALLWP =   64 )
16465       PARAMETER ( NELEMX =   80 )
16466       PARAMETER ( MPDPDX =   18 )
16467       PARAMETER ( MXHTTR =  260 )
16468       PARAMETER ( MXSEAX =   20 )
16469       PARAMETER ( MXHTNC = MXSEAX + 1 )
16470       PARAMETER ( ICOMAX = 2400 )
16471       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
16472       PARAMETER ( NSTBIS =  304 )
16473       PARAMETER ( NQSTIS =   46 )
16474       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
16475       PARAMETER ( MXPABL =  120 )
16476       PARAMETER ( IDMAXP =  450 )
16477       PARAMETER ( IDMXDC = 2000 )
16478       PARAMETER ( MXMCIN =  410 )
16479       PARAMETER ( IHYPMX =    4 )
16480       PARAMETER ( MKBMX1 =   11 )
16481       PARAMETER ( MKBMX2 =   11 )
16482       PARAMETER ( MXIRRD = 2500 )
16483       PARAMETER ( MXTRDC = 1500 )
16484       PARAMETER ( NKTL   =   17 )
16485       PARAMETER ( NBLNMX = 40000000 )
16486
16487 *      INCLUDE '(PART)'
16488 *     PART taken from FLUKA
16489       PARAMETER ( KPETA0 =  31 )
16490       PARAMETER ( KPRHOP =  32 )
16491       PARAMETER ( KPRHO0 =  33 )
16492       PARAMETER ( KPRHOM =  34 )
16493       PARAMETER ( KPOME0 =  35 )
16494       PARAMETER ( KPPHI0 =  96 )
16495       PARAMETER ( KPDEPP =  53 )
16496       PARAMETER ( KPDELP =  54 )
16497       PARAMETER ( KPDEL0 =  55 )
16498       PARAMETER ( KPDELM =  56 )
16499       PARAMETER ( KPN14P =  91 )
16500       PARAMETER ( KPN140 =  92 )
16501 *  Low mass diffraction partners:
16502       PARAMETER ( KDETA0 =   0 )
16503       PARAMETER ( KDRHOP =   0 )
16504       PARAMETER ( KDRHO0 = 210 )
16505       PARAMETER ( KDRHOM =   0 )
16506       PARAMETER ( KDOME0 = 210 )
16507       PARAMETER ( KDPHI0 = 210 )
16508       PARAMETER ( KDDEPP =   0 )
16509       PARAMETER ( KDDELP =   0 )
16510       PARAMETER ( KDDEL0 =   0 )
16511       PARAMETER ( KDDELM =   0 )
16512       PARAMETER ( KDN14P =   0 )
16513       PARAMETER ( KDN140 =   0 )
16514 *
16515       CHARACTER*8  ANAME
16516       COMMON / PART /  AM     (-6:IDMAXP), GA     (-6:IDMAXP),
16517      &                 TAU    (-6:IDMAXP), AMDISC (-6:IDMAXP),
16518      &                 ZMNABS (-6:IDMAXP), ATNMNA (-6:IDMAXP),
16519      &                 ATXN14,     ATMN14, RNRN14    (-10:10),
16520      &                 ICH    (-6:IDMAXP), IBAR   (-6:IDMAXP),
16521      &                 ISOSYM (-6:IDMAXP), ICHCON (-6:IDMAXP),
16522      &                 K1     (-6:IDMAXP), K2     (-6:IDMAXP),
16523      &                 KPTOIP (-6:IDMAXP), IPTOKP (-6:NALLWP),
16524      &                 KPTOIA (-6:IDMAXP), IATOKP (-6:MXPABL),
16525      &                 IDCFLG (-6:NALLWP), IPTYPE (-6:NALLWP)
16526
16527       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16528       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16529       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16530
16531 * flags for particle decays
16532       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
16533      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
16534      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
16535
16536 * flags for input different options
16537       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16538       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16539      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16540
16541       INTEGER PYCOMP
16542
16543       DIMENSION IDXSTA(40)
16544       DATA IDXSTA
16545 *          K0s   pi0  lam   alam  sig+  asig+ sig-  asig- tet0  atet0
16546      &  /  310,  111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
16547 *          tet- atet-  om-  aom-   D+    D-    D0    aD0   Ds+   aDs+
16548      &    3312,-3312, 3334,-3334,  411, -411,  421, -421,  431, -431,
16549 *          etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
16550      &     441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
16551 *         Ksic0 aKsic+aKsic0 sig0 asig0
16552      &    4132,-4232,-4132, 3212,-3212, 5*0/
16553
16554       DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
16555
16556       IF (LFIRST) THEN
16557 * save default settings
16558          PDEF1  = PARJ(1)
16559          PDEF2  = PARJ(2)
16560          PDEF3  = PARJ(3)
16561          PDEF5  = PARJ(5)
16562          PDEF6  = PARJ(6)
16563          PDEF7  = PARJ(7)
16564          PDEF18 = PARJ(18)
16565          PDEF19 = PARJ(19)
16566          PDEF21 = PARJ(21)
16567          PDEF42 = PARJ(42)
16568          MDEF12 = MSTJ(12)
16569 * LUJETS / PYJETS array-dimensions
16570
16571          MSTU(4) = 4000
16572
16573 * increase maximum number of JETSET-error prints
16574          MSTU(22) = 50000
16575 * prevent particles decaying
16576          DO 1 I=1,35
16577             IF (I.LT.34) THEN
16578
16579                KC = PYCOMP(IDXSTA(I))
16580
16581                IF (KC.GT.0) THEN
16582                   IF (I.EQ.2) THEN
16583 *  pi0 decay
16584 C                    MDCY(KC,1) = 1
16585                      MDCY(KC,1) = 0
16586 **cr mode
16587 C                 ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
16588 C   &                    (I.EQ.8).OR.(I.EQ.10)) THEN
16589 C                 ELSEIF (I.EQ.4) THEN
16590 C                    MDCY(KC,1) = 1
16591 **
16592                   ELSE
16593                      MDCY(KC,1) = 0
16594                   ENDIF
16595                ENDIF
16596             ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
16597
16598                KC = PYCOMP(IDXSTA(I))
16599
16600                IF (KC.GT.0) THEN
16601                   MDCY(KC,1) = 0
16602                ENDIF
16603             ENDIF
16604     1    CONTINUE
16605 *
16606
16607 * as Fluka event-generator: allow only paprop particles to be stable
16608 * and let all other particles decay (i.e. those with strong decays)
16609          IF (ITRSPT.EQ.1) THEN
16610             DO 5 I=1,IDMAXP
16611                IF (KPTOIP(I).NE.0) THEN
16612                   IDPDG = MPDGHA(I)
16613
16614                   KC    = PYCOMP(IDPDG)
16615
16616                   IF (KC.GT.0) THEN
16617                      IF (MDCY(KC,1).EQ.1) THEN
16618                         WRITE(LOUT,*)
16619      &                     ' DT_INITJS: Decay flag for FLUKA-',
16620      &                     'transport : particle should not ',
16621      &                     'decay : ',IDPDG,'  ',ANAME(I)
16622                         MDCY(KC,1) = 0
16623                      ENDIF
16624                   ENDIF
16625                ENDIF
16626     5       CONTINUE
16627             DO 6 KC=1,500
16628                IDPDG = KCHG(KC,4)
16629                KP    = MCIHAD(IDPDG)
16630                IF (KP.GT.0) THEN
16631                   IF ((MDCY(KC,1).EQ.0).AND.(KPTOIP(KP).EQ.0).AND.
16632      &                (ANAME(KP).NE.'BLANK   ').AND.
16633      &                (ANAME(KP).NE.'RNDFLV  ')) THEN
16634                      WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-',
16635      &                             'transport: particle should decay ',
16636      &                             ': ',IDPDG,' ',ANAME(KP)
16637                      MDCY(KC,1) = 1
16638                   ENDIF
16639                ENDIF
16640     6       CONTINUE
16641          ENDIF
16642
16643 *
16644 * popcorn:
16645          IF (PDB.LE.ZERO) THEN
16646 *   no popcorn-mechanism
16647             MSTJ(12) = 1
16648          ELSE
16649             MSTJ(12) = 3
16650             PARJ(5)  = PDB
16651          ENDIF
16652 * set JETSET-parameter requested by input cards
16653          IF (NMSTU.GT.0) THEN
16654             DO 2 I=1,NMSTU
16655                MSTU(IMSTU(I)) = MSTUX(I)
16656     2       CONTINUE
16657          ENDIF
16658          IF (NMSTJ.GT.0) THEN
16659             DO 3 I=1,NMSTJ
16660                MSTJ(IMSTJ(I)) = MSTJX(I)
16661     3       CONTINUE
16662          ENDIF
16663          IF (NPARU.GT.0) THEN
16664             DO 4 I=1,NPARU
16665                PARU(IPARU(I)) = PARUX(I)
16666     4       CONTINUE
16667          ENDIF
16668          LFIRST = .FALSE.
16669       ENDIF
16670 *
16671 * PARJ(1)  suppression of qq-aqaq pair prod. compared to
16672 *          q-aq pair prod.                      (default: 0.1)
16673 * PARJ(2)  strangeness suppression               (default: 0.3)
16674 * PARJ(3)  extra suppression of strange diquarks (default: 0.4)
16675 * PARJ(6)  extra suppression of sas-pair shared by B and
16676 *          aB in BMaB                           (default: 0.5)
16677 * PARJ(7)  extra suppression of strange meson M in BMaB
16678 *          configuration                        (default: 0.5)
16679 * PARJ(18) spin 3/2 baryon suppression           (default: 1.0)
16680 * PARJ(21) width sigma in Gaussian p_x, p_y transverse
16681 *          momentum distrib. for prim. hadrons  (default: 0.35)
16682 * PARJ(42) b-parameter for symmetric Lund-fragmentation
16683 *          function                             (default: 0.9 GeV^-2)
16684 *
16685 * PHOJET settings
16686       IF (MODE.EQ.1) THEN
16687 *   JETSET default
16688 C        PARJ(1)  = PDEF1
16689 C        PARJ(2)  = PDEF2
16690 C        PARJ(3)  = PDEF3
16691 C        PARJ(6)  = PDEF6
16692 C        PARJ(7)  = PDEF7
16693 C        PARJ(18) = PDEF18
16694 C        PARJ(21) = PDEF21
16695 C        PARJ(42) = PDEF42
16696 **sr 18.11.98 parameter tuning
16697 C        PARJ(1)  = 0.092D0
16698 C        PARJ(2)  = 0.25D0
16699 C        PARJ(3)  = 0.45D0
16700 C        PARJ(19) = 0.3D0
16701 C        PARJ(21) = 0.45D0
16702 C        PARJ(42) = 1.0D0
16703 **sr 28.04.99 parameter tuning (May 99 minor modifications)
16704          PARJ(1)  = 0.085D0
16705          PARJ(2)  = 0.26D0
16706          PARJ(3)  = 0.8D0
16707          PARJ(11) = 0.38D0
16708          PARJ(18) = 0.3D0
16709          PARJ(19) = 0.4D0
16710          PARJ(21) = 0.36D0
16711          PARJ(41) = 0.3D0
16712          PARJ(42) = 0.86D0
16713          IF (NPARJ.GT.0) THEN
16714             DO 10 I=1,NPARJ
16715                IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
16716    10       CONTINUE
16717          ENDIF
16718          IF (LFIRPH) THEN
16719             WRITE(LOUT,'(1X,A)')
16720      &         'DT_INITJS: JETSET-parameter for PHOJET'
16721             CALL DT_JSPARA(0)
16722             LFIRPH = .FALSE.
16723          ENDIF
16724 * DTUNUC settings
16725       ELSEIF (MODE.EQ.2) THEN
16726          IF (IFRAG(2).EQ.1) THEN
16727 **sr parameters before 9.3.96
16728 C           PARJ(2)  = 0.27D0
16729 C           PARJ(3)  = 0.6D0
16730 C           PARJ(6)  = 0.75D0
16731 C           PARJ(7)  = 0.75D0
16732 C           PARJ(21) = 0.55D0
16733 C           PARJ(42) = 1.3D0
16734 **sr 18.11.98 parameter tuning
16735 C           PARJ(1)  = 0.05D0
16736 C           PARJ(2)  = 0.27D0
16737 C           PARJ(3)  = 0.4D0
16738 C           PARJ(19) = 0.2D0
16739 C           PARJ(21) = 0.45D0
16740 C           PARJ(42) = 1.0D0
16741 **sr 28.04.99 parameter tuning
16742             PARJ(1)  = 0.11D0
16743             PARJ(2)  = 0.36D0
16744             PARJ(3)  = 0.8D0
16745             PARJ(19) = 0.2D0
16746             PARJ(21) = 0.3D0
16747             PARJ(41) = 0.3D0
16748             PARJ(42) = 0.58D0
16749             IF (NPARJ.GT.0) THEN
16750                DO 20 I=1,NPARJ
16751                   IF (IPARJ(I).LT.0) THEN
16752                      IDX = ABS(IPARJ(I))
16753                      PARJ(IDX) = PARJX(I)
16754                   ENDIF
16755    20          CONTINUE
16756             ENDIF
16757             IF (LFIRDT) THEN
16758                WRITE(LOUT,'(1X,A)')
16759      &           'DT_INITJS: JETSET-parameter for DTUNUC'
16760                CALL DT_JSPARA(0)
16761                LFIRDT = .FALSE.
16762             ENDIF
16763          ELSEIF (IFRAG(2).EQ.2) THEN
16764             PARJ(1)  = 0.11D0
16765             PARJ(2)  = 0.27D0
16766             PARJ(3)  = 0.3D0
16767             PARJ(6)  = 0.35D0
16768             PARJ(7)  = 0.45D0
16769             PARJ(18) = 0.66D0
16770 C           PARJ(21) = 0.55D0
16771 C           PARJ(42) = 1.0D0
16772             PARJ(21) = 0.60D0
16773             PARJ(42) = 1.3D0
16774          ELSE
16775             PARJ(1)  = PDEF1
16776             PARJ(2)  = PDEF2
16777             PARJ(3)  = PDEF3
16778             PARJ(6)  = PDEF6
16779             PARJ(7)  = PDEF7
16780             PARJ(18) = PDEF18
16781             PARJ(21) = PDEF21
16782             PARJ(42) = PDEF42
16783          ENDIF
16784       ELSE
16785          PARJ(1)  = PDEF1
16786          PARJ(2)  = PDEF2
16787          PARJ(3)  = PDEF3
16788          PARJ(5)  = PDEF5
16789          PARJ(6)  = PDEF6
16790          PARJ(7)  = PDEF7
16791          PARJ(18) = PDEF18
16792          PARJ(19) = PDEF19
16793          PARJ(21) = PDEF21
16794          PARJ(42) = PDEF42
16795          MSTJ(12) = MDEF12
16796       ENDIF
16797
16798       RETURN
16799       END
16800
16801 *$ CREATE DT_JSPARA.FOR
16802 *COPY DT_JSPARA
16803 *
16804 *===jspara=============================================================*
16805 *
16806       SUBROUTINE DT_JSPARA(MODE)
16807
16808       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16809       SAVE
16810
16811       PARAMETER ( LINP = 10 ,
16812      &            LOUT = 6 ,
16813      &            LDAT = 9 )
16814
16815       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
16816      &           ONE=1.0D0,ZERO=0.0D0)
16817
16818       LOGICAL LFIRST
16819
16820       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16821
16822       DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
16823
16824       DATA LFIRST /.TRUE./
16825
16826 * save the default JETSET-parameter on the first call
16827       IF (LFIRST) THEN
16828          DO 1 I=1,200
16829             ISTU(I) = MSTU(I)
16830             QARU(I) = PARU(I)
16831             ISTJ(I) = MSTJ(I)
16832             QARJ(I) = PARJ(I)
16833     1    CONTINUE
16834          LFIRST = .FALSE.
16835       ENDIF
16836
16837       WRITE(LOUT,1000)
16838  1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
16839
16840 * compare the default JETSET-parameter with the present values
16841       DO 2 I=1,200
16842          IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
16843             WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
16844 C           ISTU(I) = MSTU(I)
16845          ENDIF
16846          DIFF = ABS(PARU(I)-QARU(I))
16847          IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
16848             WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
16849 C           QARU(I) = PARU(I)
16850          ENDIF
16851          IF (MSTJ(I).NE.ISTJ(I)) THEN
16852             WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16853 C           ISTJ(I) = MSTJ(I)
16854          ENDIF
16855          DIFF = ABS(PARJ(I)-QARJ(I))
16856          IF (DIFF.GE.1.0D-5) THEN
16857             WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16858 C           QARJ(I) = PARJ(I)
16859          ENDIF
16860     2 CONTINUE
16861  1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16862  1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16863
16864       RETURN
16865       END
16866 *$ CREATE DT_FOZOCA.FOR
16867 *COPY DT_FOZOCA
16868 *
16869 *===fozoca=============================================================*
16870 *
16871       SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16872
16873 ************************************************************************
16874 * This subroutine treats the complete FOrmation ZOne supressed intra-  *
16875 * nuclear CAscade.                                                     *
16876 *               LFZC = .true.  cascade has been treated                *
16877 *                    = .false. cascade skipped                         *
16878 * This is a completely revised version of the original FOZOKL.         *
16879 * This version dated 18.11.95 is written by S. Roesler                 *
16880 ************************************************************************
16881
16882       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16883       SAVE
16884
16885       PARAMETER ( LINP = 10 ,
16886      &            LOUT = 6 ,
16887      &            LDAT = 9 )
16888
16889       PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16890       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16891
16892       LOGICAL LSTART,LCAS,LFZC
16893
16894 * event history
16895
16896       PARAMETER (NMXHKK=200000)
16897
16898       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16899      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16900      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16901
16902 * extended event history
16903       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16904      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16905      &                IHIST(2,NMXHKK)
16906
16907 * rejection counter
16908       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16909      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16910      &                IREXCI(3),IRDIFF(2),IRINC
16911
16912 * properties of interacting particles
16913       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16914
16915 * Glauber formalism: collision properties
16916       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16917      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
16918      &                NCP,NCT
16919
16920 * flags for input different options
16921       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16922       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16923      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16924
16925 * final state after intranuclear cascade step
16926       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16927
16928 * parameter for intranuclear cascade
16929       LOGICAL LPAULI
16930       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16931
16932       DIMENSION NCWOUN(2)
16933
16934       DATA LSTART /.TRUE./
16935
16936       LFZC = .TRUE.
16937       IREJ = 0
16938
16939 * skip cascade if hadron-hadron interaction or if supressed by user
16940       IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16941 * skip cascade if not all possible chains systems are hadronized
16942       DO 1 I=1,8
16943          IF (.NOT.LHADRO(I)) GOTO 9999
16944     1 CONTINUE
16945
16946       IF (LSTART) THEN
16947          WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16948  1000    FORMAT(/,1X,'FOZOCA:  intranuclear cascade treated for a ',
16949      &          'maximum of',I4,' generations',/,10X,'formation time ',
16950      &          'parameter:',F5.1,'  fm/c',9X,'modus:',I2)
16951          IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16952          IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16953  1001    FORMAT(10X,'p_t dependent formation zone',/)
16954  1002    FORMAT(10X,'constant formation zone',/)
16955          LSTART = .FALSE.
16956       ENDIF
16957
16958 * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16959 * which may interact with final state particles are stored in a seperate
16960 * array - here all proj./target nucleon-indices (just for simplicity)
16961       NOINC = 0
16962       DO 9 I=1,NPOINT(1)-1
16963          NOINC = NOINC+1
16964          IDXINC(NOINC) = I
16965     9 CONTINUE
16966
16967 * initialize Pauli-principle treatment (find wounded nucleons)
16968       NWOUND(1) = 0
16969       NWOUND(2) = 0
16970       NCWOUN(1) = 0
16971       NCWOUN(2) = 0
16972       DO 2 J=1,NPOINT(1)
16973          DO 3 I=1,2
16974             IF (ISTHKK(J).EQ.10+I) THEN
16975                NWOUND(I) = NWOUND(I)+1
16976                EWOUND(I,NWOUND(I)) = PHKK(4,J)
16977                IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16978             ENDIF
16979     3    CONTINUE
16980     2 CONTINUE
16981
16982 * modify nuclear potential for wounded nucleons
16983       IPRCL  = IP -NWOUND(1)
16984       IPZRCL = IPZ-NCWOUN(1)
16985       ITRCL  = IT -NWOUND(2)
16986       ITZRCL = ITZ-NCWOUN(2)
16987       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16988
16989       NSTART = NPOINT(4)
16990       NEND   = NHKK
16991
16992     7 CONTINUE
16993       DO 8 I=NSTART,NEND
16994
16995          IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16996 * select nucleus the cascade starts first (proj. - 1, target - -1)
16997             NCAS   = 1
16998 *   projectile/target with probab. 1/2
16999             IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
17000                IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
17001 *   in the nucleus with highest mass
17002             ELSEIF (INCMOD.EQ.2) THEN
17003                IF (IP.GT.IT) THEN
17004                   NCAS = -NCAS
17005                ELSEIF (IP.EQ.IT) THEN
17006                   IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
17007                ENDIF
17008 * the nucleus the cascade starts first is requested to be the one
17009 * moving in the direction of the secondary
17010             ELSEIF (INCMOD.EQ.3) THEN
17011                NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
17012             ENDIF
17013 * check that the selected "nucleus" is not a hadron
17014             IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
17015      &          ((NCAS.EQ.-1).AND.(IT.LE.1)))    NCAS = -NCAS
17016
17017 * treat intranuclear cascade in the nucleus selected first
17018             LCAS = .FALSE.
17019             CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
17020             IF (IREJ1.NE.0) GOTO 9998
17021 * treat intranuclear cascade in the other nucleus if this isn't a had.
17022             NCAS = -NCAS
17023             IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
17024      &          ((NCAS.EQ.-1).AND.(IT.GT.1)))    THEN
17025                IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
17026                IF (IREJ1.NE.0) GOTO 9998
17027             ENDIF
17028
17029          ENDIF
17030
17031     8 CONTINUE
17032       NSTART = NEND+1
17033       NEND   = NHKK
17034       IF (NSTART.LE.NEND) GOTO 7
17035
17036       RETURN
17037
17038  9998 CONTINUE
17039 * reject this event
17040       IRINC = IRINC+1
17041       IREJ = 1
17042
17043  9999 CONTINUE
17044 * intranucl. cascade not treated because of interaction properties or
17045 * it is supressed by user or it was rejected or...
17046       LFZC = .FALSE.
17047 * reset flag characterizing direction of motion in n-n-cms
17048 **sr14-11-95
17049 C     DO 9990 I=NPOINT(5),NHKK
17050 C        IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
17051 C9990 CONTINUE
17052
17053       RETURN
17054       END
17055
17056 *$ CREATE DT_INUCAS.FOR
17057 *COPY DT_INUCAS
17058 *
17059 *===inucas=============================================================*
17060 *
17061       SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
17062
17063 ************************************************************************
17064 * Formation zone supressed IntraNUclear CAScade for one final state    *
17065 * particle.                                                            *
17066 *           IT, IP    mass numbers of target, projectile nuclei        *
17067 *           IDXCAS    index of final state particle in DTEVT1          *
17068 *           NCAS =  1 intranuclear cascade in projectile               *
17069 *                = -1 intranuclear cascade in target                   *
17070 * This version dated 18.11.95 is written by S. Roesler                 *
17071 ************************************************************************
17072
17073       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17074       SAVE
17075
17076       PARAMETER ( LINP = 10 ,
17077      &            LOUT = 6 ,
17078      &            LDAT = 9 )
17079
17080       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
17081      &           OHALF=0.5D0,ONE=1.0D0)
17082       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
17083       PARAMETER (TWOPI=6.283185307179586454D+00)
17084       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
17085
17086       LOGICAL LABSOR,LCAS
17087
17088 * event history
17089
17090       PARAMETER (NMXHKK=200000)
17091
17092       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17093      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17094      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17095
17096 * extended event history
17097       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17098      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17099      &                IHIST(2,NMXHKK)
17100
17101 * final state after inc step
17102       PARAMETER (MAXFSP=10)
17103       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17104
17105 * flags for input different options
17106       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17107       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17108      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17109
17110 * particle properties (BAMJET index convention)
17111       CHARACTER*8  ANAME
17112       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17113      &                IICH(210),IIBAR(210),K1(210),K2(210)
17114
17115 * Glauber formalism: collision properties
17116       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
17117      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
17118      &                NCP,NCT
17119 * nuclear potential
17120       LOGICAL LFERMI
17121       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17122      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17123      &                ETACOU(2),ICOUL,LFERMI
17124
17125 * parameter for intranuclear cascade
17126       LOGICAL LPAULI
17127       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17128
17129 * final state after intranuclear cascade step
17130       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
17131
17132 * nucleon-nucleon event-generator
17133       CHARACTER*8 CMODEL
17134       LOGICAL LPHOIN
17135       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
17136
17137 * statistics: residual nuclei
17138       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
17139      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
17140      &                NINCST(2,4),NINCEV(2),
17141      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
17142      &                NRESPB(2),NRESCH(2),NRESEV(4),
17143      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
17144      &                NEVAFI(2,2)
17145
17146       DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
17147      &          PCAS1(5),PNUC(5),BGTA(4),
17148      &          BGCAS(2),GACAS(2),BECAS(2),
17149      &          RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
17150
17151       DATA PDIF /0.545D0/
17152
17153       IREJ = 0
17154
17155 * update counter
17156       IF (NINCEV(1).NE.NEVHKK) THEN
17157          NINCEV(1) = NEVHKK
17158          NINCEV(2) = NINCEV(2)+1
17159       ENDIF
17160
17161 * "BAMJET-index" of this hadron
17162       IDCAS = IDBAM(IDXCAS)
17163       IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
17164
17165 * skip gammas, electrons, etc..
17166       IF (AAM(IDCAS).LT.TINY2) RETURN
17167
17168 * Lorentz-trsf. into projectile rest system
17169       IF (IP.GT.1) THEN
17170          CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
17171      &               PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
17172      &               PCAS(1,4),IDCAS,-2)
17173          PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
17174          PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
17175          IF (PCAS(1,5).GT.ZERO) THEN
17176             PCAS(1,5) = SQRT(PCAS(1,5))
17177          ELSE
17178             PCAS(1,5) = AAM(IDCAS)
17179          ENDIF
17180          DO 20 K=1,3
17181             COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
17182    20    CONTINUE
17183 * Lorentz-parameters
17184 *   particle rest system --> projectile rest system
17185          BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
17186          GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
17187          BECAS(1) = BGCAS(1)/GACAS(1)
17188       ELSE
17189          DO 21 K=1,5
17190             PCAS(1,K) = ZERO
17191             IF (K.LE.3) COSCAS(1,K) = ZERO
17192    21    CONTINUE
17193          PTOCAS(1) = ZERO
17194          BGCAS(1)  = ZERO
17195          GACAS(1)  = ZERO
17196          BECAS(1)  = ZERO
17197       ENDIF
17198 * Lorentz-trsf. into target rest system
17199       IF (IT.GT.1) THEN
17200 * LEPTO: final state particles are already in target rest frame
17201 C        IF (MCGENE.EQ.3) THEN
17202 C           PCAS(2,1) = PHKK(1,IDXCAS)
17203 C           PCAS(2,2) = PHKK(2,IDXCAS)
17204 C           PCAS(2,3) = PHKK(3,IDXCAS)
17205 C           PCAS(2,4) = PHKK(4,IDXCAS)
17206 C        ELSE
17207             CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
17208      &                  PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
17209      &                  PCAS(2,4),IDCAS,-3)
17210 C        ENDIF
17211          PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
17212          PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
17213          IF (PCAS(2,5).GT.ZERO) THEN
17214             PCAS(2,5) = SQRT(PCAS(2,5))
17215          ELSE
17216             PCAS(2,5) = AAM(IDCAS)
17217          ENDIF
17218          DO 22 K=1,3
17219             COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
17220    22    CONTINUE
17221 * Lorentz-parameters
17222 *   particle rest system --> target rest system
17223          BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
17224          GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
17225          BECAS(2) = BGCAS(2)/GACAS(2)
17226       ELSE
17227          DO 23 K=1,5
17228             PCAS(2,K) = ZERO
17229             IF (K.LE.3) COSCAS(2,K) = ZERO
17230    23    CONTINUE
17231          PTOCAS(2) = ZERO
17232          BGCAS(2)  = ZERO
17233          GACAS(2)  = ZERO
17234          BECAS(2)  = ZERO
17235       ENDIF
17236
17237 * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
17238 * potential (see CONUCL)
17239       RNUC(1)  = (RPROJ+4.605D0*PDIF)*FM2MM
17240       RNUC(2)  = (RTARG+4.605D0*PDIF)*FM2MM
17241 * impact parameter (the projectile moving along z)
17242       BIMPC(1) = ZERO
17243       BIMPC(2) = BIMPAC*FM2MM
17244
17245 * get position of initial hadron in projectile/target rest-syst.
17246       DO 3 K=1,4
17247          VTXCAS(1,K) = WHKK(K,IDXCAS)
17248          VTXCAS(2,K) = VHKK(K,IDXCAS)
17249     3 CONTINUE
17250
17251       ICAS = 1
17252       I2   = 2
17253       IF (NCAS.EQ.-1) THEN
17254          ICAS = 2
17255          I2   = 1
17256       ENDIF
17257
17258       IF (PTOCAS(ICAS).LT.TINY10) THEN
17259          WRITE(LOUT,1000) PTOCAS
17260  1000    FORMAT(1X,'INUCAS:   warning! zero momentum of initial',
17261      &          '  hadron ',/,20X,2E12.4)
17262          GOTO 9999
17263       ENDIF
17264
17265 * reset spectator flags
17266       NSPE = 0
17267       IDXSPE(1) = 0
17268       IDXSPE(2) = 0
17269       IDSPE(1)  = 0
17270       IDSPE(2)  = 0
17271
17272 * formation length (in fm)
17273 C     IF (LCAS) THEN
17274 C        DEL0 = ZERO
17275 C     ELSE
17276          DEL0 = TAUFOR*BGCAS(ICAS)
17277          IF (ITAUVE.EQ.1) THEN
17278             AMT  = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
17279             DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
17280          ENDIF
17281 C     ENDIF
17282 *   sample from exp(-del/del0)
17283       DEL1   = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
17284 * save formation time
17285       TAUSA1 = DEL1/BGCAS(ICAS)
17286       REL1   = TAUSA1*BGCAS(I2)
17287
17288       DEL    = DEL1
17289       TAUSAM = DEL/BGCAS(ICAS)
17290       REL    = TAUSAM*BGCAS(I2)
17291
17292 * special treatment for negative particles unable to escape
17293 * nuclear potential (implemented for ap, pi-, K- only)
17294       LABSOR = .FALSE.
17295       IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
17296 *   threshold energy = nuclear potential + Coulomb potential
17297 *   (nuclear potential for hadron-nucleus interactions only)
17298          ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
17299          IF (PCAS(ICAS,4).LT.ETHR) THEN
17300             DO 4 K=1,5
17301                PCAS1(K) = PCAS(ICAS,K)
17302     4       CONTINUE
17303 *   "absorb" negative particle in nucleus
17304             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
17305             IF (IREJ1.NE.0) GOTO 9999
17306             IF (NSPE.GE.1) LABSOR = .TRUE.
17307          ENDIF
17308       ENDIF
17309
17310 * if the initial particle has not been absorbed proceed with
17311 * "normal" cascade
17312       IF (.NOT.LABSOR) THEN
17313
17314 *   calculate coordinates of hadron at the end of the formation zone
17315 *   transport-time and -step in the rest system where this step is
17316 *   treated
17317          DSTEP  = DEL*FM2MM
17318          DTIME  = DSTEP/BECAS(ICAS)
17319          RSTEP  = REL*FM2MM
17320          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17321             RTIME = RSTEP/BECAS(I2)
17322          ELSE
17323             RTIME = ZERO
17324          ENDIF
17325 *   save step whithout considering the overlapping region
17326          DSTEP1 = DEL1*FM2MM
17327          DTIME1 = DSTEP1/BECAS(ICAS)
17328          RSTEP1 = REL1*FM2MM
17329          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17330             RTIME1 = RSTEP1/BECAS(I2)
17331          ELSE
17332             RTIME1 = ZERO
17333          ENDIF
17334 *   transport to the end of the formation zone in this system
17335          DO 5 K=1,3
17336             VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
17337             VTXCA1(I2,K)   = VTXCAS(I2,K)  +RSTEP1*COSCAS(I2,K)
17338             VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
17339             VTXCAS(I2,K)   = VTXCAS(I2,K)  +RSTEP*COSCAS(I2,K)
17340     5    CONTINUE
17341          VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
17342          VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME1
17343          VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17344          VTXCAS(I2,4)   = VTXCAS(I2,4)  +RTIME
17345
17346          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17347             XCAS   = VTXCAS(ICAS,1)
17348             YCAS   = VTXCAS(ICAS,2)
17349             XNCLTA = BIMPAC*FM2MM
17350             RNCLPR = (RPROJ+RNUCLE)*FM2MM
17351             RNCLTA = (RTARG+RNUCLE)*FM2MM
17352 C           RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
17353 C           RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
17354 C           RNCLPR = (RPROJ)*FM2MM
17355 C           RNCLTA = (RTARG)*FM2MM
17356             RCASPR = SQRT( XCAS**2        +YCAS**2)
17357             RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
17358             IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
17359                IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
17360             ENDIF
17361          ENDIF
17362
17363 *   check if particle is already outside of the corresp. nucleus
17364          RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
17365      &                VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
17366          IF (RDIST.GE.RNUC(ICAS)) THEN
17367 *   here: IDCH is the generation of the final state part. starting
17368 *   with zero for hadronization products
17369 *   flag particles of generation 0 being outside the nuclei after
17370 *   formation time (to be used for excitation energy calculation)
17371             IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
17372      &         NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
17373             GOTO 9997
17374          ENDIF
17375          DIST   = DLARGE
17376          DISTP  = DLARGE
17377          DISTN  = DLARGE
17378          IDXP   = 0
17379          IDXN   = 0
17380
17381 *   already here: skip particles being outside HADRIN "energy-window"
17382 *   to avoid wasting of time
17383          NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
17384          IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
17385             NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
17386 C           WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
17387 C1002       FORMAT(1X,'INUCAS:   warning! momentum of particle with ',
17388 C    &             'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
17389 C    &             E12.4,', above or below HADRIN-thresholds',I6)
17390             NSPE = 0
17391             GOTO 9997
17392          ENDIF
17393
17394          DO 7 IDXHKK=1,NOINC
17395             I = IDXINC(IDXHKK)
17396 *   scan DTEVT1 for unwounded or excited nucleons
17397             IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
17398                DO 8 K=1,3
17399                   IF (ICAS.EQ.1) THEN
17400                      VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
17401                   ELSEIF (ICAS.EQ.2) THEN
17402                      VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
17403                   ENDIF
17404     8          CONTINUE
17405                POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
17406      &                  VTXDST(2)*COSCAS(ICAS,2)+
17407      &                  VTXDST(3)*COSCAS(ICAS,3)
17408 *   check if nucleon is situated in forward direction
17409                IF (POSNUC.GT.ZERO) THEN
17410 *   distance between hadron and this nucleon
17411                   DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17412      &                          VTXDST(3)**2)
17413 *   impact parameter
17414                   BIMNU2 = DISTNU**2-POSNUC**2
17415                   IF (BIMNU2.LT.ZERO) THEN
17416                      WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
17417  1001                FORMAT(1X,'INUCAS:   warning! inconsistent impact',
17418      &                      '  parameter ',/,20X,3E12.4)
17419                      GOTO 7
17420                   ENDIF
17421                   BIMNU  = SQRT(BIMNU2)
17422 *   maximum impact parameter to have interaction
17423                   IDNUC  = IDT_ICIHAD(IDHKK(I))
17424                   IDNUC1 = IDT_MCHAD(IDNUC)
17425                   IDCAS1 = IDT_MCHAD(IDCAS)
17426                   DO 19 K=1,5
17427                      PCAS1(K) = PCAS(ICAS,K)
17428                      PNUC(K)  = PHKK(K,I)
17429    19             CONTINUE
17430 * Lorentz-parameter for trafo into rest-system of target
17431                   DO 18 K=1,4
17432                      BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
17433    18             CONTINUE
17434 * transformation of projectile into rest-system of target
17435                   CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
17436      &                        PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
17437      &                        PPTOT,PX,PY,PZ,PE)
17438 **
17439 C                 CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
17440 C                 CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
17441                   DUMZER = ZERO
17442                   CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
17443                   CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
17444                   IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
17445      &                (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
17446                   SIGIN = SIGTOT-SIGEL-SIGAB
17447 C                 SIGTOT = SIGIN+SIGEL+SIGAB
17448 **
17449                   BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
17450 *   check if interaction is possible
17451                   IF (BIMNU.LE.BIMMAX) THEN
17452 *   get nucleon with smallest distance and kind of interaction
17453 *   (elastic/inelastic)
17454                      IF (DISTNU.LT.DIST) THEN
17455                         DIST      = DISTNU
17456                         BINT      = BIMNU
17457                         IF (IDNUC.NE.IDSPE(1)) THEN
17458                            IDSPE(2)  = IDSPE(1)
17459                            IDXSPE(2) = IDXSPE(1)
17460                            IDSPE(1)  = IDNUC
17461                         ENDIF
17462                         IDXSPE(1) = I
17463                         NSPE      = 1
17464 **sr
17465                         SELA = SIGEL
17466                         SABS = SIGAB
17467                         STOT = SIGTOT
17468 C                       IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
17469 C                          SELA = SIGEL
17470 C                          STOT = SIGIN+SIGEL
17471 C                       ELSE
17472 C                          SELA = SIGEL+0.75D0*SIGIN
17473 C                          STOT = 0.25D0*SIGIN+SELA
17474 C                       ENDIF
17475 **
17476                      ENDIF
17477                   ENDIf
17478                ENDIF
17479                DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17480      &                       VTXDST(3)**2)
17481                IDNUC  = IDT_ICIHAD(IDHKK(I))
17482                IF (IDNUC.EQ.1) THEN
17483                   IF (DISTNU.LT.DISTP) THEN
17484                      DISTP = DISTNU
17485                      IDXP  = I
17486                      POSP  = POSNUC
17487                   ENDIF
17488                ELSEIF (IDNUC.EQ.8) THEN
17489                   IF (DISTNU.LT.DISTN) THEN
17490                      DISTN = DISTNU
17491                      IDXN  = I
17492                      POSN  = POSNUC
17493                   ENDIF
17494                ENDIF
17495             ENDIF
17496     7    CONTINUE
17497
17498 * there is no nucleon for a secondary interaction
17499          IF (NSPE.EQ.0) GOTO 9997
17500
17501 C        IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
17502 C    &      WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
17503          IF (IDXSPE(2).EQ.0) THEN
17504             IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
17505 C              DO 80 K=1,3
17506 C                 IF (ICAS.EQ.1) THEN
17507 C                    VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
17508 C                 ELSEIF (ICAS.EQ.2) THEN
17509 C                    VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
17510 C                 ENDIF
17511 C  80          CONTINUE
17512 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17513 C    &                       VTXDST(3)**2)
17514 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
17515                   IDXSPE(2) = IDXN
17516                   IDSPE(2)  = 8
17517 C              ELSE
17518 C                 STOT = STOT-SABS
17519 C                 SABS = ZERO
17520 C              ENDIF
17521             ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
17522 C              DO 81 K=1,3
17523 C                 IF (ICAS.EQ.1) THEN
17524 C                    VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
17525 C                 ELSEIF (ICAS.EQ.2) THEN
17526 C                    VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
17527 C                 ENDIF
17528 C  81          CONTINUE
17529 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17530 C    &                       VTXDST(3)**2)
17531 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
17532                   IDXSPE(2) = IDXP
17533                   IDSPE(2)  = 1
17534 C              ELSE
17535 C                 STOT = STOT-SABS
17536 C                 SABS = ZERO
17537 C              ENDIF
17538             ELSE
17539                STOT = STOT-SABS
17540                SABS = ZERO
17541             ENDIF
17542          ENDIF
17543          RR = DT_RNDM(DIST)
17544          IF (RR.LT.SELA/STOT) THEN
17545             IPROC = 2
17546          ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
17547             IPROC = 3
17548          ELSE
17549             IPROC = 1
17550          ENDIF
17551
17552          DO 9 K=1,5
17553             PCAS1(K) = PCAS(ICAS,K)
17554             PNUC(K)  = PHKK(K,IDXSPE(1))
17555     9    CONTINUE
17556          IF (IPROC.EQ.3) THEN
17557 * 2-nucleon absorption of pion
17558             NSPE = 2
17559             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
17560             IF (IREJ1.NE.0) GOTO 9999
17561             IF (NSPE.GE.1) LABSOR = .TRUE.
17562          ELSE
17563 * sample secondary interaction
17564             IDNUC = IDBAM(IDXSPE(1))
17565             CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
17566             IF (IREJ1.EQ.1) GOTO 9999
17567             IF (IREJ1.GT.1) GOTO 9998
17568          ENDIF
17569       ENDIF
17570
17571 * update arrays to include Pauli-principle
17572       DO 10 I=1,NSPE
17573          IF (NWOUND(ICAS).LE.299) THEN
17574             NWOUND(ICAS) = NWOUND(ICAS)+1
17575             EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
17576          ENDIF
17577    10 CONTINUE
17578
17579 * dump initial hadron for energy-momentum conservation check
17580       IF (LEMCCK)
17581      &   CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
17582      &               PCAS(ICAS,4),1,IDUM,IDUM)
17583
17584 * dump final state particles into DTEVT1
17585
17586 *   check if Pauli-principle is fulfilled
17587       NPAULI = 0
17588       NWTMP(1) = NWOUND(1)
17589       NWTMP(2) = NWOUND(2)
17590       DO 111 I=1,NFSP
17591          NPAULI = 0
17592          J1 = 2
17593          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
17594      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
17595          DO 117 J=1,J1
17596             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
17597             IF (J.EQ.1) THEN
17598                IDX = ICAS
17599                PE  = PFSP(4,I)
17600             ELSE
17601                IDX  = I2
17602                MODE = 1
17603                IF (IDX.EQ.1) MODE = -1
17604                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
17605             ENDIF
17606 * first check if cascade step is forbidden due to Pauli-principle
17607 * (in case of absorpion this step is forced)
17608             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
17609      &          (IDFSP(I).EQ.8))) THEN
17610 *   get nuclear potential barrier
17611                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
17612                IF (IDFSP(I).EQ.1) THEN
17613                   POTLOW = POT-EBINDP(IDX)
17614                ELSE
17615                   POTLOW = POT-EBINDN(IDX)
17616                ENDIF
17617 *   final state particle not able to escape nucleus
17618                IF (PE.LE.POTLOW) THEN
17619 *     check if there are wounded nucleons
17620                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
17621      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
17622                      NPAULI      = NPAULI+1
17623                      NWOUND(IDX) = NWOUND(IDX)-1
17624                   ELSE
17625 *     interaction prohibited by Pauli-principle
17626                      NWOUND(1) = NWTMP(1)
17627                      NWOUND(2) = NWTMP(2)
17628                      GOTO 9997
17629                   ENDIF
17630                ENDIF
17631             ENDIF
17632   117    CONTINUE
17633   111 CONTINUE
17634
17635       NPAULI = 0
17636       NWOUND(1) = NWTMP(1)
17637       NWOUND(2) = NWTMP(2)
17638
17639       DO 11 I=1,NFSP
17640
17641          IST = ISTHKK(IDXCAS)
17642
17643          NPAULI = 0
17644          J1 = 2
17645          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
17646      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
17647          DO 17 J=1,J1
17648             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
17649             IDX = ICAS
17650             PE  = PFSP(4,I)
17651             IF (J.EQ.2) THEN
17652                IDX = I2
17653                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
17654             ENDIF
17655 * first check if cascade step is forbidden due to Pauli-principle
17656 * (in case of absorpion this step is forced)
17657             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
17658      &          (IDFSP(I).EQ.8))) THEN
17659 *   get nuclear potential barrier
17660                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
17661                IF (IDFSP(I).EQ.1) THEN
17662                   POTLOW = POT-EBINDP(IDX)
17663                ELSE
17664                   POTLOW = POT-EBINDN(IDX)
17665                ENDIF
17666 *   final state particle not able to escape nucleus
17667                IF (PE.LE.POTLOW) THEN
17668 *     check if there are wounded nucleons
17669                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
17670      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
17671                      NWOUND(IDX) = NWOUND(IDX)-1
17672                      NPAULI = NPAULI+1
17673                      IST    = 14+IDX
17674                   ELSE
17675 *     interaction prohibited by Pauli-principle
17676                      NWOUND(1) = NWTMP(1)
17677                      NWOUND(2) = NWTMP(2)
17678                      GOTO 9997
17679                   ENDIF
17680 **sr
17681 c               ELSEIF (PE.LE.POT) THEN
17682 cC              ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
17683 cC                 NWOUND(IDX) = NWOUND(IDX)-1
17684 c**
17685 c                  NPAULI = NPAULI+1
17686 c                  IST    = 14+IDX
17687                ENDIF
17688             ENDIF
17689    17    CONTINUE
17690
17691 * dump final state particles for energy-momentum conservation check
17692          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
17693      &                           -PFSP(4,I),2,IDUM,IDUM)
17694
17695          PX = PFSP(1,I)
17696          PY = PFSP(2,I)
17697          PZ = PFSP(3,I)
17698          PE = PFSP(4,I)
17699          IF (ABS(IST).EQ.1) THEN
17700 * transform particles back into n-n cms
17701 * LEPTO: leave final state particles in target rest frame
17702 C           IF (MCGENE.EQ.3) THEN
17703 C              PFSP(1,I) = PX
17704 C              PFSP(2,I) = PY
17705 C              PFSP(3,I) = PZ
17706 C              PFSP(4,I) = PE
17707 C           ELSE
17708                IMODE = ICAS+1
17709                CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17710      &                     PFSP(4,I),IDFSP(I),IMODE)
17711 C           ENDIF
17712          ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
17713 * target cascade but fsp got stuck in proj. --> transform it into
17714 * proj. rest system
17715             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17716      &                  PFSP(4,I),IDFSP(I),-1)
17717          ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
17718 * proj. cascade but fsp got stuck in target --> transform it into
17719 * target rest system
17720             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17721      &                  PFSP(4,I),IDFSP(I),1)
17722          ENDIF
17723
17724 * dump final state particles into DTEVT1
17725          IGEN = IDCH(IDXCAS)+1
17726          ID   = IDT_IPDGHA(IDFSP(I))
17727          IXR  = 0
17728          IF (LABSOR) IXR = 99
17729          CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
17730      &               PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
17731
17732 * update the counter for particles which got stuck inside the nucleus
17733          IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
17734             NOINC = NOINC+1
17735             IDXINC(NOINC) = NHKK
17736          ENDIF
17737          IF (LABSOR) THEN
17738 *   in case of absorption the spatial treatment is an approximate
17739 *   solution anyway (the positions of the nucleons which "absorb" the
17740 *   cascade particle are not taken into consideration) therefore the
17741 *   particles are produced at the position of the cascade particle
17742             DO 12 K=1,4
17743                WHKK(K,NHKK) = WHKK(K,IDXCAS)
17744                VHKK(K,NHKK) = VHKK(K,IDXCAS)
17745    12       CONTINUE
17746          ELSE
17747 *   DDISTL - distance the cascade particle moves to the intera. point
17748 *   (the position where impact-parameter = distance to the interacting
17749 *   nucleon), DIST - distance to the interacting nucleon at the time of
17750 *   formation of the cascade particle, BINT - impact-parameter of this
17751 *   cascade-interaction
17752             DDISTL = SQRT(DIST**2-BINT**2)
17753             DTIME  = DDISTL/BECAS(ICAS)
17754             DTIMEL = DDISTL/BGCAS(ICAS)
17755             RDISTL = DTIMEL*BGCAS(I2)
17756             IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17757                RTIME = RDISTL/BECAS(I2)
17758             ELSE
17759                RTIME = ZERO
17760             ENDIF
17761 *   RDISTL, RTIME are this step and time in the rest system of the other
17762 *   nucleus
17763             DO 13 K=1,3
17764                VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
17765                VTXCA1(I2,K)   = VTXCAS(I2,K)  +COSCAS(I2,K)  *RDISTL
17766    13       CONTINUE
17767             VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17768             VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME
17769 *   position of particle production is half the impact-parameter to
17770 *   the interacting nucleon
17771             DO 14 K=1,3
17772                WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
17773                VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
17774    14       CONTINUE
17775 *   time of production of secondary = time of interaction
17776             WHKK(4,NHKK) = VTXCA1(1,4)
17777             VHKK(4,NHKK) = VTXCA1(2,4)
17778          ENDIF
17779
17780    11 CONTINUE
17781
17782 * modify status and position of cascade particle (the latter for
17783 * statistics reasons only)
17784       ISTHKK(IDXCAS) = 2
17785       IF (LABSOR) ISTHKK(IDXCAS) = 19
17786       IF (.NOT.LABSOR) THEN
17787          DO 15 K=1,4
17788             WHKK(K,IDXCAS) = VTXCA1(1,K)
17789             VHKK(K,IDXCAS) = VTXCA1(2,K)
17790    15    CONTINUE
17791       ENDIF
17792
17793       DO 16 I=1,NSPE
17794          IS = IDXSPE(I)
17795 * dump interacting nucleons for energy-momentum conservation check
17796          IF (LEMCCK)
17797      &      CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
17798      &                                                  2,IDUM,IDUM)
17799 * modify entry for interacting nucleons
17800          IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
17801          IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
17802          IF (I.GE.2) THEN
17803             JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
17804             JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
17805          ENDIF
17806    16 CONTINUE
17807
17808 * check energy-momentum conservation
17809       IF (LEMCCK) THEN
17810          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
17811          IF (IREJ1.NE.0) GOTO 9999
17812       ENDIF
17813
17814 * update counter
17815       IF (LABSOR) THEN
17816          NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
17817       ELSE
17818          IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
17819          IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
17820       ENDIF
17821
17822       RETURN
17823
17824  9997 CONTINUE
17825  9998 CONTINUE
17826 * transport-step but no cascade step due to configuration (i.e. there
17827 * is no nucleon for interaction etc.)
17828       IF (LCAS) THEN
17829          DO 100 K=1,4
17830 C           WHKK(K,IDXCAS) = VTXCAS(1,K)
17831 C           VHKK(K,IDXCAS) = VTXCAS(2,K)
17832             WHKK(K,IDXCAS) = VTXCA1(1,K)
17833             VHKK(K,IDXCAS) = VTXCA1(2,K)
17834   100    CONTINUE
17835       ENDIF
17836
17837 C9998 CONTINUE
17838 * no cascade-step because of configuration
17839 * (i.e. hadron outside nucleus etc.)
17840       LCAS = .TRUE.
17841       RETURN
17842
17843  9999 CONTINUE
17844 * rejection
17845       IREJ = 1
17846       RETURN
17847       END
17848
17849 *$ CREATE DT_ABSORP.FOR
17850 *COPY DT_ABSORP
17851 *
17852 *===absorp=============================================================*
17853 *
17854       SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
17855
17856 ************************************************************************
17857 * Two-nucleon absorption of antiprotons, pi-, and K-.                  *
17858 * Antiproton absorption is handled by HADRIN.                          *
17859 * The following channels for meson-absorption are considered:          *
17860 *          pi- + p + p ---> n + p                                      *
17861 *          pi- + p + n ---> n + n                                      *
17862 *          K-  + p + p ---> sigma+ + n / Lam + p / sigma0 + p          *
17863 *          K-  + p + n ---> sigma- + n / Lam + n / sigma0 + n          *
17864 *          K-  + p + p ---> sigma- + n                                 *
17865 *      IDCAS, PCAS   identity, momentum of particle to be absorbed     *
17866 *      NCAS =  1     intranuclear cascade in projectile                *
17867 *           = -1     intranuclear cascade in target                    *
17868 *      NSPE          number of spectator nucleons involved             *
17869 *      IDXSPE(2)     DTEVT1-indices of spectator nucleons involved     *
17870 * Revised version of the original STOPIK written by HJM and J. Ranft.  *
17871 * This version dated 24.02.95 is written by S. Roesler                 *
17872 ************************************************************************
17873
17874       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17875       SAVE
17876
17877       PARAMETER ( LINP = 10 ,
17878      &            LOUT = 6 ,
17879      &            LDAT = 9 )
17880
17881       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17882      &           ONETHI=0.3333D0,TWOTHI=0.6666D0)
17883
17884 * event history
17885
17886       PARAMETER (NMXHKK=200000)
17887
17888       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17889      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17890      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17891
17892 * extended event history
17893       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17894      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17895      &                IHIST(2,NMXHKK)
17896
17897 * flags for input different options
17898       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17899       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17900      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17901
17902 * final state after inc step
17903       PARAMETER (MAXFSP=10)
17904       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17905
17906 * particle properties (BAMJET index convention)
17907       CHARACTER*8  ANAME
17908       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17909      &                IICH(210),IIBAR(210),K1(210),K2(210)
17910
17911       DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17912      &          PTOT3P(4),BG3P(4),
17913      &          ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17914
17915       IREJ = 0
17916       NFSP = 0
17917
17918 * skip particles others than ap, pi-, K- for mode=0
17919       IF ((MODE.EQ.0).AND.
17920      &    (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17921 * skip particles others than pions for mode=1
17922 * (2-nucleon absorption in intranuclear cascade)
17923       IF ((MODE.EQ.1).AND.
17924      &    (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17925
17926       NUCAS = NCAS
17927       IF (NUCAS.EQ.-1) NUCAS = 2
17928
17929       IF (MODE.EQ.0) THEN
17930 * scan spectator nucleons for nucleons being able to "absorb"
17931          NSPE      = 0
17932          IDXSPE(1) = 0
17933          IDXSPE(2) = 0
17934          DO 1 I=1,NHKK
17935             IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17936                NSPE         = NSPE+1
17937                IDXSPE(NSPE) = I
17938                IDSPE(NSPE)  = IDBAM(I)
17939                IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17940                IF (NSPE.EQ.2) THEN
17941                   IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17942      &                                  (IDSPE(2).EQ.8)) THEN
17943 *    there is no pi-+n+n channel
17944                      NSPE = 1
17945                      GOTO 1
17946                   ELSE
17947                      GOTO 2
17948                   ENDIF
17949                ENDIF
17950             ENDIF
17951     1    CONTINUE
17952
17953     2    CONTINUE
17954       ENDIF
17955 * transform excited projectile nucleons (status=15) into proj. rest s.
17956       DO 3 I=1,NSPE
17957          DO 4 K=1,5
17958             PSPE(I,K) = PHKK(K,IDXSPE(I))
17959     4    CONTINUE
17960     3 CONTINUE
17961
17962 * antiproton absorption
17963       IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17964          DO 5 K=1,5
17965             PSPE1(K) = PSPE(1,K)
17966     5    CONTINUE
17967          CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17968          IF (IREJ1.NE.0) GOTO 9999
17969
17970 * meson absorption
17971       ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17972      &                      .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17973          IF (IDCAS.EQ.14) THEN
17974 *   pi- absorption
17975             IDFSP(1) = 8
17976             IDFSP(2) = 8
17977             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17978          ELSEIF (IDCAS.EQ.13) THEN
17979 *   pi+ absorption
17980             IDFSP(1) = 1
17981             IDFSP(2) = 1
17982             IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17983          ELSEIF (IDCAS.EQ.23) THEN
17984 *   pi0 absorption
17985             IDFSP(1) = IDSPE(1)
17986             IDFSP(2) = IDSPE(2)
17987          ELSEIF (IDCAS.EQ.16) THEN
17988 *   K- absorption
17989             R = DT_RNDM(PCAS)
17990             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17991                IF (R.LT.ONETHI) THEN
17992                   IDFSP(1) = 21
17993                   IDFSP(2) = 8
17994                ELSEIF (R.LT.TWOTHI) THEN
17995                   IDFSP(1) = 17
17996                   IDFSP(2) = 1
17997                ELSE
17998                   IDFSP(1) = 22
17999                   IDFSP(2) = 1
18000                ENDIF
18001             ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
18002                IDFSP(1) = 20
18003                IDFSP(2) = 8
18004             ELSE
18005                IF (R.LT.ONETHI) THEN
18006                   IDFSP(1) = 20
18007                   IDFSP(2) = 1
18008                ELSEIF (R.LT.TWOTHI) THEN
18009                   IDFSP(1) = 17
18010                   IDFSP(2) = 8
18011                ELSE
18012                   IDFSP(1) = 22
18013                   IDFSP(2) = 8
18014                ENDIF
18015             ENDIF
18016          ENDIF
18017 *   dump initial particles for energy-momentum cons. check
18018          IF (LEMCCK) THEN
18019             CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
18020             CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
18021      &                                                    IDUM,IDUM)
18022             CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
18023      &                                                    IDUM,IDUM)
18024          ENDIF
18025 *   get Lorentz-parameter of 3 particle initial state
18026          DO 6 K=1,4
18027             PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
18028     6    CONTINUE
18029          P3P  = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
18030          AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
18031          DO 7 K=1,4
18032             BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
18033     7    CONTINUE
18034 *   2-particle decay of the 3-particle compound system
18035          CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
18036      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
18037      &               AAM(IDFSP(1)),AAM(IDFSP(2)))
18038          DO 8 I=1,2
18039             SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
18040             PX  = PCMF(I)*COFF(I)*SDF
18041             PY  = PCMF(I)*SIFF(I)*SDF
18042             PZ  = PCMF(I)*CODF(I)
18043             CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
18044      &                  ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
18045      &                  PFSP(4,I))
18046             PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
18047 *   check consistency of kinematics
18048             IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
18049                WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
18050  1001          FORMAT(1X,'ABSORP:   warning! inconsistent',
18051      &                ' tree-particle kinematics',/,20X,'id: ',I3,
18052      &                ' AAM = ',E10.4,' MFSP = ',E10.4)
18053             ENDIF
18054 *   dump final state particles for energy-momentum cons. check
18055             IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
18056      &                              -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
18057     8    CONTINUE
18058          NFSP = 2
18059          IF (LEMCCK) THEN
18060             CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
18061             IF (IREJ1.NE.0) THEN
18062                WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
18063      &                      AM3P
18064                GOTO 9999
18065             ENDIF
18066          ENDIF
18067       ELSE
18068          IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
18069  1000    FORMAT(1X,'ABSORP:   warning! absorption for particle ',I3,
18070      &          ' impossible',/,20X,'too few spectators (',I2,')')
18071          NSPE = 0
18072       ENDIF
18073
18074       RETURN
18075
18076  9999 CONTINUE
18077       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
18078       IREJ = 1
18079       RETURN
18080       END
18081
18082 *$ CREATE DT_HADRIN.FOR
18083 *COPY DT_HADRIN
18084 *
18085 *===hadrin=============================================================*
18086 *
18087       SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
18088
18089 ************************************************************************
18090 * Interface to the HADRIN-routines for inelastic and elastic           *
18091 * scattering.                                                          *
18092 *      IDPR,PPR(5)   identity, momentum of projectile                  *
18093 *      IDTA,PTA(5)   identity, momentum of target                      *
18094 *      MODE  = 1     inelastic interaction                             *
18095 *            = 2     elastic   interaction                             *
18096 * Revised version of the original FHAD.                                *
18097 * This version dated 27.10.95 is written by S. Roesler                 *
18098 ************************************************************************
18099
18100       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18101       SAVE
18102
18103       PARAMETER ( LINP = 10 ,
18104      &            LOUT = 6 ,
18105      &            LDAT = 9 )
18106
18107       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
18108      &           TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
18109
18110       LOGICAL LCORR,LMSSG
18111
18112 * flags for input different options
18113       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18114       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18115      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18116
18117 * final state after inc step
18118       PARAMETER (MAXFSP=10)
18119       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
18120
18121 * particle properties (BAMJET index convention)
18122       CHARACTER*8  ANAME
18123       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18124      &                IICH(210),IIBAR(210),K1(210),K2(210)
18125 * output-common for DHADRI/ELHAIN
18126
18127 * final state from HADRIN interaction
18128       PARAMETER (MAXFIN=10)
18129       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
18130      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
18131
18132       DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
18133      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
18134
18135       DATA LMSSG /.TRUE./
18136
18137       IREJ  = 0
18138       NFSP  = 0
18139       KCORR = 0
18140       IMCORR(1) = 0
18141       IMCORR(2) = 0
18142       LCORR = .FALSE.
18143
18144 *   dump initial particles for energy-momentum cons. check
18145       IF (LEMCCK) THEN
18146          CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
18147          CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
18148       ENDIF
18149
18150       AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
18151       AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
18152       IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
18153      &    (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
18154      &    (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
18155          IF (LMSSG.AND.(IOULEV(3).GT.0))
18156      &   WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
18157  1000    FORMAT(1X,'HADRIN:   warning! inconsistent projectile/target',
18158      &          ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
18159      &          E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
18160          LMSSG = .FALSE.
18161          LCORR = .TRUE.
18162       ENDIF
18163
18164 * convert initial state particles into particles which can be
18165 * handled by HADRIN
18166       IDHPR = IDPR
18167       IDHTA = IDTA
18168       IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
18169          IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
18170          DO 1 K=1,4
18171             P1IN(K) = PPR(K)
18172             P2IN(K) = PTA(K)
18173     1    CONTINUE
18174          XM1 = AAM(IDHPR)
18175          XM2 = AAM(IDHTA)
18176          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
18177          IF (IREJ1.GT.0) THEN
18178             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
18179             GOTO 9999
18180          ENDIF
18181          DO 2 K=1,4
18182             PPR(K) = P1OUT(K)
18183             PTA(K) = P2OUT(K)
18184     2    CONTINUE
18185          PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
18186          PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
18187       ENDIF
18188
18189 * Lorentz-parameter for trafo into rest-system of target
18190       DO 3 K=1,4
18191          BGTA(K) = PTA(K)/PTA(5)
18192     3 CONTINUE
18193 * transformation of projectile into rest-system of target
18194       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
18195      &            PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
18196      &            PPR1(4))
18197
18198 * direction cosines of projectile in target rest system
18199       CX = PPR1(1)/PPRTO1
18200       CY = PPR1(2)/PPRTO1
18201       CZ = PPR1(3)/PPRTO1
18202
18203 * sample inelastic interaction
18204       IF (MODE.EQ.1) THEN
18205          CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
18206          IF (IRH.EQ.1) GOTO 9998
18207 * sample elastic interaction
18208       ELSEIF (MODE.EQ.2) THEN
18209          CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
18210          IF (IREJ1.NE.0) THEN
18211             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
18212             GOTO 9999
18213          ENDIF
18214          IF (IRH.EQ.1) GOTO 9998
18215       ELSE
18216          WRITE(LOUT,1001) MODE,INTHAD
18217  1001    FORMAT(1X,'HADRIN:   warning! inconsistent interaction mode',
18218      &          I4,' (INTHAD =',I4,')')
18219          GOTO 9999
18220       ENDIF
18221
18222 * transform final state particles back into Lab.
18223       DO 4 I=1,IRH
18224          NFSP = NFSP+1
18225          PX   = CXRH(I)*PLRH(I)
18226          PY   = CYRH(I)*PLRH(I)
18227          PZ   = CZRH(I)*PLRH(I)
18228          CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
18229      &               PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
18230      &               PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
18231          IDFSP(NFSP) = ITRH(I)
18232          AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
18233      &                                            PFSP(3,NFSP)**2
18234          IF (AMFSP2.LT.-TINY3) THEN
18235             WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
18236      &                       PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
18237  1002       FORMAT(1X,'HADRIN:   warning! final state particle (id = ',
18238      &             I2,') with negative mass^2',/,1X,5E12.4)
18239             GOTO 9999
18240          ELSE
18241             PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
18242             IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
18243                WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
18244      &                          PFSP(5,NFSP)
18245  1003          FORMAT(1X,'HADRIN:   warning! final state particle',
18246      &                ' (id = ',I2,') with inconsistent mass',/,1X,
18247      &                2E12.4)
18248                KCORR         = KCORR+1
18249                IF (KCORR.GT.2) GOTO 9999
18250                IMCORR(KCORR) = NFSP
18251             ENDIF
18252          ENDIF
18253 *   dump final state particles for energy-momentum cons. check
18254          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
18255      &                           -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
18256     4 CONTINUE
18257
18258 * transform momenta on mass shell in case of inconsistencies in
18259 * HADRIN
18260       IF (KCORR.GT.0) THEN
18261          IF (KCORR.EQ.2) THEN
18262             I1 = IMCORR(1)
18263             I2 = IMCORR(2)
18264          ELSE
18265             IF (IMCORR(1).EQ.1) THEN
18266                I1 = 1
18267                I2 = 2
18268             ELSE
18269                I1 = 1
18270                I2 = IMCORR(1)
18271             ENDIF
18272          ENDIF
18273          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
18274      &                           PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
18275          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
18276      &                           PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
18277          DO 5 K=1,4
18278             P1IN(K) = PFSP(K,I1)
18279             P2IN(K) = PFSP(K,I2)
18280     5    CONTINUE
18281          XM1 = AAM(IDFSP(I1))
18282          XM2 = AAM(IDFSP(I2))
18283          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
18284          IF (IREJ1.GT.0) THEN
18285             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
18286 C           GOTO 9999
18287          ENDIF
18288          DO 6 K=1,4
18289             PFSP(K,I1) = P1OUT(K)
18290             PFSP(K,I2) = P2OUT(K)
18291     6    CONTINUE
18292          PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
18293      &                    -PFSP(2,I1)**2-PFSP(3,I1)**2)
18294          PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
18295      &                    -PFSP(2,I2)**2-PFSP(3,I2)**2)
18296 *   dump final state particles for energy-momentum cons. check
18297          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
18298      &                           -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
18299          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
18300      &                           -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
18301       ENDIF
18302
18303 * check energy-momentum conservation
18304       IF (LEMCCK) THEN
18305          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
18306          IF (IREJ1.NE.0) GOTO 9999
18307       ENDIF
18308
18309       RETURN
18310
18311  9998 CONTINUE
18312       IREJ = 2
18313       RETURN
18314
18315  9999 CONTINUE
18316       IREJ = 1
18317       RETURN
18318       END
18319
18320 *$ CREATE DT_HADCOL.FOR
18321 *COPY DT_HADCOL
18322 *
18323 *===hadcol=============================================================*
18324 *
18325       SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
18326
18327 ************************************************************************
18328 * Interface to the HADRIN-routines for inelastic and elastic           *
18329 * scattering. This subroutine samples hadron-nucleus interactions      *
18330 * below DPM-threshold.                                                 *
18331 *      IDPROJ        BAMJET-index of projectile hadron                 *
18332 *      PPN           projectile momentum in target rest frame          *
18333 *      IDXTAR        DTEVT1-index of target nucleon undergoing         *
18334 *                    interaction with projectile hadron                *
18335 * This subroutine replaces HADHAD.                                     *
18336 * This version dated 5.5.95 is written by S. Roesler                   *
18337 ************************************************************************
18338
18339       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18340       SAVE
18341
18342       PARAMETER ( LINP = 10 ,
18343      &            LOUT = 6 ,
18344      &            LDAT = 9 )
18345
18346       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
18347
18348       LOGICAL LSTART
18349
18350 * event history
18351
18352       PARAMETER (NMXHKK=200000)
18353
18354       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18355      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18356      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18357
18358 * extended event history
18359       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18360      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18361      &                IHIST(2,NMXHKK)
18362
18363 * nuclear potential
18364       LOGICAL LFERMI
18365       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18366      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18367      &                ETACOU(2),ICOUL,LFERMI
18368
18369 * interface HADRIN-DPM
18370       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
18371
18372 * parameter for intranuclear cascade
18373       LOGICAL LPAULI
18374       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
18375
18376 * final state after inc step
18377       PARAMETER (MAXFSP=10)
18378       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
18379
18380 * particle properties (BAMJET index convention)
18381       CHARACTER*8  ANAME
18382       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18383      &                IICH(210),IIBAR(210),K1(210),K2(210)
18384
18385       DIMENSION PPROJ(5),PNUC(5)
18386
18387       DATA LSTART /.TRUE./
18388
18389       IREJ   = 0
18390
18391       NPOINT(1) = NHKK+1
18392
18393       TAUSAV = TAUFOR
18394 **sr 6/9/01 commented
18395 C     TAUFOR = TAUFOR/2.0D0
18396 **
18397       IF (LSTART) THEN
18398          WRITE(LOUT,1000)
18399  1000    FORMAT(/,1X,'HADCOL:  Scattering handled by HADRIN')
18400          WRITE(LOUT,1001) TAUFOR
18401  1001    FORMAT(/,1X,'HADCOL:  Formation zone parameter set to ',
18402      &          F5.1,' fm/c')
18403          LSTART = .FALSE.
18404       ENDIF
18405
18406       IDNUC  = IDBAM(IDXTAR)
18407       IDNUC1 = IDT_MCHAD(IDNUC)
18408       IDPRO1 = IDT_MCHAD(IDPROJ)
18409
18410       IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
18411          IPROC = INTHAD
18412       ELSE
18413 **
18414 C        CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
18415 C        CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
18416          DUMZER = ZERO
18417          CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
18418          SIGIN = SIGTOT-SIGEL
18419 C        SIGTOT = SIGIN+SIGEL
18420 **
18421          IPROC  = 1
18422          IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
18423       ENDIF
18424
18425       PPROJ(1) = ZERO
18426       PPROJ(2) = ZERO
18427       PPROJ(3) = PPN
18428       PPROJ(5) = AAM(IDPROJ)
18429       PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
18430       DO 1 K=1,5
18431          PNUC(K)  = PHKK(K,IDXTAR)
18432     1 CONTINUE
18433
18434       ILOOP = 0
18435     2 CONTINUE
18436       ILOOP = ILOOP+1
18437       IF (ILOOP.GT.100) GOTO 9999
18438
18439       CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
18440       IF (IREJ1.EQ.1) GOTO 9999
18441
18442       IF (IREJ1.GT.1) THEN
18443 * no interaction possible
18444 *   require Pauli blocking
18445          IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
18446          IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
18447          IF ((IIBAR(IDPROJ).NE.1).AND.
18448      &       (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5)))              GOTO 2
18449 *   store incoming particle as final state particle
18450          CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
18451          CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
18452          NPOINT(4) = NHKK
18453       ELSE
18454 * require Pauli blocking for final state nucleons
18455          DO 4 I=1,NFSP
18456             IF ((IDFSP(I).EQ.1).AND.
18457      &          (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I))))       GOTO 2
18458             IF ((IDFSP(I).EQ.8).AND.
18459      &          (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I))))       GOTO 2
18460             IF ((IIBAR(IDFSP(I)).NE.1).AND.
18461      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
18462     4    CONTINUE
18463 * store final state particles
18464          DO 5 I=1,NFSP
18465             IST = 1
18466             IF ((IIBAR(IDFSP(I)).EQ.1).AND.
18467      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
18468             IDHAD = IDT_IPDGHA(IDFSP(I))
18469             CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
18470             CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
18471      &                                        PCMS,ECMS,0,0,0)
18472             IF (I.EQ.1) NPOINT(4) = NHKK
18473             VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
18474             VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
18475             VHKK(3,NHKK) = VHKK(3,IDXTAR)
18476             VHKK(4,NHKK) = VHKK(4,IDXTAR)
18477             WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
18478             WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
18479             WHKK(3,NHKK) = WHKK(3,1)
18480             WHKK(4,NHKK) = WHKK(4,1)
18481     5    CONTINUE
18482       ENDIF
18483       TAUFOR = TAUSAV
18484       RETURN
18485
18486  9999 CONTINUE
18487       IREJ = 1
18488       TAUFOR = TAUSAV
18489       RETURN
18490       END
18491 *$ CREATE DT_GETEMU.FOR
18492 *COPY DT_GETEMU
18493 *
18494 *===getemu=============================================================*
18495 *
18496       SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
18497
18498 ************************************************************************
18499 * Sampling of emulsion component to be considered as target-nucleus.   *
18500 * This version dated 6.5.95   is written by S. Roesler.                *
18501 ************************************************************************
18502
18503       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18504       SAVE
18505
18506       PARAMETER ( LINP = 10 ,
18507      &            LOUT = 6 ,
18508      &            LDAT = 9 )
18509
18510       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18511
18512       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
18513
18514 * emulsion treatment
18515       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
18516      &                NCOMPO,IEMUL
18517
18518 * Glauber formalism: flags and parameters for statistics
18519       LOGICAL LPROD
18520       CHARACTER*8 CGLB
18521       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
18522
18523       IF (MODE.EQ.0) THEN
18524          SUMFRA = ZERO
18525          RR = DT_RNDM(SUMFRA)
18526          IT  = 0
18527          ITZ = 0
18528          DO 1 ICOMP=1,NCOMPO
18529             SUMFRA = SUMFRA+EMUFRA(ICOMP)
18530             IF (SUMFRA.GT.RR) THEN
18531                IT    = IEMUMA(ICOMP)
18532                ITZ   = IEMUCH(ICOMP)
18533                KKMAT = ICOMP
18534                GOTO 2
18535             ENDIF
18536     1    CONTINUE
18537     2    CONTINUE
18538          IF (IT.LE.0) THEN
18539             WRITE(LOUT,'(1X,A,E12.3)')
18540      &       'Warning!  norm. failure within emulsion fractions',
18541      &       SUMFRA
18542             STOP
18543          ENDIF
18544       ELSEIF (MODE.EQ.1) THEN
18545          NDIFF = 10000
18546          DO 3 I=1,NCOMPO
18547             IDIFF = ABS(IT-IEMUMA(I))
18548             IF (IDIFF.LT.NDIFF) THEN
18549                KKMAT = I
18550                NDIFF = IDIFF
18551             ENDIF
18552     3    CONTINUE
18553       ELSE
18554          STOP 'DT_GETEMU'
18555       ENDIF
18556
18557 * bypass for variable projectile/target/energy runs: the correct
18558 * Glauber data will be always loaded on kkmat=1
18559       IF (IOGLB.EQ.100) THEN
18560          KKMAT = 1
18561       ENDIF
18562
18563       RETURN
18564       END
18565
18566 *$ CREATE DT_NCLPOT.FOR
18567 *COPY DT_NCLPOT
18568 *
18569 *===nclpot=============================================================*
18570 *
18571       SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
18572
18573 ************************************************************************
18574 * Calculation of Coulomb and nuclear potential for a given configurat. *
18575 *               IPZ, IP       charge/mass number of proj.              *
18576 *               ITZ, IT       charge/mass number of targ.              *
18577 *               AFERP,AFERT   factors modifying proj./target pot.      *
18578 *                             if =0, FERMOD is used                    *
18579 *               MODE = 0      calculation of binding energy            *
18580 *                    = 1      pre-calculated binding energy is used    *
18581 * This version dated 16.11.95  is written by S. Roesler.               *
18582 *                                                                      *
18583 * Last change 28.12.2006 by S. Roesler.                                *
18584 ************************************************************************
18585
18586       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18587       SAVE
18588
18589       PARAMETER ( LINP = 10 ,
18590      &            LOUT = 6 ,
18591      &            LDAT = 9 )
18592
18593       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18594      &           TINY10=1.0D-10)
18595
18596       LOGICAL LSTART
18597
18598 * particle properties (BAMJET index convention)
18599       CHARACTER*8  ANAME
18600       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18601      &                IICH(210),IIBAR(210),K1(210),K2(210)
18602
18603 * nuclear potential
18604       LOGICAL LFERMI
18605       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18606      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18607      &                ETACOU(2),ICOUL,LFERMI
18608
18609       DIMENSION IDXPOT(14)
18610 *                   ap   an  lam  alam sig- sig+ sig0 tet0 tet- asig-
18611       DATA IDXPOT /   2,   9,  17,  18,  20,  21,  22,  97,  98,  99,
18612 *                 asig0 asig+ atet0 atet+
18613      &              100, 101, 102, 103/
18614
18615       DATA AN     /0.4D0/
18616       DATA LSTART /.TRUE./
18617
18618       IF (MODE.EQ.0) THEN
18619          EBINDP(1) = ZERO
18620          EBINDN(1) = ZERO
18621          EBINDP(2) = ZERO
18622          EBINDN(2) = ZERO
18623       ENDIF
18624       AIP  = DBLE(IP)
18625       AIPZ = DBLE(IPZ)
18626       AIT  = DBLE(IT)
18627       AITZ = DBLE(ITZ)
18628
18629       FERMIP = AFERP
18630       IF (AFERP.LE.ZERO) FERMIP = FERMOD
18631       FERMIT = AFERT
18632       IF (AFERT.LE.ZERO) FERMIT = FERMOD
18633
18634 * Fermi momenta and binding energy for projectile
18635       IF ((IP.GT.1).AND.LFERMI) THEN
18636          IF (MODE.EQ.0) THEN
18637 C           EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
18638 C           EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
18639             BIP  = AIP -ONE
18640             BIPZ = AIPZ-ONE
18641
18642 C           EBINDP(1) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIP,BIPZ)
18643 C    &                                         -ENERGY(AIP,AIPZ))
18644             EBINDP(1) = 1.0D-3*(EXMSAZ(ONE,ONE ,.TRUE.,IZDUM)
18645      &                         +EXMSAZ(BIP,BIPZ,.TRUE.,IZDUM)
18646      &                         -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
18647
18648             IF (AIP.LE.AIPZ) THEN
18649                EBINDN(1) = EBINDP(1)
18650                WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
18651             ELSE
18652
18653 C              EBINDN(1) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIP,AIPZ)
18654 C    &                                             -ENERGY(AIP,AIPZ))
18655                EBINDN(1) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
18656      &                            +EXMSAZ(BIP,AIPZ,.TRUE.,IZDUM)
18657      &                            -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
18658
18659             ENDIF
18660          ENDIF
18661          PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
18662          PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
18663       ELSE
18664          PFERMP(1) = ZERO
18665          PFERMN(1) = ZERO
18666       ENDIF
18667 * effective nuclear potential for projectile
18668 C     EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
18669 C     EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
18670       EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
18671       EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
18672
18673 * Fermi momenta and binding energy for target
18674       IF ((IT.GT.1).AND.LFERMI) THEN
18675          IF (MODE.EQ.0) THEN
18676 C           EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
18677 C           EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
18678             BIT  = AIT -ONE
18679             BITZ = AITZ-ONE
18680
18681 C           EBINDP(2) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIT,BITZ)
18682 C    &                                         -ENERGY(AIT,AITZ))
18683             EBINDP(2) = 1.0D-3*(EXMSAZ(ONE,ONE, .TRUE.,IZDUM)
18684      &                         +EXMSAZ(BIT,BITZ,.TRUE.,IZDUM)
18685      &                         -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
18686
18687             IF (AIT.LE.AITZ) THEN
18688                EBINDN(2) = EBINDP(2)
18689                WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
18690             ELSE
18691
18692 C              EBINDN(2) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIT,AITZ)
18693 C    &                                             -ENERGY(AIT,AITZ))
18694                EBINDN(2) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
18695      &                            +EXMSAZ(BIT,AITZ,.TRUE.,IZDUM)
18696      &                            -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
18697
18698             ENDIF
18699          ENDIF
18700          PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
18701          PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
18702       ELSE
18703          PFERMP(2) = ZERO
18704          PFERMN(2) = ZERO
18705       ENDIF
18706 * effective nuclear potential for target
18707 C     EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
18708 C     EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
18709       EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
18710       EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
18711
18712       DO 2 I=1,14
18713          EPOT(1,IDXPOT(I)) = EPOT(1,8)
18714          EPOT(2,IDXPOT(I)) = EPOT(2,8)
18715     2 CONTINUE
18716
18717 * Coulomb energy
18718       ETACOU(1) = ZERO
18719       ETACOU(2) = ZERO
18720       IF (ICOUL.EQ.1) THEN
18721          IF (IP.GT.1)
18722      &   ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
18723          IF (IT.GT.1)
18724      &   ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
18725       ENDIF
18726
18727       IF (LSTART) THEN
18728          WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
18729      &                    EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
18730      &                    EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
18731      &                    FERMOD,ETACOU
18732  1000    FORMAT(/,/,1X,'NCLPOT:    quantities for inclusion of nuclear'
18733      &           ,' effects',/,12X,'---------------------------',
18734      &           '----------------',/,/,38X,'projectile',
18735      &           '      target',/,/,1X,'Mass number / charge',
18736      &           17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy  -',
18737      &           ' proton   (GeV) ',2E14.4,/,17X,'- neutron  (GeV)'
18738      &          ,1X,2E14.4,/,1X,'Fermi-potential - proton   (GeV)',
18739      &           1X,2E14.4,/,17X,'- neutron  (GeV) ',2E14.4,/,/,
18740      &           1X,'Scale factor for Fermi-momentum    ',F4.2,/,
18741      &           /,1X,'Coulomb-energy ',2(E14.4,' GeV  '),/,/)
18742          LSTART = .FALSE.
18743       ENDIF
18744
18745       RETURN
18746       END
18747
18748 *$ CREATE DT_RESNCL.FOR
18749 *COPY DT_RESNCL
18750 *
18751 *===resncl=============================================================*
18752 *
18753       SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
18754
18755 ************************************************************************
18756 * Treatment of residual nuclei and nuclear effects.                    *
18757 *         MODE = 1     initializations                                 *
18758 *              = 2     treatment of final state                        *
18759 * This version dated 16.11.95 is written by S. Roesler.                *
18760 *                                                                      *
18761 * Last change 05.01.2007 by S. Roesler.                                *
18762 ************************************************************************
18763
18764       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18765       SAVE
18766
18767       PARAMETER ( LINP = 10 ,
18768      &            LOUT = 6 ,
18769      &            LDAT = 9 )
18770
18771       PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
18772      &           TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
18773      &           ONETHI=ONE/THREE)
18774       PARAMETER (AMUAMU = 0.93149432D0,
18775      &           FM2MM  = 1.0D-12,
18776      &           RNUCLE = 1.12D0)
18777       PARAMETER ( EMVGEV = 1.0                D-03 )
18778       PARAMETER ( AMUGEV = 0.93149432         D+00 )
18779       PARAMETER ( AMPRTN = 0.93827231         D+00 )
18780       PARAMETER ( AMNTRN = 0.93956563         D+00 )
18781       PARAMETER ( AMELCT = 0.51099906         D-03 )
18782       PARAMETER ( HLFHLF = 0.5D+00 )
18783       PARAMETER ( FERTHO = 14.33       D-09 )
18784       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
18785       PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
18786       PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
18787
18788 * event history
18789
18790       PARAMETER (NMXHKK=200000)
18791
18792       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18793      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18794      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18795
18796 * extended event history
18797       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18798      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18799      &                IHIST(2,NMXHKK)
18800
18801 * particle properties (BAMJET index convention)
18802       CHARACTER*8  ANAME
18803       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18804      &                IICH(210),IIBAR(210),K1(210),K2(210)
18805
18806 * flags for input different options
18807       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18808       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18809      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18810
18811 * nuclear potential
18812       LOGICAL LFERMI
18813       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18814      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18815      &                ETACOU(2),ICOUL,LFERMI
18816
18817 * properties of interacting particles
18818       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18819
18820 * properties of photon/lepton projectiles
18821       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
18822
18823 * Lorentz-parameters of the current interaction
18824       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
18825      &                UMO,PPCM,EPROJ,PPROJ
18826
18827 * treatment of residual nuclei: wounded nucleons
18828       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18829
18830 * treatment of residual nuclei: 4-momenta
18831       LOGICAL LRCLPR,LRCLTA
18832       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18833      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18834
18835       DIMENSION PFSP(4),PSEC(4),PSEC0(4)
18836       DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
18837      &          IDXCOR(15000),IDXOTH(NMXHKK)
18838
18839       GOTO (1,2) MODE
18840
18841 *------- initializations
18842     1 CONTINUE
18843
18844 * initialize arrays for residual nuclei
18845       DO 10 K=1,5
18846          IF (K.LE.4) THEN
18847             PFSP(K)     = ZERO
18848          ENDIF
18849          PINIPR(K) = ZERO
18850          PINITA(K) = ZERO
18851          PRCLPR(K) = ZERO
18852          PRCLTA(K) = ZERO
18853          TRCLPR(K) = ZERO
18854          TRCLTA(K) = ZERO
18855    10 CONTINUE
18856       SCPOT = ONE
18857       NLOOP = 0
18858
18859 * correction of projectile 4-momentum for effective target pot.
18860 * and Coulomb-energy (in case of hadron-nucleus interaction only)
18861 *      IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18862 *         EPNI = EPN
18863 *   Coulomb-energy:
18864 *     positively charged hadron - check energy for Coloumb pot.
18865 *         IF (IICH(IJPROJ).EQ.1) THEN
18866 *            THRESH = ETACOU(2)+AAM(IJPROJ)
18867 *            IF (EPNI.LE.THRESH) THEN
18868 *               WRITE(LOUT,1000)
18869 * 1000          FORMAT(/,1X,'KKINC:  WARNING!  projectile energy',
18870 *     &                ' below Coulomb threshold - event rejected',/)
18871 *               ISTHKK(1) = 1
18872 *               RETURN
18873 *            ENDIF
18874 *     negatively charged hadron - increase energy by Coulomb energy
18875 *         ELSEIF (IICH(IJPROJ).EQ.-1) THEN
18876 *            EPNI = EPNI+ETACOU(2)
18877 *         ENDIF
18878 *         IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
18879 *   Effective target potential
18880 *sr 6.6. binding energy only (to avoid negative exc. energies)
18881 C           EPNI = EPNI+EPOT(2,IJPROJ)
18882 *            EBIPOT = EBINDP(2)
18883 *            IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
18884 *     &         EBIPOT = EBINDN(2)
18885 *            EPNI = EPNI+ABS(EBIPOT)
18886 * re-initialization of DTLTRA
18887 *            DUM1 = ZERO
18888 *            DUM2 = ZERO
18889 *            CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
18890 *         ENDIF
18891 *      ENDIF
18892
18893 * projectile in n-n cms
18894       IF ((IP.LE.1).AND.(IT.GT.1)) THEN
18895          PMASS1 = AAM(IJPROJ)
18896 C* VDM assumption
18897 C         IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
18898          IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
18899          PMASS2 = AAM(1)
18900          PM1 = SIGN(PMASS1**2,PMASS1)
18901          PM2 = SIGN(PMASS2**2,PMASS2)
18902          PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
18903          PINIPR(5) = PMASS1
18904          IF (PMASS1.GT.ZERO) THEN
18905             PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
18906      &                      *(PINIPR(4)+PINIPR(5)))
18907          ELSE
18908             PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
18909          ENDIF
18910          AIT  = DBLE(IT)
18911          AITZ = DBLE(ITZ)
18912
18913 C        PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18914          PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
18915
18916          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18917       ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
18918          PMASS1 = AAM(1)
18919          PMASS2 = AAM(IJTARG)
18920          PM1 = SIGN(PMASS1**2,PMASS1)
18921          PM2 = SIGN(PMASS2**2,PMASS2)
18922          PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
18923          PINITA(5) = PMASS2
18924          PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
18925      &                    *(PINITA(4)+PINITA(5)))
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       ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
18934          AIP  = DBLE(IP)
18935          AIPZ = DBLE(IPZ)
18936
18937 C        PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18938          PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)
18939
18940          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18941          AIT  = DBLE(IT)
18942          AITZ = DBLE(ITZ)
18943
18944 C        PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18945          PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
18946
18947          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18948       ENDIF
18949
18950       RETURN
18951
18952 *------- treatment of final state
18953     2 CONTINUE
18954
18955       NLOOP = NLOOP+1
18956       IF (NLOOP.GT.1) SCPOT = 0.10D0
18957 C     WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18958
18959       JPW  = NPW
18960       JPCW = NPCW
18961       JTW  = NTW
18962       JTCW = NTCW
18963       DO 40 K=1,4
18964          PFSP(K)   = ZERO
18965    40 CONTINUE
18966
18967       NOB = 0
18968       NOM = 0
18969       DO 900 I=NPOINT(4),NHKK
18970          IDXOTH(I) = -1
18971          IF (ISTHKK(I).EQ.1) THEN
18972             IF (IDBAM(I).EQ.7) GOTO 900
18973             IPOT = 0
18974             IOTHER = 0
18975 * particle moving into forward direction
18976             IF (PHKK(3,I).GE.ZERO) THEN
18977 *   most likely to be effected by projectile potential
18978                IPOT = 1
18979 *     there is no projectile nucleus, try target
18980                IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18981                   IPOT   = 2
18982                   IF (IP.GT.1) IOTHER = 1
18983 *       there is no target nucleus --> skip
18984                   IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18985                ENDIF
18986 * particle moving into backward direction
18987             ELSE
18988 *   most likely to be effected by target potential
18989                IPOT = 2
18990 *     there is no target nucleus, try projectile
18991                IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18992                   IPOT   = 1
18993                   IF (IT.GT.1) IOTHER = 1
18994 *       there is no projectile nucleus --> skip
18995                   IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18996                ENDIF
18997             ENDIF
18998             IFLG = -IPOT
18999 * nobam=3: particle is in overlap-region or neither inside proj. nor target
19000 *      =1: particle is not in overlap-region AND is inside target (2)
19001 *      =2: particle is not in overlap-region AND is inside projectile (1)
19002 * flag particles which are inside the nucleus ipot but not in its
19003 * overlap region
19004             IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
19005             IF (IDBAM(I).NE.0) THEN
19006 * baryons: keep all nucleons and all others where flag is set
19007                IF (IIBAR(IDBAM(I)).NE.0) THEN
19008                   IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
19009      &                                                              THEN
19010                      NOB = NOB+1
19011                      PMOMB(NOB) = PHKK(3,I)
19012                      IDXB(NOB)  = SIGN(10000000*IABS(IFLG)
19013      &                           +1000000*IOTHER+I,IFLG)
19014                   ENDIF
19015 * mesons: keep only those mesons where flag is set
19016                ELSE
19017                   IF (IFLG.GT.0) THEN
19018                      NOM = NOM+1
19019                      PMOMM(NOM) = PHKK(3,I)
19020                      IDXM(NOM)  = 10000000*IFLG+1000000*IOTHER+I
19021                   ENDIF
19022                ENDIF
19023             ENDIF
19024          ENDIF
19025   900 CONTINUE
19026 *
19027 * sort particles in the arrays according to increasing long. momentum
19028       CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
19029       CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
19030 *
19031 * shuffle indices into one and the same array according to the later
19032 * sequence of correction
19033       NCOR = 0
19034       IF (IT.GT.1) THEN
19035          DO 910 I=1,NOB
19036             IF (PMOMB(I).GT.ZERO) GOTO 911
19037             NCOR = NCOR+1
19038             IDXCOR(NCOR) = IDXB(I)
19039   910    CONTINUE
19040   911    CONTINUE
19041          IF (IP.GT.1) THEN
19042             DO 912 J=1,NOB
19043                I = NOB+1-J
19044                IF (PMOMB(I).LT.ZERO) GOTO 913
19045                NCOR = NCOR+1
19046                IDXCOR(NCOR) = IDXB(I)
19047   912       CONTINUE
19048   913       CONTINUE
19049          ELSE
19050             DO 914 I=1,NOB
19051                IF (PMOMB(I).GT.ZERO) THEN
19052                   NCOR = NCOR+1
19053                   IDXCOR(NCOR) = IDXB(I)
19054                ENDIF
19055   914       CONTINUE
19056          ENDIF
19057       ELSE
19058          DO 915 J=1,NOB
19059             I = NOB+1-J
19060             NCOR = NCOR+1
19061             IDXCOR(NCOR) = IDXB(I)
19062   915    CONTINUE
19063       ENDIF
19064       DO 925 I=1,NOM
19065          IF (PMOMM(I).GT.ZERO) GOTO 926
19066          NCOR = NCOR+1
19067          IDXCOR(NCOR) = IDXM(I)
19068   925 CONTINUE
19069   926 CONTINUE
19070       DO 927 J=1,NOM
19071          I = NOM+1-J
19072          IF (PMOMM(I).LT.ZERO) GOTO 928
19073          NCOR = NCOR+1
19074          IDXCOR(NCOR) = IDXM(I)
19075   927 CONTINUE
19076   928 CONTINUE
19077 *
19078 C      IF (NEVHKK.EQ.484) THEN
19079 C         WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
19080 C 9000    FORMAT(1X,'wounded nucleons (proj.-p,n  targ.-p,n)',/,4I10)
19081 C         WRITE(LOUT,9001) NOB,NOM,NCOR
19082 C 9001    FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
19083 C         WRITE(LOUT,'(/,A)') ' baryons '
19084 C         DO 950 I=1,NOB
19085 CC           J     = IABS(IDXB(I))
19086 CC           INDEX = J-IABS(J/10000000)*10000000
19087 C            IPOT   = IABS(IDXB(I))/10000000
19088 C            IOTHER = IABS(IDXB(I))/1000000-IPOT*10
19089 C            INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
19090 C            WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
19091 C  950    CONTINUE
19092 C         WRITE(LOUT,'(/,A)') ' mesons '
19093 C         DO 951 I=1,NOM
19094 CC           INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
19095 C            IPOT   = IABS(IDXM(I))/10000000
19096 C            IOTHER = IABS(IDXM(I))/1000000-IPOT*10
19097 C            INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
19098 C            WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
19099 C  951    CONTINUE
19100 C 9002    FORMAT(1X,4I14,E14.5)
19101 C         WRITE(LOUT,'(/,A)') ' all '
19102 C         DO 952 I=1,NCOR
19103 CC           J     = IABS(IDXCOR(I))
19104 CC           INDEX = J-IABS(J/10000000)*10000000
19105 CC            IPOT   = IABS(IDXCOR(I))/10000000
19106 C            IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
19107 C            INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
19108 C            WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
19109 C  952    CONTINUE
19110 C 9003    FORMAT(1X,4I14)
19111 C      ENDIF
19112 *
19113       DO 20 ICOR=1,NCOR
19114          IPOT   = IABS(IDXCOR(ICOR))/10000000
19115          IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
19116          I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
19117          IDXOTH(I) = 1
19118
19119          IDSEC  = IDBAM(I)
19120
19121 * reduction of particle momentum by corresponding nuclear potential
19122 * (this applies only if Fermi-momenta are requested)
19123
19124          IF (LFERMI) THEN
19125
19126 *   Lorentz-transformation into the rest system of the selected nucleus
19127             IMODE = -IPOT-1
19128             CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
19129      &                  PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
19130             PSECO  = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
19131             AMSEC  = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
19132             JPMOD  = 0
19133
19134             CHKLEV = TINY3
19135             IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
19136             IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
19137             IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
19138                IF (IOULEV(3).GT.0)
19139      &            WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
19140  2000          FORMAT(1X,'RESNCL: inconsistent mass of particle',
19141      &                ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
19142      &                I4,'   AMSEC: ',E12.3,'  AAM(IDSEC): ',E12.3,/)
19143                GOTO 23
19144             ENDIF
19145
19146             DO 21 K=1,4
19147                PSEC0(K) = PSEC(K)
19148    21       CONTINUE
19149
19150 *   the correction for nuclear potential effects is applied to as many
19151 *   p/n as many nucleons were wounded; the momenta of other final state
19152 *   particles are corrected only if they materialize inside the corresp.
19153 *   nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
19154 *   = 3 part. outside proj. and targ., >=10 in overlapping region)
19155             IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
19156                IF (IPOT.EQ.1) THEN
19157                   IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
19158 *      this is most likely a wounded nucleon
19159 **test
19160 C                    RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
19161 C    &                           +(VHKK(2,IPW(JPW))/FM2MM)**2
19162 C    &                           +(VHKK(3,IPW(JPW))/FM2MM)**2)
19163 C                    RAD   = RNUCLE*DBLE(IP)**ONETHI
19164 C                    FDEN  = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
19165 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
19166 **
19167                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19168                      JPW = JPW-1
19169                      JPMOD = 1
19170                   ELSE
19171 *      correct only if part. was materialized inside nucleus
19172 *      and if it is ouside the overlapping region
19173                      IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
19174                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19175                         JPMOD = 1
19176                      ENDIF
19177                   ENDIF
19178                ELSEIF (IPOT.EQ.2) THEN
19179                   IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
19180 *      this is most likely a wounded nucleon
19181 **test
19182 C                    RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
19183 C    &                           +(VHKK(2,ITW(JTW))/FM2MM)**2
19184 C    &                           +(VHKK(3,ITW(JTW))/FM2MM)**2)
19185 C                    RAD   = RNUCLE*DBLE(IT)**ONETHI
19186 C                    FDEN  = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
19187 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
19188 **
19189                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19190                      JTW = JTW-1
19191                      JPMOD = 1
19192                   ELSE
19193 *      correct only if part. was materialized inside nucleus
19194                      IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
19195                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19196                         JPMOD = 1
19197                      ENDIF
19198                   ENDIF
19199                ENDIF
19200             ELSE
19201                IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
19202                   PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19203                   JPMOD = 1
19204                ENDIF
19205             ENDIF
19206
19207             IF (NLOOP.EQ.1) THEN
19208 * Coulomb energy correction:
19209 * the treatment of Coulomb potential correction is similar to the
19210 * one for nuclear potential
19211                IF (IDSEC.EQ.1) THEN
19212                   IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
19213                      JPCW = JPCW-1
19214                   ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
19215                      JTCW = JTCW-1
19216                   ELSE
19217                      IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
19218                   ENDIF
19219                ELSE
19220                   IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
19221                ENDIF
19222                IF (IICH(IDSEC).EQ.1) THEN
19223 *    pos. particles: check if they are able to escape Coulomb potential
19224                   IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
19225                      ISTHKK(I) = 14+IPOT
19226                      IF (ISTHKK(I).EQ.15) THEN
19227                         DO 26 K=1,4
19228                            PHKK(K,I) = PSEC0(K)
19229                            TRCLPR(K) = TRCLPR(K)+PSEC0(K)
19230    26                CONTINUE
19231                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
19232                         IF (IDSEC.EQ.1) NPCW = NPCW-1
19233                      ELSEIF (ISTHKK(I).EQ.16) THEN
19234                         DO 27 K=1,4
19235                            PHKK(K,I) = PSEC0(K)
19236                            TRCLTA(K) = TRCLTA(K)+PSEC0(K)
19237    27                   CONTINUE
19238                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
19239                         IF (IDSEC.EQ.1) NTCW = NTCW-1
19240                      ENDIF
19241                      GOTO 20
19242                   ENDIF
19243                ELSEIF (IICH(IDSEC).EQ.-1) THEN
19244 *    neg. particles: decrease energy by Coulomb-potential
19245                   PSEC(4) = PSEC(4)-ETACOU(IPOT)
19246                   JPMOD = 1
19247                ENDIF
19248             ENDIF
19249
19250    25       CONTINUE
19251
19252             IF (PSEC(4).LT.AMSEC) THEN
19253                IF (IOULEV(6).GT.0)
19254      &            WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
19255  2001          FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
19256      &                ' is not allowed to escape nucleus',/,
19257      &                8X,'id : ',I3,'   reduced energy: ',E15.4,
19258      &                '   mass: ',E12.3)
19259                ISTHKK(I) = 14+IPOT
19260                IF (ISTHKK(I).EQ.15) THEN
19261                   DO 28 K=1,4
19262                      PHKK(K,I) = PSEC0(K)
19263                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)
19264    28             CONTINUE
19265                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
19266                   IF (IDSEC.EQ.1) NPCW = NPCW-1
19267                ELSEIF (ISTHKK(I).EQ.16) THEN
19268                   DO 29 K=1,4
19269                      PHKK(K,I) = PSEC0(K)
19270                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)
19271    29             CONTINUE
19272                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
19273                   IF (IDSEC.EQ.1) NTCW = NTCW-1
19274                ENDIF
19275                GOTO 20
19276             ENDIF
19277
19278             IF (JPMOD.EQ.1) THEN
19279                PSECN  = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
19280 * 4-momentum after correction for nuclear potential
19281                DO 22 K=1,3
19282                   PSEC(K) = PSEC(K)*PSECN/PSECO
19283    22          CONTINUE
19284
19285 * store recoil momentum from particles escaping the nuclear potentials
19286                DO 30 K=1,4
19287                   IF (IPOT.EQ.1) THEN
19288                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
19289                   ELSEIF (IPOT.EQ.2) THEN
19290                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
19291                   ENDIF
19292    30          CONTINUE
19293
19294 * transform momentum back into n-n cms
19295                IMODE = IPOT+1
19296                CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
19297      &                     PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
19298      &                     IDSEC,IMODE)
19299             ENDIF
19300
19301          ENDIF
19302
19303    23    CONTINUE
19304          DO 31 K=1,4
19305             PFSP(K) = PFSP(K)+PHKK(K,I)
19306    31    CONTINUE
19307
19308    20 CONTINUE
19309
19310       DO 33 I=NPOINT(4),NHKK
19311          IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
19312             PFSP(1) = PFSP(1)+PHKK(1,I)
19313             PFSP(2) = PFSP(2)+PHKK(2,I)
19314             PFSP(3) = PFSP(3)+PHKK(3,I)
19315             PFSP(4) = PFSP(4)+PHKK(4,I)
19316          ENDIF
19317    33 CONTINUE
19318
19319       DO 34 K=1,5
19320          PRCLPR(K) = TRCLPR(K)
19321          PRCLTA(K) = TRCLTA(K)
19322    34 CONTINUE
19323
19324       IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
19325 * hadron-nucleus interactions: get residual momentum from energy-
19326 * momentum conservation
19327          DO 32 K=1,4
19328             PRCLPR(K) = ZERO
19329             PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
19330    32    CONTINUE
19331       ELSE
19332 * nucleus-hadron, nucleus-nucleus: get residual momentum from
19333 * accumulated recoil momenta of particles leaving the spectators
19334 *   transform accumulated recoil momenta of residual nuclei into
19335 *   n-n cms
19336          PZI = PRCLPR(3)
19337          PEI = PRCLPR(4)
19338          CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
19339          PZI = PRCLTA(3)
19340          PEI = PRCLTA(4)
19341          CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
19342 C        IF (IP.GT.1) THEN
19343             PRCLPR(3) = PRCLPR(3)+PINIPR(3)
19344             PRCLPR(4) = PRCLPR(4)+PINIPR(4)
19345 C        ENDIF
19346          IF (IT.GT.1) THEN
19347             PRCLTA(3) = PRCLTA(3)+PINITA(3)
19348             PRCLTA(4) = PRCLTA(4)+PINITA(4)
19349          ENDIF
19350       ENDIF
19351
19352 * check momenta of residual nuclei
19353       IF (LEMCCK) THEN
19354          CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
19355      &               1,IDUM,IDUM)
19356          CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
19357      &               2,IDUM,IDUM)
19358          CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
19359      &               2,IDUM,IDUM)
19360          CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
19361      &               2,IDUM,IDUM)
19362          CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
19363 **sr 19.12. changed to avoid output when used with phojet
19364 C        CHKLEV = TINY3
19365          CHKLEV = TINY1
19366          CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
19367 C        IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
19368 C    &      CALL DT_EVTOUT(4)
19369          IF (IREJ1.GT.0) RETURN
19370       ENDIF
19371
19372       RETURN
19373       END
19374
19375 *$ CREATE DT_SCN4BA.FOR
19376 *COPY DT_SCN4BA
19377 *
19378 *===scn4ba=============================================================*
19379 *
19380       SUBROUTINE DT_SCN4BA
19381
19382 ************************************************************************
19383 * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot.    *
19384 * This version dated 12.12.95 is written by S. Roesler.                *
19385 ************************************************************************
19386
19387       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19388       SAVE
19389
19390       PARAMETER ( LINP = 10 ,
19391      &            LOUT = 6 ,
19392      &            LDAT = 9 )
19393
19394       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
19395      &           TINY10=1.0D-10)
19396
19397 * event history
19398
19399       PARAMETER (NMXHKK=200000)
19400
19401       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19402      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19403      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19404
19405 * extended event history
19406       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19407      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19408      &                IHIST(2,NMXHKK)
19409
19410 * particle properties (BAMJET index convention)
19411       CHARACTER*8  ANAME
19412       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19413      &                IICH(210),IIBAR(210),K1(210),K2(210)
19414
19415 * properties of interacting particles
19416       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
19417
19418 * nuclear potential
19419       LOGICAL LFERMI
19420       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
19421      &                EBINDP(2),EBINDN(2),EPOT(2,210),
19422      &                ETACOU(2),ICOUL,LFERMI
19423
19424 * treatment of residual nuclei: wounded nucleons
19425       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
19426
19427 * treatment of residual nuclei: 4-momenta
19428       LOGICAL LRCLPR,LRCLTA
19429       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
19430      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
19431
19432       DIMENSION PLAB(2,5),PCMS(4)
19433
19434       IREJ = 0
19435
19436 * get number of wounded nucleons
19437       NPW    = 0
19438       NPW0   = 0
19439       NPCW   = 0
19440       NPSTCK = 0
19441       NTW    = 0
19442       NTW0   = 0
19443       NTCW   = 0
19444       NTSTCK = 0
19445
19446       ISGLPR = 0
19447       ISGLTA = 0
19448       LRCLPR = .FALSE.
19449       LRCLTA = .FALSE.
19450
19451 C     DO 2 I=1,NHKK
19452       DO 2 I=1,NPOINT(1)
19453 * projectile nucleons wounded in primary interaction and in fzc
19454          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
19455             NPW      = NPW+1
19456             IPW(NPW) = I
19457             NPSTCK   = NPSTCK+1
19458             IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
19459             IF (ISTHKK(I).EQ.11)  NPW0 = NPW0+1
19460 C           IF (IP.GT.1) THEN
19461                DO 5 K=1,4
19462                   TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
19463     5          CONTINUE
19464 C           ENDIF
19465 * target nucleons wounded in primary interaction and in fzc
19466          ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
19467             NTW      = NTW+1
19468             ITW(NTW) = I
19469             NTSTCK   = NTSTCK+1
19470             IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
19471             IF (ISTHKK(I).EQ.12)  NTW0 = NTW0+1
19472             IF (IT.GT.1) THEN
19473                DO 6 K=1,4
19474                   TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
19475     6          CONTINUE
19476             ENDIF
19477          ELSEIF (ISTHKK(I).EQ.13) THEN
19478             ISGLPR = I
19479          ELSEIF (ISTHKK(I).EQ.14) THEN
19480             ISGLTA = I
19481          ENDIF
19482     2 CONTINUE
19483
19484       DO 11 I=NPOINT(4),NHKK
19485 * baryons which are unable to escape the nuclear potential of proj.
19486          IF (ISTHKK(I).EQ.15) THEN
19487             ISGLPR = I
19488             NPSTCK = NPSTCK-1
19489             IF (IIBAR(IDBAM(I)).NE.0) THEN
19490                NPW    = NPW-1
19491                IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
19492             ENDIF
19493             DO 7 K=1,4
19494                TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
19495     7       CONTINUE
19496 * baryons which are unable to escape the nuclear potential of targ.
19497          ELSEIF (ISTHKK(I).EQ.16) THEN
19498             ISGLTA = I
19499             NTSTCK = NTSTCK-1
19500             IF (IIBAR(IDBAM(I)).NE.0) THEN
19501                NTW    = NTW-1
19502                IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
19503             ENDIF
19504             DO 8 K=1,4
19505                TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
19506     8       CONTINUE
19507          ENDIF
19508    11 CONTINUE
19509
19510 * residual nuclei so far
19511       IRESP = IP-NPSTCK
19512       IREST = IT-NTSTCK
19513
19514 * ckeck for "residual nuclei" consisting of one nucleon only
19515 * treat it as final state particle
19516       IF (IRESP.EQ.1) THEN
19517          ID  = IDBAM(ISGLPR)
19518          IST = ISTHKK(ISGLPR)
19519          CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
19520      &               PHKK(3,ISGLPR),PHKK(4,ISGLPR),
19521      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
19522          IF (IST.EQ.13) THEN
19523             ISTHKK(ISGLPR) = 11
19524          ELSE
19525             ISTHKK(ISGLPR) = 2
19526          ENDIF
19527          CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
19528      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
19529      &               IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
19530          NOBAM(NHKK)      = NOBAM(ISGLPR)
19531          JDAHKK(1,ISGLPR) = NHKK
19532          DO 21 K=1,4
19533             TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
19534    21    CONTINUE
19535       ENDIF
19536       IF (IREST.EQ.1) THEN
19537          ID  = IDBAM(ISGLTA)
19538          IST = ISTHKK(ISGLTA)
19539          CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
19540      &               PHKK(3,ISGLTA),PHKK(4,ISGLTA),
19541      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
19542          IF (IST.EQ.14) THEN
19543             ISTHKK(ISGLTA) = 12
19544          ELSE
19545             ISTHKK(ISGLTA) = 2
19546          ENDIF
19547          CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
19548      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
19549      &               IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
19550          NOBAM(NHKK)      = NOBAM(ISGLTA)
19551          JDAHKK(1,ISGLTA) = NHKK
19552          DO 22 K=1,4
19553             TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
19554    22    CONTINUE
19555       ENDIF
19556
19557 * get nuclear potential corresp. to the residual nucleus
19558       IPRCL  = IP -NPW
19559       IPZRCL = IPZ-NPCW
19560       ITRCL  = IT -NTW
19561       ITZRCL = ITZ-NTCW
19562       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
19563
19564 * baryons unable to escape the nuclear potential are treated as
19565 * excited nucleons (ISTHKK=15,16)
19566       DO 3 I=NPOINT(4),NHKK
19567          IF (ISTHKK(I).EQ.1) THEN
19568             ID  = IDBAM(I)
19569             IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
19570 *   final state n and p not being outside of both nuclei are considered
19571                NPOTP = 1
19572                NPOTT = 1
19573                IF ( (IP.GT.1)      .AND.(IRESP.GT.1).AND.
19574      &              (NOBAM(I).NE.1).AND.(NPW.GT.0)        ) THEN
19575 *     Lorentz-trsf. into proj. rest sys. for those being inside proj.
19576                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
19577      &                        PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
19578      &                        PLAB(1,4),ID,-2)
19579                   PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
19580                   PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
19581      &                                  (PLAB(1,4)+PLABT) ))
19582                   EKIN = PLAB(1,4)-PLAB(1,5)
19583                   IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
19584                   IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
19585                ENDIF
19586                IF ( (IT.GT.1)      .AND.(IREST.GT.1).AND.
19587      &              (NOBAM(I).NE.2).AND.(NTW.GT.0)        ) THEN
19588 *     Lorentz-trsf. into targ. rest sys. for those being inside targ.
19589                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
19590      &                        PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
19591      &                        PLAB(2,4),ID,-3)
19592                   PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
19593                   PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
19594      &                                  (PLAB(2,4)+PLABT) ))
19595                   EKIN = PLAB(2,4)-PLAB(2,5)
19596                   IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
19597                   IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
19598                ENDIF
19599                IF (PHKK(3,I).GE.ZERO) THEN
19600                   ISTHKK(I) = NPOTT
19601                   IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
19602                ELSE
19603                   ISTHKK(I) = NPOTP
19604                   IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
19605                ENDIF
19606                IF (ISTHKK(I).NE.1) THEN
19607                   J = ISTHKK(I)-14
19608                   DO 4 K=1,5
19609                      PHKK(K,I) = PLAB(J,K)
19610     4             CONTINUE
19611                   IF (ISTHKK(I).EQ.15) THEN
19612                      NPW = NPW-1
19613                      IF (ID.EQ.1) NPCW = NPCW-1
19614                      DO 9 K=1,4
19615                         TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
19616     9                CONTINUE
19617                   ELSEIF (ISTHKK(I).EQ.16) THEN
19618                      NTW = NTW-1
19619                      IF (ID.EQ.1) NTCW = NTCW-1
19620                      DO 10 K=1,4
19621                         TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
19622    10                CONTINUE
19623                   ENDIF
19624                ENDIF
19625             ENDIF
19626          ENDIF
19627     3 CONTINUE
19628
19629 * again: get nuclear potential corresp. to the residual nucleus
19630       IPRCL  = IP -NPW
19631       IPZRCL = IPZ-NPCW
19632       ITRCL  = IT -NTW
19633       ITZRCL = ITZ-NTCW
19634 c      AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
19635 cC     AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
19636 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
19637 C     AFERP = 0.0D0
19638 c      AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
19639 cC     AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
19640 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
19641 C     AFERT = 0.0D0
19642 C     IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
19643 C     IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
19644 C     IF (AFERP.GT.0.85D0) AFERP = 0.85D0
19645 C     IF (AFERT.GT.0.85D0) AFERT = 0.85D0
19646       AFERP = FERMOD+0.1D0
19647       AFERT = FERMOD+0.1D0
19648
19649       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
19650
19651       RETURN
19652       END
19653
19654 *$ CREATE DT_FICONF.FOR
19655 *COPY DT_FICONF
19656 *
19657 *===ficonf=============================================================*
19658 *
19659       SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
19660
19661 ************************************************************************
19662 * Treatment of FInal CONFiguration including evaporation, fission and  *
19663 * Fermi-break-up (for light nuclei only).                              *
19664 * Adopted from the original routine FINALE and extended to residual    *
19665 * projectile nuclei.                                                   *
19666 * This version dated 12.12.95 is written by S. Roesler.                *
19667 *                                                                      *
19668 * Last change 27.12.2006 by S. Roesler.                                *
19669 ************************************************************************
19670
19671       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19672       SAVE
19673
19674       PARAMETER ( LINP = 10 ,
19675      &            LOUT = 6 ,
19676      &            LDAT = 9 )
19677
19678       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
19679       PARAMETER (ANGLGB=5.0D-16)
19680
19681 * event history
19682
19683       PARAMETER (NMXHKK=200000)
19684
19685       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19686      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19687      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19688
19689 * extended event history
19690       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19691      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19692      &                IHIST(2,NMXHKK)
19693
19694 * rejection counter
19695       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
19696      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
19697      &                IREXCI(3),IRDIFF(2),IRINC
19698
19699 * central particle production, impact parameter biasing
19700       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
19701
19702 * particle properties (BAMJET index convention)
19703       CHARACTER*8  ANAME
19704       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19705      &                IICH(210),IIBAR(210),K1(210),K2(210)
19706
19707 * treatment of residual nuclei: 4-momenta
19708       LOGICAL LRCLPR,LRCLTA
19709       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
19710      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
19711
19712 * treatment of residual nuclei: properties of residual nuclei
19713       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19714      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19715      &                NTOTFI(2),NPROFI(2)
19716
19717 * statistics: residual nuclei
19718       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19719      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19720      &                NINCST(2,4),NINCEV(2),
19721      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19722      &                NRESPB(2),NRESCH(2),NRESEV(4),
19723      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19724      &                NEVAFI(2,2)
19725
19726 * flags for input different options
19727       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19728       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19729      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19730
19731 *      INCLUDE '(DIMPAR)'
19732 *     DIMPAR taken from FLUKA
19733       PARAMETER ( MXXRGN =20000 )
19734       PARAMETER ( MXXMDF =  710 )
19735       PARAMETER ( MXXMDE =  702 )
19736       PARAMETER ( MFSTCK =40000 )
19737       PARAMETER ( MESTCK =  100 )
19738       PARAMETER ( MOSTCK = 2000 )
19739       PARAMETER ( MXPRSN =  100 )
19740       PARAMETER ( MXPDPM =  800 )
19741       PARAMETER ( MXPSCS =30000 )
19742       PARAMETER ( MXGLWN =  300 )
19743       PARAMETER ( MXOUTU =   50 )
19744       PARAMETER ( NALLWP =   64 )
19745       PARAMETER ( NELEMX =   80 )
19746       PARAMETER ( MPDPDX =   18 )
19747       PARAMETER ( MXHTTR =  260 )
19748       PARAMETER ( MXSEAX =   20 )
19749       PARAMETER ( MXHTNC = MXSEAX + 1 )
19750       PARAMETER ( ICOMAX = 2400 )
19751       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
19752       PARAMETER ( NSTBIS =  304 )
19753       PARAMETER ( NQSTIS =   46 )
19754       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
19755       PARAMETER ( MXPABL =  120 )
19756       PARAMETER ( IDMAXP =  450 )
19757       PARAMETER ( IDMXDC = 2000 )
19758       PARAMETER ( MXMCIN =  410 )
19759       PARAMETER ( IHYPMX =    4 )
19760       PARAMETER ( MKBMX1 =   11 )
19761       PARAMETER ( MKBMX2 =   11 )
19762       PARAMETER ( MXIRRD = 2500 )
19763       PARAMETER ( MXTRDC = 1500 )
19764       PARAMETER ( NKTL   =   17 )
19765       PARAMETER ( NBLNMX = 40000000 )
19766
19767 *      INCLUDE '(GENSTK)'
19768 *     GENSTK taken from FLUKA
19769       COMMON / GENSTK /                CXR    (MXPSCS), CYR    (MXPSCS),
19770      &                CZR    (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
19771      &                CZRPOL (MXPSCS), TKI    (MXPSCS), PLR    (MXPSCS),
19772      &                WEI    (MXPSCS), AGESEC (MXPSCS), TV    , TVCMS  ,
19773      &                TVRECL,  TVHEAV, TVBIND,
19774      &                KPART  (MXPSCS), INFEXT (MXPSCS), NP0   , NP
19775
19776 *      INCLUDE '(RESNUC)'
19777 *     RESNUC from FLUKA
19778       LOGICAL LRNFSS, LFRAGM
19779       COMMON /RESNUC/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19780      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19781      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
19782      &                  PYRES,  PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
19783      &                 ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
19784      &                  KTARP,  KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
19785      &                 IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,  ICRES,
19786      &                  IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
19787      &                 IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
19788      &                 IEV4HE, IDEEXG,  IBTAR, ICHTAR, IBLEFT, ICLEFT,
19789      &                 ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
19790      &                 LRNFSS, LFRAGM
19791
19792       PARAMETER ( EMVGEV = 1.0                D-03 )
19793       PARAMETER ( AMUGEV = 0.93149432         D+00 )
19794       PARAMETER ( AMPRTN = 0.93827231         D+00 )
19795       PARAMETER ( AMNTRN = 0.93956563         D+00 )
19796       PARAMETER ( AMELCT = 0.51099906         D-03 )
19797       PARAMETER ( ELCCGS = 4.8032068          D-10 )
19798       PARAMETER ( ELCMKS = 1.60217733         D-19 )
19799       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19800      &                   * 1.D-09 )
19801       PARAMETER ( HLFHLF = 0.5D+00 )
19802       PARAMETER ( FERTHO = 14.33       D-09 )
19803       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
19804       PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
19805       PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
19806
19807 *      INCLUDE '(NUCDAT)'
19808 *     Taken from FLUKA
19809       PARAMETER ( AMUAMU = AMUGEV )
19810       PARAMETER ( AMPROT = AMPRTN )
19811       PARAMETER ( AMNEUT = AMNTRN )
19812       PARAMETER ( AMELEC = AMELCT )
19813       PARAMETER ( R0NUCL = 1.12        D+00 )
19814       PARAMETER ( RCCOUL = 1.7         D+00 )
19815       PARAMETER ( COULPR = COUGFM )
19816       PARAMETER ( AMHYDR = AMPRTN + AMELCT  )
19817       PARAMETER ( AMHTON = AMHYDR - AMNTRN  )
19818       PARAMETER ( AMNTOU = AMNTRN - AMUC12  )
19819       PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
19820       PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
19821 *   Gammin : threshold for deexcitation gammas production, set to 1 keV
19822 *   (this means that up to 1 keV of energy unbalancing can occur
19823 *    during an event)
19824       PARAMETER ( GAMMIN = 1.0D-06 )
19825       PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
19826 *   Tvepsi : "epsilon" for excitation energy, set to gammin / 100
19827       PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
19828 *
19829       COMMON /NUCDAT/ AV0WEL,     APFRMX,     AEFRMX,     AEFRMA,
19830      &                RDSNUC,     V0WELL (2), PFRMMX (2), EFRMMX (2),
19831      &                EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
19832      &                VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
19833      &                PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
19834      &                EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
19835      &                ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV    ,
19836      &                AMRCSQ    , ATO1O3    , ZTO1O3    , FRMRFC    ,
19837      &                ELBNDE (0:110)
19838
19839 *      INCLUDE '(PAREVT)'
19840 *     Taken from FLUKA
19841       PARAMETER ( FRDIFF = 0.2D+00 )
19842       PARAMETER ( ETHSEA = 1.0D+00 )
19843 *
19844       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
19845      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
19846      &        LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
19847      &        LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
19848       COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
19849      &                  LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
19850      &                  LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
19851      &                  LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
19852      &                  LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
19853      &                  LVP2XX, LV2XNW, LNWV2X, LEVFIN
19854
19855 *      INCLUDE '(FHEAVY)'
19856 *     Taken from FLUKA
19857       PARAMETER ( MXHEAV = 100 )
19858       PARAMETER ( KXHEAV =  30 )
19859       CHARACTER*8 ANHEAV
19860       COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19861      &                  CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19862      &                  PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19863      &                  AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
19864      &                  AMHEAV (KXHEAV), AMNHEA (KXHEAV),
19865      &                  KHEAVY (MXHEAV), INFHEA (MXHEAV),
19866      &                  ICHEAV (KXHEAV), IBHEAV (KXHEAV),
19867      &                  IMHEAV (KXHEAV), IHHEAV (KXHEAV),
19868      &                  KHHEAV (IHYPMX,KXHEAV), NPHEAV
19869       COMMON / FHEAVC / ANHEAV (KXHEAV)
19870
19871 * event flag
19872       COMMON /DTEVNO/ NEVENT,ICASCA
19873
19874       DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
19875      &          PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
19876      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
19877
19878       DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
19879       LOGICAL LLCPOT
19880       DATA EXC,NEXC /520*ZERO,520*0/
19881       DATA EXPNUC /4.0D-3,4.0D-3/
19882
19883       IREJ   = 0
19884       LRCLPR = .FALSE.
19885       LRCLTA = .FALSE.
19886
19887 * skip residual nucleus treatment if not requested or in case
19888 * of central collisions
19889       IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
19890
19891       DO 1 K=1,2
19892          IDPAR(K) = 0
19893          IDXPAR(K)= 0
19894          NTOT(K)  = 0
19895          NTOTFI(K)= 0
19896          NPRO(K)  = 0
19897          NPROFI(K)= 0
19898          NN(K)    = 0
19899          NH(K)    = 0
19900          NHPOS(K) = 0
19901          NQ(K)    = 0
19902          EEXC(K)  = ZERO
19903          MO1(K)   = 0
19904          MO2(K)   = 0
19905          DO 2 I=1,4
19906             VRCL(K,I) = ZERO
19907             WRCL(K,I) = ZERO
19908     2    CONTINUE
19909     1 CONTINUE
19910       NFSP = 0
19911       INUC(1) = IP
19912       INUC(2) = IT
19913
19914       DO 3 I=1,NHKK
19915
19916 * number of final state particles
19917          IF (ABS(ISTHKK(I)).EQ.1) THEN
19918             NFSP  = NFSP+1
19919             IDFSP = IDBAM(I)
19920          ENDIF
19921
19922 * properties of remaining nucleon configurations
19923          KF = 0
19924          IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
19925          IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
19926          IF (KF.GT.0) THEN
19927             IF (MO1(KF).EQ.0) MO1(KF) = I
19928             MO2(KF)  = I
19929 *   position of residual nucleus = average position of nucleons
19930             DO 4 K=1,4
19931                VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
19932                WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
19933     4       CONTINUE
19934 *   total number of particles contributing to each residual nucleus
19935             NTOT(KF)  = NTOT(KF)+1
19936             IDTMP     = IDBAM(I)
19937             IDXTMP    = I
19938 *   total charge of residual nuclei
19939             NQ(KF) = NQ(KF)+IICH(IDTMP)
19940 *   number of protons
19941             IF (IDHKK(I).EQ.2212) THEN
19942                NPRO(KF) = NPRO(KF)+1
19943 *   number of neutrons
19944             ELSEIF (IDHKK(I).EQ.2112) THEN
19945                NN(KF) = NN(KF)+1
19946             ELSE
19947 *   number of baryons other than n, p
19948                IF (IIBAR(IDTMP).EQ.1) THEN
19949                   NH(KF) = NH(KF)+1
19950                   IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
19951                ELSE
19952 *   any other mesons (status set to 1)
19953 C                 WRITE(LOUT,1002) KF,IDTMP
19954 C1002             FORMAT(1X,'FICONF:   residual nucleus ',I2,
19955 C    &                   ' containing meson ',I4,', status set to 1')
19956                   ISTHKK(I) = 1
19957                   IDTMP     = IDPAR(KF)
19958                   IDXTMP    = IDXPAR(KF)
19959                   NTOT(KF)  = NTOT(KF)-1
19960                ENDIF
19961             ENDIF
19962             IDPAR(KF)  = IDTMP
19963             IDXPAR(KF) = IDXTMP
19964          ENDIF
19965     3 CONTINUE
19966
19967 * reject elastic events (def: one final state particle = projectile)
19968       IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
19969          IREXCI(3) = IREXCI(3)+1
19970          GOTO 9999
19971 C        RETURN
19972       ENDIF
19973
19974 * check if one nucleus disappeared..
19975 C     IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
19976 C        DO 5 K=1,4
19977 C           PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
19978 C           PRCLPR(K) = ZERO
19979 C   5    CONTINUE
19980 C     ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
19981 C        DO 6 K=1,4
19982 C           PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
19983 C           PRCLTA(K) = ZERO
19984 C   6    CONTINUE
19985 C     ENDIF
19986
19987       ICOR   = 0
19988       INORCL = 0
19989       DO 7 I=1,2
19990          DO 8 K=1,4
19991 * get the average of the nucleon positions
19992             VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
19993             WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
19994             IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
19995             IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
19996     8    CONTINUE
19997 * mass number and charge of residual nuclei
19998          AIF(I)  = DBLE(NTOT(I))
19999          AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
20000          IF (NTOT(I).GT.1) THEN
20001 * masses of residual nuclei in ground state
20002
20003 C           AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*ENERGY(AIF(I),AIZF(I))
20004             AMRCL0(I) = AIF(I)*AMUC12
20005      &                  +EMVGEV*EXMSAZ(AIF(I),AIZF(I),.TRUE.,IZDUM)
20006
20007 * masses of residual nuclei
20008             PTORCL   = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
20009             AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
20010             IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
20011 *
20012 *   M_res^2 < 0 : configuration not allowed
20013 *
20014 *      a) re-calculate E_exc with scaled nuclear potential
20015 *         (conditional jump to label 9998)
20016 *      b) or reject event if N_loop(max) is exceeded
20017 *         (conditional jump to label 9999)
20018 *
20019             IF (AMRCL(I).LE.ZERO) THEN
20020                IF (IOULEV(3).GT.0)
20021      &            WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
20022      &                             PRCL(I,4),NTOT
20023  1000          FORMAT(1X,'warning! negative excitation energy',/,
20024      &                I4,4E15.4,2I4)
20025                AMRCL(I) = ZERO
20026                EEXC(I)  = ZERO
20027                IF (NLOOP.LE.500) THEN
20028                   GOTO 9998
20029                ELSE
20030                   IREXCI(2) = IREXCI(2)+1
20031                   GOTO 9999
20032                ENDIF
20033 *
20034 *   0 < M_res < M_res0 : mass below ground-state mass
20035 *
20036 *      a) we had residual nuclei with mass N_tot and reasonable E_exc
20037 *         before- assign average E_exc of those configurations to this
20038 *         one ( Nexc(i,N_tot) > 0 )
20039 *      b) or (and this applies always if run in transport codes) go up
20040 *         one mass number and
20041 *           i) if mass now larger than proj/targ mass or if run in
20042 *              transport codes assign average E_exc per wounded nucleon
20043 *              x number of wounded nucleons (Inuc-Ntot)
20044 *          ii) or assign average E_exc of those configurations to this
20045 *              one ( Nexc(i,m) > 0 )
20046 *
20047             ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
20048      &                                                         THEN
20049                M = MIN(NTOT(I),260)
20050                IF (NEXC(I,M).GT.0) THEN
20051                   AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
20052                ELSE
20053    70             CONTINUE
20054                   M = M+1
20055 **sr corrected 27.12.06
20056 *                 IF (M.GE.INUC(I)) THEN
20057 *                    AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
20058                   IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
20059                      IF ( INUC (I) .GT. NTOT (I) ) THEN
20060                         AMRCL(I) = AMRCL0(I)
20061      &                         + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
20062                      ELSE
20063                         AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
20064                      END IF
20065 **
20066                   ELSE
20067                      IF (NEXC(I,M).GT.0) THEN
20068                         AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
20069                      ELSE
20070                         GOTO 70
20071                      ENDIF
20072                   ENDIF
20073                ENDIF
20074                EEXC(I)  = AMRCL(I)-AMRCL0(I)
20075                ICOR     = ICOR+I
20076 *
20077 *   M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
20078 *
20079 *      a) re-calculate E_exc with scaled nuclear potential
20080 *         (conditional jump to label 9998)
20081 *      b) or reject event if N_loop(max) is exceeded
20082 *         (conditional jump to label 9999)
20083 *
20084 *
20085             ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
20086                IF (IOULEV(3).GT.0)
20087      &            WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
20088  1004          FORMAT(1X,'warning! too high excitation energy',/,
20089      &                I4,1P,2E15.4,3I5)
20090                AMRCL(I) = ZERO
20091                EEXC(I)  = ZERO
20092                IF (NLOOP.LE.500) THEN
20093                   GOTO 9998
20094                ELSE
20095                   IREXCI(2) = IREXCI(2)+1
20096                   GOTO 9999
20097                ENDIF
20098 *
20099 *   Otherwise (reasonable E_exc) :
20100 *      E_exc = M_res - M_res0
20101 *      in addition: calculate and save E_exc per wounded nucleon as
20102 *                   well as E_exc in <E_exc> counter
20103 *
20104             ELSE
20105 * excitation energies of residual nuclei
20106                EEXC(I)   = AMRCL(I)-AMRCL0(I)
20107 **sr 27.12.06 new excitation energy correction by A.F.
20108 *
20109 * all parts with Ilcopt<3 commented since not used
20110 *
20111 * still to be done/decided:
20112 *   Increase Icor and put back both residual nuclei on mass shell
20113 *   with the exciting correction further below.
20114 *   For the moment the modification in the excitation energy is simply
20115 *   corrected by scaling the energy of the residual nucleus.
20116 *
20117                LLCPOT = .TRUE.
20118                ILCOPT = 3
20119                IF ( LLCPOT ) THEN
20120                   NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
20121                   IF ( ILCOPT .LE. 2 ) THEN
20122 C* Patch for Fermi momentum reduction correlated with impact parameter:
20123 C                     FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
20124 C                     DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
20125 C                     AKPRHO = ONE - DLKPRH
20126 C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
20127 C                     FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO  - ONE,
20128 C     &                              0.05D+00 )
20129 C*                    REDORI = 0.75D+00
20130 C*                    REDORI = ONE
20131 C                     REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
20132                   ELSE
20133                      DLKPRH = ZERO
20134                      RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
20135 *  Take out roughly one/half of the skin:
20136                      RDCORE = RDCORE - 0.5D+00
20137                      FRCFLL = RDCORE**3
20138                      PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
20139                      PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
20140                      FRCFLL = ONE - PRSKIN
20141                      FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
20142                      REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
20143                   END IF
20144                   IF ( NNCHIT .GT. 0 ) THEN
20145 C                     IF ( ILCOPT .EQ. 1 ) THEN
20146 C                        SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
20147 C                        DO 1220 NCH = 1, 10
20148 C                           ETAETA = ( ONE - SKINRH**INUC(I)
20149 C     &                            - DBLE(INUC(I))* ( ONE - FRCFLL )
20150 C     &                            * ( ONE - SKINRH ) )
20151 C     &                            / ( SKINRH**INUC(I) - DBLE (INUC(I))
20152 C     &                            * ( ONE - FRCFLL) * SKINRH )
20153 C                           SKINRH = SKINRH * ( ONE + ETAETA )
20154 C 1220                   CONTINUE
20155 C                        PRSKIN = SKINRH**(NNCHIT-1)
20156 C                     ELSE IF ( ILCOPT .EQ. 2 ) THEN
20157 C                        PRSKIN = ONE - FRCFLL
20158 C                     END IF
20159                      REDCTN = ZERO
20160                      DO 1230 NCH = 1, NNCHIT
20161                         IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
20162                            PRFRMI = (( ONE - 2.D+00 * DLKPRH )
20163      &                            * DT_RNDM(PRFRMI))**0.333333333333D+00
20164                         ELSE
20165                            PRFRMI = ( ONE - 2.D+00 * DLKPRH
20166      &                            * DT_RNDM(PRFRMI))**0.333333333333D+00
20167                         END IF
20168                         REDCTN = REDCTN + PRFRMI**2
20169  1230                CONTINUE
20170                      REDCTN = REDCTN / DBLE (NNCHIT)
20171                   ELSE
20172                      REDCTN = 0.5D+00
20173                   END IF
20174                   EEXC  (I) = EEXC   (I) * REDCTN / REDORI
20175                   AMRCL (I) = AMRCL0 (I) + EEXC (I)
20176                   PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
20177                END IF
20178 **
20179                IF (ICASCA.EQ.0) THEN
20180                   EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
20181                   M = MIN(NTOT(I),260)
20182                   EXC(I,M)  = EXC(I,M)+EEXC(I)
20183                   NEXC(I,M) = NEXC(I,M)+1
20184                ENDIF
20185             ENDIF
20186          ELSEIF (NTOT(I).EQ.1) THEN
20187             WRITE(LOUT,1003) I
20188  1003       FORMAT(1X,'FICONF:   warning! NTOT(I)=1? (I=',I3,')')
20189             GOTO 9999
20190          ELSE
20191             AMRCL0(I) = ZERO
20192             AMRCL(I)  = ZERO
20193             EEXC(I)   = ZERO
20194             INORCL    = INORCL+I
20195          ENDIF
20196     7 CONTINUE
20197
20198       PRCLPR(5) = AMRCL(1)
20199       PRCLTA(5) = AMRCL(2)
20200
20201       IF (ICOR.GT.0) THEN
20202          IF (INORCL.EQ.0) THEN
20203 * one or both residual nuclei consist of one nucleon only, transform
20204 * this nucleon on mass shell
20205             DO 9 K=1,4
20206                P1IN(K) = PRCL(1,K)
20207                P2IN(K) = PRCL(2,K)
20208     9       CONTINUE
20209             XM1 = AMRCL(1)
20210             XM2 = AMRCL(2)
20211             CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
20212             IF (IREJ1.GT.0) THEN
20213                WRITE(LOUT,*) 'ficonf-mashel rejection'
20214                GOTO 9999
20215             ENDIF
20216             DO 10 K=1,4
20217                PRCL(1,K) = P1OUT(K)
20218                PRCL(2,K) = P2OUT(K)
20219                PRCLPR(K) = P1OUT(K)
20220                PRCLTA(K) = P2OUT(K)
20221    10       CONTINUE
20222             PRCLPR(5) = AMRCL(1)
20223             PRCLTA(5) = AMRCL(2)
20224          ELSE
20225             IF (IOULEV(3).GT.0)
20226      &      WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
20227      &                       INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
20228      &                       AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
20229      &                       AMRCL(2),AMRCL(2)-AMRCL0(2)
20230  1001       FORMAT(1X,'FICONF:   warning! no residual nucleus for',
20231      &             ' correction',/,11X,'at event',I8,
20232      &             ',  nucleon config. 1:',2I4,' 2:',2I4,
20233      &             2(/,11X,3E12.3))
20234             IF (NLOOP.LE.500) THEN
20235                GOTO 9998
20236             ELSE
20237                IREXCI(1) = IREXCI(1)+1
20238             ENDIF
20239          ENDIF
20240       ENDIF
20241
20242 * update counter
20243 C     IF (NRESEV(1).NE.NEVHKK) THEN
20244 C        NRESEV(1) = NEVHKK
20245 C        NRESEV(2) = NRESEV(2)+1
20246 C     ENDIF
20247       NRESEV(2) = NRESEV(2)+1
20248       DO 15 I=1,2
20249          EXCDPM(I)   = EXCDPM(I)+EEXC(I)
20250          EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
20251          NRESTO(I) = NRESTO(I)+NTOT(I)
20252          NRESPR(I) = NRESPR(I)+NPRO(I)
20253          NRESNU(I) = NRESNU(I)+NN(I)
20254          NRESBA(I) = NRESBA(I)+NH(I)
20255          NRESPB(I) = NRESPB(I)+NHPOS(I)
20256          NRESCH(I) = NRESCH(I)+NQ(I)
20257    15 CONTINUE
20258
20259 * evaporation
20260       IF (LEVPRT) THEN
20261          DO 13 I=1,2
20262 * initialize evaporation counter
20263             EEXCFI(I) = ZERO
20264             IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
20265      &          (EEXC(I).GT.ZERO)) THEN
20266 * put residual nuclei into DTEVT1
20267                IDRCL = 80000
20268                JMASS = INT( AIF(I))
20269                JCHAR = INT(AIZF(I))
20270 *  the following patch is required to transmit the correct excitation
20271 *   energy to Eventd
20272                IF (ITRSPT.EQ.1) THEN
20273                   IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
20274      &                (IOULEV(3).GT.0))
20275      &               WRITE(LOUT,*)
20276      &                  ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
20277      &                              AMRCL(I),AMRCL0(I),EEXC(I)
20278                   PRCL0 = PRCL(I,4)
20279                   PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
20280      &                                                    +PRCL(I,3)**2)
20281                   IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
20282                      WRITE(LOUT,*)
20283      &                  ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
20284                   ENDIF
20285                ENDIF
20286                CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
20287      &              PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
20288 **sr 22.6.97
20289                NOBAM(NHKK) = I
20290 **
20291                DO 14 J=1,4
20292                   VHKK(J,NHKK) = VRCL(I,J)
20293                   WHKK(J,NHKK) = WRCL(I,J)
20294    14          CONTINUE
20295 *  interface to evaporation module - fill final residual nucleus into
20296 *  common FKRESN
20297 *   fill resnuc only if code is not used as event generator in Fluka
20298                IF (ITRSPT.NE.1) THEN
20299                   PXRES  = PRCL(I,1)
20300                   PYRES  = PRCL(I,2)
20301                   PZRES  = PRCL(I,3)
20302                   IBRES  = NPRO(I)+NN(I)+NH(I)
20303                   ICRES  = NPRO(I)+NHPOS(I)
20304                   ANOW   = DBLE(IBRES)
20305                   ZNOW   = DBLE(ICRES)
20306                   PTRES  = SQRT(PXRES**2+PYRES**2+PZRES**2)
20307 *   ground state mass of the residual nucleus (should be equal to AM0T)
20308
20309                   AMNRES = AMRCL0(I)
20310                   AMMRES = AMNAMA ( AMNRES, IBRES, ICRES )
20311
20312 *  common FKFINU
20313                   TV = ZERO
20314 *   kinetic energy of residual nucleus
20315                   TVRECL = PRCL(I,4)-AMRCL(I)
20316 *   excitation energy of residual nucleus
20317                   TVCMS  = EEXC(I)
20318                   PTOLD  = PTRES
20319                   PTRES  = SQRT(ABS(TVRECL*(TVRECL+
20320      &                          2.0D0*(AMMRES+TVCMS))))
20321                   IF (PTOLD.LT.ANGLGB) THEN
20322                      CALL DT_RACO(PXRES,PYRES,PZRES)
20323                      PTOLD = ONE
20324                   ENDIF
20325                   PXRES = PXRES*PTRES/PTOLD
20326                   PYRES = PYRES*PTRES/PTOLD
20327                   PZRES = PZRES*PTRES/PTOLD
20328 * zero counter of secondaries from evaporation
20329                   NP = 0
20330 * evaporation
20331                   WE = ONE
20332
20333                   NPHEAV = 0
20334                   LRNFSS = .FALSE.
20335                   LFRAGM = .FALSE.
20336                   CALL EVEVAP(WE)
20337
20338 * put evaporated particles and residual nuclei to DTEVT1
20339                   MO = NHKK
20340                   CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
20341                ENDIF
20342                EEXCFI(I) = EXCITF
20343                EXCEVA(I) = EXCEVA(I)+EXCITF
20344             ENDIF
20345    13    CONTINUE
20346       ENDIF
20347
20348       RETURN
20349
20350 C9998 IREXCI(1) = IREXCI(1)+1
20351  9998 IREJ   = IREJ+1
20352  9999 CONTINUE
20353       LRCLPR = .TRUE.
20354       LRCLTA = .TRUE.
20355       IREJ   = IREJ+1
20356       RETURN
20357       END
20358
20359 *$ CREATE DT_EVA2HE.FOR
20360 *COPY DT_EVA2HE
20361 *                                                                      *
20362 *====eva2he============================================================*
20363 *                                                                      *
20364       SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
20365
20366 ************************************************************************
20367 * Interface between common's of evaporation module (FKFINU,FKFHVY)     *
20368 * and DTEVT1.                                                          *
20369 *    MO    DTEVT1-index of "mother" (residual) nucleus before evap.    *
20370 *    EEXCF exitation energy of residual nucleus after evaporation      *
20371 *    IRCL  = 1 projectile residual nucleus                             *
20372 *          = 2 target     residual nucleus                             *
20373 * This version dated 19.04.95 is written by S. Roesler.                *
20374 *                                                                      *
20375 * Last change 27.12.2006 by S. Roesler.                                *
20376 ************************************************************************
20377
20378       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20379       SAVE
20380
20381       PARAMETER ( LINP = 10 ,
20382      &            LOUT = 6 ,
20383      &            LDAT = 9 )
20384
20385       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
20386
20387 * event history
20388
20389       PARAMETER (NMXHKK=200000)
20390
20391       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
20392      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
20393      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
20394 * Note: DTEVT2 - special use for heavy fragments !
20395 *       (IDRES(I) = mass number, IDXRES(I) = charge)
20396
20397 * extended event history
20398       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
20399      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
20400      &                IHIST(2,NMXHKK)
20401
20402 * particle properties (BAMJET index convention)
20403       CHARACTER*8  ANAME
20404       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20405      &                IICH(210),IIBAR(210),K1(210),K2(210)
20406
20407 * flags for input different options
20408       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
20409       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
20410      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
20411
20412 * statistics: residual nuclei
20413       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
20414      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
20415      &                NINCST(2,4),NINCEV(2),
20416      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
20417      &                NRESPB(2),NRESCH(2),NRESEV(4),
20418      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
20419      &                NEVAFI(2,2)
20420
20421 * treatment of residual nuclei: properties of residual nuclei
20422       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
20423      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
20424      &                NTOTFI(2),NPROFI(2)
20425
20426 *      INCLUDE '(DIMPAR)'
20427 *     Taken from FLUKA
20428       PARAMETER ( MXXRGN =20000 )
20429       PARAMETER ( MXXMDF =  710 )
20430       PARAMETER ( MXXMDE =  702 )
20431       PARAMETER ( MFSTCK =40000 )
20432       PARAMETER ( MESTCK =  100 )
20433       PARAMETER ( MOSTCK = 2000 )
20434       PARAMETER ( MXPRSN =  100 )
20435       PARAMETER ( MXPDPM =  800 )
20436       PARAMETER ( MXPSCS =30000 )
20437       PARAMETER ( MXGLWN =  300 )
20438       PARAMETER ( MXOUTU =   50 )
20439       PARAMETER ( NALLWP =   64 )
20440       PARAMETER ( NELEMX =   80 )
20441       PARAMETER ( MPDPDX =   18 )
20442       PARAMETER ( MXHTTR =  260 )
20443       PARAMETER ( MXSEAX =   20 )
20444       PARAMETER ( MXHTNC = MXSEAX + 1 )
20445       PARAMETER ( ICOMAX = 2400 )
20446       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
20447       PARAMETER ( NSTBIS =  304 )
20448       PARAMETER ( NQSTIS =   46 )
20449       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
20450       PARAMETER ( MXPABL =  120 )
20451       PARAMETER ( IDMAXP =  450 )
20452       PARAMETER ( IDMXDC = 2000 )
20453       PARAMETER ( MXMCIN =  410 )
20454       PARAMETER ( IHYPMX =    4 )
20455       PARAMETER ( MKBMX1 =   11 )
20456       PARAMETER ( MKBMX2 =   11 )
20457       PARAMETER ( MXIRRD = 2500 )
20458       PARAMETER ( MXTRDC = 1500 )
20459       PARAMETER ( NKTL   =   17 )
20460       PARAMETER ( NBLNMX = 40000000 )
20461
20462 *      INCLUDE '(GENSTK)'
20463 *     Taken from FLUKA
20464       PARAMETER ( MXP = MXPSCS )
20465 *
20466       COMMON / GENSTK /                CXR    (MXPSCS), CYR    (MXPSCS),
20467      &                CZR    (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
20468      &                CZRPOL (MXPSCS), TKI    (MXPSCS), PLR    (MXPSCS),
20469      &                WEI    (MXPSCS), AGESEC (MXPSCS), TV    , TVCMS  ,
20470      &                TVRECL,  TVHEAV, TVBIND,
20471      &                KPART  (MXPSCS), INFEXT (MXPSCS), NP0   , NP
20472
20473 *      INCLUDE '(RESNUC)'
20474       LOGICAL LRNFSS, LFRAGM
20475       COMMON /RESNUC/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
20476      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
20477      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
20478      &                  PYRES,  PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
20479      &                 ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
20480      &                  KTARP,  KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
20481      &                 IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,  ICRES,
20482      &                  IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
20483      &                 IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
20484      &                 IEV4HE, IDEEXG,  IBTAR, ICHTAR, IBLEFT, ICLEFT,
20485      &                 ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
20486      &                 LRNFSS, LFRAGM
20487 *     Taken from FLUKA
20488
20489 *      INCLUDE '(FHEAVY)'
20490 *     Taken from FLUKA
20491       PARAMETER ( MXHEAV = 100 )
20492       PARAMETER ( KXHEAV =  30 )
20493       CHARACTER*8 ANHEAV
20494       COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20495      &                  CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20496      &                  PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20497      &                  AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
20498      &                  AMHEAV (KXHEAV), AMNHEA (KXHEAV),
20499      &                  KHEAVY (MXHEAV), INFHEA (MXHEAV),
20500      &                  ICHEAV (KXHEAV), IBHEAV (KXHEAV),
20501      &                  IMHEAV (KXHEAV), IHHEAV (KXHEAV),
20502      &                  KHHEAV (IHYPMX,KXHEAV), NPHEAV
20503       COMMON / FHEAVC / ANHEAV (KXHEAV)
20504
20505       DIMENSION IPTOKP(39)
20506       DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
20507      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
20508      & 100, 101, 97, 102, 98, 103, 109, 115 /
20509
20510       IREJ = 0
20511
20512 * skip if evaporation package is not included
20513       IF (.NOT.LEVAPO) RETURN
20514
20515 * update counter
20516       IF (NRESEV(3).NE.NEVHKK) THEN
20517          NRESEV(3) = NEVHKK
20518          NRESEV(4) = NRESEV(4)+1
20519       ENDIF
20520
20521       IF (LEMCCK)
20522      &   CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
20523      &                                                   IDUM,IDUM)
20524 * mass number/charge of residual nucleus before evaporation
20525       IBTOT = IDRES(MO)
20526       IZTOT = IDXRES(MO)
20527
20528 * protons/neutrons/gammas
20529       DO 1 I=1,NP
20530          PX    = CXR(I)*PLR(I)
20531          PY    = CYR(I)*PLR(I)
20532          PZ    = CZR(I)*PLR(I)
20533          ID    = IPTOKP(KPART(I))
20534          IDPDG = IDT_IPDGHA(ID)
20535          AM    = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
20536      &           (2.0D0*MAX(TKI(I),TINY10))
20537          IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
20538             WRITE(LOUT,1000) ID,AM,AAM(ID)
20539  1000       FORMAT(1X,'EVA2HE:  inconsistent mass of evap. ',
20540      &             'particle',I3,2E10.3)
20541          ENDIF
20542          PE = TKI(I)+AM
20543          CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
20544          NOBAM(NHKK) = IRCL
20545          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
20546          IBTOT = IBTOT-IIBAR(ID)
20547          IZTOT = IZTOT-IICH(ID)
20548     1 CONTINUE
20549
20550 * heavy fragments
20551       DO 2 I=1,NPHEAV
20552          PX     = CXHEAV(I)*PHEAVY(I)
20553          PY     = CYHEAV(I)*PHEAVY(I)
20554          PZ     = CZHEAV(I)*PHEAVY(I)
20555          IDHEAV = 80000
20556          AM     = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
20557      &            (2.0D0*MAX(TKHEAV(I),TINY10))
20558          PE     = TKHEAV(I)+AM
20559          CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
20560      &                  IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
20561          NOBAM(NHKK) = IRCL
20562          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
20563          IBTOT = IBTOT-IBHEAV(KHEAVY(I))
20564          IZTOT = IZTOT-ICHEAV(KHEAVY(I))
20565     2 CONTINUE
20566
20567       IF (IBRES.GT.0) THEN
20568 * residual nucleus after evaporation
20569          IDNUC = 80000
20570          CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
20571      &                                        IBRES,ICRES,0)
20572          NOBAM(NHKK) = IRCL
20573       ENDIF
20574       EEXCF = TVCMS
20575       NTOTFI(IRCL) = IBRES
20576       NPROFI(IRCL) = ICRES
20577       IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
20578       IBTOT = IBTOT-IBRES
20579       IZTOT = IZTOT-ICRES
20580
20581 * count events with fission
20582       NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
20583       IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
20584
20585 * energy-momentum conservation check
20586       IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
20587 C     IF (IREJ.GT.0) THEN
20588 C        CALL DT_EVTOUT(4)
20589 C        WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
20590 C     ENDIF
20591 * baryon-number/charge conservation check
20592       IF (IBTOT+IZTOT.NE.0) THEN
20593          WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
20594  1001    FORMAT(1X,'EVA2HE:   baryon-number/charge conservation ',
20595      &          'failure at event ',I8,' :  IBTOT,IZTOT = ',2I3)
20596       ENDIF
20597
20598       RETURN
20599       END
20600
20601 *$ CREATE DT_EBIND.FOR
20602 *COPY DT_EBIND
20603 *
20604 *===ebind==============================================================*
20605 *
20606       DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
20607
20608 ************************************************************************
20609 * Binding energy for nuclei.                                           *
20610 * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972)                  *
20611 *                 IA        mass number                                *
20612 *                 IZ        atomic number                              *
20613 * This version dated 5.5.95   is updated by S. Roesler.                *
20614 ************************************************************************
20615
20616       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20617       SAVE
20618
20619       PARAMETER ( LINP = 10 ,
20620      &            LOUT = 6 ,
20621      &            LDAT = 9 )
20622
20623       PARAMETER (ZERO=0.0D0)
20624
20625       DATA       A1,       A2,        A3,        A4,      A5
20626      &     / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
20627
20628       IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
20629          WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0.  ',IA,IZ
20630          DT_EBIND = ZERO
20631          RETURN
20632       ENDIF
20633       AA = IA
20634       DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
20635      &        -A4*(IA-2*IZ)**2/AA
20636       IF (MOD(IA,2).EQ.1) THEN
20637          IA5 = 0
20638       ELSEIF (MOD(IZ,2).EQ.1) THEN
20639          IA5 = 1
20640       ELSE
20641          IA5 = -1
20642       ENDIF
20643       DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
20644
20645       RETURN
20646       END
20647
20648 ************************************************************************
20649 *                                                                      *
20650 *  DPMJET 3.0:   cross section routines                                *
20651 *                                                                      *
20652 ************************************************************************
20653 *
20654 *
20655 *     SUBROUTINE DT_SHNDIF
20656 *         diffractive cross sections (all energies)
20657 *     SUBROUTINE DT_PHOXS
20658 *         total and inel. cross sections from PHOJET interpol. tables
20659 *     SUBROUTINE DT_XSHN
20660 *         total and el. cross sections for all energies
20661 *     SUBROUTINE DT_SIHNAB
20662 *         pion 2-nucleon absorption cross sections
20663 *     SUBROUTINE DT_SIGEMU
20664 *         cross section for target "compounds"
20665 *     SUBROUTINE DT_SIGGA
20666 *         photon nucleus cross sections
20667 *     SUBROUTINE DT_SIGGAT
20668 *         photon nucleus cross sections from tables
20669 *     SUBROUTINE DT_SANO
20670 *         anomalous hard photon-nucleon cross sections from tables
20671 *     SUBROUTINE DT_SIGGP
20672 *         photon nucleon cross sections
20673 *     SUBROUTINE DT_SIGVEL
20674 *         quasi-elastic vector meson prod. cross sections
20675 *     DOUBLE PRECISION FUNCTION DT_SIGVP
20676 *         sigma_VN(tilde)
20677 *     DOUBLE PRECISION FUNCTION DT_RRM2
20678 *     DOUBLE PRECISION FUNCTION DT_RM2
20679 *     DOUBLE PRECISION FUNCTION DT_SAM2
20680 *     SUBROUTINE DT_CKMT
20681 *     SUBROUTINE DT_CKMTX
20682 *     SUBROUTINE DT_PDF0
20683 *     SUBROUTINE DT_CKMTQ0
20684 *     SUBROUTINE DT_CKMTDE
20685 *     SUBROUTINE DT_CKMTPR
20686 *     FUNCTION DT_CKMTFF
20687 *
20688 *     SUBROUTINE DT_FLUINI
20689 *         total nucleon cross section fluctuation treatment
20690 *
20691 *     SUBROUTINE DT_SIGTBL
20692 *         pre-tabulation of low-energy elastic x-sec. using SIHNEL
20693 *     SUBROUTINE DT_XSTABL
20694 *         service routines
20695 *
20696 *
20697 *$ CREATE DT_SHNDIF.FOR
20698 *COPY DT_SHNDIF
20699 *
20700 *===shndif===============================================================*
20701 *
20702       SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
20703
20704 **********************************************************************
20705 *   Single diffractive hadron-nucleon cross sections                 *
20706 *                                              S.Roesler 14/1/93     *
20707 *                                                                    *
20708 *   The cross sections are calculated from extrapolated single       *
20709 *   diffractive antiproton-proton cross sections (DTUJET92) using    *
20710 *   scaling relations between total and single diffractive cross     *
20711 *   sections.                                                        *
20712 **********************************************************************
20713
20714       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20715       SAVE
20716       PARAMETER (ZERO=0.0D0)
20717
20718 * particle properties (BAMJET index convention)
20719       CHARACTER*8  ANAME
20720       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20721      &                IICH(210),IIBAR(210),K1(210),K2(210)
20722 *
20723       CSD1   =   4.201483727D0
20724       CSD4   = -0.4763103556D-02
20725       CSD5   =  0.4324148297D0
20726 *
20727       CHMSD1 =  0.8519297242D0
20728       CHMSD4 = -0.1443076599D-01
20729       CHMSD5 =  0.4014954567D0
20730 *
20731       EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
20732       PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
20733 *
20734       SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
20735       SHMSD  = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
20736       FRAC   = SHMSD/SDIAPP
20737 *
20738       GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
20739      &     999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
20740      &      10, 10, 20, 20, 20) KPROJ
20741 *
20742    10 CONTINUE
20743 *---------------------------- p - p , n - p , sigma0+- - p ,
20744 *                             Lambda - p
20745       CSD1   =  6.004476070D0
20746       CSD4   = -0.1257784606D-03
20747       CSD5   =  0.2447335720D0
20748       SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
20749       SIGDIH = FRAC*SIGDIF
20750       RETURN
20751 *
20752    20 CONTINUE
20753 *
20754       KPSCAL = 2
20755       KTSCAL = 1
20756 C     F      = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
20757       DUMZER = ZERO
20758       CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
20759       F      = SDIAPP/SIGTO
20760       KT     = 1
20761 C     SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
20762       CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
20763       SIGDIF = SIGTO*F
20764       SIGDIH = FRAC*SIGDIF
20765       RETURN
20766 *
20767   999 CONTINUE
20768 *-------------------------- leptons..
20769       SIGDIF = 1.D-10
20770       SIGDIH = 1.D-10
20771       RETURN
20772       END
20773
20774 *$ CREATE DT_PHOXS.FOR
20775 *COPY DT_PHOXS
20776 *
20777 *===phoxs================================================================*
20778 *
20779       SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
20780
20781 ************************************************************************
20782 * Total/inelastic proton-nucleon cross sections taken from PHOJET-     *
20783 * interpolation tables.                                                *
20784 * This version dated 05.11.97 is written by S. Roesler                 *
20785 ************************************************************************
20786
20787       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20788       SAVE
20789
20790       PARAMETER ( LINP = 10 ,
20791      &            LOUT = 6 ,
20792      &            LDAT = 9 )
20793
20794       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
20795       PARAMETER (TWOPI  = 6.283185307179586454D+00,
20796      &           PI     = TWOPI/TWO,
20797      &           GEV2MB = 0.38938D0)
20798
20799       LOGICAL LFIRST
20800       DATA LFIRST /.TRUE./
20801
20802 * nucleon-nucleon event-generator
20803       CHARACTER*8 CMODEL
20804       LOGICAL LPHOIN
20805       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20806
20807 * particle properties (BAMJET index convention)
20808       CHARACTER*8  ANAME
20809       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20810      &                IICH(210),IIBAR(210),K1(210),K2(210)
20811
20812 **PHOJET105a
20813 C     PARAMETER (IEETAB=10)
20814 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20815 **PHOJET110
20816
20817 C  energy-interpolation table
20818       INTEGER IEETA2
20819       PARAMETER ( IEETA2 = 20 )
20820       INTEGER ISIMAX
20821       DOUBLE PRECISION SIGTAB,SIGECM
20822       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20823 **
20824
20825       IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
20826          WRITE(LOUT,*) MCGENE
20827  1000    FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
20828          STOP
20829       ENDIF
20830
20831       IF (ECM.LE.ZERO) THEN
20832          EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
20833          ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
20834       ENDIF
20835
20836       IF (MODE.EQ.1) THEN
20837 * DL
20838          DELDL = 0.0808D0
20839          EPSDL = -0.4525D0
20840          S     = ECM*ECM
20841          STOT  = 21.7D0*S**DELDL+56.08D0*S**EPSDL
20842          ALPHAP= 0.25D0
20843          BEL   = 8.5D0+2.D0*ALPHAP*LOG(S)
20844          SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
20845          SINE  = STOT-SIGEL
20846          SDIF1 = ZERO
20847       ELSE
20848 * Phojet
20849          IP = 1
20850          IF(ECM.LE.SIGECM(IP,1)) THEN
20851            I1 = 1
20852            I2 = 1
20853          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
20854            DO 1 I=2,ISIMAX
20855               IF (ECM.LE.SIGECM(IP,I)) GOTO 2
20856     1      CONTINUE
20857     2      CONTINUE
20858            I1 = I-1
20859            I2 = I
20860          ELSE
20861            IF (LFIRST) THEN
20862               WRITE(LOUT,'(/1X,A,2E12.3)')
20863      &          'PHOXS: warning! energy above initialization limit (',
20864      &          ECM,SIGECM(IP,ISIMAX)
20865              LFIRST = .FALSE.
20866            ENDIF
20867            I1 = ISIMAX
20868            I2 = ISIMAX
20869          ENDIF
20870          FAC2 = ZERO
20871          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
20872      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
20873          FAC1  = ONE-FAC2
20874          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
20875          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
20876          SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
20877      &           FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
20878          BEL   = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
20879       ENDIF
20880
20881       RETURN
20882       END
20883
20884 *$ CREATE DT_XSHN.FOR
20885 *COPY DT_XSHN
20886 *
20887 *===xshn===============================================================*
20888 *
20889       SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
20890
20891 ************************************************************************
20892 * Total and elastic hadron-nucleon cross section.                      *
20893 * Below 500GeV cross sections are based on the '98 data compilation    *
20894 * of the PDG. At higher energies PHOJET results are used (patched to   *
20895 * the low energy data at 500GeV).                                      *
20896 *     IP      projectile index (BAMJET numbering scheme)               *
20897 *             (should be in the range 1..25)                           *
20898 *     IT      target index (BAMJET numbering scheme)                   *
20899 *             (1 = proton, 8 = neutron)                                *
20900 *     PL      laboratory momentum                                      *
20901 *     ECM     cm. energy (ignored if PL>0)                             *
20902 *     STOT    total cross section                                      *
20903 *     SELA    elastic cross section                                    *
20904 * Last change: 24.4.99 by S. Roesler                                   *
20905 ************************************************************************
20906
20907       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20908       SAVE
20909
20910       PARAMETER ( LINP = 10 ,
20911      &            LOUT = 6 ,
20912      &            LDAT = 9 )
20913
20914       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
20915
20916       PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
20917      &           PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
20918       PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
20919
20920       LOGICAL LFIRST
20921
20922 * particle properties (BAMJET index convention)
20923       CHARACTER*8  ANAME
20924       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20925      &                IICH(210),IIBAR(210),K1(210),K2(210)
20926
20927 * nucleon-nucleon event-generator
20928       CHARACTER*8 CMODEL
20929       LOGICAL LPHOIN
20930       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20931 **PHOJET105a
20932 C     PARAMETER (IEETAB=10)
20933 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20934 **PHOJET110
20935
20936 C  energy-interpolation table
20937       INTEGER IEETA2
20938       PARAMETER ( IEETA2 = 20 )
20939       INTEGER ISIMAX
20940       DOUBLE PRECISION SIGTAB,SIGECM
20941       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20942
20943       DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
20944       DIMENSION IDXDAT(25,2)
20945 *
20946       DATA APL /
20947      &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
20948      &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
20949      &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
20950      &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
20951      & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
20952      & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
20953      & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
20954 *
20955 * total cross sections:
20956 * p p
20957       DATA (ASIGTO(1,K),K=1,NPOINT) /
20958      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
20959      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
20960      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
20961      & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
20962      & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
20963      & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
20964      & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
20965 * pbar p
20966       DATA (ASIGTO(2,K),K=1,NPOINT) /
20967      & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
20968      & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
20969      & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
20970      & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
20971      & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
20972      & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
20973      & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
20974 * n p
20975       DATA (ASIGTO(3,K),K=1,NPOINT) /
20976      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
20977      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
20978      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
20979      & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
20980      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
20981      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
20982      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
20983 * pi+ p
20984       DATA (ASIGTO(4,K),K=1,NPOINT) /
20985      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
20986      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
20987      & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
20988      & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
20989      & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
20990      & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
20991      & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
20992 * pi- p
20993       DATA (ASIGTO(5,K),K=1,NPOINT) /
20994      & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
20995      & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
20996      & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
20997      & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
20998      & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
20999      & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
21000      & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
21001 * K+ p
21002       DATA (ASIGTO(6,K),K=1,NPOINT) /
21003      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21004      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21005      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
21006      & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
21007      & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
21008      & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
21009      & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
21010 * K- p
21011       DATA (ASIGTO(7,K),K=1,NPOINT) /
21012      & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
21013      & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
21014      & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
21015      & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
21016      & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
21017      & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
21018      & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21019 * K+ n
21020       DATA (ASIGTO(8,K),K=1,NPOINT) /
21021      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21022      & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21023      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21024      & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21025      & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21026      & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21027      & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21028 * K- n
21029       DATA (ASIGTO(9,K),K=1,NPOINT) /
21030      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21031      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21032      & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21033      & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21034      & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21035      & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21036      & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21037 * Lambda p
21038       DATA (ASIGTO(10,K),K=1,NPOINT) /
21039      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21040      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21041      & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21042      & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21043      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21044      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21045      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21046 *
21047 * elastic cross sections:
21048 * p p
21049       DATA (ASIGEL(1,K),K=1,NPOINT) /
21050      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21051      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21052      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21053      & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21054      & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21055      & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21056      & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21057 * pbar p
21058       DATA (ASIGEL(2,K),K=1,NPOINT) /
21059      & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21060      & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21061      & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21062      & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21063      & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21064      & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21065      & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21066 * n p
21067       DATA (ASIGEL(3,K),K=1,NPOINT) /
21068      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21069      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21070      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21071      & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21072      & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21073      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21074      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21075 * pi+ p
21076       DATA (ASIGEL(4,K),K=1,NPOINT) /
21077      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21078      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21079      & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21080      & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21081      & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21082      & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21083      & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21084 * pi- p
21085       DATA (ASIGEL(5,K),K=1,NPOINT) /
21086      & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21087      & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21088      & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21089      & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21090      & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21091      & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21092      & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21093 * K+ p
21094       DATA (ASIGEL(6,K),K=1,NPOINT) /
21095      & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21096      & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21097      & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21098      & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21099      & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21100      & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21101      & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21102 * K- p
21103       DATA (ASIGEL(7,K),K=1,NPOINT) /
21104      & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21105      & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21106      & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21107      & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21108      & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21109      & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21110      & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21111 * K+ n
21112       DATA (ASIGEL(8,K),K=1,NPOINT) /
21113      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21114      & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21115      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21116      & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21117      & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21118      & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21119      & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21120 * K- n
21121       DATA (ASIGEL(9,K),K=1,NPOINT) /
21122      & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21123      & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21124      & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21125      & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21126      & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21127      & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21128      & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21129 * Lambda p
21130       DATA (ASIGEL(10,K),K=1,NPOINT) /
21131      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21132      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21133      & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21134      & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21135      & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21136      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21137      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21138
21139       DATA (IDXDAT(K,1),K=1,25) /
21140      &  1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21141      &  1, 3,45, 8, 9/
21142       DATA (IDXDAT(K,2),K=1,25) /
21143      &  3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21144      &  3, 1,45, 6, 7/
21145
21146       DATA LFIRST /.TRUE./
21147
21148       IF (LFIRST) THEN
21149          APLABL = LOG10(PLABLO)
21150          APLABH = LOG10(PLABHI)
21151          APTHRE = LOG10(PTHRE)
21152          ADP1   = (APTHRE-APLABL)/DBLE(NPOIN1)
21153          ADP2   = (APLABH-APTHRE)/DBLE(NPOIN2)
21154          DUM0   = ZERO
21155          PHOPLA = PLABHI
21156          PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21157          ECMS   = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21158          IF (MCGENE.EQ.2) THEN
21159             IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21160                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21161             ELSE
21162                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21163             ENDIF
21164          ELSE
21165             CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21166          ENDIF
21167          PHOSEL = PHOSTO-PHOSIN
21168          APHOST = LOG10(PHOSTO)
21169          APHOSE = LOG10(PHOSEL)
21170          LFIRST = .FALSE.
21171       ENDIF
21172       STOT = ZERO
21173       SELA = ZERO
21174       PLAB = PL
21175       ECMS = ECM
21176       IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21177          WRITE(LOUT,1000) IP,IT
21178  1000    FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21179      &          'proj/target',2I4)
21180          STOP
21181       ENDIF
21182
21183       IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21184          ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21185          PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21186       ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21187          WRITE(LOUT,1001) PLAB,ECMS
21188  1001    FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21189          STOP
21190       ENDIF
21191
21192 * index of spectrum
21193       IDXP = IP
21194       IF (IP.GT.25) THEN
21195          IF (AAM(IP).GT.ZERO) THEN
21196             IF (ABS(IIBAR(IP)).GT.0) THEN
21197                IDXP = 1
21198             ELSE
21199                IDXP = 13
21200             ENDIF
21201          ELSE
21202             IDXP = 7
21203          ENDIF
21204       ENDIF
21205       IDXT = 1
21206       IF (IT.EQ.8) IDXT = 2
21207       IDXS = IDXDAT(IDXP,IDXT)
21208       IF (IDXS.EQ.0) RETURN
21209
21210 * compute momentum bin indices
21211       IF (PLAB.LT.PLABLO) THEN
21212          IDX0 = 1
21213          IDX1 = 1
21214       ELSEIF (PLAB.GE.PLABHI) THEN
21215          IDX0 = NPOINT
21216          IDX1 = NPOINT
21217       ELSE
21218          APLAB = LOG10(PLAB)
21219          IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21220             IDX0 = INT((APLAB-APLABL)/ADP1)+1
21221          ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21222             IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21223          ENDIF
21224          IDX1 = IDX0+1
21225       ENDIF
21226
21227 * interpolate cross section
21228       IF (IDXS.GT.10) THEN
21229          IDXS1 = IDXS/10
21230          IDXS2 = IDXS-10*IDXS1
21231          IF (IDX0.EQ.IDX1) THEN
21232             IF (IDX0.EQ.1) THEN
21233                ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21234                ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21235             ELSE
21236                DUM0   = ZERO
21237                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21238                PHOSEL = PHOSTO-PHOSIN
21239                ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21240                ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21241                ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21242                ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21243                ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
21244                ASELA  = 0.5D0*(ASELA1+ASELA2)
21245             ENDIF
21246          ELSE
21247             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21248             ASTOT1 = ASIGTO(IDXS1,IDX0)+
21249      &               FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21250             ASTOT2 = ASIGTO(IDXS2,IDX0)+
21251      &               FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21252             ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
21253             ASELA1 = ASIGEL(IDXS1,IDX0)+
21254      &               FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21255             ASELA2 = ASIGEL(IDXS2,IDX0)+
21256      &               FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21257             ASELA  = 0.5D0*(ASELA1+ASELA2)
21258          ENDIF
21259       ELSE
21260          IF (IDX0.EQ.IDX1) THEN
21261             IF (IDX0.EQ.1) THEN
21262                ASTOT = ASIGTO(IDXS,IDX0)
21263                ASELA = ASIGEL(IDXS,IDX0)
21264             ELSE
21265                DUM0   = ZERO
21266                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21267                PHOSEL = PHOSTO-PHOSIN
21268                ASTOT  = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21269                ASELA  = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21270             ENDIF
21271          ELSE
21272             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21273             ASTOT = ASIGTO(IDXS,IDX0)+
21274      &              FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21275             ASELA = ASIGEL(IDXS,IDX0)+
21276      &              FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21277          ENDIF
21278       ENDIF
21279       STOT = 10.0D0**ASTOT
21280       SELA = 10.0D0**ASELA
21281
21282       RETURN
21283       END
21284
21285 *$ CREATE DT_SIHNAB.FOR
21286 *COPY DT_SIHNAB
21287 *
21288 *===sihnab===============================================================*
21289 *
21290       SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21291
21292 **********************************************************************
21293 * Pion 2-nucleon absorption cross sections.                          *
21294 * (sigma_tot for pi+ d --> p p, pi- d --> n n                        *
21295 *  taken from Ritchie PRC 28 (1983) 926 )                            *
21296 * This version dated 18.05.96 is written by S. Roesler               *
21297 **********************************************************************
21298
21299       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21300       SAVE
21301       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21302       PARAMETER (AMPR = 938.0D0,
21303      &           AMPI = 140.0D0,
21304      &           AMDE = TWO*AMPR,
21305      &           A    = -1.2D0,
21306      &           B    = 3.5D0,
21307      &           C    = 7.4D0,
21308      &           D    = 5600.0D0,
21309      &           ER   = 2136.0D0)
21310
21311       SIGABS = ZERO
21312       IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21313      &                   .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21314       PTOT = PLAB*1.0D3
21315       EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21316       IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21317       ECM  = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21318       SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21319 * approximate 3N-abs., I=1-abs. etc.
21320       SIGABS = SIGABS/0.40D0
21321 * pi0-absorption (rough approximation!!)
21322       IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21323
21324       RETURN
21325       END
21326
21327 *$ CREATE DT_SIGEMU.FOR
21328 *COPY DT_SIGEMU
21329 *
21330 *===sigemu=============================================================*
21331 *
21332       SUBROUTINE DT_SIGEMU
21333
21334 ************************************************************************
21335 * Combined cross section for target compounds.                         *
21336 * This version dated 6.4.98   is written by S. Roesler                 *
21337 ************************************************************************
21338
21339       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21340       SAVE
21341
21342       PARAMETER ( LINP = 10 ,
21343      &            LOUT = 6 ,
21344      &            LDAT = 9 )
21345
21346       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21347      &           OHALF=0.5D0,ONE=1.0D0)
21348
21349       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21350
21351 * Glauber formalism: cross sections
21352       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21353      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21354      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21355      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21356      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21357      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21358      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21359      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21360      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21361      &                BSLOPE,NEBINI,NQBINI
21362
21363 * emulsion treatment
21364       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21365      &                NCOMPO,IEMUL
21366
21367 * nucleon-nucleon event-generator
21368       CHARACTER*8 CMODEL
21369       LOGICAL LPHOIN
21370       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21371
21372       IF (MCGENE.NE.4) THEN
21373          WRITE(LOUT,'(A)') ' DT_SIGEMU:    Combined cross sections'
21374          WRITE(LOUT,'(15X,A)') '-----------------------'
21375       ENDIF
21376       DO 1 IE=1,NEBINI
21377          DO 2 IQ=1,NQBINI
21378             SIGTOT = ZERO
21379             SIGELA = ZERO
21380             SIGQEP = ZERO
21381             SIGQET = ZERO
21382             SIGQE2 = ZERO
21383             SIGPRO = ZERO
21384             SIGDEL = ZERO
21385             SIGDQE = ZERO
21386             ERRTOT = ZERO
21387             ERRELA = ZERO
21388             ERRQEP = ZERO
21389             ERRQET = ZERO
21390             ERRQE2 = ZERO
21391             ERRPRO = ZERO
21392             ERRDEL = ZERO
21393             ERRDQE = ZERO
21394             IF (NCOMPO.GT.0) THEN
21395                DO 3 IC=1,NCOMPO
21396                   SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21397                   SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21398                   SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21399                   SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21400                   SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21401                   SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21402                   SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21403                   SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21404                   ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21405                   ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21406                   ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21407                   ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21408                   ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21409                   ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21410                   ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21411                   ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21412     3          CONTINUE
21413                ERRTOT = SQRT(ERRTOT)
21414                ERRELA = SQRT(ERRELA)
21415                ERRQEP = SQRT(ERRQEP)
21416                ERRQET = SQRT(ERRQET)
21417                ERRQE2 = SQRT(ERRQE2)
21418                ERRPRO = SQRT(ERRPRO)
21419                ERRDEL = SQRT(ERRDEL)
21420                ERRDQE = SQRT(ERRDQE)
21421             ELSE
21422                SIGTOT = XSTOT(IE,IQ,1)
21423                SIGELA = XSELA(IE,IQ,1)
21424                SIGQEP = XSQEP(IE,IQ,1)
21425                SIGQET = XSQET(IE,IQ,1)
21426                SIGQE2 = XSQE2(IE,IQ,1)
21427                SIGPRO = XSPRO(IE,IQ,1)
21428                SIGDEL = XSDEL(IE,IQ,1)
21429                SIGDQE = XSDQE(IE,IQ,1)
21430                ERRTOT = XETOT(IE,IQ,1)
21431                ERRELA = XEELA(IE,IQ,1)
21432                ERRQEP = XEQEP(IE,IQ,1)
21433                ERRQET = XEQET(IE,IQ,1)
21434                ERRQE2 = XEQE2(IE,IQ,1)
21435                ERRPRO = XEPRO(IE,IQ,1)
21436                ERRDEL = XEDEL(IE,IQ,1)
21437                ERRDQE = XEDQE(IE,IQ,1)
21438             ENDIF
21439             IF (MCGENE.NE.4) THEN
21440                WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21441  1000         FORMAT(/,1X,'E_cm =',F9.1,' GeV  Q^2 =',F6.1,' GeV^2 :',/)
21442                WRITE(LOUT,1001) SIGTOT,ERRTOT
21443  1001          FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21444                WRITE(LOUT,1002) SIGELA,ERRELA
21445  1002          FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21446                WRITE(LOUT,1003) SIGQEP,ERRQEP
21447  1003          FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21448      &                F11.5,' mb')
21449                WRITE(LOUT,1004) SIGQET,ERRQET
21450  1004          FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21451      &                F11.5,' mb')
21452                WRITE(LOUT,1005) SIGQE2,ERRQE2
21453  1005          FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21454      &                ' +-',F11.5,' mb')
21455                WRITE(LOUT,1006) SIGPRO,ERRPRO
21456  1006          FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21457                WRITE(LOUT,1007) SIGDEL,ERRDEL
21458  1007          FORMAT(1X,'diff-el   ',27X,F10.4,' +-',F11.5,' mb')
21459                WRITE(LOUT,1008) SIGDQE,ERRDQE
21460  1008          FORMAT(1X,'diff-qel  ',27X,F10.4,' +-',F11.5,' mb')
21461             ENDIF
21462
21463     2    CONTINUE
21464     1 CONTINUE
21465
21466       RETURN
21467       END
21468
21469 *$ CREATE DT_SIGGA.FOR
21470 *COPY DT_SIGGA
21471 *
21472 *===sigga==============================================================*
21473 *
21474       SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21475
21476 ************************************************************************
21477 * Total/inelastic photon-nucleus cross sections.                       *
21478 *     !!!! Overwrites SHMAKI-initialization. Do not use it during      *
21479 *          production runs !!!!                                        *
21480 * This version dated 27.03.96 is written by S. Roesler                 *
21481 ************************************************************************
21482
21483       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21484       SAVE
21485
21486       PARAMETER ( LINP = 10 ,
21487      &            LOUT = 6 ,
21488      &            LDAT = 9 )
21489
21490       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21491      &           OHALF=0.5D0,ONE=1.0D0)
21492       PARAMETER (AMPROT = 0.938D0)
21493
21494       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21495
21496 * Glauber formalism: cross sections
21497       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21498      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21499      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21500      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21501      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21502      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21503      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21504      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21505      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21506      &                BSLOPE,NEBINI,NQBINI
21507
21508       NT  = NTI
21509       X   = XI
21510       Q2  = Q2I
21511       ECM = ECMI
21512       XNU = XNUI
21513       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21514      &   ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21515       CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21516       STOT  = XSTOT(1,1,1)
21517       ETOT  = XETOT(1,1,1)
21518       SIN   = XSPRO(1,1,1)
21519       EIN   = XEPRO(1,1,1)
21520
21521       RETURN
21522       END
21523
21524 *$ CREATE DT_SIGGAT.FOR
21525 *COPY DT_SIGGAT
21526 *
21527 *===siggat=============================================================*
21528 *
21529       SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21530
21531 ************************************************************************
21532 * Total/inelastic photon-nucleus cross sections.                       *
21533 * Uses pre-tabulated cross section.                                    *
21534 * This version dated 29.07.96 is written by S. Roesler                 *
21535 ************************************************************************
21536
21537       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21538       SAVE
21539
21540       PARAMETER ( LINP = 10 ,
21541      &            LOUT = 6 ,
21542      &            LDAT = 9 )
21543
21544       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21545      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21546
21547       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21548
21549 * Glauber formalism: cross sections
21550       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21551      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21552      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21553      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21554      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21555      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21556      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21557      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21558      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21559      &                BSLOPE,NEBINI,NQBINI
21560
21561       NTARG = ABS(NT)
21562       I1   = 1
21563       I2   = 1
21564       RATE = ONE
21565       IF (NEBINI.GT.1) THEN
21566          IF (ECMI.GE.ECMNN(NEBINI)) THEN
21567             I1   = NEBINI
21568             I2   = NEBINI
21569             RATE = ONE
21570          ELSEIF (ECMI.GT.ECMNN(1)) THEN
21571             DO 1 I=2,NEBINI
21572                IF (ECMI.LT.ECMNN(I)) THEN
21573                   I1   = I-1
21574                   I2   = I
21575                   RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21576                   GOTO 2
21577                ENDIF
21578     1       CONTINUE
21579     2       CONTINUE
21580          ENDIF
21581       ENDIF
21582       J1   = 1
21583       J2   = 1
21584       RATQ = ONE
21585       IF (NQBINI.GT.1) THEN
21586          IF (Q2I.GE.Q2G(NQBINI)) THEN
21587             J1   = NQBINI
21588             J2   = NQBINI
21589             RATQ = ONE
21590          ELSEIF (Q2I.GT.Q2G(1)) THEN
21591             DO 3 I=2,NQBINI
21592                IF (Q2I.LT.Q2G(I)) THEN
21593                   J1   = I-1
21594                   J2   = I
21595                   RATQ = LOG10(    Q2I/MAX(Q2G(J1),TINY14))/
21596      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21597 C                 RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21598                   GOTO 4
21599                ENDIF
21600     3       CONTINUE
21601     4       CONTINUE
21602          ENDIF
21603       ENDIF
21604
21605       STOT = XSTOT(I1,J1,NTARG)+
21606      &   RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21607      &   RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21608      &   RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21609      &              XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21610
21611       RETURN
21612       END
21613
21614 *$ CREATE DT_SANO.FOR
21615 *COPY DT_SANO
21616 *
21617 *===sigano=============================================================*
21618 *
21619       DOUBLE PRECISION FUNCTION DT_SANO(ECM)
21620
21621 ************************************************************************
21622 * This version dated 31.07.96 is written by S. Roesler                 *
21623 ************************************************************************
21624
21625       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21626       SAVE
21627
21628       PARAMETER ( LINP = 10 ,
21629      &            LOUT = 6 ,
21630      &            LDAT = 9 )
21631
21632       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21633      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21634       PARAMETER (NE = 8)
21635
21636 * VDM parameter for photon-nucleus interactions
21637       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21638
21639 * properties of interacting particles
21640       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
21641
21642       DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
21643       DATA ECMANO /
21644      &             0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
21645      &             0.100D+04,0.200D+04,0.500D+04
21646      &            /
21647 * fixed cut (3 GeV/c)
21648       DATA FRAANO /
21649      &             0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
21650      &             0.062D+00,0.054D+00,0.042D+00
21651      &            /
21652       DATA SIGHRD /
21653      &           4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
21654      &           3.3086D-01,7.6255D-01,2.1319D+00
21655      &            /
21656 * running cut (based on obsolete Phojet-caluclations, bugs..)
21657 C     DATA FRAANO /
21658 C    &             0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
21659 C    &             0.167E+00,0.150E+00,0.131E+00
21660 C    &            /
21661 C     DATA SIGHRD /
21662 C    &           6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
21663 C    &           2.5736E-01,4.5593E-01,8.2550E-01
21664 C    &            /
21665
21666       DT_SANO = ZERO
21667       IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
21668       J1   = 0
21669       J2   = 0
21670       RATE = ONE
21671       IF (ECM.GE.ECMANO(NE)) THEN
21672          J1 = NE
21673          J2 = NE
21674       ELSEIF (ECM.GT.ECMANO(1)) THEN
21675          DO 1 IE=2,NE
21676             IF (ECM.LT.ECMANO(IE)) THEN
21677                J1   = IE-1
21678                J2   = IE
21679                RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
21680                GOTO 2
21681             ENDIF
21682     1    CONTINUE
21683     2    CONTINUE
21684       ENDIF
21685       IF ((J1.GT.0).AND.(J2.GT.0)) THEN
21686          AFRA1  = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
21687          AFRA2  = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
21688          DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
21689       ENDIF
21690
21691       RETURN
21692       END
21693
21694 *$ CREATE DT_SIGGP.FOR
21695 *COPY DT_SIGGP
21696 *
21697 *===siggp==============================================================*
21698 *
21699       SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
21700
21701 ************************************************************************
21702 * Total/inelastic photon-nucleon cross sections.                       *
21703 * This version dated 30.04.96 is written by S. Roesler                 *
21704 ************************************************************************
21705
21706       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21707       SAVE
21708
21709       PARAMETER ( LINP = 10 ,
21710      &            LOUT = 6 ,
21711      &            LDAT = 9 )
21712
21713       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21714       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
21715      &           PI     = TWOPI/TWO,
21716      &           GEV2MB = 0.38938D0,
21717      &           ALPHEM = ONE/137.0D0)
21718
21719 * particle properties (BAMJET index convention)
21720       CHARACTER*8  ANAME
21721       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21722      &                IICH(210),IIBAR(210),K1(210),K2(210)
21723
21724 * VDM parameter for photon-nucleus interactions
21725       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21726
21727 **PHOJET105a
21728 C     CHARACTER*8 MDLNA
21729 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
21730 C     PARAMETER (IEETAB=10)
21731 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21732 **PHOJET110
21733
21734 C  model switches and parameters
21735       CHARACTER*8 MDLNA
21736       INTEGER ISWMDL,IPAMDL
21737       DOUBLE PRECISION PARMDL
21738       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21739
21740 C  energy-interpolation table
21741       INTEGER IEETA2
21742       PARAMETER ( IEETA2 = 20 )
21743       INTEGER ISIMAX
21744       DOUBLE PRECISION SIGTAB,SIGECM
21745       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21746 **
21747
21748 C     PARAMETER (NPOINT=80)
21749       PARAMETER (NPOINT=16)
21750       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
21751
21752       STOT = ZERO
21753       SINE = ZERO
21754       SDIR = ZERO
21755
21756       W2 = ECMI**2
21757       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21758      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
21759       Q2 = Q2I
21760       X  = XI
21761 * photoprod.
21762       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21763          Q2 = 0.0001D0
21764          X  = Q2/(W2+Q2-AAM(1)**2)
21765 * DIS
21766       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
21767          X  = Q2/(W2+Q2-AAM(1)**2)
21768       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21769          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
21770       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
21771          W2 = Q2*(ONE-X)/X+AAM(1)**2
21772       ELSE
21773          WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
21774          STOP
21775       ENDIF
21776       ECM = SQRT(W2)
21777
21778       IF (MODEGA.EQ.1) THEN
21779          SCALE = SQRT(Q2)
21780          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
21781      &                                                       IDPDF)
21782 C        W = SQRT(W2)
21783
21784 C        ALLMF2 = PHO_ALLM97(Q2,W)
21785
21786 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
21787          STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
21788          SINE = ZERO
21789          SDIR = ZERO
21790       ELSEIF (MODEGA.EQ.2) THEN
21791          IF (INTRGE(1).EQ.1) THEN
21792             AMLO2 = (3.0D0*AAM(13))**2
21793          ELSEIF (INTRGE(1).EQ.2) THEN
21794             AMLO2 = AAM(33)**2
21795          ELSE
21796             AMLO2 = AAM(96)**2
21797          ENDIF
21798          IF (INTRGE(2).EQ.1) THEN
21799             AMHI2 = W2/TWO
21800          ELSEIF (INTRGE(2).EQ.2) THEN
21801             AMHI2 = W2/4.0D0
21802          ELSE
21803             AMHI2 = W2
21804          ENDIF
21805          AMHI20 = (ECM-AAM(1))**2
21806          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
21807          XAMLO  = LOG( AMLO2+Q2 )
21808          XAMHI  = LOG( AMHI2+Q2 )
21809 **PHOJET105a
21810 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
21811 **PHOJET112
21812
21813          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
21814
21815 **
21816          SUM  = ZERO
21817          DO 1 J=1,NPOINT
21818             AM2 = EXP(ABSZX(J))-Q2
21819             IF (AM2.LT.16.0D0) THEN
21820                R = TWO
21821             ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
21822                R = 10.0D0/3.0D0
21823             ELSE
21824                R = 11.0D0/3.0D0
21825             ENDIF
21826 C           FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
21827             FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
21828      &            * (ONE+EPSPOL*Q2/AM2)
21829             SUM = SUM+WEIGHT(J)*FAC
21830     1    CONTINUE
21831          SINE = SUM
21832          SDIR = DT_SIGVP(X,Q2)
21833          STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
21834          SDIR = SDIR/(0.588D0+RL2+Q2)
21835 C        STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
21836       ELSEIF (MODEGA.EQ.3) THEN
21837          CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
21838       ELSEIF (MODEGA.EQ.4) THEN
21839 *  load cross sections from PHOJET interpolation table
21840          IP = 1
21841          IF(ECM.LE.SIGECM(IP,1)) THEN
21842            I1 = 1
21843            I2 = 1
21844          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21845            DO 2 I=2,ISIMAX
21846               IF (ECM.LE.SIGECM(IP,I)) GOTO 3
21847     2      CONTINUE
21848     3      CONTINUE
21849            I1 = I-1
21850            I2 = I
21851          ELSE
21852            WRITE(LOUT,'(/1X,A,2E12.3)')
21853      &       'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
21854            I1 = ISIMAX
21855            I2 = ISIMAX
21856          ENDIF
21857          FAC2 = ZERO
21858          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21859      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21860          FAC1 = ONE-FAC2
21861 *  cross section dependence on photon virtuality
21862          FSUP1 = ZERO
21863          DO 4 I=1,3
21864             FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
21865      &                                /(1.D0+Q2/PARMDL(30+I))**2
21866     4    CONTINUE
21867          FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
21868          FAC1  = FAC1*FSUP1
21869          FAC2  = FAC2*FSUP1
21870          FSUP2 = 1.0D0
21871          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21872          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21873          SDIR  = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
21874 **re:
21875          STOT  = STOT-SDIR
21876 **
21877          SDIR  = SDIR/(FSUP1*FSUP2)
21878 **re:
21879          STOT  = STOT+SDIR
21880 **
21881       ENDIF
21882
21883       RETURN
21884       END
21885
21886 *$ CREATE DT_SIGVEL.FOR
21887 *COPY DT_SIGVEL
21888 *
21889 *===sigvel=============================================================*
21890 *
21891       SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
21892
21893 ************************************************************************
21894 * Cross section for elastic vector meson production                    *
21895 * This version dated 10.05.96 is written by S. Roesler                 *
21896 ************************************************************************
21897
21898       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21899       SAVE
21900
21901       PARAMETER ( LINP = 10 ,
21902      &            LOUT = 6 ,
21903      &            LDAT = 9 )
21904
21905       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21906       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
21907      &           PI     = TWOPI/TWO,
21908      &           GEV2MB = 0.38938D0,
21909      &           ALPHEM = ONE/137.0D0)
21910
21911 * particle properties (BAMJET index convention)
21912       CHARACTER*8  ANAME
21913       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21914      &                IICH(210),IIBAR(210),K1(210),K2(210)
21915
21916 * VDM parameter for photon-nucleus interactions
21917       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21918
21919       W2 = ECMI**2
21920       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21921      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
21922       Q2 = Q2I
21923       X  = XI
21924 * photoprod.
21925       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21926          Q2 = 0.0001D0
21927          X  = Q2/(W2+Q2-AAM(1)**2)
21928 * DIS
21929       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
21930          X  = Q2/(W2+Q2-AAM(1)**2)
21931       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21932          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
21933       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
21934          W2 = Q2*(ONE-X)/X+AAM(1)**2
21935       ELSE
21936          WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
21937          STOP
21938       ENDIF
21939       ECM = SQRT(W2)
21940
21941       AMV  = AAM(IDXV)
21942       AMV2 = AMV**2
21943
21944       BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
21945      &        +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
21946       ROSH   = 0.1D0
21947       STOVP  = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
21948       SELVP  = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
21949
21950       IF (IDXV.EQ.33) THEN
21951          COUPL = 0.00365D0
21952       ELSE
21953          STOP
21954       ENDIF
21955       SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
21956       SIG2 = SELVP
21957       SVEL  = COUPL * (AMV2/(AMV2+Q2))**2
21958      &              * (ONE+EPSPOL*Q2/AMV2) * SELVP
21959
21960       RETURN
21961       END
21962
21963 *$ CREATE DT_SIGVP.FOR
21964 *COPY DT_SIGVP
21965 *
21966 *===sigvp==============================================================*
21967 *
21968       DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
21969
21970 ************************************************************************
21971 * sigma_Vp                                                             *
21972 ************************************************************************
21973
21974       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21975       SAVE
21976
21977       PARAMETER ( LINP = 10 ,
21978      &            LOUT = 6 ,
21979      &            LDAT = 9 )
21980
21981       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21982       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21983      &           PI    = TWOPI/TWO,
21984      &           GEV2MB = 0.38938D0,
21985      &           AMPROT = 0.938D0,
21986      &           ALPHEM = ONE/137.0D0)
21987
21988 * VDM parameter for photon-nucleus interactions
21989       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21990
21991       X  = XI
21992       Q2 = Q2I
21993       IF (XI.LE.ZERO)  X  = 0.0001D0
21994       IF (Q2I.LE.ZERO) Q2 = 0.0001D0
21995
21996       ECM    = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
21997
21998       SCALE = SQRT(Q2)
21999       IF (MODEGA.EQ.1) THEN
22000          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22001      &                                                       IDPDF)
22002 C        W = ECM
22003
22004 C        ALLMF2 = PHO_ALLM97(Q2,W)
22005
22006 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22007 C        STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22008 C        DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
22009          DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
22010       ELSEIF (MODEGA.EQ.4) THEN
22011          CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
22012 C        F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
22013          DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
22014       ELSE
22015          STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
22016       ENDIF
22017
22018       RETURN
22019
22020       END
22021
22022 *$ CREATE DT_RRM2.FOR
22023 *COPY DT_RRM2
22024 *
22025 *===RRM2===============================================================*
22026 *
22027       DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22028
22029       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22030       SAVE
22031
22032       PARAMETER ( LINP = 10 ,
22033      &            LOUT = 6 ,
22034      &            LDAT = 9 )
22035
22036       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22037       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22038      &           PI    = TWOPI/TWO,
22039      &           GEV2MB = 0.38938D0)
22040
22041 * particle properties (BAMJET index convention)
22042       CHARACTER*8  ANAME
22043       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22044      &                IICH(210),IIBAR(210),K1(210),K2(210)
22045
22046 * VDM parameter for photon-nucleus interactions
22047       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22048
22049       S   = Q2*(ONE-X)/X+AAM(1)**2
22050       ECM = SQRT(S)
22051
22052       IF (INTRGE(1).EQ.1) THEN
22053          AMLO2 = (3.0D0*AAM(13))**2
22054       ELSEIF (INTRGE(1).EQ.2) THEN
22055          AMLO2 = AAM(33)**2
22056       ELSE
22057          AMLO2 = AAM(96)**2
22058       ENDIF
22059       IF (INTRGE(2).EQ.1) THEN
22060          AMHI2 = S/TWO
22061       ELSEIF (INTRGE(2).EQ.2) THEN
22062          AMHI2 = S/4.0D0
22063       ELSE
22064          AMHI2 = S
22065       ENDIF
22066       AMHI20 = (ECM-AAM(1))**2
22067       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22068
22069       AM1C2 = 16.0D0
22070       AM2C2 = 121.0D0
22071       IF (AMHI2.LE.AM1C2) THEN
22072          DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22073       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22074          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22075      &          10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22076       ELSE
22077          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22078      &          10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22079      &          11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22080       ENDIF
22081
22082       RETURN
22083       END
22084
22085 *$ CREATE DT_RM2.FOR
22086 *COPY DT_RM2
22087 *
22088 *===RM2================================================================*
22089 *
22090       DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22091
22092       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22093       SAVE
22094
22095       PARAMETER ( LINP = 10 ,
22096      &            LOUT = 6 ,
22097      &            LDAT = 9 )
22098
22099       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22100       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22101      &           PI    = TWOPI/TWO,
22102      &           GEV2MB = 0.38938D0)
22103
22104 * VDM parameter for photon-nucleus interactions
22105       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22106
22107       IF (RL2.LE.ZERO) THEN
22108          DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22109      &        (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22110      &         +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22111       ELSE
22112          TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22113          TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22114          DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22115      &       -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22116      &       +EPSPOL*(
22117      &         -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22118      &       -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22119       ENDIF
22120
22121       RETURN
22122       END
22123
22124 *$ CREATE DT_SAM2.FOR
22125 *COPY DT_SAM2
22126 *
22127 *===SAM2===============================================================*
22128 *
22129       DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22130
22131       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22132       SAVE
22133
22134       PARAMETER ( LINP = 10 ,
22135      &            LOUT = 6 ,
22136      &            LDAT = 9 )
22137
22138       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22139      &           TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22140       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22141      &           PI    = TWOPI/TWO,
22142      &           GEV2MB = 0.38938D0)
22143
22144 * particle properties (BAMJET index convention)
22145       CHARACTER*8  ANAME
22146       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22147      &                IICH(210),IIBAR(210),K1(210),K2(210)
22148
22149 * VDM parameter for photon-nucleus interactions
22150       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22151
22152       S = ECM**2
22153       IF (INTRGE(1).EQ.1) THEN
22154          AMLO2 = (3.0D0*AAM(13))**2
22155       ELSEIF (INTRGE(1).EQ.2) THEN
22156          AMLO2 = AAM(33)**2
22157       ELSE
22158          AMLO2 = AAM(96)**2
22159       ENDIF
22160       IF (INTRGE(2).EQ.1) THEN
22161          AMHI2 = S/TWO
22162       ELSEIF (INTRGE(2).EQ.2) THEN
22163          AMHI2 = S/4.0D0
22164       ELSE
22165          AMHI2 = S
22166       ENDIF
22167       AMHI20 = (ECM-AAM(1))**2
22168       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22169
22170       AM1C2 = 16.0D0
22171       AM2C2 = 121.0D0
22172       YLO   = LOG(AMLO2+Q2)
22173       YC1   = LOG(AM1C2+Q2)
22174       YC2   = LOG(AM2C2+Q2)
22175       YHI   = LOG(AMHI2+Q2)
22176       IF (AMHI2.LE.AM1C2) THEN
22177          FACHI = TWO
22178       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22179          FACHI = TENTRD
22180       ELSE
22181          FACHI = ELVTRD
22182       ENDIF
22183
22184     1 CONTINUE
22185       YSAM2  = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22186       IF (YSAM2.LE.YC1) THEN
22187          FAC = TWO
22188       ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22189          FAC = TENTRD
22190       ELSE
22191          FAC = ELVTRD
22192       ENDIF
22193       WEIGMX = FACHI*(ONE-Q2*EXP(  -YHI))
22194       XSAM2  = FAC  *(ONE-Q2*EXP(-YSAM2))
22195       IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22196
22197       DT_SAM2   = EXP(YSAM2)-Q2
22198
22199       RETURN
22200       END
22201
22202 *$ CREATE DT_CKMT.FOR
22203 *COPY DT_CKMT
22204 *
22205 *===ckmt===============================================================*
22206 *
22207       SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22208      &                F2,IPAR)
22209
22210 ************************************************************************
22211 * This version dated 31.01.96 is written by S. Roesler                 *
22212 ************************************************************************
22213
22214       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22215       SAVE
22216
22217       PARAMETER ( LINP = 10 ,
22218      &            LOUT = 6 ,
22219      &            LDAT = 9 )
22220
22221       PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22222
22223       PARAMETER (Q02 = 2.0D0,
22224      &           DQ2 = 10.05D0,
22225      &           Q12 = Q02+DQ2)
22226
22227       DIMENSION PD(-6:6),SEA(3),VAL(2)
22228
22229       CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22230       CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22231       ADQ2 = LOG10(Q12)-LOG10(Q02)
22232       F2P  = (F2Q1-F2Q0)/ADQ2
22233       CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22234       CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22235       F2PP = (F2PQ1-F2PQ0)/ADQ2
22236       FX   = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22237
22238       Q2     = MAX(SCALE**2.0D0,TINY10)
22239       SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22240       IF (Q2.LT.Q02) THEN
22241          CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22242          UPV  = VAL(1)
22243          DNV  = VAL(2)
22244          USEA = SEA(1)
22245          DSEA = SEA(2)
22246          STR  = SEA(3)
22247          CHM  = 0.0D0
22248          BOT  = 0.0D0
22249          TOP  = 0.0D0
22250          GL   = GLU
22251       ELSE
22252          CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22253          F2 = F2*SMOOTH
22254          UPV  = PD(2)-PD(3)
22255          DNV  = PD(1)-PD(3)
22256          USEA = PD(3)
22257          DSEA = PD(3)
22258          STR  = PD(3)
22259          CHM  = PD(4)
22260          BOT  = PD(5)
22261          TOP  = PD(6)
22262          GL   = PD(0)
22263 C        UPV  = UPV*SMOOTH
22264 C        DNV  = DNV*SMOOTH
22265 C        USEA = USEA*SMOOTH
22266 C        DSEA = DSEA*SMOOTH
22267 C        STR  = STR*SMOOTH
22268 C        CHM  = CHM*SMOOTH
22269 C        GL   = GL*SMOOTH
22270       ENDIF
22271
22272       RETURN
22273       END
22274 C
22275
22276 *$ CREATE DT_CKMTX.FOR
22277 *COPY DT_CKMTX
22278       SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22279 C**********************************************************************
22280 C
22281 C     PDF based on Regge theory, evolved with .... by ....
22282 C
22283 C     input: IPAR     2212   proton (not installed)
22284 C                       45   Pomeron
22285 C                      100   Deuteron
22286 C
22287 C     output: PD(-6:6) x*f(x)  parton distribution functions
22288 C            (PDFLIB convention: d = PD(1), u = PD(2) )
22289 C
22290 C**********************************************************************
22291
22292       SAVE
22293       DOUBLE PRECISION  X,SCALE2,PD(-6:6),CDN,CUP,F2
22294
22295       PARAMETER ( LINP = 10 ,
22296      &            LOUT = 6 ,
22297      &            LDAT = 9 )
22298
22299       DIMENSION QQ(7)
22300 C
22301       Q2=SNGL(SCALE2)
22302       Q1S=Q2
22303       XX=SNGL(X)
22304 C  QCD lambda for evolution
22305       OWLAM = 0.23D0
22306       OWLAM2=OWLAM**2
22307 C  Q0**2 for evolution
22308       Q02 = 2.D0
22309 C
22310 C
22311 C  the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22312 C                        q(6)=x*charm, q(7)=x*gluon
22313 C
22314       SB=0.
22315       IF(Q2-Q02) 1,1,2
22316     2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22317     1 CONTINUE
22318       IF(IPAR.EQ.2212) THEN
22319         CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22320         CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22321         CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22322         CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22323         CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22324         CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22325         CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22326 C     ELSEIF (IPAR.EQ.45) THEN
22327 C       CALL CKMTPO(1,0,XX,SB,QQ(1))
22328 C       CALL CKMTPO(2,0,XX,SB,QQ(2))
22329 C       CALL CKMTPO(3,0,XX,SB,QQ(3))
22330 C       CALL CKMTPO(4,0,XX,SB,QQ(4))
22331 C       CALL CKMTPO(5,0,XX,SB,QQ(5))
22332 C       CALL CKMTPO(8,0,XX,SB,QQ(6))
22333 C       CALL CKMTPO(7,0,XX,SB,QQ(7))
22334       ELSEIF (IPAR.EQ.100) THEN
22335         CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22336         CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22337         CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22338         CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22339         CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22340         CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22341         CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22342       ELSE
22343         WRITE(LOUT,'(1X,A,I4,A)')
22344      &     'CKMTX:   IPAR =',IPAR,' not implemented!'
22345         STOP
22346       ENDIF
22347 C
22348       PD(-6) = 0.D0
22349       PD(-5) = 0.D0
22350       PD(-4) = DBLE(QQ(6))
22351       PD(-3) = DBLE(QQ(3))
22352       PD(-2) = DBLE(QQ(4))
22353       PD(-1) = DBLE(QQ(5))
22354       PD(0)  = DBLE(QQ(7))
22355       PD(1)  = DBLE(QQ(2))
22356       PD(2)  = DBLE(QQ(1))
22357       PD(3)  = DBLE(QQ(3))
22358       PD(4)  = DBLE(QQ(6))
22359       PD(5)  = 0.D0
22360       PD(6)  = 0.D0
22361       IF(IPAR.EQ.45) THEN
22362         CDN = (PD(1)-PD(-1))/2.D0
22363         CUP = (PD(2)-PD(-2))/2.D0
22364         PD(-1) = PD(-1) + CDN
22365         PD(-2) = PD(-2) + CUP
22366         PD(1) = PD(-1)
22367         PD(2) = PD(-2)
22368       ENDIF
22369       F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22370      &     1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22371      &     1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22372       END
22373 C
22374
22375 *$ CREATE DT_PDF0.FOR
22376 *COPY DT_PDF0
22377 *
22378 *===pdf0===============================================================*
22379 *
22380       SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22381
22382 ************************************************************************
22383 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
22384 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
22385 *                   IPAR  = 2212   proton                              *
22386 *                         =  100   deuteron                            *
22387 * This version dated 31.01.96 is written by S. Roesler                 *
22388 ************************************************************************
22389
22390       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22391       SAVE
22392
22393       PARAMETER ( LINP = 10 ,
22394      &            LOUT = 6 ,
22395      &            LDAT = 9 )
22396
22397       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22398
22399       PARAMETER (
22400      &              AA     = 0.1502D0,
22401      &              BBDEU  = 1.2D0,
22402      &              BUD    = 0.754D0,
22403      &              BDD    = 0.4495D0,
22404      &              BUP    = 1.2064D0,
22405      &              BDP    = 0.1798D0,
22406      &              DELTA0 = 0.07684D0,
22407      &              D      = 1.117D0,
22408      &              C      = 3.5489D0,
22409      &              A      = 0.2631D0,
22410      &              B      = 0.6452D0,
22411      &              ALPHAR = 0.415D0,
22412      &              E      = 0.1D0
22413      &          )
22414
22415       PARAMETER (NPOINT=16)
22416 C     DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22417       DIMENSION SEA(3),VAL(2)
22418
22419       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22420       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
22421 * proton, deuteron
22422       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22423          CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22424          SEA(1) = 0.75D0*SEA0
22425          SEA(2) = SEA(1)
22426          SEA(3) = SEA(1)
22427          VAL(1) = 9.0D0/4.0D0*VALU0
22428          VAL(2) = 9.0D0*VALD0
22429          GLU0   = SEA(1)/(1.0D0-X)
22430          F2     = SEA0+VALU0+VALD0
22431          F2PDF  = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22432      &            1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22433      &            1.0D0/9.0D0*(2.0D0*SEA(3))
22434          IF (ABS(F2-F2PDF).GT.TINY9) THEN
22435             WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22436             STOP
22437          ENDIF
22438 **PHOJET105a
22439 C        CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22440 **PHOJET112
22441
22442 C        CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22443
22444 **
22445 C        SUMQ = ZERO
22446 C        SUMG = ZERO
22447 C        DO 1 J=1,NPOINT
22448 C           CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22449 C           VALU0 = 9.0D0/4.0D0*VALU0
22450 C           VALD0 = 9.0D0*VALD0
22451 C           SEA0  = 0.75D0*SEA0
22452 C           SUMQ  = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22453 C           SUMG  = SUMG+ (SEA0/(1.0D0-ABSZX(J)))  *WEIGHT(J)
22454 C   1    CONTINUE
22455 C        GLU = GLU0*(1.0D0-SUMQ)/SUMG
22456       ELSE
22457          WRITE(LOUT,'(1X,A,I4,A)')
22458      &      'PDF0:   IPAR =',IPAR,' not implemented!'
22459          STOP
22460       ENDIF
22461
22462       RETURN
22463       END
22464
22465 *$ CREATE DT_CKMTQ0.FOR
22466 *COPY DT_CKMTQ0
22467 *
22468 *===ckmtq0=============================================================*
22469 *
22470       SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22471
22472 ************************************************************************
22473 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
22474 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
22475 *                   IPAR  = 2212   proton                              *
22476 *                         =  100   deuteron                            *
22477 * This version dated 31.01.96 is written by S. Roesler                 *
22478 ************************************************************************
22479
22480       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22481       SAVE
22482
22483       PARAMETER ( LINP = 10 ,
22484      &            LOUT = 6 ,
22485      &            LDAT = 9 )
22486
22487       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22488
22489       PARAMETER (
22490      &              AA     = 0.1502D0,
22491      &              BBDEU  = 1.2D0,
22492      &              BUD    = 0.754D0,
22493      &              BDD    = 0.4495D0,
22494      &              BUP    = 1.2064D0,
22495      &              BDP    = 0.1798D0,
22496      &              DELTA0 = 0.07684D0,
22497      &              D      = 1.117D0,
22498      &              C      = 3.5489D0,
22499      &              A      = 0.2631D0,
22500      &              B      = 0.6452D0,
22501      &              ALPHAR = 0.415D0,
22502      &              E      = 0.1D0
22503      &          )
22504
22505       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22506       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
22507 * proton, deuteron
22508       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22509          IF (IPAR.EQ.2212) THEN
22510             BU = BUP
22511             BD = BDP
22512          ELSE
22513             BU = BUD
22514             BD = BDD
22515          ENDIF
22516          SEA0  = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22517      &          (Q2/(Q2+A))**(1.0D0+DELTA)
22518          VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22519      &           (Q2/(Q2+B))**(ALPHAR)
22520          VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22521      &           (Q2/(Q2+B))**(ALPHAR)
22522       ELSE
22523          WRITE(LOUT,'(1X,A,I4,A)')
22524      &      'CKMTQ0: IPAR =',IPAR,' not implemented!'
22525          STOP
22526       ENDIF
22527       RETURN
22528       END
22529 C
22530 C
22531
22532 *$ CREATE DT_CKMTDE.FOR
22533 *COPY DT_CKMTDE
22534       SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22535 C
22536 C**********************************************************************
22537 C    Deuteron - PDFs
22538 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22539 C    ANS = PDF(I)
22540 C    This version by S. Roesler, 30.01.96
22541 C**********************************************************************
22542
22543       SAVE
22544       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22545       EQUIVALENCE (GF(1,1,1),DL(1))
22546       DATA DELTA/.13/
22547 C
22548       DATA (DL(K),K=    1,   85) /
22549      &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22550      &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22551      &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22552      &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22553      &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22554      &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22555      &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22556      &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22557      &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22558      &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22559      &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22560      &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22561      &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22562      &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22563      &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22564      &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22565      &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22566       DATA (DL(K),K=   86,  170) /
22567      &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22568      &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22569      &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22570      &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22571      &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22572      &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22573      &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
22574      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22575      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22576      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22577      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22578      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22579      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22580      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22581      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22582      &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22583      &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22584       DATA (DL(K),K=  171,  255) /
22585      &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22586      &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22587      &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22588      &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22589      &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22590      &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22591      &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22592      &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22593      &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22594      &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22595      &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22596      &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22597      &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22598      &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22599      &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22600      &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22601      &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22602       DATA (DL(K),K=  256,  340) /
22603      &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22604      &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22605      &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22606      &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22607      &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
22608      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22609      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22610      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22611      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22612      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22613      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22614      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22615      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22616      &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22617      &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22618      &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22619      &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22620       DATA (DL(K),K=  341,  425) /
22621      &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22622      &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22623      &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22624      &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22625      &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22626      &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22627      &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22628      &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22629      &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22630      &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22631      &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22632      &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22633      &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22634      &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22635      &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22636      &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22637      &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22638       DATA (DL(K),K=  426,  510) /
22639      &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22640      &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22641      &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
22642      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22643      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22644      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22645      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22646      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22647      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22648      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22649      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22650      &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22651      &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22652      &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22653      &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22654      &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22655      &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22656       DATA (DL(K),K=  511,  595) /
22657      &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
22658      &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
22659      &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
22660      &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
22661      &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
22662      &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
22663      &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
22664      &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
22665      &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
22666      &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
22667      &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
22668      &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
22669      &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
22670      &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
22671      &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
22672      &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
22673      &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
22674       DATA (DL(K),K=  596,  680) /
22675      &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
22676      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22677      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22678      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22679      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22680      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22681      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22682      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22683      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22684      &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
22685      &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
22686      &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
22687      &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
22688      &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
22689      &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
22690      &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
22691      &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
22692       DATA (DL(K),K=  681,  765) /
22693      &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
22694      &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
22695      &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
22696      &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
22697      &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
22698      &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
22699      &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
22700      &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
22701      &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
22702      &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
22703      &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
22704      &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
22705      &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
22706      &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
22707      &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
22708      &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
22709      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22710       DATA (DL(K),K=  766,  850) /
22711      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22712      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22713      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22714      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22715      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22716      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22717      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22718      &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
22719      &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
22720      &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
22721      &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
22722      &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
22723      &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
22724      &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
22725      &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
22726      &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
22727      &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
22728       DATA (DL(K),K=  851,  935) /
22729      &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
22730      &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
22731      &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
22732      &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
22733      &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
22734      &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
22735      &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
22736      &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
22737      &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
22738      &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
22739      &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
22740      &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
22741      &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
22742      &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
22743      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22744      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22745      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22746       DATA (DL(K),K=  936, 1020) /
22747      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22748      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22749      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22750      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22751      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22752      &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
22753      &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
22754      &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
22755      &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
22756      &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
22757      &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
22758      &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
22759      &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
22760      &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
22761      &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
22762      &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
22763      &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
22764       DATA (DL(K),K= 1021, 1105) /
22765      &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
22766      &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
22767      &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
22768      &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
22769      &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
22770      &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
22771      &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
22772      &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
22773      &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
22774      &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
22775      &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
22776      &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
22777      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22778      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22779      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22780      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22781      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22782       DATA (DL(K),K= 1106, 1190) /
22783      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22784      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22785      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22786      &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
22787      &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
22788      &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
22789      &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
22790      &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
22791      &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
22792      &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
22793      &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
22794      &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
22795      &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
22796      &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
22797      &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
22798      &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
22799      &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
22800       DATA (DL(K),K= 1191, 1275) /
22801      &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
22802      &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
22803      &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
22804      &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
22805      &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
22806      &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
22807      &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
22808      &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
22809      &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
22810      &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
22811      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22812      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22813      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22814      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22815      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22816      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22817      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22818       DATA (DL(K),K= 1276, 1360) /
22819      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22820      &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
22821      &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
22822      &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
22823      &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
22824      &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
22825      &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
22826      &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
22827      &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
22828      &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
22829      &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
22830      &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
22831      &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
22832      &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
22833      &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
22834      &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
22835      &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
22836       DATA (DL(K),K= 1361, 1445) /
22837      &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
22838      &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
22839      &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
22840      &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
22841      &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
22842      &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
22843      &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
22844      &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
22845      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22846      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22847      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22848      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22849      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22850      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22851      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22852      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22853      &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
22854       DATA (DL(K),K= 1446, 1530) /
22855      &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
22856      &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
22857      &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
22858      &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
22859      &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
22860      &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
22861      &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
22862      &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
22863      &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
22864      &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
22865      &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
22866      &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
22867      &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
22868      &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
22869      &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
22870      &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
22871      &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
22872       DATA (DL(K),K= 1531, 1615) /
22873      &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
22874      &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
22875      &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
22876      &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
22877      &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
22878      &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
22879      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22880      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22881      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22882      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22883      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22884      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22885      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22886      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22887      &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
22888      &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
22889      &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
22890       DATA (DL(K),K= 1616, 1700) /
22891      &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
22892      &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
22893      &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
22894      &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
22895      &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
22896      &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
22897      &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
22898      &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
22899      &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
22900      &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
22901      &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
22902      &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
22903      &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
22904      &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
22905      &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
22906      &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
22907      &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
22908       DATA (DL(K),K= 1701, 1785) /
22909      &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
22910      &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
22911      &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
22912      &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
22913      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22914      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22915      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22916      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22917      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22918      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22919      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22920      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22921      &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
22922      &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
22923      &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
22924      &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
22925      &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
22926       DATA (DL(K),K= 1786, 1870) /
22927      &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
22928      &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
22929      &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
22930      &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
22931      &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
22932      &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
22933      &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
22934      &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
22935      &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
22936      &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
22937      &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
22938      &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
22939      &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
22940      &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
22941      &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
22942      &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
22943      &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
22944       DATA (DL(K),K= 1871, 1955) /
22945      &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
22946      &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
22947      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22948      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22949      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22950      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22951      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22952      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22953      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22954      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22955      &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
22956      &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
22957      &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
22958      &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
22959      &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
22960      &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
22961      &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
22962       DATA (DL(K),K= 1956, 2040) /
22963      &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
22964      &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
22965      &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
22966      &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
22967      &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
22968      &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
22969      &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
22970      &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
22971      &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
22972      &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
22973      &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
22974      &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
22975      &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
22976      &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
22977      &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
22978      &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
22979      &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
22980       DATA (DL(K),K= 2041, 2125) /
22981      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22982      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22983      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22984      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22985      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22986      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22987      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22988      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22989      &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
22990      &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
22991      &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
22992      &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
22993      &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
22994      &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
22995      &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
22996      &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
22997      &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
22998       DATA (DL(K),K= 2126, 2210) /
22999      &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
23000      &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
23001      &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
23002      &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
23003      &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
23004      &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
23005      &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
23006      &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
23007      &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
23008      &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
23009      &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
23010      &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
23011      &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
23012      &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
23013      &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
23014      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23015      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23016       DATA (DL(K),K= 2211, 2295) /
23017      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23018      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23019      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23020      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23021      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23022      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23023      &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23024      &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23025      &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23026      &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23027      &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23028      &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23029      &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23030      &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23031      &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23032      &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23033      &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23034       DATA (DL(K),K= 2296, 2380) /
23035      &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23036      &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23037      &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23038      &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23039      &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23040      &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23041      &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23042      &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23043      &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23044      &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23045      &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23046      &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23047      &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
23048      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23049      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23050      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23051      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23052       DATA (DL(K),K= 2381, 2465) /
23053      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23054      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23055      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23056      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23057      &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23058      &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23059      &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23060      &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23061      &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23062      &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23063      &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23064      &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23065      &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23066      &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23067      &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23068      &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23069      &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23070       DATA (DL(K),K= 2466, 2550) /
23071      &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23072      &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23073      &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23074      &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23075      &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23076      &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23077      &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23078      &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23079      &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23080      &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23081      &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
23082      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23083      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23084      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23085      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23086      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23087      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23088       DATA (DL(K),K= 2551, 2635) /
23089      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23090      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23091      &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23092      &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23093      &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23094      &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23095      &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23096      &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23097      &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23098      &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23099      &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23100      &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23101      &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23102      &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23103      &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23104      &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23105      &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23106       DATA (DL(K),K= 2636, 2720) /
23107      &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23108      &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23109      &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23110      &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23111      &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23112      &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23113      &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23114      &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23115      &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
23116      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23117      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23118      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23119      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23120      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23121      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23122      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23123      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23124       DATA (DL(K),K= 2721, 2805) /
23125      &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23126      &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23127      &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23128      &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23129      &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23130      &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23131      &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23132      &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23133      &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23134      &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23135      &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23136      &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23137      &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23138      &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23139      &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23140      &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23141      &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23142       DATA (DL(K),K= 2806, 2890) /
23143      &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23144      &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23145      &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23146      &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23147      &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23148      &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23149      &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
23150      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23151      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23152      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23153      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23154      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23155      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23156      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23157      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23158      &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23159      &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23160       DATA (DL(K),K= 2891, 2975) /
23161      &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23162      &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23163      &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23164      &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23165      &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23166      &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23167      &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23168      &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23169      &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23170      &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23171      &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23172      &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23173      &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23174      &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23175      &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23176      &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23177      &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23178       DATA (DL(K),K= 2976, 3060) /
23179      &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23180      &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23181      &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23182      &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23183      &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
23184      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23185      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23186      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23187      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23188      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23189      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23190      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23191      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23192      &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23193      &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23194      &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23195      &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23196       DATA (DL(K),K= 3061, 3145) /
23197      &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23198      &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23199      &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23200      &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23201      &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23202      &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23203      &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23204      &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23205      &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23206      &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23207      &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23208      &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23209      &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23210      &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23211      &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23212      &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23213      &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23214       DATA (DL(K),K= 3146, 3230) /
23215      &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23216      &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23217      &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
23218      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23219      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23220      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23221      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23222      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23223      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23224      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23225      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23226      &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23227      &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23228      &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23229      &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23230      &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23231      &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23232       DATA (DL(K),K= 3231, 3315) /
23233      &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23234      &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23235      &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23236      &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23237      &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23238      &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23239      &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23240      &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23241      &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23242      &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23243      &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23244      &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23245      &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23246      &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23247      &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23248      &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23249      &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23250       DATA (DL(K),K= 3316, 3400) /
23251      &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
23252      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23253      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23254      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23255      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23256      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23257      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23258      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23259      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23260      &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23261      &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23262      &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23263      &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23264      &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23265      &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23266      &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23267      &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23268       DATA (DL(K),K= 3401, 3485) /
23269      &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23270      &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23271      &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23272      &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23273      &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23274      &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23275      &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23276      &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23277      &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23278      &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23279      &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23280      &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23281      &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23282      &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23283      &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23284      &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23285      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23286       DATA (DL(K),K= 3486, 3570) /
23287      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23288      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23289      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23290      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23291      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23292      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23293      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23294      &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23295      &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23296      &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23297      &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23298      &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23299      &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23300      &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23301      &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23302      &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23303      &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23304       DATA (DL(K),K= 3571, 3655) /
23305      &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23306      &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23307      &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23308      &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23309      &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23310      &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23311      &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23312      &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23313      &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23314      &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23315      &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23316      &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23317      &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23318      &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
23319      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23320      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23321      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23322       DATA (DL(K),K= 3656, 3740) /
23323      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23324      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23325      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23326      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23327      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23328      &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23329      &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23330      &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23331      &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23332      &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23333      &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23334      &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23335      &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23336      &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23337      &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23338      &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23339      &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23340       DATA (DL(K),K= 3741, 3825) /
23341      &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23342      &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23343      &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23344      &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23345      &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23346      &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23347      &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23348      &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23349      &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23350      &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23351      &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23352      &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
23353      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23354      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23355      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23356      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23357      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23358       DATA (DL(K),K= 3826, 3910) /
23359      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23360      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23361      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23362      &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23363      &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23364      &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23365      &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23366      &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23367      &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23368      &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23369      &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23370      &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23371      &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23372      &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23373      &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23374      &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23375      &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23376       DATA (DL(K),K= 3911, 3995) /
23377      &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23378      &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23379      &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23380      &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23381      &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23382      &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23383      &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23384      &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23385      &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23386      &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
23387      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23388      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23389      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23390      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23391      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23392      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23393      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23394       DATA (DL(K),K= 3996, 4000) /
23395      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23396 C
23397       ANS = 0.
23398       IF (X.GT.0.9985) RETURN
23399       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23400 C
23401       IS  = S/DELTA+1
23402       IS1 = IS+1
23403       DO 1 L=1,25
23404          KL    = L+NDRV*25
23405          F1(L) = GF(I,IS,KL)
23406          F2(L) = GF(I,IS1,KL)
23407     1 CONTINUE
23408       A1 = DT_CKMTFF(X,F1)
23409       A2 = DT_CKMTFF(X,F2)
23410 C      A1=ALOG(A1)
23411 C      A2=ALOG(A2)
23412       S1  = (IS-1)*DELTA
23413       S2  = S1+DELTA
23414       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23415 C      ANS=EXP(ANS)
23416       RETURN
23417       END
23418 C
23419 C
23420
23421 *$ CREATE DT_CKMTPR.FOR
23422 *COPY DT_CKMTPR
23423       SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23424 C
23425 C**********************************************************************
23426 C    Proton   - PDFs
23427 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23428 C    ANS = PDF(I)
23429 C    This version by S. Roesler, 31.01.96
23430 C**********************************************************************
23431
23432       SAVE
23433       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23434       EQUIVALENCE (GF(1,1,1),DL(1))
23435       DATA DELTA/.10/
23436 C
23437       DATA (DL(K),K=    1,   85) /
23438      &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23439      &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23440      &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23441      &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23442      &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23443      &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23444      &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23445      &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23446      &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23447      &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23448      &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23449      &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23450      &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23451      &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23452      &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23453      &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23454      &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23455       DATA (DL(K),K=   86,  170) /
23456      &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23457      &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23458      &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23459      &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23460      &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23461      &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23462      &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23463      &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23464      &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23465      &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23466      &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23467      &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23468      &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23469      &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23470      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23471      &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23472      &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23473       DATA (DL(K),K=  171,  255) /
23474      &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23475      &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23476      &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23477      &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23478      &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23479      &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23480      &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23481      &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23482      &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23483      &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23484      &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23485      &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23486      &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23487      &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23488      &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23489      &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23490      &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23491       DATA (DL(K),K=  256,  340) /
23492      &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23493      &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23494      &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23495      &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23496      &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23497      &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23498      &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23499      &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23500      &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23501      &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23502      &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23503      &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23504      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23505      &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23506      &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23507      &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23508      &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23509       DATA (DL(K),K=  341,  425) /
23510      &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23511      &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23512      &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23513      &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23514      &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23515      &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23516      &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23517      &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23518      &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23519      &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23520      &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23521      &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23522      &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23523      &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23524      &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23525      &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23526      &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23527       DATA (DL(K),K=  426,  510) /
23528      &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23529      &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23530      &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23531      &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23532      &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23533      &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23534      &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23535      &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23536      &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23537      &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23538      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23539      &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23540      &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23541      &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23542      &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23543      &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23544      &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23545       DATA (DL(K),K=  511,  595) /
23546      &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23547      &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23548      &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23549      &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23550      &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23551      &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23552      &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23553      &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23554      &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23555      &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23556      &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23557      &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23558      &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23559      &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23560      &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23561      &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23562      &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23563       DATA (DL(K),K=  596,  680) /
23564      &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23565      &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23566      &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23567      &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23568      &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23569      &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23570      &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23571      &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23572      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23573      &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23574      &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23575      &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23576      &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23577      &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23578      &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23579      &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23580      &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23581       DATA (DL(K),K=  681,  765) /
23582      &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23583      &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23584      &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23585      &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23586      &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23587      &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23588      &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23589      &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23590      &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23591      &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23592      &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23593      &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23594      &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23595      &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23596      &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23597      &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23598      &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23599       DATA (DL(K),K=  766,  850) /
23600      &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23601      &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23602      &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23603      &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23604      &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23605      &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23606      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23607      &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23608      &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23609      &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23610      &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23611      &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23612      &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23613      &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23614      &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23615      &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23616      &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23617       DATA (DL(K),K=  851,  935) /
23618      &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23619      &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23620      &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23621      &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23622      &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23623      &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23624      &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23625      &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23626      &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23627      &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23628      &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23629      &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23630      &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23631      &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23632      &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23633      &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23634      &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23635       DATA (DL(K),K=  936, 1020) /
23636      &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23637      &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23638      &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23639      &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23640      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23641      &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23642      &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23643      &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23644      &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23645      &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23646      &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23647      &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23648      &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23649      &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23650      &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23651      &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23652      &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23653       DATA (DL(K),K= 1021, 1105) /
23654      &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23655      &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23656      &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23657      &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
23658      &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
23659      &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
23660      &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
23661      &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
23662      &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
23663      &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
23664      &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
23665      &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
23666      &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
23667      &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
23668      &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
23669      &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
23670      &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
23671       DATA (DL(K),K= 1106, 1190) /
23672      &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
23673      &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23674      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23675      &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23676      &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
23677      &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
23678      &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
23679      &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
23680      &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
23681      &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
23682      &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
23683      &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
23684      &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
23685      &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
23686      &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
23687      &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
23688      &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
23689       DATA (DL(K),K= 1191, 1275) /
23690      &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
23691      &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
23692      &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
23693      &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
23694      &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
23695      &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
23696      &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
23697      &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
23698      &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
23699      &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
23700      &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
23701      &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
23702      &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
23703      &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
23704      &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
23705      &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
23706      &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
23707       DATA (DL(K),K= 1276, 1360) /
23708      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23709      &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23710      &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
23711      &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
23712      &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
23713      &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
23714      &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
23715      &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
23716      &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
23717      &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
23718      &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
23719      &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
23720      &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
23721      &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
23722      &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
23723      &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
23724      &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
23725       DATA (DL(K),K= 1361, 1445) /
23726      &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
23727      &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
23728      &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
23729      &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
23730      &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
23731      &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
23732      &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
23733      &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
23734      &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
23735      &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
23736      &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
23737      &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
23738      &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
23739      &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
23740      &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23741      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23742      &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23743       DATA (DL(K),K= 1446, 1530) /
23744      &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
23745      &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
23746      &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
23747      &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
23748      &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
23749      &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
23750      &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
23751      &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
23752      &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
23753      &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
23754      &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
23755      &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
23756      &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
23757      &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
23758      &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
23759      &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
23760      &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
23761       DATA (DL(K),K= 1531, 1615) /
23762      &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
23763      &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
23764      &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
23765      &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
23766      &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
23767      &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
23768      &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
23769      &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
23770      &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
23771      &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
23772      &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
23773      &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
23774      &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23775      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23776      &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23777      &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
23778      &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
23779       DATA (DL(K),K= 1616, 1700) /
23780      &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
23781      &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
23782      &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
23783      &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
23784      &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
23785      &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
23786      &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
23787      &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
23788      &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
23789      &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
23790      &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
23791      &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
23792      &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
23793      &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
23794      &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
23795      &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
23796      &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
23797       DATA (DL(K),K= 1701, 1785) /
23798      &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
23799      &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
23800      &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
23801      &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
23802      &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
23803      &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
23804      &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
23805      &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
23806      &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
23807      &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
23808      &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23809      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23810      &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23811      &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
23812      &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
23813      &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
23814      &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
23815       DATA (DL(K),K= 1786, 1870) /
23816      &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
23817      &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
23818      &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
23819      &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
23820      &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
23821      &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
23822      &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
23823      &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
23824      &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
23825      &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
23826      &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
23827      &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
23828      &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
23829      &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
23830      &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
23831      &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
23832      &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
23833       DATA (DL(K),K= 1871, 1955) /
23834      &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
23835      &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
23836      &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
23837      &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
23838      &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
23839      &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
23840      &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
23841      &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
23842      &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23843      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23844      &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23845      &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
23846      &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
23847      &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
23848      &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
23849      &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
23850      &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
23851       DATA (DL(K),K= 1956, 2040) /
23852      &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
23853      &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
23854      &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
23855      &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
23856      &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
23857      &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
23858      &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
23859      &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
23860      &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
23861      &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
23862      &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
23863      &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
23864      &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
23865      &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
23866      &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
23867      &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
23868      &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
23869       DATA (DL(K),K= 2041, 2125) /
23870      &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
23871      &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
23872      &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
23873      &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
23874      &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
23875      &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
23876      &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23877      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23878      &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23879      &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
23880      &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
23881      &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
23882      &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
23883      &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
23884      &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
23885      &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
23886      &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
23887       DATA (DL(K),K= 2126, 2210) /
23888      &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
23889      &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
23890      &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
23891      &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
23892      &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
23893      &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
23894      &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
23895      &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
23896      &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
23897      &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
23898      &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
23899      &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
23900      &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
23901      &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
23902      &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
23903      &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
23904      &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
23905       DATA (DL(K),K= 2211, 2295) /
23906      &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
23907      &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
23908      &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
23909      &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
23910      &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23911      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23912      &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23913      &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
23914      &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
23915      &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
23916      &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
23917      &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
23918      &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
23919      &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
23920      &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
23921      &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
23922      &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
23923       DATA (DL(K),K= 2296, 2380) /
23924      &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
23925      &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
23926      &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
23927      &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
23928      &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
23929      &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
23930      &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
23931      &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
23932      &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
23933      &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
23934      &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
23935      &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
23936      &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
23937      &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
23938      &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
23939      &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
23940      &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
23941       DATA (DL(K),K= 2381, 2465) /
23942      &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
23943      &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
23944      &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23945      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23946      &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23947      &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
23948      &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
23949      &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
23950      &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
23951      &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
23952      &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
23953      &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
23954      &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
23955      &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
23956      &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
23957      &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
23958      &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
23959       DATA (DL(K),K= 2466, 2550) /
23960      &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
23961      &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
23962      &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
23963      &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
23964      &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
23965      &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
23966      &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
23967      &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
23968      &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
23969      &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
23970      &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
23971      &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
23972      &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
23973      &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
23974      &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
23975      &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
23976      &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
23977       DATA (DL(K),K= 2551, 2635) /
23978      &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
23979      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23980      &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
23981      &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
23982      &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
23983      &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
23984      &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
23985      &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
23986      &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
23987      &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
23988      &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
23989      &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
23990      &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
23991      &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
23992      &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
23993      &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
23994      &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
23995       DATA (DL(K),K= 2636, 2720) /
23996      &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
23997      &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
23998      &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
23999      &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
24000      &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
24001      &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
24002      &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
24003      &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
24004      &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
24005      &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
24006      &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
24007      &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
24008      &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
24009      &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
24010      &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
24011      &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24012      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24013       DATA (DL(K),K= 2721, 2805) /
24014      &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
24015      &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
24016      &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
24017      &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
24018      &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24019      &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24020      &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24021      &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24022      &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24023      &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24024      &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24025      &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24026      &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24027      &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24028      &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24029      &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24030      &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24031       DATA (DL(K),K= 2806, 2890) /
24032      &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24033      &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24034      &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24035      &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24036      &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24037      &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24038      &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24039      &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24040      &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24041      &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24042      &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24043      &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24044      &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24045      &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24046      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24047      &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24048      &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24049       DATA (DL(K),K= 2891, 2975) /
24050      &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24051      &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24052      &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24053      &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24054      &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24055      &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24056      &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24057      &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24058      &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24059      &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24060      &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24061      &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24062      &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24063      &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24064      &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24065      &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24066      &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24067       DATA (DL(K),K= 2976, 3060) /
24068      &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24069      &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24070      &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24071      &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24072      &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24073      &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24074      &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24075      &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24076      &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24077      &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24078      &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24079      &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24080      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24081      &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24082      &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24083      &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24084      &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24085       DATA (DL(K),K= 3061, 3145) /
24086      &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24087      &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24088      &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24089      &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24090      &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24091      &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24092      &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24093      &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24094      &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24095      &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24096      &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24097      &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24098      &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24099      &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24100      &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24101      &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24102      &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24103       DATA (DL(K),K= 3146, 3230) /
24104      &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24105      &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24106      &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24107      &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24108      &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24109      &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24110      &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24111      &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24112      &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24113      &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24114      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24115      &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24116      &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24117      &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24118      &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24119      &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24120      &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24121       DATA (DL(K),K= 3231, 3315) /
24122      &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24123      &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24124      &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24125      &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24126      &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24127      &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24128      &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24129      &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24130      &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24131      &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24132      &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24133      &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24134      &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24135      &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24136      &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24137      &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24138      &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24139       DATA (DL(K),K= 3316, 3400) /
24140      &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24141      &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24142      &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24143      &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24144      &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24145      &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24146      &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24147      &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24148      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24149      &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24150      &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24151      &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24152      &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24153      &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24154      &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24155      &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24156      &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24157       DATA (DL(K),K= 3401, 3485) /
24158      &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24159      &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24160      &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24161      &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24162      &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24163      &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24164      &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24165      &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24166      &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24167      &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24168      &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24169      &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24170      &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24171      &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24172      &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24173      &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24174      &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24175       DATA (DL(K),K= 3486, 3570) /
24176      &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24177      &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24178      &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24179      &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24180      &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24181      &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24182      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24183      &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24184      &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24185      &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24186      &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24187      &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24188      &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24189      &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24190      &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24191      &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24192      &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24193       DATA (DL(K),K= 3571, 3655) /
24194      &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24195      &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24196      &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24197      &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24198      &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24199      &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24200      &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24201      &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24202      &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24203      &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24204      &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24205      &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24206      &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24207      &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24208      &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24209      &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24210      &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24211       DATA (DL(K),K= 3656, 3740) /
24212      &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24213      &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24214      &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24215      &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24216      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24217      &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24218      &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24219      &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24220      &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24221      &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24222      &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24223      &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24224      &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24225      &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24226      &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24227      &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24228      &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24229       DATA (DL(K),K= 3741, 3825) /
24230      &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24231      &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24232      &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24233      &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24234      &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24235      &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24236      &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24237      &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24238      &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24239      &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24240      &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24241      &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24242      &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24243      &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24244      &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24245      &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24246      &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24247       DATA (DL(K),K= 3826, 3910) /
24248      &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24249      &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24250      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24251      &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24252      &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24253      &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24254      &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24255      &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24256      &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24257      &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24258      &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24259      &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24260      &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24261      &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24262      &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24263      &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24264      &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24265       DATA (DL(K),K= 3911, 3995) /
24266      &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24267      &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24268      &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24269      &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24270      &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24271      &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24272      &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24273      &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24274      &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24275      &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24276      &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24277      &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24278      &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24279      &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24280      &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24281      &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24282      &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24283       DATA (DL(K),K= 3996, 4000) /
24284      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24285 C
24286       ANS = 0.
24287       IF (X.GT.0.9985) RETURN
24288       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24289 C
24290       IS  = S/DELTA+1
24291       IS1 = IS+1
24292       DO 1 L=1,25
24293          KL    = L+NDRV*25
24294          F1(L) = GF(I,IS,KL)
24295          F2(L) = GF(I,IS1,KL)
24296     1 CONTINUE
24297       A1 = DT_CKMTFF(X,F1)
24298       A2 = DT_CKMTFF(X,F2)
24299 C      A1=ALOG(A1)
24300 C      A2=ALOG(A2)
24301       S1  = (IS-1)*DELTA
24302       S2  = S1+DELTA
24303       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24304 C      ANS=EXP(ANS)
24305       RETURN
24306       END
24307 C
24308
24309 *$ CREATE DT_CKMTFF.FOR
24310 *COPY DT_CKMTFF
24311       FUNCTION DT_CKMTFF(X,FVL)
24312 C**********************************************************************
24313 C
24314 C     LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24315 C     FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24316 C     NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24317 C     IN MAIN ROUTINE.
24318 C
24319 C**********************************************************************
24320
24321       SAVE
24322       DIMENSION FVL(25),XGRID(25)
24323       DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24324      *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24325 C
24326       DT_CKMTFF=0.
24327       DO 1 I=1,NX
24328       IF(X.LT.XGRID(I)) GO TO 2
24329     1 CONTINUE
24330     2 I=I-1
24331       IF(I.EQ.0) THEN
24332          I=I+1
24333       ELSE IF(I.GT.23) THEN
24334          I=23
24335       ENDIF
24336       J=I+1
24337       K=J+1
24338       AXI=LOG(XGRID(I))
24339       BXI=LOG(1.-XGRID(I))
24340       AXJ=LOG(XGRID(J))
24341       BXJ=LOG(1.-XGRID(J))
24342       AXK=LOG(XGRID(K))
24343       BXK=LOG(1.-XGRID(K))
24344       FI=LOG(ABS(FVL(I)) +1.E-15)
24345       FJ=LOG(ABS(FVL(J)) +1.E-16)
24346       FK=LOG(ABS(FVL(K)) +1.E-17)
24347       DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24348       ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24349      $ BXI))/DET
24350       ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24351       BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24352       IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24353      1RETURN
24354 C      IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24355 C         WRITE(6,2001) X,FVL
24356 C 2001    FORMAT(8E12.4)
24357 C         WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24358 C      ENDIF
24359       DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24360       RETURN
24361       END
24362
24363 *$ CREATE DT_FLUINI.FOR
24364 *COPY DT_FLUINI
24365 *
24366 *===fluini=============================================================*
24367 *
24368       SUBROUTINE DT_FLUINI
24369
24370 ************************************************************************
24371 * Initialisation of the nucleon-nucleon cross section fluctuation      *
24372 * treatment. The original version by J. Ranft.                         *
24373 * This version dated 21.04.95 is revised by S. Roesler.                *
24374 ************************************************************************
24375
24376       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24377       SAVE
24378
24379       PARAMETER ( LINP = 10 ,
24380      &            LOUT = 6 ,
24381      &            LDAT = 9 )
24382
24383       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24384
24385       PARAMETER ( A     = 0.1D0,
24386      &            B     = 0.893D0,
24387      &            OM    = 1.1D0,
24388      &            N     = 6,
24389      &            DX    = 0.003D0)
24390
24391 * n-n cross section fluctuations
24392       PARAMETER (NBINS = 1000)
24393       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24394       DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24395
24396       WRITE(LOUT,1000)
24397  1000 FORMAT(/,1X,'FLUINI:  hadronic cross section fluctuations ',
24398      &       'treated')
24399
24400       FLUSU  = ZERO
24401       FLUSUU = ZERO
24402
24403       DO 1 I=1,NBINS
24404          X        = DBLE(I)*DX
24405          FLUIX(I) = X
24406          FLUS     = ((X-B)/(OM*B))**N
24407          IF (FLUS.LE.20.0D0) THEN
24408             FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24409          ELSE
24410             FLUSI(I) = ZERO
24411          ENDIF
24412          FLUSU = FLUSU+FLUSI(I)
24413     1 CONTINUE
24414       DO 2 I=1,NBINS
24415          FLUSUU   = FLUSUU+FLUSI(I)/FLUSU
24416          FLUSI(I) = FLUSUU
24417     2 CONTINUE
24418
24419 C     WRITE(LOUT,1001)
24420 C1001 FORMAT(1X,'FLUCTUATIONS')
24421 C     CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24422
24423       DO 3 I=1,NBINS
24424          AF = DBLE(I)*0.001D0
24425          DO 4 J=1,NBINS
24426             IF (AF.LE.FLUSI(J)) THEN
24427                FLUIXX(I) = FLUIX(J)
24428                GOTO 5
24429             ENDIF
24430     4    CONTINUE
24431     5    CONTINUE
24432     3 CONTINUE
24433       FLUIXX(1)     = FLUIX(1)
24434       FLUIXX(NBINS) = FLUIX(NBINS)
24435
24436       RETURN
24437       END
24438
24439 *$ CREATE DT_SIGTBL.FOR
24440 *COPY DT_SIGTBL
24441 *
24442 *===sigtab=============================================================*
24443 *
24444       SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24445
24446 ************************************************************************
24447 * This version dated 18.11.95 is written by S. Roesler                 *
24448 ************************************************************************
24449
24450       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24451       SAVE
24452
24453       PARAMETER ( LINP = 10 ,
24454      &            LOUT = 6 ,
24455      &            LDAT = 9 )
24456
24457       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24458      &           OHALF=0.5D0,ONE=1.0D0)
24459       PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24460
24461       LOGICAL LINIT
24462
24463 * particle properties (BAMJET index convention)
24464       CHARACTER*8  ANAME
24465       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24466      &                IICH(210),IIBAR(210),K1(210),K2(210)
24467
24468       DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24469       DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24470      &             0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24471      &             0, 0, 5/
24472       DATA LINIT /.FALSE./
24473
24474 * precalculation and tabulation of elastic cross sections
24475       IF (ABS(MODE).EQ.1) THEN
24476          IF (MODE.EQ.1)
24477      &      OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24478          PLABLX = LOG10(PLO)
24479          PLABHX = LOG10(PHI)
24480          DPLAB  = (PLABHX-PLABLX)/DBLE(NBINS)
24481          DO 1 I=1,NBINS+1
24482             PLAB = PLABLX+DBLE(I-1)*DPLAB
24483             PLAB = 10**PLAB
24484             DO 2 IPROJ=1,23
24485                IDX = IDSIG(IPROJ)
24486                IF (IDX.GT.0) THEN
24487 C                 CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24488 C                 CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24489                   DUMZER = ZERO
24490                   CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24491                   CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24492                ENDIF
24493     2       CONTINUE
24494             IF (MODE.EQ.1) THEN
24495                WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24496      &                                (SIGEN(IDX,I),IDX=1,5)
24497  1000          FORMAT(F5.1,10F7.2)
24498             ENDIF
24499     1    CONTINUE
24500          IF (MODE.EQ.1) CLOSE(LDAT)
24501          LINIT = .TRUE.
24502       ELSE
24503          SIGE = -ONE
24504          IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24505      &                           .AND.(PTOT.LE.PHI) ) THEN
24506             IDX = IDSIG(JP)
24507             IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24508                PLABX = LOG10(PTOT)
24509                IF (PLABX.LE.PLABLX) THEN
24510                   I1 = 1
24511                   I2 = 1
24512                ELSEIF (PLABX.GE.PLABHX) THEN
24513                   I1 = NBINS+1
24514                   I2 = NBINS+1
24515                ELSE
24516                   I1 = INT((PLABX-PLABLX)/DPLAB)+1
24517                   I2 = I1+1
24518                ENDIF
24519                PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24520                PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24521                PBIN   = PLAB2X-PLAB1X
24522                IF (PBIN.GT.TINY10) THEN
24523                   RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24524                ELSE
24525                   RATX = ZERO
24526                ENDIF
24527                IF (JT.EQ.1) THEN
24528                   SIG1 = SIGEP(IDX,I1)
24529                   SIG2 = SIGEP(IDX,I2)
24530                ELSE
24531                   SIG1 = SIGEN(IDX,I1)
24532                   SIG2 = SIGEN(IDX,I2)
24533                ENDIF
24534                SIGE = SIG1+RATX*(SIG2-SIG1)
24535             ENDIF
24536          ENDIF
24537       ENDIF
24538
24539       RETURN
24540       END
24541
24542 *$ CREATE DT_XSTABL.FOR
24543 *COPY DT_XSTABL
24544 *
24545 *===xstabl=============================================================*
24546 *
24547       SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24548
24549       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24550       SAVE
24551
24552       PARAMETER ( LINP = 10 ,
24553      &            LOUT = 6 ,
24554      &            LDAT = 9 )
24555
24556       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24557      &           OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24558       LOGICAL LLAB,LELOG,LQLOG
24559
24560 * particle properties (BAMJET index convention)
24561       CHARACTER*8  ANAME
24562       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24563      &                IICH(210),IIBAR(210),K1(210),K2(210)
24564
24565 * properties of interacting particles
24566       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24567
24568       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24569
24570 * Glauber formalism: cross sections
24571       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24572      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24573      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24574      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24575      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24576      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24577      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24578      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24579      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24580      &                BSLOPE,NEBINI,NQBINI
24581
24582 * emulsion treatment
24583       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24584      &                NCOMPO,IEMUL
24585
24586       DIMENSION WHAT(6)
24587
24588       LLAB   = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24589       ELO    = ABS(WHAT(1))
24590       EHI    = ABS(WHAT(2))
24591       IF (ELO.GT.EHI) ELO = EHI
24592       LELOG  = WHAT(3).LT.ZERO
24593       NEBINS = MAX(INT(ABS(WHAT(3))),1)
24594       DEBINS = (EHI-ELO)/DBLE(NEBINS)
24595       IF (LELOG) THEN
24596          AELO   = LOG10(ELO)
24597          AEHI   = LOG10(EHI)
24598          ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24599       ENDIF
24600       Q2LO   = WHAT(4)
24601       Q2HI   = WHAT(5)
24602       IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24603       LQLOG  = WHAT(6).LT.ZERO
24604       NQBINS = MAX(INT(ABS(WHAT(6))),1)
24605       DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24606       IF (LQLOG) THEN
24607          AQ2LO  = LOG10(Q2LO)
24608          AQ2HI  = LOG10(Q2HI)
24609          ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24610       ENDIF
24611
24612       IF ( ELO.EQ. EHI) NEBINS = 0
24613       IF (Q2LO.EQ.Q2HI) NQBINS = 0
24614
24615       WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24616  1000 FORMAT(/,1X,'XSTABL:  E_lo  =',E10.3,' GeV  E_hi  =',E10.3,
24617      &       ' GeV     Lab = ',L1,'  qel: ',I2,/,10X,'Q2_lo =',F10.5,
24618      &       ' GeV^2  Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24619      &       '   A_p = ',I3,'   A_t = ',I3,/)
24620
24621 C     IF (IJPROJ.NE.7) THEN
24622          WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24623 * normalize fractions of emulsion components
24624          IF (NCOMPO.GT.0) THEN
24625             SUMFRA = ZERO
24626             DO 10 I=1,NCOMPO
24627                SUMFRA = SUMFRA+EMUFRA(I)
24628    10       CONTINUE
24629             IF (SUMFRA.GT.ZERO) THEN
24630                DO 11 I=1,NCOMPO
24631                   EMUFRA(I) = EMUFRA(I)/SUMFRA
24632    11          CONTINUE
24633             ENDIF
24634          ENDIF
24635 C     ELSE
24636 C        WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24637 C     ENDIF
24638       DO 1 I=1,NEBINS+1
24639          IF (LELOG) THEN
24640             E = 10**(AELO+DBLE(I-1)*ADEBIN)
24641          ELSE
24642             E = ELO+DBLE(I-1)*DEBINS
24643          ENDIF
24644          DO 2 J=1,NQBINS+1
24645             IF (LQLOG) THEN
24646                Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24647             ELSE
24648                Q2 = Q2LO+DBLE(J-1)*DQBINS
24649             ENDIF
24650 c            IF (IJPROJ.NE.7) THEN
24651                IF (LLAB) THEN
24652                   PLAB = ZERO
24653                   ECM  = ZERO
24654                   CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24655                ELSE
24656                   ECM = E
24657                ENDIF
24658                XI  = ZERO
24659                Q2I = ZERO
24660                IF (IJPROJ.EQ.7) Q2I = Q2
24661                IF (NCOMPO.GT.0) THEN
24662                   DO 20 IC=1,NCOMPO
24663                      IIT = IEMUMA(IC)
24664                      CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
24665    20             CONTINUE
24666                ELSE
24667                   CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
24668 C                 CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
24669                ENDIF
24670                IF (NCOMPO.GT.0) THEN
24671                   XTOT = ZERO
24672                   ETOT = ZERO
24673                   XELA = ZERO
24674                   EELA = ZERO
24675                   XQEP = ZERO
24676                   EQEP = ZERO
24677                   XQET = ZERO
24678                   EQET = ZERO
24679                   XQE2 = ZERO
24680                   EQE2 = ZERO
24681                   XPRO = ZERO
24682                   EPRO = ZERO
24683                   XPRO1= ZERO
24684                   XDEL = ZERO
24685                   EDEL = ZERO
24686                   XDQE = ZERO
24687                   EDQE = ZERO
24688                   DO 21 IC=1,NCOMPO
24689                      XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
24690                      ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
24691                      XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
24692                      EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
24693                      XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
24694                      EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
24695                      XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
24696                      EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
24697                      XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
24698                      EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
24699                      XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
24700                      EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
24701                      XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
24702                      EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
24703                      XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
24704                      EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
24705                      YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
24706      &                     -XSQEP(1,1,IC)-XSQET(1,1,IC)
24707      &                     -XSQE2(1,1,IC)
24708                      XPRO1= XPRO1+EMUFRA(IC)*YPRO
24709    21             CONTINUE
24710                   ETOT = SQRT(ETOT)
24711                   EELA = SQRT(EELA)
24712                   EQEP = SQRT(EQEP)
24713                   EQET = SQRT(EQET)
24714                   EQE2 = SQRT(EQE2)
24715                   EPRO = SQRT(EPRO)
24716                   EDEL = SQRT(EDEL)
24717                   EDQE = SQRT(EDQE)
24718                   WRITE(LOUT,'(8E9.3)')
24719      &               E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
24720 C                 WRITE(LOUT,'(4E9.3)')
24721 C    &               E,XDEL,XDQE,XDEL+XDQE
24722                ELSE
24723                   WRITE(LOUT,'(11E10.3)')
24724      &              E,
24725      &              XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
24726      &              XSQE2(1,1,1),XSPRO(1,1,1),
24727      &              XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
24728      &             -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
24729      &              XSDEL(1,1,1)+XSDQE(1,1,1)
24730 C                 WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
24731 C    &                                    XSDEL(1,1,1)+XSDQE(1,1,1)
24732                ENDIF
24733 c            ELSE
24734 c               IF (LLAB) THEN
24735 c                  IF (IT.GT.1) THEN
24736 c                     IF (IXSQEL.EQ.0) THEN
24737 cC                       CALL DT_SIGGA(IT,  Q2, E,ZERO,ZERO,
24738 cC                       CALL DT_SIGGA(IT,   E,Q2,ZERO,ZERO,
24739 c                        CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
24740 c     &                             STOT,ETOT,SIN,EIN,STOT0)
24741 c                        IF (IRATIO.EQ.1) THEN
24742 c                           CALL DT_SIGGP(  Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
24743 cC                          CALL DT_SIGGP(   E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
24744 cC                          CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
24745 c*!! save cross sections
24746 c                           STOTA = STOT
24747 c                           ETOTA = ETOT
24748 c                           STOTP = STGP
24749 c*!!
24750 c                           STOT  = STOT/(DBLE(IT)*STGP)
24751 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
24752 c                           STOT0 = STGP
24753 c                           ETOT  = ZERO
24754 c                           EIN   = ZERO
24755 c                        ENDIF
24756 c                     ELSE
24757 c                        WRITE(LOUT,*)
24758 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
24759 c                        STOP
24760 c                     ENDIF
24761 c                  ELSE
24762 c                     ETOT = ZERO
24763 c                     EIN  = ZERO
24764 c                     STOT0= ZERO
24765 c                     IF (IXSQEL.EQ.0) THEN
24766 c                        CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
24767 c                     ELSE
24768 c                       SIN = ZERO
24769 c                       CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
24770 c                     ENDIF
24771 c                  ENDIF
24772 c               ELSE
24773 c                  IF (IT.GT.1) THEN
24774 c                     IF (IXSQEL.EQ.0) THEN
24775 c                        CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
24776 c     &                             STOT,ETOT,SIN,EIN,STOT0)
24777 c                        IF (IRATIO.EQ.1) THEN
24778 c                           CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
24779 c*!! save cross sections
24780 c                           STOTA = STOT
24781 c                           ETOTA = ETOT
24782 c                           STOTP = STGP
24783 c*!!
24784 c                           STOT  = STOT/(DBLE(IT)*STGP)
24785 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
24786 c                           STOT0 = STGP
24787 c                           ETOT  = ZERO
24788 c                           EIN   = ZERO
24789 c                        ENDIF
24790 c                     ELSE
24791 c                        WRITE(LOUT,*)
24792 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
24793 c                        STOP
24794 c                     ENDIF
24795 c                  ELSE
24796 c                     ETOT = ZERO
24797 c                     EIN  = ZERO
24798 c                     STOT0= ZERO
24799 c                     IF (IXSQEL.EQ.0) THEN
24800 c                        CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
24801 c                     ELSE
24802 c                       SIN = ZERO
24803 c                       CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
24804 c                     ENDIF
24805 c                  ENDIF
24806 c               ENDIF
24807 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
24808 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
24809 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
24810 c               WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
24811 c            ENDIF
24812     2    CONTINUE
24813     1 CONTINUE
24814
24815       RETURN
24816       END
24817
24818 *$ CREATE DT_TESTXS.FOR
24819 *COPY DT_TESTXS
24820 *
24821 *===testxs=============================================================*
24822 *
24823       SUBROUTINE DT_TESTXS
24824
24825       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24826       SAVE
24827
24828       DIMENSION XSTOT(26,2),XSELA(26,2)
24829
24830       OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
24831       OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
24832       OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
24833       OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
24834       DUMECM = 0.0D0
24835       PLABL = 0.01D0
24836       PLABH = 10000.0D0
24837       NBINS = 120
24838       APLABL = LOG10(PLABL)
24839       APLABH = LOG10(PLABH)
24840       ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
24841       DO 1 I=1,NBINS+1
24842          ADP = APLABL+DBLE(I-1)*ADPLAB
24843          P = 10.0D0**ADP
24844          DO 2 J=1,26
24845             CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
24846             CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
24847     2    CONTINUE
24848          WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
24849          WRITE(11,1000) P,(XSELA(K,1),K=1,26)
24850          WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
24851          WRITE(13,1000) P,(XSELA(K,2),K=1,26)
24852     1 CONTINUE
24853  1000 FORMAT(F8.3,26F9.3)
24854
24855       RETURN
24856       END
24857 ************************************************************************
24858 *                                                                      *
24859 *  DTUNUC 2.0:   library routines                                      *
24860 *                                   processed by S. Roesler, 6.5.95    *
24861 *                                                                      *
24862 ************************************************************************
24863 *
24864 *     1) Handling of parton momenta
24865 *          SUBROUTINE MASHEL
24866 *          SUBROUTINE DFERMI
24867 *
24868 *     2) Handling of parton flavors and particle indices
24869 *          INTEGER FUNCTION IPDG2B
24870 *          INTEGER FUNCTION IB2PDG
24871 *          INTEGER FUNCTION IQUARK
24872 *          INTEGER FUNCTION IBJQUA
24873 *          INTEGER FUNCTION ICIHAD
24874 *          INTEGER FUNCTION IPDGHA
24875 *          INTEGER FUNCTION MCHAD
24876 *          SUBROUTINE FLAHAD
24877 *
24878 *     3) Energy-momentum and quantum number conservation check routines
24879 *          SUBROUTINE EMC1
24880 *          SUBROUTINE EMC2
24881 *          SUBROUTINE EVTEMC
24882 *          SUBROUTINE EVTFLC
24883 *          SUBROUTINE EVTCHG
24884 *
24885 *     4) Transformations
24886 *          SUBROUTINE LTINI
24887 *          SUBROUTINE LTRANS
24888 *          SUBROUTINE LTNUC
24889 *          SUBROUTINE DALTRA
24890 *          SUBROUTINE DTRAFO
24891 *          SUBROUTINE STTRAN
24892 *          SUBROUTINE MYTRAN
24893 *          SUBROUTINE LT2LAO
24894 *          SUBROUTINE LT2LAB
24895 *
24896 *     5) Sampling from distributions
24897 *          INTEGER FUNCTION NPOISS
24898 *          DOUBLE PRECISION FUNCTION SAMPXB
24899 *          DOUBLE PRECISION FUNCTION SAMPEX
24900 *          DOUBLE PRECISION FUNCTION SAMSQX
24901 *          DOUBLE PRECISION FUNCTION BETREJ
24902 *          DOUBLE PRECISION FUNCTION DGAMRN
24903 *          DOUBLE PRECISION FUNCTION DBETAR
24904 *          SUBROUTINE RANNOR
24905 *          SUBROUTINE DPOLI
24906 *          SUBROUTINE DSFECF
24907 *          SUBROUTINE RACO
24908 *
24909 *     6) Special functions, algorithms and service routines
24910 *          DOUBLE PRECISION FUNCTION YLAMB
24911 *          SUBROUTINE SORT
24912 *          SUBROUTINE SORT1
24913 *          SUBROUTINE DT_XTIME
24914 *
24915 *     7) Random number generator package
24916 *          DOUBLE PRECISION FUNCTION DT_RNDM
24917 *          SUBROUTINE DT_RNDMST
24918 *          SUBROUTINE DT_RNDMIN
24919 *          SUBROUTINE DT_RNDMOU
24920 *          SUBROUTINE DT_RNDMTE
24921 *
24922 ************************************************************************
24923 *                                                                      *
24924 *                 1) Handling of parton momenta                        *
24925 *                                                                      *
24926 ************************************************************************
24927 *$ CREATE DT_MASHEL.FOR
24928 *COPY DT_MASHEL
24929 *
24930 *===mashel=============================================================*
24931 *
24932       SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
24933
24934 ************************************************************************
24935 *                                                                      *
24936 *    rescaling of momenta of two partons to put both                   *
24937 *                                       on mass shell                  *
24938 *                                                                      *
24939 *    input:       PA1,PA2   input momentum vectors                     *
24940 *                 XM1,2     desired masses of particles afterwards     *
24941 *                 P1,P2     changed momentum vectors                   *
24942 *                                                                      *
24943 * The original version is written by R. Engel.                         *
24944 * This version dated 12.12.94 is modified by S. Roesler.               *
24945 ************************************************************************
24946
24947       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24948       SAVE
24949
24950       PARAMETER ( LINP = 10 ,
24951      &            LOUT = 6 ,
24952      &            LDAT = 9 )
24953
24954       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
24955
24956       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
24957
24958       IREJ = 0
24959
24960 * Lorentz transformation into system CMS
24961       PX  = PA1(1)+PA2(1)
24962       PY  = PA1(2)+PA2(2)
24963       PZ  = PA1(3)+PA2(3)
24964       EE  = PA1(4)+PA2(4)
24965       XPTOT = SQRT(PX**2+PY**2+PZ**2)
24966       XMS   = (EE-XPTOT)*(EE+XPTOT)
24967       IF(XMS.LT.(XM1+XM2)**2) THEN
24968 C        WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
24969          GOTO 9999
24970       ENDIF
24971       XMS = SQRT(XMS)
24972       BGX = PX/XMS
24973       BGY = PY/XMS
24974       BGZ = PZ/XMS
24975       GAM = EE/XMS
24976       CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
24977      &           PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
24978 * rotation angles
24979       COD = P1(3)/PTOT1
24980 C     SID = SQRT((ONE-COD)*(ONE+COD))
24981       PPT = SQRT(P1(1)**2+P1(2)**2)
24982       SID = PPT/PTOT1
24983       COF = ONE
24984       SIF = ZERO
24985       IF(PTOT1*SID.GT.TINY10) THEN
24986          COF   = P1(1)/(SID*PTOT1)
24987          SIF   = P1(2)/(SID*PTOT1)
24988          ANORF = SQRT(COF*COF+SIF*SIF)
24989          COF   = COF/ANORF
24990          SIF   = SIF/ANORF
24991       ENDIF
24992 * new CM momentum and energies (for masses XM1,XM2)
24993       XM12 = SIGN(XM1**2,XM1)
24994       XM22 = SIGN(XM2**2,XM2)
24995       SS   = XMS**2
24996       PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
24997       EE1  = SQRT(XM12+PCMP**2)
24998       EE2  = XMS-EE1
24999 * back rotation
25000       MODE = 1
25001       CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
25002       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
25003      &            PTOT1,P1(1),P1(2),P1(3),P1(4))
25004       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
25005      &            PTOT2,P2(1),P2(2),P2(3),P2(4))
25006 * check consistency
25007       DEL = XMS*0.0001D0
25008       IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
25009         IDEV = 1
25010       ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
25011         IDEV = 2
25012       ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
25013         IDEV = 3
25014       ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
25015         IDEV = 4
25016       ELSE
25017         IDEV = 0
25018       ENDIF
25019       IF (IDEV.NE.0) THEN
25020          WRITE(LOUT,'(/1X,A,I3)')
25021      &      'MASHEL: inconsistent transformation',IDEV
25022          WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25023          WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25024          WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25025          WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25026          WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25027          WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25028       ENDIF
25029       RETURN
25030
25031  9999 CONTINUE
25032       IREJ = 1
25033       RETURN
25034       END
25035
25036 *$ CREATE DT_DFERMI.FOR
25037 *COPY DT_DFERMI
25038 *
25039 *===dfermi=============================================================*
25040 *
25041       SUBROUTINE DT_DFERMI(GPART)
25042
25043 ************************************************************************
25044 * Find largest of three random numbers.                                *
25045 ************************************************************************
25046
25047       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25048       SAVE
25049
25050       DIMENSION G(3)
25051
25052       DO 10 I=1,3
25053         G(I)=DT_RNDM(GPART)
25054    10 CONTINUE
25055       IF (G(3).LT.G(2)) GOTO 40
25056       IF (G(3).LT.G(1)) GOTO 30
25057       GPART = G(3)
25058    20 RETURN
25059    30 GPART = G(1)
25060       GOTO 20
25061    40 IF (G(2).LT.G(1)) GOTO 30
25062       GPART = G(2)
25063       GOTO 20
25064
25065       END
25066
25067 ************************************************************************
25068 *                                                                      *
25069 *         2) Handling of parton flavors and particle indices           *
25070 *                                                                      *
25071 ************************************************************************
25072 *$ CREATE IDT_IPDG2B.FOR
25073 *COPY IDT_IPDG2B
25074 *
25075 *===ipdg2b=============================================================*
25076 *
25077       INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25078
25079 ************************************************************************
25080 *                                                                      *
25081 *     conversion of quark numbering scheme                             *
25082 *                                                                      *
25083 *     input:   PDG parton numbering                                    *
25084 *              for diquarks:  NN number of the constituent quark       *
25085 *                             (e.g. ID=2301,NN=1 -> ICONV2=1)          *
25086 *                                                                      *
25087 *     output:  BAMJET particle codes                                   *
25088 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
25089 *              2 d     8 a-d             -2 a-d                        *
25090 *              3 s     9 a-s             -3 a-s                        *
25091 *              4 c    10 a-c             -4 a-c                        *
25092 *                                                                      *
25093 * This is a modified version of ICONV2 written by R. Engel.            *
25094 * This version dated 13.12.94 is written by S. Roesler.                *
25095 ************************************************************************
25096
25097       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25098       SAVE
25099
25100       PARAMETER ( LINP = 10 ,
25101      &            LOUT = 6 ,
25102      &            LDAT = 9 )
25103
25104       IDA = ABS(ID)
25105 * diquarks
25106       IF (IDA.GT.6) THEN
25107         KF  = 3
25108         IF (IDA.GE.1000) KF = 4
25109         IDA = IDA/(10**(KF-NN))
25110         IDA = MOD(IDA,10)
25111       ENDIF
25112 * exchange up and dn quarks
25113       IF (IDA.EQ.1) THEN
25114         IDA = 2
25115       ELSEIF (IDA.EQ.2) THEN
25116         IDA = 1
25117       ENDIF
25118 * antiquarks
25119       IF (ID.LT.0) THEN
25120          IF (MODE.EQ.1) THEN
25121             IDA = IDA+6
25122          ELSE
25123             IDA = -IDA
25124          ENDIF
25125       ENDIF
25126       IDT_IPDG2B = IDA
25127
25128       RETURN
25129       END
25130
25131 *$ CREATE IDT_IB2PDG.FOR
25132 *COPY IDT_IB2PDG
25133 *
25134 *===ib2pdg=============================================================*
25135 *
25136       INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25137
25138 ************************************************************************
25139 *                                                                      *
25140 *     conversion of quark numbering scheme                             *
25141 *                                                                      *
25142 *     input:   BAMJET particle codes                                   *
25143 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
25144 *              2 d     8 a-d             -2 a-d                        *
25145 *              3 s     9 a-s             -3 a-s                        *
25146 *              4 c    10 a-c             -4 a-c                        *
25147 *                                                                      *
25148 *     output:  PDG parton numbering                                    *
25149 *                                                                      *
25150 * This version dated 13.12.94 is written by S. Roesler.                *
25151 ************************************************************************
25152
25153       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25154       SAVE
25155
25156       PARAMETER ( LINP = 10 ,
25157      &            LOUT = 6 ,
25158      &            LDAT = 9 )
25159
25160       DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25161       DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25162       DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25163      &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25164      &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25165
25166       IDA = ID1
25167       IDB = ID2
25168       IF (MODE.EQ.1) THEN
25169          IF (ID1.GT.6) IDA = -(ID1-6)
25170          IF (ID2.GT.6) IDB = -(ID2-6)
25171       ENDIF
25172       IF (ID2.EQ.0) THEN
25173          IDT_IB2PDG = IHKKQ(IDA)
25174       ELSE
25175          IDT_IB2PDG = IHKKQQ(IDA,IDB)
25176       ENDIF
25177
25178       RETURN
25179       END
25180
25181 *$ CREATE IDT_IQUARK.FOR
25182 *COPY IDT_IQUARK
25183 *
25184 *===ipdgqu=============================================================*
25185 *
25186       INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25187
25188 ************************************************************************
25189 *                                                                      *
25190 *     quark contents according to PDG conventions                      *
25191 *     (random selection in case of quark mixing)                       *
25192 *                                                                      *
25193 *     input:   IDBAMJ BAMJET particle code                             *
25194 *              K      1..3   quark number                              *
25195 *                                                                      *
25196 *     output:  1   d  (anti --> neg.)                                  *
25197 *              2   u                                                   *
25198 *              3   s                                                   *
25199 *              4   c                                                   *
25200 *                                                                      *
25201 * This version written by R. Engel.                                    *
25202 ************************************************************************
25203
25204       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25205       SAVE
25206
25207       IQ = IDT_IBJQUA(K,IDBAMJ)
25208 * quark-antiquark
25209       IF (IQ.GT.6) THEN
25210          IQ = 6-IQ
25211       ENDIF
25212 * exchange of up and down
25213       IF (ABS(IQ).EQ.1) THEN
25214          IQ = SIGN(2,IQ)
25215       ELSEIF (ABS(IQ).EQ.2) THEN
25216          IQ = SIGN(1,IQ)
25217       ENDIF
25218       IDT_IQUARK = IQ
25219
25220       RETURN
25221       END
25222
25223 *$ CREATE IDT_IBJQUA.FOR
25224 *COPY IDT_IBJQUA
25225 *
25226 *===ibamq==============================================================*
25227 *
25228       INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25229
25230 ************************************************************************
25231 *                                                                      *
25232 *     quark contents according to BAMJET conventions                   *
25233 *     (random selection in case of quark mixing)                       *
25234 *                                                                      *
25235 *     input:   IDBAMJ BAMJET particle code                             *
25236 *              K      1..3   quark number                              *
25237 *                                                                      *
25238 *     output:  1   u      7   u bar                                    *
25239 *              2   d      8   d bar                                    *
25240 *              3   s      9   s bar                                    *
25241 *              4   c     10   c bar                                    *
25242 *                                                                      *
25243 * This version written by R. Engel.                                    *
25244 ************************************************************************
25245
25246       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25247       SAVE
25248
25249       DIMENSION ITAB(3,210)
25250       DATA ((ITAB(I,K),I=1,3),K=1,30) /
25251      &    1,  1,  2,   7,  7,  8,   0,  0,  0,
25252      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25253      &    0,  0,  0,   1,  2,  2,   7,  8,  8,
25254 *sr 10.1.94
25255 C    &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25256      &    0,  0,  0,   0,  0,  0,   3,  8,  0,
25257 *
25258      &    1,  8,  0,   2,  7,  0,   1,  9,  0,
25259 *sr 10.1.94
25260 C    &    3,  7,  0,   0,  0,  0,   0,  0,  0,
25261      &    3,  7,  0,   3,  1,  2,   9,  7,  8,
25262 *sr 10.1.94
25263 C    &    0,  0,  0,   2,  2,  3,   1,  1,  3,
25264      &    2,  9,  0,   2,  2,  3,   1,  1,  3,
25265 *
25266      &    1,  2,  3, 201,202,  0,   2,  9,  0,
25267      &    3,  8,  0,   0,  0,  0,   0,  0,  0,
25268      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25269       DATA ((ITAB(I,K),I=1,3),K=31,60) /
25270      &    3,  9,  0,   1,  8,  0, 203,204,  0,
25271      &    2,  7,  0,   0,  0,  0,   1,  9,  0,
25272      &    2,  9,  0,   3,  7,  0,   3,  8,  0,
25273      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25274      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25275      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25276      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25277      &    0,  0,  0,   1,  1,  1,   1,  1,  2,
25278      &    1,  2,  2,   2,  2,  2,   0,  0,  0,
25279      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25280       DATA ((ITAB(I,K),I=1,3),K=61,90) /
25281      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25282      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25283      &    7,  7,  7,   7,  7,  8,   7,  8,  8,
25284      &    8,  8,  8,   0,  0,  0,   0,  0,  0,
25285      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25286      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25287      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25288      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25289      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25290      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25291       DATA ((ITAB(I,K),I=1,3),K=91,120) /
25292      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25293      &    0,  0,  0,   0,  0,  0,   3,  9,  0,
25294      &    1,  3,  3,   2,  3,  3,   7,  7,  9,
25295      &    7,  8,  9,   8,  8,  9,   7,  9,  9,
25296      &    8,  9,  9,   1,  1,  3,   1,  2,  3,
25297      &    2,  2,  3,   1,  3,  3,   2,  3,  3,
25298      &    3,  3,  3,   7,  7,  9,   7,  8,  9,
25299      &    8,  8,  9,   7,  9,  9,   8,  9,  9,
25300      &    9,  9,  9,   4,  7,  0,   4,  8,  0,
25301      &    2, 10,  0,   1, 10,  0,   4,  9,  0 /
25302       DATA ((ITAB(I,K),I=1,3),K=121,150) /
25303      &    3, 10,  0,   4, 10,  0,   4,  7,  0,
25304      &    4,  8,  0,   2, 10,  0,   1, 10,  0,
25305      &    4,  9,  0,   3, 10,  0,   4, 10,  0,
25306      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25307      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25308      &    0,  0,  0,   1,  2,  4,   1,  3,  4,
25309      &    2,  3,  4,   1,  1,  4,   0,  0,  0,
25310      &    2,  2,  4,   0,  0,  0,   0,  0,  0,
25311      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
25312      &    3,  4,  4,   7,  8, 10,   7,  9, 10 /
25313       DATA ((ITAB(I,K),I=1,3),K=151,180) /
25314      &    8,  9, 10,   7,  7, 10,   0,  0,  0,
25315      &    8,  8, 10,   0,  0,  0,   0,  0,  0,
25316      &    9,  9, 10,   7, 10, 10,   8, 10, 10,
25317      &    9, 10, 10,   1,  1,  4,   1,  2,  4,
25318      &    2,  2,  4,   1,  3,  4,   2,  3,  4,
25319      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
25320      &    3,  4,  4,   4,  4,  4,   7,  7, 10,
25321      &    7,  8, 10,   8,  8, 10,   7,  9, 10,
25322      &    8,  9, 10,   9,  9, 10,   7, 10, 10,
25323      &    8, 10, 10,   9, 10, 10,  10, 10, 10 /
25324       DATA ((ITAB(I,K),I=1,3),K=181,210) /
25325      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25326      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25327      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25328      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25329      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25330      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25331      &    0,  0,  0,   0,  0,  0,   1,  7,  0,
25332      &    2,  8,  0,   1,  7,  0,   2,  8,  0,
25333      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25334      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25335       DATA IDOLD /0/
25336
25337       ONE = 1.0D0
25338       IF (ITAB(1,IDBAMJ).LE.200) THEN
25339          ID = ITAB(K,IDBAMJ)
25340       ELSE
25341          IF(IDOLD.NE.IDBAMJ) THEN
25342             IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25343      &           DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25344         ELSE
25345            IDOLD = 0
25346         ENDIF
25347         ID = ITAB(K,IT)
25348       ENDIF
25349       IDOLD  = IDBAMJ
25350       IDT_IBJQUA = ID
25351
25352       RETURN
25353       END
25354
25355 *$ CREATE IDT_ICIHAD.FOR
25356 *COPY IDT_ICIHAD
25357 *
25358 *===icihad=============================================================*
25359 *
25360       INTEGER FUNCTION IDT_ICIHAD(MCIND)
25361
25362 ************************************************************************
25363 * Conversion of particle index PDG proposal --> BAMJET-index scheme    *
25364 * This is a completely new version dated 25.10.95.                     *
25365 * Renamed to be not in conflict with the modified PHOJET-version       *
25366 ************************************************************************
25367
25368       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25369       SAVE
25370
25371 * hadron index conversion (BAMJET <--> PDG)
25372       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25373      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25374      &                IAMCIN(210)
25375
25376       IDT_ICIHAD = 0
25377       KPDG   = ABS(MCIND)
25378       IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25379       IF (MCIND.LT.0) THEN
25380          JSIGN = 1
25381       ELSE
25382          JSIGN = 2
25383       ENDIF
25384       IF (KPDG.GE.10000) THEN
25385          DO 1 I=1,19
25386             IDT_ICIHAD = IBAM5(JSIGN,I)
25387             IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25388             IDT_ICIHAD = 0
25389     1    CONTINUE
25390       ELSEIF (KPDG.GE.1000) THEN
25391          DO 2 I=1,29
25392             IDT_ICIHAD = IBAM4(JSIGN,I)
25393             IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25394             IDT_ICIHAD = 0
25395     2    CONTINUE
25396       ELSEIF (KPDG.GE.100) THEN
25397          DO 3 I=1,22
25398             IDT_ICIHAD = IBAM3(JSIGN,I)
25399             IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25400             IDT_ICIHAD = 0
25401     3    CONTINUE
25402       ELSEIF (KPDG.GE.10) THEN
25403          DO 4 I=1,7
25404             IDT_ICIHAD = IBAM2(JSIGN,I)
25405             IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25406             IDT_ICIHAD = 0
25407     4    CONTINUE
25408       ENDIF
25409     5 CONTINUE
25410
25411       RETURN
25412       END
25413
25414 *$ CREATE IDT_IPDGHA.FOR
25415 *COPY IDT_IPDGHA
25416 *
25417 *===ipdgha=============================================================*
25418 *
25419       INTEGER FUNCTION IDT_IPDGHA(MCIND)
25420
25421 ************************************************************************
25422 * Conversion of particle index BAMJET-index scheme --> PDG proposal    *
25423 * Adopted from the original by S. Roesler. This version dated 12.5.95  *
25424 * Renamed to be not in conflict with the modified PHOJET-version       *
25425 ************************************************************************
25426
25427       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25428       SAVE
25429
25430 * hadron index conversion (BAMJET <--> PDG)
25431       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25432      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25433      &                IAMCIN(210)
25434
25435       IDT_IPDGHA = IAMCIN(MCIND)
25436
25437       RETURN
25438       END
25439
25440 *$ CREATE DT_FLAHAD.FOR
25441 *COPY DT_FLAHAD
25442 *
25443 *===flahad=============================================================*
25444 *
25445       SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25446
25447 ************************************************************************
25448 * sampling of FLAvor composition for HADrons/photons                   *
25449 *              ID         BAMJET-id of hadron                          *
25450 *              IF1,2,3    flavor content                               *
25451 *                         (u,d,s: 1,2,3;  au,ad,as: -1,-1,-3)          *
25452 * Note:  -  u,d numbering as in BAMJET                                 *
25453 *        -  ID .le. 30 !!                                              *
25454 * This version dated 12.03.96 is written by S. Roesler                 *
25455 ************************************************************************
25456
25457       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25458       SAVE
25459
25460 * auxiliary common for reggeon exchange (DTUNUC 1.x)
25461       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25462      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25463      &                IQTCHR(-6:6),MQUARK(3,39)
25464
25465       DIMENSION JSEL(3,6)
25466       DATA JSEL/ 1,2,3,  2,3,1,  3,1,2,  1,3,2,   2,1,3,   3,2,1/
25467
25468       ONE = 1.0D0
25469       IF (ID.EQ.7) THEN
25470 * photon (charge dependent flavour sampling)
25471          K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25472          IF (K.LE.4) THEN
25473             IF1 = 2
25474             IF2 = -2
25475          ELSE IF(K.EQ.5) THEN
25476             IF1 = 1
25477             IF2 = -1
25478          ELSE
25479             IF1 = 3
25480             IF2 = -3
25481          ENDIF
25482          IF(DT_RNDM(ONE).LT.0.5D0) THEN
25483             K   = IF1
25484             IF1 = IF2
25485             IF2 = K
25486          ENDIF
25487          IF3 = 0
25488       ELSE
25489 * hadron
25490          IX  = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25491          IF1 = MQUARK(JSEL(1,IX),ID)
25492          IF2 = MQUARK(JSEL(2,IX),ID)
25493          IF3 = MQUARK(JSEL(3,IX),ID)
25494          IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25495             IF1 = IF3
25496             IF3 = 0
25497          ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25498             IF2 = IF3
25499             IF3 = 0
25500          ENDIF
25501       ENDIF
25502
25503       RETURN
25504       END
25505
25506 *$ CREATE IDT_MCHAD.FOR
25507 *COPY IDT_MCHAD
25508 *
25509 *===mchad==============================================================*
25510 *
25511       INTEGER FUNCTION IDT_MCHAD(ITDTU)
25512
25513 ************************************************************************
25514 * Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25515 * Adopted from the original by S. Roesler. This version dated 6.5.95   *
25516 *                                                                      *
25517 * Last change 28.12.2006 by S. Roesler.                                *
25518 ************************************************************************
25519
25520       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25521       SAVE
25522
25523       DIMENSION ITRANS(210)
25524       DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25525      &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25526      &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25527      &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25528      &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25529      &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25530      &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25531
25532       IF ( ITDTU .GT. 0 ) THEN
25533          IDT_MCHAD = ITRANS(ITDTU)
25534       ELSE
25535          IDT_MCHAD = -1
25536       END IF
25537
25538       RETURN
25539       END
25540
25541 ************************************************************************
25542 *                                                                      *
25543 *   3) Energy-momentum and quantum number conservation check routines  *
25544 *                                                                      *
25545 ************************************************************************
25546 *$ CREATE DT_EMC1.FOR
25547 *COPY DT_EMC1
25548 *
25549 *===emc1===============================================================*
25550 *
25551       SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25552
25553 ************************************************************************
25554 * This version dated 15.12.94 is written by S. Roesler                 *
25555 ************************************************************************
25556
25557       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25558       SAVE
25559
25560       PARAMETER ( LINP = 10 ,
25561      &            LOUT = 6 ,
25562      &            LDAT = 9 )
25563
25564       PARAMETER (TINY10=1.0D-10)
25565
25566       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25567
25568       IREJ = 0
25569
25570       IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25571      &   WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25572
25573       IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25574          IF (MODE.EQ.1) THEN
25575             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25576          ELSEIF (MODE.EQ.2) THEN
25577             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25578          ENDIF
25579          CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25580          CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25581          CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25582       ELSEIF (MODE.LT.0) THEN
25583          IF (MODE.EQ.-1) THEN
25584             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
25585          ELSEIF (MODE.EQ.-2) THEN
25586             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
25587          ENDIF
25588          CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
25589          CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
25590          CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
25591       ENDIF
25592
25593       IF (ABS(MODE).EQ.3) THEN
25594          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25595          IF (IREJ1.NE.0) GOTO 9999
25596       ENDIF
25597       RETURN
25598
25599  9999 CONTINUE
25600       IREJ = 1
25601       RETURN
25602       END
25603
25604 *$ CREATE DT_EMC2.FOR
25605 *COPY DT_EMC2
25606 *
25607 *===emc2===============================================================*
25608 *
25609       SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25610      &                                                MODE,IPOS,IREJ)
25611
25612 ************************************************************************
25613 *             MODE = 1   energy-momentum cons. check                   *
25614 *                  = 2   flavor-cons. check                            *
25615 *                  = 3   energy-momentum & flavor cons. check          *
25616 *                  = 4   energy-momentum & charge cons. check          *
25617 *                  = 5   energy-momentum & flavor & charge cons. check *
25618 * This version dated 16.01.95 is written by S. Roesler                 *
25619 ************************************************************************
25620
25621       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25622       SAVE
25623
25624       PARAMETER ( LINP = 10 ,
25625      &            LOUT = 6 ,
25626      &            LDAT = 9 )
25627
25628       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25629
25630 * event history
25631
25632       PARAMETER (NMXHKK=200000)
25633
25634       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25635      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25636      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25637
25638 * extended event history
25639       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25640      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25641      &                IHIST(2,NMXHKK)
25642
25643       IREJ  = 0
25644       IREJ1 = 0
25645       IREJ2 = 0
25646       IREJ3 = 0
25647
25648       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25649      &                CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25650       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25651      &                                CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25652       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25653       DO 1 I=1,NHKK
25654          IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25655      &       (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25656      &       (ISTHKK(I).EQ.IP5))                          THEN
25657             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25658      &                                    .OR.(MODE.EQ.5))
25659      &      CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25660      &                                               2,IDUM,IDUM)
25661             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25662      &         CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25663             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25664      &                            CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25665          ENDIF
25666          IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25667      &       (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25668      &       (ISTHKK(I).EQ.IN5))                          THEN
25669             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25670      &                                    .OR.(MODE.EQ.5))
25671      &      CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25672      &                                                   2,IDUM,IDUM)
25673             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25674      &         CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25675             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25676      &                            CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
25677          ENDIF
25678     1 CONTINUE
25679       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25680      &   CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
25681       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25682      &   CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
25683       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
25684       IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
25685
25686       RETURN
25687
25688  9999 CONTINUE
25689       IREJ = 1
25690       RETURN
25691       END
25692
25693 *$ CREATE DT_EVTEMC.FOR
25694 *COPY DT_EVTEMC
25695 *
25696 *===evtemc=============================================================*
25697 *
25698       SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
25699
25700 ************************************************************************
25701 * This version dated 13.12.94 is written by S. Roesler                 *
25702 ************************************************************************
25703
25704       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25705       SAVE
25706
25707       PARAMETER ( LINP = 10 ,
25708      &            LOUT = 6 ,
25709      &            LDAT = 9 )
25710
25711       PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
25712      &           ZERO=0.0D0)
25713
25714 * event history
25715
25716       PARAMETER (NMXHKK=200000)
25717
25718       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25719      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25720      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25721
25722 * flags for input different options
25723       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
25724       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
25725      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
25726
25727       IREJ = 0
25728
25729       MODE = IMODE
25730       CHKLEV = TINY10
25731       IF (MODE.EQ.4) THEN
25732          CHKLEV = TINY2
25733          MODE   = 3
25734       ELSEIF (MODE.EQ.5) THEN
25735          CHKLEV = TINY1
25736          MODE   = 3
25737       ELSEIF (MODE.EQ.-1) THEN
25738          CHKLEV = EIO
25739          MODE   = 3
25740       ENDIF
25741
25742       IF (ABS(MODE).EQ.3) THEN
25743          PXDEV = PX
25744          PYDEV = PY
25745          PZDEV = PZ
25746          EDEV  = E
25747          IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
25748          IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
25749      &       (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
25750             IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
25751      &         'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
25752      &         '  event  ',NEVHKK,
25753      &         ' ! ',PXDEV,PYDEV,PZDEV,EDEV
25754             PX   = 0.0D0
25755             PY   = 0.0D0
25756             PZ   = 0.0D0
25757             E    = 0.0D0
25758             GOTO 9999
25759          ENDIF
25760          PX   = 0.0D0
25761          PY   = 0.0D0
25762          PZ   = 0.0D0
25763          E    = 0.0D0
25764          RETURN
25765       ENDIF
25766
25767       IF (MODE.EQ.1) THEN
25768          PX = 0.0D0
25769          PY = 0.0D0
25770          PZ = 0.0D0
25771          E  = 0.0D0
25772       ENDIF
25773
25774       PX = PX+PXIO
25775       PY = PY+PYIO
25776       PZ = PZ+PZIO
25777       E  = E+EIO
25778
25779       RETURN
25780
25781  9999 CONTINUE
25782       IREJ = 1
25783       RETURN
25784       END
25785
25786 *$ CREATE DT_EVTFLC.FOR
25787 *COPY DT_EVTFLC
25788 *
25789 *===evtflc=============================================================*
25790 *
25791       SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
25792
25793 ************************************************************************
25794 * Flavor conservation check.                                           *
25795 *        ID       identity of particle                                 *
25796 *        ID1 = 1  ID for q,aq,qq,aqaq in PDG-numbering scheme          *
25797 *            = 2  ID for particle/resonance in BAMJET numbering scheme *
25798 *            = 3  ID for particle/resonance in PDG    numbering scheme *
25799 *        MODE = 1 initialization and add ID                            *
25800 *             =-1 initialization and subtract ID                       *
25801 *             = 2 add ID                                               *
25802 *             =-2 subtract ID                                          *
25803 *             = 3 check flavor cons.                                   *
25804 *        IPOS     flag to give position of call of EVTFLC to output    *
25805 *                 unit in case of violation                            *
25806 * This version dated 10.01.95 is written by S. Roesler                 *
25807 ************************************************************************
25808
25809       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25810       SAVE
25811
25812       PARAMETER ( LINP = 10 ,
25813      &            LOUT = 6 ,
25814      &            LDAT = 9 )
25815
25816       PARAMETER (TINY10=1.0D-10)
25817
25818       IREJ = 0
25819
25820       IF (MODE.EQ.3) THEN
25821          IF (IFL.NE.0) THEN
25822             WRITE(LOUT,'(1X,A,I3,A,I3)')
25823      &         'EVTFLC: flavor-conservation failure at pos. ',IPOS,
25824      &         ' !  IFL = ',IFL
25825             IFL = 0
25826             GOTO 9999
25827          ENDIF
25828          IFL = 0
25829          RETURN
25830       ENDIF
25831
25832       IF (MODE.EQ.1) IFL = 0
25833       IF (ID.EQ.0)   RETURN
25834
25835       IF (ID1.EQ.1) THEN
25836          IDD = ABS(ID)
25837          NQ  = 1
25838          IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
25839          IF (IDD.GE.1000) NQ = 3
25840          DO 1 I=1,NQ
25841             IFBAM = IDT_IPDG2B(ID,I,2)
25842             IF (ABS(IFBAM).EQ.1) THEN
25843                IFBAM = SIGN(2,IFBAM)
25844             ELSEIF (ABS(IFBAM).EQ.2) THEN
25845                IFBAM = SIGN(1,IFBAM)
25846             ENDIF
25847             IF (MODE.GT.0) THEN
25848                IFL = IFL+IFBAM
25849             ELSE
25850                IFL = IFL-IFBAM
25851             ENDIF
25852     1    CONTINUE
25853          RETURN
25854       ENDIF
25855
25856       IDD = ID
25857       IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
25858       IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
25859          DO 2 I=1,3
25860             IF (MODE.GT.0) THEN
25861                IFL = IFL+IDT_IQUARK(I,IDD)
25862             ELSE
25863                IFL = IFL-IDT_IQUARK(I,IDD)
25864             ENDIF
25865     2    CONTINUE
25866       ENDIF
25867       RETURN
25868
25869  9999 CONTINUE
25870       IREJ = 1
25871       RETURN
25872       END
25873
25874 *$ CREATE DT_EVTCHG.FOR
25875 *COPY DT_EVTCHG
25876 *
25877 *===evtchg=============================================================*
25878 *
25879       SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
25880
25881 ************************************************************************
25882 * Charge conservation check.                                           *
25883 *        ID       identity of particle (PDG-numbering scheme)          *
25884 *        MODE = 1 initialization                                       *
25885 *             =-2 subtract ID-charge                                   *
25886 *             = 2 add ID-charge                                        *
25887 *             = 3 check charge cons.                                   *
25888 *        IPOS     flag to give position of call of EVTCHG to output    *
25889 *                 unit in case of violation                            *
25890 * This version dated 10.01.95 is written by S. Roesler                 *
25891 * Last change: s.r. 21.01.01                                           *
25892 ************************************************************************
25893
25894       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25895       SAVE
25896
25897       PARAMETER ( LINP = 10 ,
25898      &            LOUT = 6 ,
25899      &            LDAT = 9 )
25900
25901 * event history
25902
25903       PARAMETER (NMXHKK=200000)
25904
25905       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25906      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25907      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25908
25909 * particle properties (BAMJET index convention)
25910       CHARACTER*8  ANAME
25911       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
25912      &                IICH(210),IIBAR(210),K1(210),K2(210)
25913
25914       IREJ = 0
25915
25916       IF (MODE.EQ.1) THEN
25917          ICH  = 0
25918          IBAR = 0
25919          RETURN
25920       ENDIF
25921
25922       IF (MODE.EQ.3) THEN
25923          IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
25924             WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
25925      &         'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
25926      &         '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
25927             ICH  = 0
25928             IBAR = 0
25929             GOTO 9999
25930          ENDIF
25931          ICH  = 0
25932          IBAR = 0
25933          RETURN
25934       ENDIF
25935
25936       IF (ID.EQ.0)   RETURN
25937
25938       IDD = IDT_ICIHAD(ID)
25939 * modification 21.1.01: use intrinsic phojet-functions to determine charge
25940 * and baryon number
25941 C     IF (IDD.GT.0) THEN
25942 C        IF (MODE.EQ.2) THEN
25943 C           ICH  = ICH+IICH(IDD)
25944 C           IBAR = IBAR+IIBAR(IDD)
25945 C        ELSEIF (MODE.EQ.-2) THEN
25946 C           ICH  = ICH-IICH(IDD)
25947 C           IBAR = IBAR-IIBAR(IDD)
25948 C        ENDIF
25949 C     ELSE
25950 C        WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
25951 C        CALL DT_EVTOUT(4)
25952 C        STOP
25953 C     ENDIF
25954       IF (MODE.EQ.2) THEN
25955          ICH  = ICH+IPHO_CHR3(ID,1)/3
25956          IBAR = IBAR+IPHO_BAR3(ID,1)/3
25957       ELSEIF (MODE.EQ.-2) THEN
25958          ICH  = ICH-IPHO_CHR3(ID,1)/3
25959          IBAR = IBAR-IPHO_BAR3(ID,1)/3
25960       ENDIF
25961
25962       RETURN
25963
25964  9999 CONTINUE
25965       IREJ = 1
25966       RETURN
25967       END
25968
25969 ************************************************************************
25970 *                                                                      *
25971 *                 4) Transformations                                   *
25972 *                                                                      *
25973 ************************************************************************
25974 *$ CREATE DT_LTINI.FOR
25975 *COPY DT_LTINI
25976 *
25977 *===ltini==============================================================*
25978 *
25979       SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
25980
25981 ************************************************************************
25982 * Initializations of Lorentz-transformations, calculation of Lorentz-  *
25983 * parameters.                                                          *
25984 * This version dated 13.11.95 is written by  S. Roesler.               *
25985 ************************************************************************
25986
25987       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25988       SAVE
25989
25990       PARAMETER ( LINP = 10 ,
25991      &            LOUT = 6 ,
25992      &            LDAT = 9 )
25993
25994       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
25995      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
25996
25997 * Lorentz-parameters of the current interaction
25998       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
25999      &                UMO,PPCM,EPROJ,PPROJ
26000
26001 * properties of photon/lepton projectiles
26002       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
26003
26004 * particle properties (BAMJET index convention)
26005       CHARACTER*8  ANAME
26006       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26007      &                IICH(210),IIBAR(210),K1(210),K2(210)
26008
26009 * nucleon-nucleon event-generator
26010       CHARACTER*8 CMODEL
26011       LOGICAL LPHOIN
26012       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26013
26014       Q2   = VIRT
26015       IDP  = IDPR
26016       IF (MCGENE.NE.3) THEN
26017 * lepton-projectiles and PHOJET: initialize real photon instead
26018          IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26019      &       (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26020      &       (IDPR.EQ. 5).OR.(IDPR.EQ. 6))   THEN
26021             IDP = 7
26022             Q2  = ZERO
26023          ENDIF
26024       ENDIF
26025       IDT  = IDTA
26026       EPN  = EPN0
26027       PPN  = PPN0
26028       ECM  = ECM0
26029       AMP  = AAM(IDP)-SQRT(ABS(Q2))
26030       AMT  = AAM(IDT)
26031       AMP2 = SIGN(AMP**2,AMP)
26032       AMT2 = AMT**2
26033       IF (ECM0.GT.ZERO) THEN
26034          EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26035          IF (AMP2.GT.ZERO) THEN
26036             PPN = SQRT((EPN+AMP)*(EPN-AMP))
26037          ELSE
26038             PPN = SQRT(EPN**2-AMP2)
26039          ENDIF
26040       ELSE
26041          IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26042             IF (IDP.EQ.7) EPN = ABS(EPN)
26043             IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26044             IF (AMP2.GT.ZERO) THEN
26045                PPN = SQRT((EPN+AMP)*(EPN-AMP))
26046             ELSE
26047                PPN = SQRT(EPN**2-AMP2)
26048             ENDIF
26049          ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26050             IF (AMP2.GT.ZERO) THEN
26051                EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26052             ELSE
26053                EPN = SQRT(PPN**2+AMP2)
26054             ENDIF
26055          ENDIF
26056          ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26057       ENDIF
26058       UMO   = ECM
26059       EPROJ = EPN
26060       PPROJ = PPN
26061       IF (AMP2.GT.ZERO) THEN
26062          ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26063          PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26064       ELSE
26065          ETARG = TINY10
26066          PTARG = TINY10
26067       ENDIF
26068 * photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26069       IF (IDP.EQ.7) THEN
26070          PGAMM(1) = ZERO
26071          PGAMM(2) = ZERO
26072          AMGAM  = AMP
26073          AMGAM2 = AMP2
26074          IF (ECM0.GT.ZERO) THEN
26075             S = ECM0**2
26076          ELSE
26077             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26078                S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26079             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26080                S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26081             ENDIF
26082          ENDIF
26083          PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26084      &                     +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26085          PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26086          IF (MODE.EQ.1) THEN
26087             PNUCL(1) = ZERO
26088             PNUCL(2) = ZERO
26089             PNUCL(3) = -PGAMM(3)
26090             PNUCL(4) = SQRT(S)-PGAMM(4)
26091          ENDIF
26092       ENDIF
26093       IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26094      &    (IDPR.EQ.10).OR.(IDPR.EQ.11))   THEN
26095          PLEPT0(1) = ZERO
26096          PLEPT0(2) = ZERO
26097 * neglect lepton masses
26098 C        AMLPT2   = AAM(IDPR)**2
26099          AMLPT2   = ZERO
26100 *
26101          IF (ECM0.GT.ZERO) THEN
26102             S = ECM0**2
26103          ELSE
26104             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26105                S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26106             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26107                S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26108             ENDIF
26109          ENDIF
26110          PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26111      &                     +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26112          PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26113          PNUCL(1) = ZERO
26114          PNUCL(2) = ZERO
26115          PNUCL(3) = -PLEPT0(3)
26116          PNUCL(4) = SQRT(S)-PLEPT0(4)
26117       ENDIF
26118 * Lorentz-parameter for transformation Lab. - projectile rest system
26119       IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26120          GALAB = TINY10
26121          BGLAB = TINY10
26122          BLAB  = TINY10
26123       ELSE
26124          GALAB = EPROJ/AMP
26125          BGLAB = PPROJ/AMP
26126          BLAB  = BGLAB/GALAB
26127       ENDIF
26128 * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26129       IF (IDP.EQ.7) THEN
26130          GACMS(1) = TINY10
26131          BGCMS(1) = TINY10
26132       ELSE
26133          GACMS(1) = (ETARG+AMP)/UMO
26134          BGCMS(1) = PTARG/UMO
26135       ENDIF
26136 * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26137       GACMS(2) = (EPROJ+AMT)/UMO
26138       BGCMS(2) = PPROJ/UMO
26139       PPCM     = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26140
26141       EPN0 = EPN
26142       PPN0 = PPN
26143       ECM0 = ECM
26144
26145       RETURN
26146       END
26147
26148 *$ CREATE DT_LTRANS.FOR
26149 *COPY DT_LTRANS
26150 *
26151 *===ltrans=============================================================*
26152 *
26153       SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26154
26155 ************************************************************************
26156 * Lorentz-transformations.                                             *
26157 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
26158 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
26159 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
26160 * This version dated 01.11.95 is written by  S. Roesler.               *
26161 ************************************************************************
26162
26163       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26164       SAVE
26165
26166       PARAMETER ( LINP = 10 ,
26167      &            LOUT = 6 ,
26168      &            LDAT = 9 )
26169
26170       PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26171
26172       PARAMETER (SQTINF=1.0D+15)
26173
26174 * particle properties (BAMJET index convention)
26175       CHARACTER*8  ANAME
26176       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26177      &                IICH(210),IIBAR(210),K1(210),K2(210)
26178
26179       PXO = PXI
26180       PYO = PYI
26181       CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26182
26183 * check particle mass for consistency (numerical rounding errors)
26184       PO     = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26185       AMO2   = (PEO-PO)*(PEO+PO)
26186       AMORQ2 = AAM(ID)**2
26187       AMDIF2 = ABS(AMO2-AMORQ2)
26188       IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26189          DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26190          PEO   = PEO+DELTA
26191          PO1   = PO -DELTA
26192          PXO   = PXO*PO1/PO
26193          PYO   = PYO*PO1/PO
26194          PZO   = PZO*PO1/PO
26195 C        WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26196       ENDIF
26197
26198       RETURN
26199       END
26200
26201 *$ CREATE DT_LTNUC.FOR
26202 *COPY DT_LTNUC
26203 *
26204 *===ltnuc==============================================================*
26205 *
26206       SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26207
26208 ************************************************************************
26209 * Lorentz-transformations.                                             *
26210 *   PIN        longitudnal momentum       (input)                      *
26211 *   EIN        energy                     (input)                      *
26212 *   POUT       transformed long. momentum (output)                     *
26213 *   EOUT       transformed energy         (output)                     *
26214 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
26215 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
26216 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
26217 * This version dated 01.11.95 is written by  S. Roesler.               *
26218 ************************************************************************
26219
26220       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26221       SAVE
26222
26223       PARAMETER ( LINP = 10 ,
26224      &            LOUT = 6 ,
26225      &            LDAT = 9 )
26226
26227       PARAMETER (ZERO=0.0D0)
26228
26229 * Lorentz-parameters of the current interaction
26230       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26231      &                UMO,PPCM,EPROJ,PPROJ
26232
26233       BDUM1 = ZERO
26234       BDUM2 = ZERO
26235       PDUM1 = ZERO
26236       PDUM2 = ZERO
26237       IF (ABS(MODE).EQ.1) THEN
26238          BG = -SIGN(BGLAB,DBLE(MODE))
26239          CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26240      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26241       ELSEIF (ABS(MODE).EQ.2) THEN
26242          BG = SIGN(BGCMS(1),DBLE(MODE))
26243          CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26244      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26245       ELSEIF (ABS(MODE).EQ.3) THEN
26246          BG = -SIGN(BGCMS(2),DBLE(MODE))
26247          CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26248      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26249       ELSE
26250          WRITE(LOUT,1000) MODE
26251  1000    FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26252          EOUT = EIN
26253          POUT = PIN
26254       ENDIF
26255
26256       RETURN
26257       END
26258
26259 *$ CREATE DT_DALTRA.FOR
26260 *COPY DT_DALTRA
26261 *
26262 *===daltra=============================================================*
26263 *
26264       SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26265
26266 ************************************************************************
26267 * Arbitrary Lorentz-transformation.                                    *
26268 * Adopted from the original by S. Roesler. This version dated 15.01.95 *
26269 ************************************************************************
26270
26271       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26272       SAVE
26273       PARAMETER (ONE=1.0D0)
26274
26275       EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26276       PE = EP/(GA+ONE)+EC
26277       PX = PCX+BGX*PE
26278       PY = PCY+BGY*PE
26279       PZ = PCZ+BGZ*PE
26280       P  = SQRT(PX*PX+PY*PY+PZ*PZ)
26281       E  = GA*EC+EP
26282
26283       RETURN
26284       END
26285
26286 *$ CREATE DT_DTRAFO.FOR
26287 *COPY DT_DTRAFO
26288 *
26289 *====dtrafo============================================================*
26290 *
26291       SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26292      &                                    PL,CXL,CYL,CZL,EL)
26293
26294 C     LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26295
26296       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26297       SAVE
26298
26299       IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26300       SID  = SQRT(1.D0-COD*COD)
26301       PLX  = P*SID*COF
26302       PLY  = P*SID*SIF
26303       PCMZ = P*COD
26304       PLZ  = GAM*PCMZ+BGAM*ECM
26305       PL   = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26306       EL   = GAM*ECM+BGAM*PCMZ
26307 C     ROTATION INTO THE ORIGINAL DIRECTION
26308       COZ  = PLZ/PL
26309       SIZ  = SQRT(1.D0-COZ**2)
26310       CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26311
26312       RETURN
26313       END
26314
26315 *$ CREATE DT_STTRAN.FOR
26316 *COPY DT_STTRAN
26317 *
26318 *====sttran============================================================*
26319 *
26320       SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26321
26322       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26323       SAVE
26324       DATA ANGLSQ/1.D-30/
26325 ************************************************************************
26326 *     VERSION BY                     J. RANFT                          *
26327 *                                    LEIPZIG                           *
26328 *                                                                      *
26329 *     THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES      *
26330 *                                                                      *
26331 *     INPUT VARIABLES:                                                 *
26332 *        XO,YO,ZO = ORIGINAL DIRECTION COSINES                         *
26333 *        CDE,SDE  = COSINE AND SINE OF THE POLAR (THETA)               *
26334 *                   ANGLE OF "SCATTERING"                              *
26335 *        SDE      = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING"    *
26336 *        SFE,CFE  = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE       *
26337 *                   OF "SCATTERING"                                    *
26338 *                                                                      *
26339 *     OUTPUT VARIABLES:                                                *
26340 *        X,Y,Z     = NEW DIRECTION COSINES                             *
26341 *                                                                      *
26342 *     ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 )                  *
26343 ************************************************************************
26344 *
26345 *
26346 *  Changed by A. Ferrari
26347 *
26348 *     IF (ABS(XO)-0.0001D0) 1,1,2
26349 *   1 IF (ABS(YO)-0.0001D0) 3,3,2
26350 *   3 CONTINUE
26351       A = XO**2 + YO**2
26352       IF ( A .LT. ANGLSQ ) THEN
26353          X=SDE*CFE
26354          Y=SDE*SFE
26355          Z=CDE*ZO
26356       ELSE
26357          XI=SDE*CFE
26358          YI=SDE*SFE
26359          ZI=CDE
26360          A=SQRT(A)
26361          X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26362          Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26363          Z=A*YI+ZO*ZI
26364       ENDIF
26365
26366       RETURN
26367       END
26368
26369 *$ CREATE DT_MYTRAN.FOR
26370 *COPY DT_MYTRAN
26371 *
26372 *===mytran=============================================================*
26373 *
26374       SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26375
26376 ************************************************************************
26377 * This subroutine rotates the coordinate frame                         *
26378 *    a) theta  around y                                                *
26379 *    b) phi    around z      if IMODE = 1                              *
26380 *                                                                      *
26381 *     x'          cos(ph) -sin(ph) 0      cos(th)  0  sin(th)   x      *
26382 *     y' = A B =  sin(ph) cos(ph)  0  .   0        1        0   y      *
26383 *     z'          0       0        1     -sin(th)  0  cos(th)   z      *
26384 *                                                                      *
26385 * and vice versa if IMODE = 0.                                         *
26386 * This version dated 5.4.94 is based on the original version DTRAN     *
26387 * by J. Ranft and is written by S. Roesler.                            *
26388 ************************************************************************
26389
26390       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26391       SAVE
26392
26393       PARAMETER ( LINP = 10 ,
26394      &            LOUT = 6 ,
26395      &            LDAT = 9 )
26396
26397       IF (IMODE.EQ.1) THEN
26398          X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26399          Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26400          Z=-SDE    *XO       +CDE    *ZO
26401       ELSE
26402          X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26403          Y= -SFE*XO+CFE*YO
26404          Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26405       ENDIF
26406       RETURN
26407       END
26408
26409 *$ CREATE DT_LT2LAO.FOR
26410 *COPY DT_LT2LAO
26411 *
26412 *===lt2lab=============================================================*
26413 *
26414       SUBROUTINE DT_LT2LAO
26415
26416 ************************************************************************
26417 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
26418 * for final state particles/fragments defined in nucleon-nucleon-cms   *
26419 * and transforms them back to the lab.                                 *
26420 * This version dated 16.11.95 is written by S. Roesler                 *
26421 ************************************************************************
26422
26423       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26424       SAVE
26425
26426       PARAMETER ( LINP = 10 ,
26427      &            LOUT = 6 ,
26428      &            LDAT = 9 )
26429
26430 * event history
26431
26432       PARAMETER (NMXHKK=200000)
26433
26434       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26435      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26436      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26437
26438 * extended event history
26439       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26440      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26441      &                IHIST(2,NMXHKK)
26442
26443       NEND      = NHKK
26444       NPOINT(5) = NHKK+1
26445       IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26446       DO 1 I=NPOINT(4),NEND
26447 C     DO 1 I=1,NEND
26448          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26449      &                                (ISTHKK(I).EQ.1001)) THEN
26450             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26451             NOB = NOBAM(I)
26452             CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26453      &                            PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26454             IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26455                ISTHKK(I) = 3*ISTHKK(I)
26456                NOBAM(NHKK)  = NOB
26457             ELSE
26458                IF (ISTHKK(I).EQ.-1) NOBAM(NHKK)  = NOB
26459                ISTHKK(I) = SIGN(3,ISTHKK(I))
26460             ENDIF
26461             JDAHKK(1,I) = NHKK
26462          ENDIF
26463     1 CONTINUE
26464
26465       RETURN
26466       END
26467
26468 *$ CREATE DT_LT2LAB.FOR
26469 *COPY DT_LT2LAB
26470 *
26471 *===lt2lab=============================================================*
26472 *
26473       SUBROUTINE DT_LT2LAB
26474
26475 ************************************************************************
26476 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
26477 * for final state particles/fragments defined in nucleon-nucleon-cms   *
26478 * and transforms them to the lab.                                      *
26479 * This version dated 07.01.96 is written by S. Roesler                 *
26480 ************************************************************************
26481
26482       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26483       SAVE
26484
26485       PARAMETER ( LINP = 10 ,
26486      &            LOUT = 6 ,
26487      &            LDAT = 9 )
26488
26489 * event history
26490
26491       PARAMETER (NMXHKK=200000)
26492
26493       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26494      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26495      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26496
26497 * extended event history
26498       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26499      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26500      &                IHIST(2,NMXHKK)
26501
26502       IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26503       DO 1 I=NPOINT(4),NHKK
26504          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26505      &                                (ISTHKK(I).EQ.1001)) THEN
26506             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26507             PHKK(3,I) = PZ
26508             PHKK(4,I) = PE
26509          ENDIF
26510     1 CONTINUE
26511
26512       RETURN
26513       END
26514
26515 ************************************************************************
26516 *                                                                      *
26517 *                 5) Sampling from distributions                       *
26518 *                                                                      *
26519 ************************************************************************
26520 *$ CREATE IDT_NPOISS.FOR
26521 *COPY IDT_NPOISS
26522 *
26523 *===npoiss=============================================================*
26524 *
26525       INTEGER FUNCTION IDT_NPOISS(AVN)
26526
26527 ************************************************************************
26528 * Sample according to Poisson distribution with Poisson parameter AVN. *
26529 * The original version written by J. Ranft.                            *
26530 * This version dated 11.1.95 is written by S. Roesler.                 *
26531 ************************************************************************
26532
26533       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26534       SAVE
26535
26536       PARAMETER ( LINP = 10 ,
26537      &            LOUT = 6 ,
26538      &            LDAT = 9 )
26539
26540       EXPAVN = EXP(-AVN)
26541       K = 1
26542       A = 1.0D0
26543
26544    10 CONTINUE
26545       A = DT_RNDM(A)*A
26546       IF (A.GE.EXPAVN) THEN
26547          K = K+1
26548          GOTO 10
26549       ENDIF
26550       IDT_NPOISS = K-1
26551
26552       RETURN
26553       END
26554
26555 *$ CREATE DT_SAMPXB.FOR
26556 *COPY DT_SAMPXB
26557 *
26558 *===sampxb=============================================================*
26559 *
26560       DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26561
26562 ************************************************************************
26563 * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2.             *
26564 * Processed by S. Roesler, 6.5.95                                      *
26565 ************************************************************************
26566
26567       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26568       SAVE
26569       PARAMETER (TWO=2.0D0)
26570
26571       A1 = LOG(X1+SQRT(X1**2+B**2))
26572       A2 = LOG(X2+SQRT(X2**2+B**2))
26573       AN = A2-A1
26574       A  = AN*DT_RNDM(A1)+A1
26575       BB = EXP(A)
26576       DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26577
26578       RETURN
26579       END
26580
26581 *$ CREATE DT_SAMPEX.FOR
26582 *COPY DT_SAMPEX
26583 *
26584 *===sampex=============================================================*
26585 *
26586       DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26587
26588 ************************************************************************
26589 * Sampling from f(x)=1./x between x1 and x2.                           *
26590 * Processed by S. Roesler, 6.5.95                                      *
26591 ************************************************************************
26592
26593       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26594       SAVE
26595       PARAMETER (ONE=1.0D0)
26596
26597       R   = DT_RNDM(X1)
26598       AL1 = LOG(X1)
26599       AL2 = LOG(X2)
26600       DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26601
26602       RETURN
26603       END
26604
26605 *$ CREATE DT_SAMSQX.FOR
26606 *COPY DT_SAMSQX
26607 *
26608 *===samsqx=============================================================*
26609 *
26610       DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26611
26612 ************************************************************************
26613 * Sampling from f(x)=1./x^0.5 between x1 and x2.                       *
26614 * Processed by S. Roesler, 6.5.95                                      *
26615 ************************************************************************
26616
26617       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26618       SAVE
26619       PARAMETER (ONE=1.0D0)
26620
26621       R = DT_RNDM(X1)
26622       DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26623
26624       RETURN
26625       END
26626
26627 *$ CREATE DT_SAMPLW.FOR
26628 *COPY DT_SAMPLW
26629 *
26630 *===samplw=============================================================*
26631 *
26632       DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26633
26634 ************************************************************************
26635 * Sampling from f(x)=1/x^b between x_min and x_max.                    *
26636 * S. Roesler, 18.4.98                                                  *
26637 ************************************************************************
26638
26639       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26640       SAVE
26641       PARAMETER (ONE=1.0D0)
26642
26643       R = DT_RNDM(B)
26644       IF (B.EQ.ONE) THEN
26645          DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26646       ELSE
26647          ONEMB  = ONE-B
26648          DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26649       ENDIF
26650
26651       RETURN
26652       END
26653
26654 *$ CREATE DT_BETREJ.FOR
26655 *COPY DT_BETREJ
26656 *
26657 *===betrej=============================================================*
26658 *
26659       DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26660
26661       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26662       SAVE
26663
26664       PARAMETER ( LINP = 10 ,
26665      &            LOUT = 6 ,
26666      &            LDAT = 9 )
26667
26668       PARAMETER (ONE=1.0D0)
26669
26670       IF (XMIN.GE.XMAX)THEN
26671          WRITE (LOUT,500) XMIN,XMAX
26672   500    FORMAT(1X,'DT_BETREJ:  XMIN<XMAX execution stopped ',2F10.5)
26673          STOP
26674       ENDIF
26675
26676    10 CONTINUE
26677       XX     = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26678       BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26679       YY     = BETMAX*DT_RNDM(XX)
26680       BETXX  = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26681       IF (YY.GT.BETXX) GOTO 10
26682       DT_BETREJ = XX
26683
26684       RETURN
26685       END
26686
26687 *$ CREATE DT_DGAMRN.FOR
26688 *COPY DT_DGAMRN
26689 *
26690 *===dgamrn=============================================================*
26691 *
26692       DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26693
26694 ************************************************************************
26695 * Sampling from Gamma-distribution.                                    *
26696 *       F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)            *
26697 * Processed by S. Roesler, 6.5.95                                      *
26698 ************************************************************************
26699
26700       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26701       SAVE
26702       PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
26703
26704       NCOU = 0
26705       N    = INT(ETA)
26706       F    = ETA-DBLE(N)
26707       IF (F.EQ.ZERO) GOTO 20
26708    10 R = DT_RNDM(F)
26709       NCOU = NCOU+1
26710       IF (NCOU.GE.11) GOTO 20
26711       IF (R.LT.F/(F+2.71828D0)) GOTO 30
26712       YYY = LOG(DT_RNDM(R)+TINY9)/F
26713       IF (ABS(YYY).GT.50.0D0) GOTO 20
26714       Y = EXP(YYY)
26715       IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
26716       GOTO 40
26717    20 Y = 0.0D0
26718       GOTO 50
26719    30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
26720       IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
26721    40 IF (N.EQ.0) GOTO 70
26722    50 Z = 1.0D0
26723       DO 60 I = 1,N
26724    60 Z = Z*DT_RNDM(Z)
26725       Y = Y-LOG(Z+TINY9)
26726    70 DT_DGAMRN = Y/ALAM
26727
26728       RETURN
26729       END
26730
26731 *$ CREATE DT_DBETAR.FOR
26732 *COPY DT_DBETAR
26733 *
26734 *===dbetar=============================================================*
26735 *
26736       DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
26737
26738 ************************************************************************
26739 * Sampling from Beta -distribution between 0.0 and 1.0                 *
26740 *  F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
26741 * Processed by S. Roesler, 6.5.95                                      *
26742 ************************************************************************
26743
26744       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26745       SAVE
26746
26747       Y = DT_DGAMRN(1.0D0,GAM)
26748       Z = DT_DGAMRN(1.0D0,ETA)
26749       DT_DBETAR = Y/(Y+Z)
26750
26751       RETURN
26752       END
26753
26754 *$ CREATE DT_RANNOR.FOR
26755 *COPY DT_RANNOR
26756 *
26757 *===rannor=============================================================*
26758 *
26759       SUBROUTINE DT_RANNOR(X,Y)
26760
26761 ************************************************************************
26762 * Sampling from Gaussian distribution.                                 *
26763 * Processed by S. Roesler, 6.5.95                                      *
26764 ************************************************************************
26765
26766       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26767       SAVE
26768       PARAMETER (TINY10=1.0D-10)
26769
26770       CALL DT_DSFECF(SFE,CFE)
26771       V = MAX(TINY10,DT_RNDM(X))
26772       A = SQRT(-2.D0*LOG(V))
26773       X = A*SFE
26774       Y = A*CFE
26775
26776       RETURN
26777       END
26778
26779 *$ CREATE DT_DPOLI.FOR
26780 *COPY DT_DPOLI
26781 *
26782 *===dpoli==============================================================*
26783 *
26784       SUBROUTINE DT_DPOLI(CS,SI)
26785
26786       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26787       SAVE
26788
26789       U  = DT_RNDM(CS)
26790       CS = DT_RNDM(U)
26791       IF (U.LT.0.5D0) CS=-CS
26792       SI = SQRT(1.0D0-CS*CS+1.0D-10)
26793
26794       RETURN
26795       END
26796
26797 *$ CREATE DT_DSFECF.FOR
26798 *COPY DT_DSFECF
26799 *
26800 *===dsfecf=============================================================*
26801 *
26802       SUBROUTINE DT_DSFECF(SFE,CFE)
26803
26804       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26805       SAVE
26806       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
26807
26808     1 CONTINUE
26809       X  = DT_RNDM(SFE)
26810       Y  = DT_RNDM(X)
26811       XX = X*X
26812       YY = Y*Y
26813       XY = XX+YY
26814       IF (XY.GT.ONE) GOTO 1
26815       CFE = (XX-YY)/XY
26816       SFE = TWO*X*Y/XY
26817       IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
26818       RETURN
26819       END
26820
26821 *$ CREATE DT_RACO.FOR
26822 *COPY DT_RACO
26823 *
26824 *===raco===============================================================*
26825 *
26826       SUBROUTINE DT_RACO(WX,WY,WZ)
26827
26828 ************************************************************************
26829 * Direction cosines of random uniform (isotropic) direction in three   *
26830 * dimensional space                                                    *
26831 * Processed by S. Roesler, 20.11.95                                    *
26832 ************************************************************************
26833
26834       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26835       SAVE
26836       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
26837
26838   10  CONTINUE
26839       X  = TWO*DT_RNDM(WX)-ONE
26840       Y  = DT_RNDM(X)
26841       X2 = X*X
26842       Y2 = Y*Y
26843       IF (X2+Y2.GT.ONE) GOTO 10
26844
26845       CFE = (X2-Y2)/(X2+Y2)
26846       SFE = TWO*X*Y/(X2+Y2)
26847 * z = 1/2 [ 1 + cos (theta) ]
26848       Z   = DT_RNDM(X)
26849 * 1/2 sin (theta)
26850       WZ = SQRT(Z*(ONE-Z))
26851       WX = TWO*WZ*CFE
26852       WY = TWO*WZ*SFE
26853       WZ = TWO*Z-ONE
26854
26855       RETURN
26856       END
26857
26858 ************************************************************************
26859 *                                                                      *
26860 *           6) Special functions, algorithms and service routines      *
26861 *                                                                      *
26862 ************************************************************************
26863 *$ CREATE DT_YLAMB.FOR
26864 *COPY DT_YLAMB
26865 *
26866 *===ylamb==============================================================*
26867 *
26868       DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
26869
26870 ************************************************************************
26871 *                                                                      *
26872 *     auxiliary function for three particle decay mode                 *
26873 *     (standard LAMBDA**(1/2) function)                                *
26874 *                                                                      *
26875 * Adopted from an original version written by R. Engel.                *
26876 * This version dated 12.12.94 is written by S. Roesler.                *
26877 ************************************************************************
26878
26879       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26880       SAVE
26881
26882       YZ   = Y-Z
26883       XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
26884       IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
26885       DT_YLAMB = SQRT(XLAM)
26886
26887       RETURN
26888       END
26889
26890 *$ CREATE DT_SORT.FOR
26891 *COPY DT_SORT
26892 *
26893 *===sort1==============================================================*
26894 *
26895       SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
26896
26897 ************************************************************************
26898 * This subroutine sorts entries in A in increasing/decreasing order    *
26899 * of A(3,i).                                                           *
26900 *              MODE  = 1     increasing in A(3,i=1..N)                 *
26901 *                    = 2     decreasing in A(3,i=1..N)                 *
26902 * This version dated 21.04.95 is revised by S. Roesler                 *
26903 ************************************************************************
26904
26905       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26906       SAVE
26907
26908       DIMENSION A(3,N)
26909
26910       M = I1
26911    10 CONTINUE
26912       M = I1-1
26913       IF (M.LE.0) RETURN
26914       L = 0
26915       DO 20 I=I0,M
26916          J = I+1
26917          IF (MODE.EQ.1) THEN
26918             IF (A(3,I).LE.A(3,J)) GOTO 20
26919          ELSE
26920             IF (A(3,I).GE.A(3,J)) GOTO 20
26921          ENDIF
26922          B = A(3,I)
26923          C = A(1,I)
26924          D = A(2,I)
26925          A(3,I) = A(3,J)
26926          A(2,I) = A(2,J)
26927          A(1,I) = A(1,J)
26928          A(3,J) = B
26929          A(1,J) = C
26930          A(2,J) = D
26931          L = 1
26932    20 CONTINUE
26933       IF (L.EQ.1) GOTO 10
26934
26935       RETURN
26936       END
26937
26938 *$ CREATE DT_SORT1.FOR
26939 *COPY DT_SORT1
26940 *
26941 *===sort1==============================================================*
26942 *
26943       SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
26944
26945 ************************************************************************
26946 * This subroutine sorts entries in A in increasing/decreasing order    *
26947 * of A(i).                                                             *
26948 *              MODE  = 1     increasing in A(i=1..N)                   *
26949 *                    = 2     decreasing in A(i=1..N)                   *
26950 * This version dated 21.04.95 is revised by S. Roesler                 *
26951 ************************************************************************
26952
26953       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26954       SAVE
26955
26956       DIMENSION A(N),IDX(N)
26957
26958       M = I1
26959    10 CONTINUE
26960       M = I1-1
26961       IF (M.LE.0) RETURN
26962       L = 0
26963       DO 20 I=I0,M
26964          J = I+1
26965          IF (MODE.EQ.1) THEN
26966             IF (A(I).LE.A(J)) GOTO 20
26967          ELSE
26968             IF (A(I).GE.A(J)) GOTO 20
26969          ENDIF
26970          B    = A(I)
26971          A(I) = A(J)
26972          A(J) = B
26973          IX     = IDX(I)
26974          IDX(I) = IDX(J)
26975          IDX(J) = IX
26976          L = 1
26977    20 CONTINUE
26978       IF (L.EQ.1) GOTO 10
26979
26980       RETURN
26981       END
26982
26983 *$ CREATE DT_XTIME.FOR
26984 *COPY DT_XTIME
26985 *
26986 *===xtime==============================================================*
26987 *
26988       SUBROUTINE DT_XTIME
26989
26990       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26991       SAVE
26992
26993       PARAMETER ( LINP = 10 ,
26994      &            LOUT = 6 ,
26995      &            LDAT = 9 )
26996
26997       CHARACTER DAT*9,TIM*11
26998
26999       DAT = '         '
27000       TIM = '           '
27001 C     CALL GETDAT(IYEAR,IMONTH,IDAY)
27002 C     CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
27003
27004 C     CALL DATE(DAT)
27005 C     CALL TIME(TIM)
27006 C     WRITE(LOUT,1000) DAT,TIM
27007  1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
27008
27009       RETURN
27010       END
27011
27012 ************************************************************************
27013 *                                                                      *
27014 *                 7) Random number generator package                   *
27015 *                                                                      *
27016 *    THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND        *
27017 *    SERVICE ROUTINES.                                                 *
27018 *    THE ALGORITHM IS FROM                                             *
27019 *      'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR'                     *
27020 *      G.MARSAGLIA, A.ZAMAN ;  FSU-SCRI-87-50                          *
27021 *    IMPLEMENTATION BY K. HAHN  DEC. 88,                               *
27022 *    THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27023 *    AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ),        *
27024 *    THE PERIOD IS ABOUT 2**144,                                       *
27025 *    TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS,            *
27026 *    THE PACKAGE CONTAINS                                              *
27027 *      FUNCTION DT_RNDM(I)                  : GENERATOR                *
27028 *      SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION           *
27029 *      SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)  : PUT SEED TO GENERATOR    *
27030 *      SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)  : TAKE SEED FROM GENERATOR *
27031 *      SUBROUTINE DT_RNDMTE(IO)             : TEST OF GENERATOR        *
27032 *---                                                                   *
27033 *    FUNCTION DT_RNDM(I)                                               *
27034 *       GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS  IN (0..1)          *
27035 *       I  - DUMMY VARIABLE, NOT USED                                  *
27036 *    SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)                             *
27037 *       INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27038 *       NA1,NA2,NA3,NB1  - VALUES FOR INITIALIZING THE GENERATOR       *
27039 *                          NA? MUST BE IN 1..178 AND NOT ALL 1         *
27040 *                          12,34,56  ARE THE STANDARD VALUES           *
27041 *                          NB1 MUST BE IN 1..168                       *
27042 *                          78  IS THE STANDARD VALUE                   *
27043 *    SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)                               *
27044 *       PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS   *
27045 *       AS AFTER THE LAST DT_RNDMOU CALL )                             *
27046 *       U(97),C,CD,CM,I,J  - SEED VALUES AS TAKEN FROM DT_RNDMOU       *
27047 *    SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)                               *
27048 *       TAKES SEED FROM GENERATOR                                      *
27049 *       U(97),C,CD,CM,I,J  - SEED VALUES                               *
27050 *    SUBROUTINE DT_RNDMTE(IO)                                          *
27051 *       TEST OF THE GENERATOR                                          *
27052 *       IO     - DEFINES OUTPUT                                        *
27053 *                  = 0  OUTPUT ONLY IF AN ERROR IS DETECTED            *
27054 *                  = 1  OUTPUT INDEPENDEND ON AN ERROR                 *
27055 *       DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO   *
27056 *       SAME STATUS                                                    *
27057 *       AS BEFORE CALL OF DT_RNDMTE                                    *
27058 ************************************************************************
27059 *$ CREATE DT_RNDM.FOR
27060 *COPY DT_RNDM
27061 *
27062 *===rndm===============================================================*
27063 *
27064 c$$$      DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27065 c$$$
27066 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27067 c$$$      SAVE
27068 c$$$
27069 c$$$* counter of calls to random number generator
27070 c$$$* uncomment if needed
27071 c$$$C     COMMON /DTRNCT/ IRNCT0,IRNCT1
27072 c$$$C     LOGICAL LFIRST
27073 c$$$C     DATA LFIRST /.TRUE./
27074 c$$$
27075 c$$$* counter of calls to random number generator
27076 c$$$* uncomment if needed
27077 c$$$C     IF (LFIRST) THEN
27078 c$$$C        IRNCT0 = 0
27079 c$$$C        IRNCT1 = 0
27080 c$$$C        LFIRST = .FALSE.
27081 c$$$C     ENDIF
27082 c$$$
27083 c$$$      DT_RNDM = FLRNDM(VDUMMY)
27084 c$$$* counter of calls to random number generator
27085 c$$$* uncomment if needed
27086 c$$$C     IRNCT1 = IRNCT1+1
27087 c$$$
27088 c$$$      RETURN
27089 c$$$      END
27090 c$$$
27091 c$$$*$ CREATE DT_RNDMST.FOR
27092 c$$$*COPY DT_RNDMST
27093 c$$$*
27094 c$$$*===rndmst=============================================================*
27095 c$$$*
27096 c$$$      SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27097 c$$$
27098 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27099 c$$$      SAVE
27100 c$$$
27101 c$$$* random number generator
27102 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27103 c$$$
27104 c$$$      MA1 = NA1
27105 c$$$      MA2 = NA2
27106 c$$$      MA3 = NA3
27107 c$$$      MB1 = NB1
27108 c$$$      I   = 97
27109 c$$$      J   = 33
27110 c$$$      DO 20 II2 = 1,97
27111 c$$$        S = 0
27112 c$$$        T = 0.5D0
27113 c$$$        DO 10 II1 = 1,24
27114 c$$$          MAT  = MOD(MOD(MA1*MA2,179)*MA3,179)
27115 c$$$          MA1  = MA2
27116 c$$$          MA2  = MA3
27117 c$$$          MA3  = MAT
27118 c$$$          MB1  = MOD(53*MB1+1,169)
27119 c$$$          IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27120 c$$$   10   T = 0.5D0*T
27121 c$$$   20 U(II2) = S
27122 c$$$      C  =   362436.0D0/16777216.0D0
27123 c$$$      CD =  7654321.0D0/16777216.0D0
27124 c$$$      CM = 16777213.0D0/16777216.0D0
27125 c$$$      RETURN
27126 c$$$      END
27127 c$$$
27128 c$$$*$ CREATE DT_RNDMIN.FOR
27129 c$$$*COPY DT_RNDMIN
27130 c$$$*
27131 c$$$*===rndmin=============================================================*
27132 c$$$*
27133 c$$$      SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27134 c$$$
27135 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27136 c$$$      SAVE
27137 c$$$
27138 c$$$* random number generator
27139 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27140 c$$$
27141 c$$$      DIMENSION UIN(97)
27142 c$$$
27143 c$$$      DO 10 KKK = 1,97
27144 c$$$   10 U(KKK) = UIN(KKK)
27145 c$$$      C  = CIN
27146 c$$$      CD = CDIN
27147 c$$$      CM = CMIN
27148 c$$$      I  = IIN
27149 c$$$      J  = JIN
27150 c$$$
27151 c$$$      RETURN
27152 c$$$      END
27153 c$$$
27154 c$$$*$ CREATE DT_RNDMOU.FOR
27155 c$$$*COPY DT_RNDMOU
27156 c$$$*
27157 c$$$*===rndmou=============================================================*
27158 c$$$*
27159 c$$$      SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
27160 c$$$
27161 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27162 c$$$      SAVE
27163 c$$$
27164 c$$$* random number generator
27165 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27166 c$$$
27167 c$$$      DIMENSION UOUT(97)
27168 c$$$
27169 c$$$      DO 10 KKK = 1,97
27170 c$$$   10 UOUT(KKK) = U(KKK)
27171 c$$$      COUT  = C
27172 c$$$      CDOUT = CD
27173 c$$$      CMOUT = CM
27174 c$$$      IOUT  = I
27175 c$$$      JOUT  = J
27176 c$$$
27177 c$$$      RETURN
27178 c$$$      END
27179 c$$$
27180 c$$$*$ CREATE DT_RNDMTE.FOR
27181 c$$$*COPY DT_RNDMTE
27182 c$$$*
27183 c$$$*===rndmte=============================================================*
27184 c$$$*
27185 c$$$      SUBROUTINE DT_RNDMTE(IO)
27186 c$$$
27187 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27188 c$$$      SAVE
27189 c$$$
27190 c$$$      DIMENSION UU(97),U(6),X(6),D(6)
27191 c$$$      DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27192 c$$$     +8354498.D0, 10633180.D0/
27193 c$$$
27194 c$$$      CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27195 c$$$      CALL DT_RNDMST(12,34,56,78)
27196 c$$$      DO 10 II1 = 1,20000
27197 c$$$   10 XX = DT_RNDM(XX)
27198 c$$$      SD        = 0.0D0
27199 c$$$      DO 20 II2 = 1,6
27200 c$$$        X(II2)  = 4096.D0*(4096.D0*DT_RNDM(SD))
27201 c$$$        D(II2)  = X(II2)-U(II2)
27202 c$$$   20 SD = SD+D(II2)
27203 c$$$      CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27204 c$$$**sr 24.01.95
27205 c$$$C     IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27206 c$$$      IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27207 c$$$C        WRITE(6,1000)
27208 c$$$ 1000    FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27209 c$$$     &          ' passed')
27210 c$$$      ENDIF
27211 c$$$**
27212 c$$$      RETURN
27213 c$$$  500 FORMAT('  === TEST OF THE RANDOM-GENERATOR ===',/,
27214 c$$$     &'    EXPECTED VALUE    CALCULATED VALUE     DIFFERENCE',/, 6(F17.
27215 c$$$     &1,F20.1,F15.3,/), '  === END OF TEST ;',
27216 c$$$     &'  GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27217 c$$$      END
27218 *
27219 *$ CREATE PHO_RNDM.FOR
27220 *COPY PHO_RNDM
27221 *
27222 *===pho_rndm===========================================================*
27223 *
27224       DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27225
27226       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27227       SAVE
27228
27229       PHO_RNDM = DT_RNDM(DUMMY)
27230
27231       RETURN
27232       END
27233
27234 *$ CREATE PYR.FOR
27235 *COPY PYR
27236 *
27237 *===pyr================================================================*
27238 *
27239       DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27240
27241       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27242       SAVE
27243
27244       DUMMY = DBLE(IDUMMY)
27245       PYR = DT_RNDM(DUMMY)
27246
27247       RETURN
27248       END
27249 *$ CREATE DT_TITLE.FOR
27250 *COPY DT_TITLE
27251 *
27252 *===title==============================================================*
27253 *
27254       SUBROUTINE DT_TITLE
27255
27256       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27257       SAVE
27258
27259       PARAMETER ( LINP = 10 ,
27260      &            LOUT = 6 ,
27261      &            LDAT = 9 )
27262
27263       CHARACTER*6 CVERSI
27264       CHARACTER*11 CCHANG
27265       DATA CVERSI,CCHANG /'3.0-5 ','31 Oct 2008'/
27266
27267       CALL DT_XTIME
27268       WRITE(LOUT,1000) CVERSI,CCHANG
27269  1000 FORMAT(1X,'+-------------------------------------------------',
27270      &                  '----------------------+',/,
27271      &     1X,'|',71X,'|',/,
27272      &     1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27273      &     1X,'|',71X,'|',/,
27274      &     1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27275      &     1X,'|',71X,'|',/,
27276      &     1X,'|',12X,'Authors: Stefan Roesler   (CERN)',27X,'|',/,
27277      &     1X,'|',21X,'Ralph Engel      (FZ Karlsruhe)',19X,'|',/,
27278      &     1X,'|',21X,'Johannes Ranft   (Siegen Univ.)',19X,'|',/,
27279 C    &     1X,'|',71X,'|',/,
27280 C    &     1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27281 C    &                                              17X,'|',/,
27282      &     1X,'|',71X,'|',/,
27283      &     1X,'+-------------------------------------------------',
27284      &                '----------------------+',/,
27285      &     1X,'| Please send suggestions, bug reports, etc. to: ',
27286      &                                  'Stefan.Roesler@cern.ch |',/,
27287      &     1X,'+-------------------------------------------------',
27288      &                '----------------------+',/)
27289
27290       RETURN
27291       END
27292
27293 *$ CREATE DT_EVTINI.FOR
27294 *COPY DT_EVTINI
27295 *
27296 *===evtini=============================================================*
27297 *
27298       SUBROUTINE DT_EVTINI
27299
27300 ************************************************************************
27301 * Initialization of DTEVT1.                                            *
27302 * This version dated 15.01.94 is written by S. Roesler                 *
27303 ************************************************************************
27304
27305       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27306       SAVE
27307
27308       PARAMETER ( LINP = 10 ,
27309      &            LOUT = 6 ,
27310      &            LDAT = 9 )
27311
27312 * event history
27313
27314       PARAMETER (NMXHKK=200000)
27315
27316       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27317      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27318      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27319
27320 * extended event history
27321       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27322      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27323      &                IHIST(2,NMXHKK)
27324
27325 * event flag
27326       COMMON /DTEVNO/ NEVENT,ICASCA
27327
27328       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27329
27330 * emulsion treatment
27331       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27332      &                NCOMPO,IEMUL
27333
27334 * initialization of DTEVT1/DTEVT2
27335       NEND = NHKK
27336       IF (NEVENT.EQ.1) NEND = NMXHKK
27337       NHKK   = 0
27338       NEVHKK = NEVENT
27339       DO 1 I=1,NEND
27340          ISTHKK(I)   = 0
27341          IDHKK(I)    = 0
27342          JMOHKK(1,I) = 0
27343          JMOHKK(2,I) = 0
27344          JDAHKK(1,I) = 0
27345          JDAHKK(2,I) = 0
27346          IDRES(I)    = 0
27347          IDXRES(I)   = 0
27348          NOBAM(I)    = 0
27349          IDCH(I)     = 0
27350          IHIST(1,I)  = 0
27351          IHIST(2,I)  = 0
27352          DO 2 J=1,4
27353             PHKK(J,I) = 0.0D0
27354             VHKK(J,I) = 0.0D0
27355             WHKK(J,I) = 0.0D0
27356     2    CONTINUE
27357          PHKK(5,I) = 0.0D0
27358     1 CONTINUE
27359       DO 3 I=1,10
27360          NPOINT(I) = 0
27361     3 CONTINUE
27362       CALL DT_CHASTA(-1)
27363
27364 C* initialization of DTLTRA
27365 C      IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27366
27367       RETURN
27368       END
27369
27370 *$ CREATE DT_STATIS.FOR
27371 *COPY DT_STATIS
27372 *
27373 *===statis=============================================================*
27374 *
27375       SUBROUTINE DT_STATIS(MODE)
27376
27377 ************************************************************************
27378 * Initialization and output of run-statistics.                         *
27379 *              MODE  = 1     initialization                            *
27380 *                    = 2     output                                    *
27381 * This version dated 23.01.94 is written by S. Roesler                 *
27382 ************************************************************************
27383
27384       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27385       SAVE
27386
27387       PARAMETER ( LINP = 10 ,
27388      &            LOUT = 6 ,
27389      &            LDAT = 9 )
27390
27391       PARAMETER (TINY3=1.0D-3)
27392
27393 * statistics
27394       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27395      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27396      &                ICEVTG(8,0:30)
27397
27398 * rejection counter
27399       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27400      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27401      &                IREXCI(3),IRDIFF(2),IRINC
27402
27403 * central particle production, impact parameter biasing
27404       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27405
27406 * various options for treatment of partons (DTUNUC 1.x)
27407 * (chain recombination, Cronin,..)
27408       LOGICAL LCO2CR,LINTPT
27409       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27410      &                LCO2CR,LINTPT
27411
27412 * nucleon-nucleon event-generator
27413       CHARACTER*8 CMODEL
27414       LOGICAL LPHOIN
27415       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27416
27417 * flags for particle decays
27418       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27419      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27420      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27421
27422 * diquark-breaking mechanism
27423       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27424
27425       DIMENSION PP(4),PT(4)
27426
27427       GOTO (1,2) MODE
27428
27429 * initialization
27430     1 CONTINUE
27431
27432 *   initialize statistics counter
27433       ICREQU = 0
27434       ICSAMP = 0
27435       ICCPRO = 0
27436       ICDPR  = 0
27437       ICDTA  = 0
27438       ICRJSS = 0
27439       ICVV2S = 0
27440       DO 10 I=1,9
27441          ICRES(I)    = 0
27442          ICCHAI(1,I) = 0
27443          ICCHAI(2,I) = 0
27444    10 CONTINUE
27445 *   initialize rejection counter
27446       IRPT      = 0
27447       IRHHA     = 0
27448       LOMRES    = 0
27449       LOBRES    = 0
27450       IRFRAG    = 0
27451       IREVT     = 0
27452       IRRES(1)  = 0
27453       IRRES(2)  = 0
27454       IRCHKI(1) = 0
27455       IRCHKI(2) = 0
27456       IRCRON(1) = 0
27457       IRCRON(2) = 0
27458       IRCRON(3) = 0
27459       IRDIFF(1) = 0
27460       IRDIFF(2) = 0
27461       IRINC     = 0
27462       DO 11 I=1,5
27463          ICDIFF(I) = 0
27464    11 CONTINUE
27465       DO 12 I=1,8
27466          DO 13 J=0,30
27467             ICEVTG(I,J) = 0
27468    13    CONTINUE
27469    12 CONTINUE
27470
27471       RETURN
27472
27473 * output
27474     2 CONTINUE
27475
27476 *   statistics counter
27477       WRITE(LOUT,1000)
27478  1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27479      &       28X,'---------------------')
27480       IF (ICREQU.GT.0) THEN
27481       WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27482  1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27483      &       I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27484      &       'event',11X,F9.1)
27485       ENDIF
27486       IF (ICDIFF(1).NE.0) THEN
27487          WRITE(LOUT,1009) ICDIFF
27488  1009    FORMAT(/,1X,'diffractive events:    total   ',I8,/,49X,
27489      &          'low mass   high mass',/,24X,'single diffraction',
27490      &          7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27491       ENDIF
27492       IF (ICENTR.GT.0.AND.ICSAMP.GT.0.AND.ICCPRO.GT.0) THEN
27493          WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27494      &                    DBLE(ICSAMP)/DBLE(ICCPRO)
27495  1002    FORMAT(/,1X,'central production:',/,2X,'mean number',
27496      &          ' of sampled Glauber-events per event',9X,F9.1,/,
27497      &          2X,'fraction of production cross section',21X,F10.6)
27498       ENDIF
27499       IF (ICSAMP.GT.0) THEN
27500       WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27501      &                 DBLE(ICDTA)/DBLE(ICSAMP)
27502  1003 FORMAT(/,54X,'proj.    targ.',/,1X,'average number of wounded',
27503      &       ' nucleons after x-sampling',2(4X,F6.2))
27504       ENDIF
27505
27506       IF (MCGENE.EQ.1) THEN
27507          IF (ICSAMP.GT.0) THEN
27508          WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27509  1004    FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27510      &          ' event',3X,F9.1)
27511          IF (ISICHA.EQ.1) THEN
27512             WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27513  1005       FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27514      &             'of single chains  per event',13X,F9.1)
27515          ENDIF
27516          ENDIF
27517          IF (ICSAMP.GT.0.AND.ICREQU.GT.0) THEN
27518          WRITE(LOUT,1006)
27519  1006    FORMAT(/,1X,'chain system statistics:  (per event)',/,
27520      &       23X,'mean number of chains      mean number of chains',/,
27521      &       23X,'sampled    hadronized      having mass of a reso.')
27522          WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27523      &                     DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27524      &                     DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27525      &                  DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27526  1007    FORMAT(1X,'sea     - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27527      &          1X,'disea   - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27528      &          1X,'sea     - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27529      &          1X,'sea     - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27530      &          1X,'disea   - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27531      &          1X,'valence - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27532      &          1X,'valence - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27533      &          1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27534      &          1X,'fused chains      ',18X,F4.1,17X,F4.1,/)
27535          WRITE(LOUT,1008)
27536      &     (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27537      &     DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27538      &     DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27539      &     (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27540      &     (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27541      &     DBLE(IRHHA)/DBLE(ICREQU),
27542      &     DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27543      &     (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27544  1008    FORMAT(/,1X,'Rejection counter:  (NEVT = no. of events)',/,/,
27545      &       1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27546      &       F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27547      &       'Intrins. p_t (GETSPT)',21X,'IRPT     /NEVT = ',F7.2,/,
27548      &       1X,'Chain mass corr. for resonances (EVTRES)',2X,
27549      &       'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES)  IRRES(2) /',
27550      &       'NEVT = ',F7.2,/,43X,'LOMRES   /NEVT = ',F7.2,/,
27551      &       43X,'LOBRES   /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27552      &       ' 2-chain systems (CHKINE)  IRCHKI(1)/NEVT = ',F7.2,/,
27553      &       43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27554      &       'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27555      &       F7.2,/,1X,'Total no. of rej.',
27556      &       ' in chain-systems treatment (GETCSY)',/,43X,
27557      &       'IRHHA    /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27558      &       ' (not yet used!)',4X,'IRFRAG   /NEVT = ',F7.2,/,
27559      &       1X,'Total no. of rej. in DPM-treatment of one event',
27560      &       ' (EVENTA)',/,43X,'IREVT    /NEVT = ',F7.2,/,1X,
27561      &       'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27562      &       ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27563      &       'IREXCI(3) = ',I5,/)
27564          ENDIF
27565       ELSEIF (MCGENE.EQ.2) THEN
27566          WRITE(LOUT,1010) ELOJET
27567  1010    FORMAT(/,/,1X,'PHOJET-treatment of chain systems above  ',
27568      &          F4.1,' GeV')
27569          WRITE(LOUT,1011)
27570  1011    FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27571      &          30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27572      &          5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27573          WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27574      &                    (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27575      &                    (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27576      &                    ((ICEVTG(I,J),I=1,8),J=3,7),
27577      &                    ((ICEVTG(I,J),I=1,8),J=19,21),
27578      &                    (ICEVTG(I,8),I=1,8),
27579      &                    ((ICEVTG(I,J),I=1,8),J=22,24),
27580      &                    (ICEVTG(I,9),I=1,8),
27581      &                    ((ICEVTG(I,J),I=1,8),J=25,28),
27582      &                    ((ICEVTG(I,J),I=1,8),J=10,18)
27583  1012    FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27584      &          8I8,/,/,1X,'PHOJET ',8I8,/,'   sngl ',8I8,/,/,
27585      &          ' no-dif.',8I8,/,
27586      &          ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27587      &          ' diff-1 ',8I8,/,'  low   ',8I8,/,'  high  ',8I8,/,
27588      &          '  h-diff',8I8,/,' diff-2 ',8I8,/,'  low   ',8I8,/,
27589      &          '  high  ',8I8,/,'  h-diff',8I8,/,' dbl-di.',8I8,/,
27590      &          '  lo-lo ',8I8,/,'  hi-hi ',8I8,/,'  lo-hi ',8I8,/,
27591      &          '  hi-lo ',8I8,/,
27592      &          ' dir-ga.',8I8,/,/,' dir-1  ',8I8,/,' dir-2  ',8I8,/,
27593      &          ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27594      &          ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27595          WRITE(LOUT,1013)
27596  1013    FORMAT(/,1X,'2. chain system statistics -',
27597      &          ' mean numbers per evt:',/,30X,'---------------------',
27598      &          /,/,16X,'s-s',7X,'d-s',7X,'s-d')
27599          IF (ICSAMP.GT.0) THEN
27600          WRITE(LOUT,1014)
27601      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27602      &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27603      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27604  1014    FORMAT(/,1X,'req.to.    ',3E10.2,/,/,1X,'low rq.    ',3E10.2,/,
27605      &          1X,'low ac.    ',3E10.2,/,/,1X,'PHOJET     ',3E10.2,/,/,
27606      &          ' no-dif.    ',3E10.2,/,' el-sca.    ',3E10.2,/,
27607      &          ' qel-sc.    ',3E10.2,/,' dbl-Po.    ',3E10.2,/,
27608      &          ' diff-1     ',3E10.2,/,' diff-2     ',3E10.2,/,
27609      &          ' dbl-di.    ',3E10.2,/,' dir-ga.    ',3E10.2,/,/,
27610      &          ' dir-1      ',3E10.2,/,' dir-2      ',3E10.2,/,
27611      &          ' dbl-dir    ',3E10.2,/,' s-Pom.     ',3E10.2,/,
27612      &          ' h-Pom.     ',3E10.2,/,' s-Reg.     ',3E10.2,/,
27613      &          ' enh-trg    ',3E10.2,/,' enh-log    ',3E10.2)
27614          ENDIF
27615          WRITE(LOUT,1015)
27616  1015    FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
27617          IF (ICSAMP.GT.0) THEN
27618          WRITE(LOUT,1016)
27619      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27620      &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27621      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27622  1016    FORMAT(/,1X,'req.to.    ',5E10.2,/,/,1X,'low rq.    ',5E10.2,/,
27623      &          1X,'low ac.    ',5E10.2,/,/,1X,'PHOJET     ',5E10.2,/,/,
27624      &          ' no-dif.    ',5E10.2,/,' el-sca.    ',5E10.2,/,
27625      &          ' qel-sc.    ',5E10.2,/,' dbl-Po.    ',5E10.2,/,
27626      &          ' diff-1     ',5E10.2,/,' diff-2     ',5E10.2,/,
27627      &          ' dbl-di.    ',5E10.2,/,' dir-ga.    ',5E10.2,/,/,
27628      &          ' dir-1      ',5E10.2,/,' dir-2      ',5E10.2,/,
27629      &          ' dbl-dir    ',5E10.2,/,' s-Pom.     ',5E10.2,/,
27630      &          ' h-Pom.     ',5E10.2,/,' s-Reg.     ',5E10.2,/,
27631      &          ' enh-trg    ',5E10.2,/,' enh-log    ',5E10.2)
27632          ENDIF
27633
27634       ENDIF
27635       CALL DT_CHASTA(1)
27636
27637       IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27638      &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
27639          WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27640      &    DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27641      &    DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27642          WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27643      &    DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27644      &    DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27645          WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27646      &    DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27647      &    DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27648          WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27649      &    DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27650      &    DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27651          WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27652      &    DBRKA(3,1),DBRKA(3,2),
27653      &    DBRKA(3,3),DBRKA(3,4)
27654          WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27655      &    DBRKR(3,1),DBRKR(3,2),
27656      &    DBRKR(3,3),DBRKR(3,4)
27657          WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27658      &    DBRKA(3,5),DBRKA(3,6),
27659      &    DBRKA(3,7),DBRKA(3,8)
27660          WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27661      &    DBRKR(3,5),DBRKR(3,6),
27662      &    DBRKR(3,7),DBRKR(3,8)
27663       ENDIF
27664
27665       FAC = 1.0D0
27666       IF (MCGENE.EQ.2) THEN
27667
27668 C        CALL PHO_PHIST(-2,SIGMAX)
27669          CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27670
27671       ENDIF
27672
27673       CALL DT_XTIME
27674
27675       RETURN
27676       END
27677
27678 *$ CREATE DT_EVTOUT.FOR
27679 *COPY DT_EVTOUT
27680 *
27681 *===evtout=============================================================*
27682 *
27683       SUBROUTINE DT_EVTOUT(MODE)
27684
27685 ************************************************************************
27686 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
27687 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
27688 *                    4  plot entries of DTEVT1 and DTEVT2              *
27689 * This version dated 11.12.94 is written by S. Roesler                 *
27690 ************************************************************************
27691
27692       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27693       SAVE
27694
27695       PARAMETER ( LINP = 10 ,
27696      &            LOUT = 6 ,
27697      &            LDAT = 9 )
27698
27699 * event history
27700
27701       PARAMETER (NMXHKK=200000)
27702
27703       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27704      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27705      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27706
27707       DIMENSION IRANGE(NMXHKK)
27708
27709       IF (MODE.EQ.2) RETURN
27710
27711       CALL DT_EVTPLO(IRANGE,MODE)
27712
27713       RETURN
27714       END
27715
27716 *$ CREATE DT_EVTPLO.FOR
27717 *COPY DT_EVTPLO
27718 *
27719 *===evtplo=============================================================*
27720 *
27721       SUBROUTINE DT_EVTPLO(IRANGE,MODE)
27722
27723 ************************************************************************
27724 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
27725 *                    2  plot entries of DTEVT1 given by IRANGE         *
27726 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
27727 *                    4  plot entries of DTEVT1 and DTEVT2              *
27728 *                    5  plot rejection counter                         *
27729 * This version dated 11.12.94 is written by S. Roesler                 *
27730 ************************************************************************
27731
27732       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27733       SAVE
27734
27735       PARAMETER ( LINP = 10 ,
27736      &            LOUT = 6 ,
27737      &            LDAT = 9 )
27738
27739       CHARACTER*16 CHAU
27740
27741 * event history
27742
27743       PARAMETER (NMXHKK=200000)
27744
27745       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27746      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27747      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27748
27749 * extended event history
27750       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27751      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27752      &                IHIST(2,NMXHKK)
27753
27754 * rejection counter
27755       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27756      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27757      &                IREXCI(3),IRDIFF(2),IRINC
27758
27759       DIMENSION IRANGE(NMXHKK)
27760
27761       IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
27762          WRITE(LOUT,1000)
27763  1000    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTEVT1/',/,
27764      &         15X,'           --------------------------',/,/,
27765      &             '       ST    ID  M1   M2   D1   D2     PX     PY',
27766      &             '     PZ      E       M',/)
27767          DO 1 I=1,NHKK
27768             WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27769      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27770      &                       PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27771      &                       PHKK(5,I)
27772 C           WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27773 C    &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27774 C    &                       PHKK(3,I),PHKK(4,I)
27775 C           WRITE(LOUT,'(4E15.4)')
27776 C    &         VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
27777  1001       FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
27778  1011       FORMAT(I5,I5,I6,4I5,2E15.5)
27779     1    CONTINUE
27780          WRITE(LOUT,*)
27781 C        DO 4 I=1,NHKK
27782 C           WRITE(LOUT,1006) I,ISTHKK(I),
27783 C    &                    VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
27784 C    &                    WHKK(2,I),WHKK(3,I)
27785 C1006       FORMAT(1X,I4,I6,6E10.3)
27786 C   4    CONTINUE
27787       ENDIF
27788
27789       IF (MODE.EQ.2) THEN
27790          WRITE(LOUT,1000)
27791          NC = 0
27792     2    CONTINUE
27793          NC = NC+1
27794          IF (IRANGE(NC).EQ.-100) GOTO 9999
27795          I = IRANGE(NC)
27796          WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27797      &                    JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27798      &                    PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27799      &                    PHKK(5,I)
27800          GOTO 2
27801       ENDIF
27802
27803       IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
27804          WRITE(LOUT,1002)
27805  1002    FORMAT(/,1X,'EVTPLO:',14X,
27806      &         ' content of COMMON /DTEVT1/,/DTEVT2/',/,
27807      &         15X,'        -----------------------------------',/,/,
27808      &             '       ST    ID   M1   M2   D1   D2  IDR  IDXR',
27809      &             ' NOBAM IDCH    M',/)
27810          DO 3 I=1,NHKK
27811 C           IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
27812                KF    = IDHKK(I)
27813                IDCHK = KF/10000
27814                IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
27815      &            (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
27816
27817                CALL PYNAME(KF,CHAU)
27818
27819                WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27820      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27821      &                       IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
27822      &                       PHKK(5,I),CHAU
27823  1003          FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
27824 C           ENDIF
27825     3    CONTINUE
27826       ENDIF
27827
27828       IF (MODE.EQ.5) THEN
27829          WRITE(LOUT,1004)
27830  1004    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTREJC/',/,
27831      &         15X,'           --------------------------',/)
27832          WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
27833      &                    IRSEA,IRCRON
27834  1005    FORMAT(1X,'IRPT   = ',I5,'  IRHHA = ',I5,/,
27835      &          1X,'IRRES  = ',2I5,'  LOMRES = ',I5,'  LOBRES = ',I5,/,
27836      &          1X,'IREMC  = ',10I5,/,
27837      &          1X,'IRFRAG = ',I5,'  IRSEA = ',I5,' IRCRON = ',I5,/)
27838       ENDIF
27839
27840  9999 RETURN
27841       END
27842
27843 *$ CREATE DT_EVTPUT.FOR
27844 *COPY DT_EVTPUT
27845 *
27846 *===evtput=============================================================*
27847 *
27848       SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
27849
27850       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27851       SAVE
27852
27853       PARAMETER ( LINP = 10 ,
27854      &            LOUT = 6 ,
27855      &            LDAT = 9 )
27856
27857       PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
27858      &           TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
27859
27860 * event history
27861
27862       PARAMETER (NMXHKK=200000)
27863
27864       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27865      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27866      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27867
27868 * extended event history
27869       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27870      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27871      &                IHIST(2,NMXHKK)
27872
27873 * Lorentz-parameters of the current interaction
27874       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
27875      &                UMO,PPCM,EPROJ,PPROJ
27876
27877 * particle properties (BAMJET index convention)
27878       CHARACTER*8  ANAME
27879       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27880      &                IICH(210),IIBAR(210),K1(210),K2(210)
27881
27882 C     IF (MODE.GT.100) THEN
27883 C        WRITE(LOUT,'(1X,A,I5,A,I5)')
27884 C    &        'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
27885 C        NHKK = NHKK-MODE+100
27886 C        RETURN
27887 C     ENDIF
27888       MO1  = M1
27889       MO2  = M2
27890       NHKK = NHKK+1
27891
27892       IF (NHKK.GT.NMXHKK) THEN
27893          WRITE(LOUT,1000) NHKK
27894  1000    FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
27895      &             '! program execution stopped..')
27896          STOP
27897       ENDIF
27898       IF (M1.LT.0) MO1 = NHKK+M1
27899       IF (M2.LT.0) MO2 = NHKK+M2
27900       ISTHKK(NHKK)   = IST
27901       IDHKK(NHKK)    = ID
27902       JMOHKK(1,NHKK) = MO1
27903       JMOHKK(2,NHKK) = MO2
27904       JDAHKK(1,NHKK) = 0
27905       JDAHKK(2,NHKK) = 0
27906       IDRES(NHKK)    = IDR
27907       IDXRES(NHKK)   = IDXR
27908       IDCH(NHKK)     = IDC
27909 ** here we need to do something..
27910       IF (ID.EQ.88888) THEN
27911          IDMO1 = ABS(IDHKK(MO1))
27912          IDMO2 = ABS(IDHKK(MO2))
27913          IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
27914          IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
27915          IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
27916          IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
27917       ELSE
27918          NOBAM(NHKK) = 0
27919       ENDIF
27920       IDBAM(NHKK) = IDT_ICIHAD(ID)
27921       IF (MO1.GT.0) THEN
27922          IF (JDAHKK(1,MO1).NE.0) THEN
27923             JDAHKK(2,MO1) = NHKK
27924          ELSE
27925             JDAHKK(1,MO1) = NHKK
27926          ENDIF
27927       ENDIF
27928       IF (MO2.GT.0) THEN
27929          IF (JDAHKK(1,MO2).NE.0) THEN
27930             JDAHKK(2,MO2) = NHKK
27931          ELSE
27932             JDAHKK(1,MO2) = NHKK
27933          ENDIF
27934       ENDIF
27935 C      IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
27936 C         PTOT   = SQRT(PX**2+PY**2+PZ**2)
27937 C         AM0    = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
27938 C         AMRQ   = AAM(IDBAM(NHKK))
27939 C         AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
27940 C         IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
27941 C     &       (PTOT.GT.ZERO)) THEN
27942 C            DELTA = -AMDIF2/(2.0D0*(E+PTOT))
27943 CC           DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
27944 C            E     = E+DELTA
27945 C            PTOT1 = PTOT-DELTA
27946 C            PX    = PX*PTOT1/PTOT
27947 C            PY    = PY*PTOT1/PTOT
27948 C            PZ    = PZ*PTOT1/PTOT
27949 C         ENDIF
27950 C      ENDIF
27951       PHKK(1,NHKK) = PX
27952       PHKK(2,NHKK) = PY
27953       PHKK(3,NHKK) = PZ
27954       PHKK(4,NHKK) = E
27955       PTOT = SQRT( PX**2+PY**2+PZ**2 )
27956       IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
27957          PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
27958          PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
27959       ELSE
27960          PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
27961 C        IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
27962 C    &      WRITE(LOUT,'(1X,A,G10.3)')
27963 C    &        'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
27964          PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
27965       ENDIF
27966       IDCHK = ID/10000
27967       IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
27968 * special treatment for chains:
27969 *    z coordinate of chain in Lab  = pos. of target nucleon
27970 *    time of chain-creation in Lab = time of passage of projectile
27971 *                                    nucleus at pos. of taget nucleus
27972 C        VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
27973 C        VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
27974          VHKK(1,NHKK) = VHKK(1,MO2)
27975          VHKK(2,NHKK) = VHKK(2,MO2)
27976          VHKK(3,NHKK) = VHKK(3,MO2)
27977          VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
27978 C        WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
27979 C        WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
27980          WHKK(1,NHKK) = WHKK(1,MO1)
27981          WHKK(2,NHKK) = WHKK(2,MO1)
27982          WHKK(3,NHKK) = WHKK(3,MO1)
27983          WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
27984       ELSE
27985          IF (MO1.GT.0) THEN
27986             DO 1 I=1,4
27987                VHKK(I,NHKK) = VHKK(I,MO1)
27988                WHKK(I,NHKK) = WHKK(I,MO1)
27989     1       CONTINUE
27990          ELSE
27991             DO 2 I=1,4
27992                VHKK(I,NHKK) = ZERO
27993                WHKK(I,NHKK) = ZERO
27994     2       CONTINUE
27995          ENDIF
27996       ENDIF
27997
27998       RETURN
27999       END
28000
28001 *$ CREATE DT_CHASTA.FOR
28002 *COPY DT_CHASTA
28003 *
28004 *===chasta=============================================================*
28005 *
28006       SUBROUTINE DT_CHASTA(MODE)
28007
28008 ************************************************************************
28009 * This subroutine performs CHAin STAtistics and checks sequence of     *
28010 * partons in dtevt1 and sorts them with projectile partons coming      *
28011 * first if necessary.                                                  *
28012 *                                                                      *
28013 * This version dated  8.5.00  is written by S. Roesler.                *
28014 ************************************************************************
28015
28016       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28017       SAVE
28018
28019       PARAMETER ( LINP = 10 ,
28020      &            LOUT = 6 ,
28021      &            LDAT = 9 )
28022
28023       CHARACTER*5 CCHTYP
28024
28025 * event history
28026
28027       PARAMETER (NMXHKK=200000)
28028
28029       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28030      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28031      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28032
28033 * extended event history
28034       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28035      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28036      &                IHIST(2,NMXHKK)
28037
28038 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28039       PARAMETER (MAXCHN=10000)
28040       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28041
28042       DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28043      &          CCHTYP(9),ICHSTA(10),ITOT(10)
28044       DATA ICHCFG /1800*0/
28045       DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28046       DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28047       DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28048       DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28049       DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28050       DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28051       DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28052      &              'ad aq',' d ad','ad d ',' g g '/
28053 *
28054 * initialization
28055 *
28056       IF (MODE.EQ.-1) THEN
28057          NCHAIN = 0
28058 *
28059 * loop over DTEVT1 and analyse chain configurations
28060 *
28061       ELSEIF (MODE.EQ.0) THEN
28062          DO 21 IDX=NPOINT(3),NHKK
28063             IDCHK = IDHKK(IDX)/10000
28064             IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28065      &          (IDHKK(IDX).NE.80000).AND.
28066      &          (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28067                IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28068                   WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28069      &                          ' at entry ',IDX
28070                   GOTO 21
28071                ENDIF
28072 *
28073                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28074                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28075                IMO1 = IST1/10
28076                IMO1 = IST1-10*IMO1
28077                IMO2 = IST2/10
28078                IMO2 = IST2-10*IMO2
28079 *   swop parton entries if necessary since we need projectile partons
28080 *   to come first in the common
28081                IF (IMO1.GT.IMO2) THEN
28082                   NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28083                   DO 22 K=1,NPTN/2
28084                      I0 = JMOHKK(1,IDX)-1+K
28085                      I1 = JMOHKK(2,IDX)+1-K
28086                      ITMP = ISTHKK(I0)
28087                      ISTHKK(I0) = ISTHKK(I1)
28088                      ISTHKK(I1) = ITMP
28089                      ITMP = IDHKK(I0)
28090                      IDHKK(I0) = IDHKK(I1)
28091                      IDHKK(I1) = ITMP
28092                      IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28093      &                  JDAHKK(1,JMOHKK(1,I0)) = I1
28094                      IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28095      &                  JDAHKK(2,JMOHKK(1,I0)) = I1
28096                      IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28097      &                  JDAHKK(1,JMOHKK(2,I0)) = I1
28098                      IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28099      &                  JDAHKK(2,JMOHKK(2,I0)) = I1
28100                      IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28101      &                  JDAHKK(1,JMOHKK(1,I1)) = I0
28102                      IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28103      &                  JDAHKK(2,JMOHKK(1,I1)) = I0
28104                      IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28105      &                  JDAHKK(1,JMOHKK(2,I1)) = I0
28106                      IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28107      &                  JDAHKK(2,JMOHKK(2,I1)) = I0
28108                      ITMP = JMOHKK(1,I0)
28109                      JMOHKK(1,I0) = JMOHKK(1,I1)
28110                      JMOHKK(1,I1) = ITMP
28111                      ITMP = JMOHKK(2,I0)
28112                      JMOHKK(2,I0) = JMOHKK(2,I1)
28113                      JMOHKK(2,I1) = ITMP
28114                      ITMP = JDAHKK(1,I0)
28115                      JDAHKK(1,I0) = JDAHKK(1,I1)
28116                      JDAHKK(1,I1) = ITMP
28117                      ITMP = JDAHKK(2,I0)
28118                      JDAHKK(2,I0) = JDAHKK(2,I1)
28119                      JDAHKK(2,I1) = ITMP
28120                      DO 23 J=1,4
28121                         RTMP1 = PHKK(J,I0)
28122                         RTMP2 = VHKK(J,I0)
28123                         RTMP3 = WHKK(J,I0)
28124                         PHKK(J,I0) = PHKK(J,I1)
28125                         VHKK(J,I0) = VHKK(J,I1)
28126                         WHKK(J,I0) = WHKK(J,I1)
28127                         PHKK(J,I1) = RTMP1
28128                         VHKK(J,I1) = RTMP2
28129                         WHKK(J,I1) = RTMP3
28130    23                CONTINUE
28131                      RTMP1 = PHKK(5,I0)
28132                      PHKK(5,I0) = PHKK(5,I1)
28133                      PHKK(5,I1) = RTMP1
28134                      ITMP = IDRES(I0)
28135                      IDRES(I0) = IDRES(I1)
28136                      IDRES(I1) = ITMP
28137                      ITMP = IDXRES(I0)
28138                      IDXRES(I0) = IDXRES(I1)
28139                      IDXRES(I1) = ITMP
28140                      ITMP = NOBAM(I0)
28141                      NOBAM(I0) = NOBAM(I1)
28142                      NOBAM(I1) = ITMP
28143                      ITMP = IDBAM(I0)
28144                      IDBAM(I0) = IDBAM(I1)
28145                      IDBAM(I1) = ITMP
28146                      ITMP = IDCH(I0)
28147                      IDCH(I0) = IDCH(I1)
28148                      IDCH(I1) = ITMP
28149                      ITMP = IHIST(1,I0)
28150                      IHIST(1,I0) = IHIST(1,I1)
28151                      IHIST(1,I1) = ITMP
28152                      ITMP = IHIST(2,I0)
28153                      IHIST(2,I0) = IHIST(2,I1)
28154                      IHIST(2,I1) = ITMP
28155    22             CONTINUE
28156                ENDIF
28157                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28158                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28159 *
28160 *   parton 1 (projectile side)
28161                IF (IST1.EQ.21) THEN
28162                   IDX1 = 1
28163                ELSEIF (IST1.EQ.22) THEN
28164                   IDX1 = 2
28165                ELSEIF (IST1.EQ.31) THEN
28166                   IDX1 = 3
28167                ELSEIF (IST1.EQ.32) THEN
28168                   IDX1 = 4
28169                ELSEIF (IST1.EQ.41) THEN
28170                   IDX1 = 5
28171                ELSEIF (IST1.EQ.42) THEN
28172                   IDX1 = 6
28173                ELSEIF (IST1.EQ.51) THEN
28174                   IDX1 = 7
28175                ELSEIF (IST1.EQ.52) THEN
28176                   IDX1 = 8
28177                ELSEIF (IST1.EQ.61) THEN
28178                   IDX1 = 9
28179                ELSEIF (IST1.EQ.62) THEN
28180                   IDX1 = 10
28181                ELSE
28182 c                 WRITE(LOUT,*)
28183 c    &               ' CHASTA: unknown parton status flag (',
28184 c    &               IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28185                   GOTO 21
28186                ENDIF
28187                ID = IDHKK(JMOHKK(1,IDX))
28188                IF (ABS(ID).LE.4) THEN
28189                   IF (ID.GT.0) THEN
28190                      ITYP1 = 1
28191                   ELSE
28192                      ITYP1 = 2
28193                   ENDIF
28194                ELSEIF (ABS(ID).GE.1000) THEN
28195                   IF (ID.GT.0) THEN
28196                      ITYP1 = 3
28197                   ELSE
28198                      ITYP1 = 4
28199                   ENDIF
28200                ELSEIF (ID.EQ.21) THEN
28201                   ITYP1 = 5
28202                ELSE
28203                   WRITE(LOUT,*)
28204      &               ' CHASTA: inconsistent parton identity (',
28205      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28206                   GOTO 21
28207                ENDIF
28208 *
28209 *   parton 2 (target side)
28210                IF (IST2.EQ.21) THEN
28211                   IDX2 = 1
28212                ELSEIF (IST2.EQ.22) THEN
28213                   IDX2 = 2
28214                ELSEIF (IST2.EQ.31) THEN
28215                   IDX2 = 3
28216                ELSEIF (IST2.EQ.32) THEN
28217                   IDX2 = 4
28218                ELSEIF (IST2.EQ.41) THEN
28219                   IDX2 = 5
28220                ELSEIF (IST2.EQ.42) THEN
28221                   IDX2 = 6
28222                ELSEIF (IST2.EQ.51) THEN
28223                   IDX2 = 7
28224                ELSEIF (IST2.EQ.52) THEN
28225                   IDX2 = 8
28226                ELSEIF (IST2.EQ.61) THEN
28227                   IDX2 = 9
28228                ELSEIF (IST2.EQ.62) THEN
28229                   IDX2 = 10
28230                ELSE
28231 c                 WRITE(LOUT,*)
28232 c    &               ' CHASTA: unknown parton status flag (',
28233 c    &               IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28234                   GOTO 21
28235                ENDIF
28236                ID = IDHKK(JMOHKK(2,IDX))
28237                IF (ABS(ID).LE.4) THEN
28238                   IF (ID.GT.0) THEN
28239                      ITYP2 = 1
28240                   ELSE
28241                      ITYP2 = 2
28242                   ENDIF
28243                ELSEIF (ABS(ID).GE.1000) THEN
28244                   IF (ID.GT.0) THEN
28245                      ITYP2 = 3
28246                   ELSE
28247                      ITYP2 = 4
28248                   ENDIF
28249                ELSEIF (ID.EQ.21) THEN
28250                   ITYP2 = 5
28251                ELSE
28252                   WRITE(LOUT,*)
28253      &               ' CHASTA: inconsistent parton identity (',
28254      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28255                   GOTO 21
28256                ENDIF
28257 *
28258 *   fill counter
28259                ITYPE = ICHTYP(ITYP1,ITYP2)
28260                IF (ITYPE.NE.0) THEN
28261                   ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28262                   NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28263                   ICHCFG(IDX1,IDX2,ITYPE,2) =
28264      &               ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28265
28266                   NCHAIN = NCHAIN+1
28267                   IF (NCHAIN.GT.MAXCHN) THEN
28268                      WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28269      &                  NCHAIN,MAXCHN
28270                      STOP
28271                   ENDIF
28272                   IDXCHN(1,NCHAIN) = IDX
28273                   IDXCHN(2,NCHAIN) = ITYPE
28274                ELSE
28275                   WRITE(LOUT,*)
28276      &               ' CHASTA: inconsistent chain at entry ',IDX
28277                   GOTO 21
28278                ENDIF
28279             ENDIF
28280    21    CONTINUE
28281 *
28282 * write statistics to output unit
28283 *
28284       ELSEIF (MODE.EQ.1) THEN
28285          WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28286          DO 31 I=1,10
28287             WRITE(LOUT,'(/,2A)')
28288      &         ' -----------------------------------------',
28289      &         '------------------------------------'
28290             WRITE(LOUT,'(2A)')
28291      &         ' p\\t         21     22     31     32     41',
28292      &         '     42     51     52     61     62'
28293             WRITE(LOUT,'(2A)')
28294      &         ' -----------------------------------------',
28295      &         '------------------------------------'
28296             DO 32 J=1,10
28297                ITOT(J) = 0
28298                DO 33 K=1,9
28299                   ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28300    33          CONTINUE
28301    32       CONTINUE
28302             WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28303             DO 34 K=1,9
28304                ISUM = 0
28305                DO 35 J=1,10
28306                   ISUM = ISUM+ICHCFG(I,J,K,1)
28307    35          CONTINUE
28308                IF (ISUM.GT.0)
28309      &            WRITE(LOUT,'(1X,A5,2X,10I7)')
28310      &               CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28311    34       CONTINUE
28312 C           WRITE(LOUT,'(2A)')
28313 C    &         ' -----------------------------------------',
28314 C    &         '-------------------------------'
28315    31    CONTINUE
28316 *
28317       ELSE
28318          WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28319          STOP
28320       ENDIF
28321
28322       RETURN
28323       END
28324 *$ CREATE PHO_PHIST.FOR
28325 *COPY PHO_PHIST
28326 *
28327 *===pohist=============================================================*
28328 *
28329       SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28330
28331       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28332       SAVE
28333
28334       PARAMETER ( LINP = 10 ,
28335      &            LOUT = 6 ,
28336      &            LDAT = 9 )
28337
28338       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28339
28340 * Glauber formalism: cross sections
28341       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28342      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28343      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28344      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28345      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28346      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28347      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28348      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28349      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28350      &                BSLOPE,NEBINI,NQBINI
28351
28352       ILAB = 0
28353       IF (IMODE.EQ.10) THEN
28354          IMODE = 1
28355          ILAB  = 1
28356       ENDIF
28357       IF (ABS(IMODE).LT.1000) THEN
28358 * PHOJET-statistics
28359 C        CALL POHISX(IMODE,WEIGHT)
28360          IF (IMODE.EQ.-1) THEN
28361             MODE = 1
28362             XSTOT(1,1,1) = WEIGHT
28363          ENDIF
28364          IF (IMODE.EQ. 1) MODE = 2
28365          IF (IMODE.EQ.-2) MODE = 3
28366          IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28367 C        IF (MODE.EQ.3) WRITE(LOUT,*)
28368 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
28369          CALL DT_HISTOG(MODE)
28370          CALL DT_USRHIS(MODE)
28371       ELSE
28372 * DTUNUC-statistics
28373          MODE = IMODE/1000
28374 C        IF (MODE.EQ.3) WRITE(LOUT,*)
28375 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
28376          CALL DT_HISTOG(MODE)
28377          CALL DT_USRHIS(MODE)
28378       ENDIF
28379
28380       RETURN
28381       END
28382
28383 *$ CREATE DT_SWPPHO.FOR
28384 *COPY DT_SWPPHO
28385 *
28386 *===swppho=============================================================*
28387 *
28388       SUBROUTINE DT_SWPPHO(ILAB)
28389
28390       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28391       SAVE
28392
28393       PARAMETER ( LINP = 10 ,
28394      &            LOUT = 6 ,
28395      &            LDAT = 9 )
28396
28397       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28398
28399       LOGICAL LSTART
28400
28401 * event history
28402
28403       PARAMETER (NMXHKK=200000)
28404
28405       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28406      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28407      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28408
28409 * extended event history
28410       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28411      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28412      &                IHIST(2,NMXHKK)
28413
28414 * flags for input different options
28415       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28416       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28417      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28418
28419 * properties of photon/lepton projectiles
28420       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28421
28422 **PHOJET105a
28423 C     PARAMETER (NMXHEP=2000)
28424 C     COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28425 C    &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28426 C     COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28427 C     COMMON /PLASAV/ PLAB
28428 **PHOJET110
28429 C  standard particle data interface
28430       INTEGER NMXHEP
28431
28432       PARAMETER (NMXHEP=4000)
28433
28434       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28435       DOUBLE PRECISION PHEP,VHEP
28436       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28437      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28438      &                VHEP(4,NMXHEP)
28439 C  extension to standard particle data interface (PHOJET specific)
28440       INTEGER IMPART,IPHIST,ICOLOR
28441       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28442
28443 C  global event kinematics and particle IDs
28444       INTEGER IFPAP,IFPAB
28445       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28446       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28447 **
28448       DATA ICOUNT/0/
28449
28450       DATA LSTART /.TRUE./
28451
28452 C     IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28453       IF ((IFRAME.EQ.1).AND.LSTART) THEN
28454          UMO  = ECM
28455          ELA  = ZERO
28456          PLA  = ZERO
28457          IDP  = IDT_ICIHAD(IFPAP(1))
28458          IDT  = IDT_ICIHAD(IFPAP(2))
28459          VIRT = PVIRT(1)
28460          CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28461          PLAB = PLA
28462          LSTART = .FALSE.
28463       ENDIF
28464
28465       NHKK   = 0
28466       ICOUNT = ICOUNT+1
28467 C     NEVHKK = NEVHEP
28468       NEVHKK = ICOUNT
28469       IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28470       DO 1 I=3,NHEP
28471          IF (ISTHEP(I).EQ.1) THEN
28472             NHKK = NHKK+1
28473             ISTHKK(NHKK) = 1
28474             IDHKK(NHKK)  = IDHEP(I)
28475             JMOHKK(1,NHKK) = 0
28476             JMOHKK(2,NHKK) = 0
28477             JDAHKK(1,NHKK) = 0
28478             JDAHKK(2,NHKK) = 0
28479             DO 2 K=1,4
28480                PHKK(K,NHKK) = PHEP(K,I)
28481                VHKK(K,NHKK) = ZERO
28482                WHKK(K,NHKK) = ZERO
28483     2       CONTINUE
28484             IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28485      &         CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28486      &                    PHKK(3,NHKK),PHKK(4,NHKK),-3)
28487             PHKK(5,NHKK) = PHEP(5,I)
28488             IDRES(NHKK)  = 0
28489             IDXRES(NHKK) = 0
28490             NOBAM(NHKK)  = 0
28491             IDBAM(NHKK)  = IDT_ICIHAD(IDHEP(I))
28492             IDCH(NHKK)   = 0
28493          ENDIF
28494     1 CONTINUE
28495
28496       RETURN
28497       END
28498
28499 *$ CREATE DT_HISTOG.FOR
28500 *COPY DT_HISTOG
28501 *
28502 *===histog=============================================================*
28503 *
28504       SUBROUTINE DT_HISTOG(MODE)
28505
28506 ************************************************************************
28507 * This version dated 25.03.96 is written by S. Roesler                 *
28508 ************************************************************************
28509
28510       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28511       SAVE
28512
28513       PARAMETER ( LINP = 10 ,
28514      &            LOUT = 6 ,
28515      &            LDAT = 9 )
28516
28517       LOGICAL LFSP,LRNL
28518
28519 * event history
28520
28521       PARAMETER (NMXHKK=200000)
28522
28523       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28524      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28525      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28526
28527 * extended event history
28528       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28529      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28530      &                IHIST(2,NMXHKK)
28531
28532 * event flag used for histograms
28533       COMMON /DTNORM/ ICEVT,IEVHKK
28534
28535 * flags for activated histograms
28536       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28537
28538       IEVHKK = NEVHKK
28539       GOTO (1,2,3) MODE
28540
28541 *------------------------------------------------------------------
28542 * initialization
28543     1 CONTINUE
28544       ICEVT = 0
28545       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28546       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28547
28548       RETURN
28549 *------------------------------------------------------------------
28550 * filling of histogram with event-record
28551     2 CONTINUE
28552       ICEVT = ICEVT+1
28553
28554       DO 20 I=1,NHKK
28555          CALL DT_SWPFSP(I,LFSP,LRNL)
28556          IF (LFSP) THEN
28557             IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28558             IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28559          ENDIF
28560          IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28561    20 CONTINUE
28562       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28563
28564       RETURN
28565 *------------------------------------------------------------------
28566 * output
28567     3 CONTINUE
28568       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28569       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28570
28571       RETURN
28572       END
28573
28574 *$ CREATE DT_SWPFSP.FOR
28575 *COPY DT_SWPFSP
28576 *
28577 *===swpfsp=============================================================*
28578 *
28579       SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28580
28581       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28582       SAVE
28583       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28584       PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28585      &           PI   =TWOPI/TWO,
28586      &           BOG  =TWOPI/360.0D0)
28587
28588 * event history
28589
28590       PARAMETER (NMXHKK=200000)
28591
28592       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28593      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28594      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28595
28596 * extended event history
28597       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28598      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28599      &                IHIST(2,NMXHKK)
28600
28601 * particle properties (BAMJET index convention)
28602       CHARACTER*8  ANAME
28603       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28604      &                IICH(210),IIBAR(210),K1(210),K2(210)
28605
28606 * Lorentz-parameters of the current interaction
28607       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28608      &                UMO,PPCM,EPROJ,PPROJ
28609
28610 * flags for input different options
28611       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28612       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28613      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28614
28615 *      INCLUDE '(DIMPAR)'
28616 *     Taken from FLUKA
28617       PARAMETER ( MXXRGN =20000 )
28618       PARAMETER ( MXXMDF =  710 )
28619       PARAMETER ( MXXMDE =  702 )
28620       PARAMETER ( MFSTCK =40000 )
28621       PARAMETER ( MESTCK =  100 )
28622       PARAMETER ( MOSTCK = 2000 )
28623       PARAMETER ( MXPRSN =  100 )
28624       PARAMETER ( MXPDPM =  800 )
28625       PARAMETER ( MXPSCS =30000 )
28626       PARAMETER ( MXGLWN =  300 )
28627       PARAMETER ( MXOUTU =   50 )
28628       PARAMETER ( NALLWP =   64 )
28629       PARAMETER ( NELEMX =   80 )
28630       PARAMETER ( MPDPDX =   18 )
28631       PARAMETER ( MXHTTR =  260 )
28632       PARAMETER ( MXSEAX =   20 )
28633       PARAMETER ( MXHTNC = MXSEAX + 1 )
28634       PARAMETER ( ICOMAX = 2400 )
28635       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
28636       PARAMETER ( NSTBIS =  304 )
28637       PARAMETER ( NQSTIS =   46 )
28638       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
28639       PARAMETER ( MXPABL =  120 )
28640       PARAMETER ( IDMAXP =  450 )
28641       PARAMETER ( IDMXDC = 2000 )
28642       PARAMETER ( MXMCIN =  410 )
28643       PARAMETER ( IHYPMX =    4 )
28644       PARAMETER ( MKBMX1 =   11 )
28645       PARAMETER ( MKBMX2 =   11 )
28646       PARAMETER ( MXIRRD = 2500 )
28647       PARAMETER ( MXTRDC = 1500 )
28648       PARAMETER ( NKTL   =   17 )
28649       PARAMETER ( NBLNMX = 40000000 )
28650
28651 *      INCLUDE '(PAREVT)'
28652 *     Taken from FLUKA
28653       PARAMETER ( FRDIFF = 0.2D+00 )
28654       PARAMETER ( ETHSEA = 1.0D+00 )
28655 *
28656       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28657      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
28658      &        LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
28659      &        LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
28660       COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
28661      &                  LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28662      &                  LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28663      &                  LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
28664      &                  LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
28665      &                  LVP2XX, LV2XNW, LNWV2X, LEVFIN
28666
28667 * temporary storage for one final state particle
28668       LOGICAL LFRAG,LGREY,LBLACK
28669       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28670      &                SINTHE,COSTHE,THETA,THECMS,
28671      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28672      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28673      &                LFRAG,LGREY,LBLACK
28674
28675       LOGICAL LFSP,LRNL
28676
28677       LFSP = .FALSE.
28678       LRNL = .FALSE.
28679       ISTRNL = 1000
28680       MULDEF = 1
28681       IF (LEVPRT) ISTRNL = 1001
28682
28683       IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28684          IST    = ISTHKK(IDX)
28685          IDPDG  = IDHKK(IDX)
28686          LFRAG  = .FALSE.
28687          IF (IDHKK(IDX).LT.80000) THEN
28688             IDBJT  = IDBAM(IDX)
28689             IBARY  = IIBAR(IDBJT)
28690             ICHAR  = IICH(IDBJT)
28691             AMASS  = AAM(IDBJT)
28692          ELSEIF (IDHKK(IDX).EQ.80000) THEN
28693             IDBJT  = 0
28694             IBARY  = IDRES(IDX)
28695             ICHAR  = IDXRES(IDX)
28696             AMASS  = PHKK(5,IDX)
28697             INUT   = IBARY-ICHAR
28698             IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28699             IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28700             IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28701             IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28702             IF (IDBJT.EQ.0) LFRAG = .TRUE.
28703          ELSE
28704             GOTO 9999
28705          ENDIF
28706          PE     = PHKK(4,IDX)
28707          PX     = PHKK(1,IDX)
28708          PY     = PHKK(2,IDX)
28709          PZ     = PHKK(3,IDX)
28710          PT2    = PX**2+PY**2
28711          PT     = SQRT(PT2)
28712          PTOT   = SQRT(PT2+PZ**2)
28713          SINTHE = PT/MAX(PTOT,TINY14)
28714          COSTHE = PZ/MAX(PTOT,TINY14)
28715          IF (COSTHE.GT.ONE) THEN
28716             THETA = ZERO
28717          ELSEIF (COSTHE.LT.-ONE) THEN
28718             THETA = TWOPI/2.0D0
28719          ELSE
28720             THETA = ACOS(COSTHE)
28721          ENDIF
28722          EKIN   = PE-AMASS
28723 **sr 15.4.96 new E_t-definition
28724          IF (IBARY.GT.0) THEN
28725             ET = EKIN*SINTHE
28726          ELSEIF (IBARY.LT.0) THEN
28727             ET = (EKIN+TWO*AMASS)*SINTHE
28728          ELSE
28729             ET = PE*SINTHE
28730          ENDIF
28731 **
28732          XLAB   = PZ/MAX(PPROJ,TINY14)
28733 C        XLAB   = PE/MAX(EPROJ,TINY14)
28734          BETA   = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28735      &                     *(ONE+AMASS/MAX(PE,TINY14)) ))
28736          PPLUS  = PE+PZ
28737          PMINUS = PE-PZ
28738          IF (PMINUS.GT.TINY14) THEN
28739             YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28740          ELSE
28741             YY = 100.0D0
28742          ENDIF
28743          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28744             ETA = -LOG(TAN(THETA/TWO))
28745          ELSE
28746             ETA = 100.0D0
28747          ENDIF
28748          IF (IFRAME.EQ.1) THEN
28749             CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28750             PPLUS  = EECMS+PZCMS
28751             PMINUS = EECMS-PZCMS
28752             IF ((PPLUS*PMINUS).GT.TINY14) THEN
28753                YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28754             ELSE
28755                YYCMS = 100.0D0
28756             ENDIF
28757             PTOTCM = SQRT(PT2+PZCMS**2)
28758             COSTH = PZCMS/MAX(PTOTCM,TINY14)
28759             IF (COSTH.GT.ONE) THEN
28760                THECMS = ZERO
28761             ELSEIF (COSTH.LT.-ONE) THEN
28762                THECMS = TWOPI/2.0D0
28763             ELSE
28764                THECMS = ACOS(COSTH)
28765             ENDIF
28766             IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28767                ETACMS = -LOG(TAN(THECMS/TWO))
28768             ELSE
28769                ETACMS = 100.0D0
28770             ENDIF
28771             XF = PZCMS/MAX(PPCM,TINY14)
28772             THECMS = THECMS/BOG
28773          ELSE
28774             PZCMS  = PZ
28775             EECMS  = PE
28776             YYCMS  = YY
28777             ETACMS = ETA
28778             XF     = XLAB
28779             THECMS = THETA/BOG
28780          ENDIF
28781          THETA  = THETA/BOG
28782
28783 * set flag for "grey/black"
28784          LGREY  = .FALSE.
28785          LBLACK = .FALSE.
28786          EK     = EKIN
28787          IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28788          IF (MULDEF.EQ.1) THEN
28789 *  EMU01-Def.
28790             IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28791      &                              (EK.LE.375.0D-3)      ).OR.
28792      &           ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28793      &                              (EK.LE. 56.0D-3)      ).OR.
28794      &           ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28795      &                              (EK.LE. 56.0D-3)      ).OR.
28796      &           ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28797      &                              (EK.LE.198.0D-3)      ).OR.
28798      &           ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28799      &                              (EK.LE.198.0D-3)      ).OR.
28800      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28801      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28802      &             (IDBJT.NE.16).AND.
28803      &             (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)    ) )
28804      &         LGREY = .TRUE.
28805             IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
28806      &           ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
28807      &           ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
28808      &           ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
28809      &           ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
28810      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28811      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28812      &             (IDBJT.NE.16).AND.(BETA.LE.0.23D0)  ) )
28813      &         LBLACK = .TRUE.
28814          ELSE
28815 *  common Def.
28816             IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
28817             IF (BETA.LE.0.23D0) LBLACK=.TRUE.
28818          ENDIF
28819          LFSP = .TRUE.
28820       ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
28821          IST    = ISTHKK(IDX)
28822          IDPDG  = IDHKK(IDX)
28823          LFRAG  = .TRUE.
28824          IDBJT  = 0
28825          IBARY  = IDRES(IDX)
28826          ICHAR  = IDXRES(IDX)
28827          AMASS  = PHKK(5,IDX)
28828          PE     = PHKK(4,IDX)
28829          PX     = PHKK(1,IDX)
28830          PY     = PHKK(2,IDX)
28831          PZ     = PHKK(3,IDX)
28832          PT2    = PX**2+PY**2
28833          PT     = SQRT(PT2)
28834          PTOT   = SQRT(PT2+PZ**2)
28835          SINTHE = PT/MAX(PTOT,TINY14)
28836          COSTHE = PZ/MAX(PTOT,TINY14)
28837          IF (COSTHE.GT.ONE) THEN
28838             THETA = ZERO
28839          ELSEIF (COSTHE.LT.-ONE) THEN
28840             THETA = TWOPI/2.0D0
28841          ELSE
28842             THETA  = ACOS(COSTHE)
28843          ENDIF
28844          EKIN   = PE-AMASS
28845 **sr 15.4.96 new E_t-definition
28846 C        ET     = PE*SINTHE
28847          ET     = EKIN*SINTHE
28848 **
28849          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28850             ETA = -LOG(TAN(THETA/TWO))
28851          ELSE
28852             ETA = 100.0D0
28853          ENDIF
28854          THETA  = THETA/BOG
28855          LRNL   = .TRUE.
28856       ENDIF
28857
28858  9999 CONTINUE
28859       RETURN
28860       END
28861
28862 *$ CREATE DT_HIMULT.FOR
28863 *COPY DT_HIMULT
28864 *
28865 *===himult=============================================================*
28866 *
28867       SUBROUTINE DT_HIMULT(MODE)
28868
28869 ************************************************************************
28870 * Tables of average energies/multiplicities.                           *
28871 * This version dated 30.08.2000 is written by S. Roesler               *
28872 ************************************************************************
28873
28874       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28875       SAVE
28876
28877       PARAMETER ( LINP = 10 ,
28878      &            LOUT = 6 ,
28879      &            LDAT = 9 )
28880
28881       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28882
28883       PARAMETER (SWMEXP=1.7D0)
28884
28885       CHARACTER*8 ANAMEH(4)
28886
28887 * particle properties (BAMJET index convention)
28888       CHARACTER*8  ANAME
28889       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28890      &                IICH(210),IIBAR(210),K1(210),K2(210)
28891
28892 * temporary storage for one final state particle
28893       LOGICAL LFRAG,LGREY,LBLACK
28894       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28895      &                SINTHE,COSTHE,THETA,THECMS,
28896      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28897      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28898      &                LFRAG,LGREY,LBLACK
28899
28900 * event flag used for histograms
28901       COMMON /DTNORM/ ICEVT,IEVHKK
28902
28903 * Lorentz-parameters of the current interaction
28904       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28905      &                UMO,PPCM,EPROJ,PPROJ
28906
28907       PARAMETER (NOPART=210)
28908       DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
28909      &          AVPT(4,NOPART),IAVPT(4,NOPART)
28910       DATA ANAMEH /'DEUTERON','3-H     ','3-HE    ','4-HE    '/
28911
28912       GOTO (1,2,3) MODE
28913
28914 *------------------------------------------------------------------
28915 * initialization
28916     1 CONTINUE
28917       DO 10 I=1,NOPART
28918          DO 11 J=1,4
28919             AVMULT(J,I) = ZERO
28920             AVE(J,I)    = ZERO
28921             AVSWM(J,I)  = ZERO
28922             AVPT(J,I)   = ZERO
28923             IAVPT(J,I)  = 0
28924    11    CONTINUE
28925    10 CONTINUE
28926
28927       RETURN
28928
28929 *------------------------------------------------------------------
28930 * filling of histogram with event-record
28931     2 CONTINUE
28932       IF (PE.LT.0.0D0) THEN
28933          WRITE(LOUT,*) ' HIMULT:  PE < 0 ! ',PE
28934          RETURN
28935       ENDIF
28936       IF (.NOT.LFRAG) THEN
28937          IVEL = 2
28938          IF (LGREY)  IVEL = 3
28939          IF (LBLACK) IVEL = 4
28940          AVE(1,IDBJT)       = AVE(1,IDBJT)   +PE
28941          AVE(IVEL,IDBJT)    = AVE(IVEL,IDBJT)+PE
28942          AVPT(1,IDBJT)     = AVPT(1,IDBJT)   +PT
28943          AVPT(IVEL,IDBJT)  = AVPT(IVEL,IDBJT)+PT
28944          IAVPT(1,IDBJT)    = IAVPT(1,IDBJT)   +1
28945          IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
28946          AVSWM(1,IDBJT)     = AVSWM(1,IDBJT)   +PE**SWMEXP
28947          AVSWM(IVEL,IDBJT)  = AVSWM(IVEL,IDBJT)+PE**SWMEXP
28948          AVMULT(1,IDBJT)    = AVMULT(1,IDBJT)   +ONE
28949          AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
28950          IF (IDBJT.LT.116) THEN
28951 *   total energy, multiplicity
28952             AVE(1,30)       = AVE(1,30)   +PE
28953             AVE(IVEL,30)    = AVE(IVEL,30)+PE
28954             AVPT(1,30)     = AVPT(1,30)   +PT
28955             AVPT(IVEL,30)  = AVPT(IVEL,30)+PT
28956             IAVPT(1,30)    = IAVPT(1,30)   +1
28957             IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
28958             AVSWM(1,30)     = AVSWM(1,30)+PE**SWMEXP
28959             AVSWM(IVEL,30)  = AVSWM(IVEL,30)+PE**SWMEXP
28960             AVMULT(1,30)    = AVMULT(1,30)   +ONE
28961             AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
28962 *   charged energy, multiplicity
28963             IF (ICHAR.LT.0) THEN
28964                AVE(1,26)       = AVE(1,26)   +PE
28965                AVE(IVEL,26)    = AVE(IVEL,26)+PE
28966                AVPT(1,26)     = AVPT(1,26)   +PT
28967                AVPT(IVEL,26)  = AVPT(IVEL,26)+PT
28968                IAVPT(1,26)    = IAVPT(1,26)   +1
28969                IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
28970                AVSWM(1,26)     = AVSWM(1,26)   +PE**SWMEXP
28971                AVSWM(IVEL,26)  = AVSWM(IVEL,26)+PE**SWMEXP
28972                AVMULT(1,26)    = AVMULT(1,26)   +ONE
28973                AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
28974             ENDIF
28975             IF (ICHAR.NE.0) THEN
28976                AVE(1,27)       = AVE(1,27)   +PE
28977                AVE(IVEL,27)    = AVE(IVEL,27)+PE
28978                AVPT(1,27)     = AVPT(1,27)   +PT
28979                AVPT(IVEL,27)  = AVPT(IVEL,27)+PT
28980                IAVPT(1,27)    = IAVPT(1,27)   +1
28981                IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
28982                AVSWM(1,27)     = AVSWM(1,27)   +PE**SWMEXP
28983                AVSWM(IVEL,27)  = AVSWM(IVEL,27)+PE**SWMEXP
28984                AVMULT(1,27)    = AVMULT(1,27)   +ONE
28985                AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
28986             ENDIF
28987          ENDIF
28988       ENDIF
28989
28990       RETURN
28991
28992 *------------------------------------------------------------------
28993 * output
28994     3 CONTINUE
28995       WRITE(LOUT,3000)
28996  3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
28997      &       29X,'---------------------',/)
28998       IF (MULDEF.EQ.1) THEN
28999          WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
29000       ELSE
29001          BETGRE = 0.7D0
29002          BETBLC = 0.23D0
29003          WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
29004  3002    FORMAT(1X,'fast:  beta > ',F4.2,'    grey:  ',F4.2,' > beta > '
29005      &          ,F4.2,'    black:  beta < ',F4.2,/)
29006       ENDIF
29007       WRITE(LOUT,3003) SWMEXP
29008  3003 FORMAT(1X,'particle    |',12X,'average multiplicity',/,
29009      &      13X,'|     total         fast',
29010 C    &      '       grey     black      K      f(',F3.1,')',/,1X,
29011      &      '       grey     black    <pt>     f(',F3.1,')',/,1X,
29012      &      '------------+--------------',
29013      &      '-------------------------------------------------')
29014       DO 30 I=1,NOPART
29015          DO 31 J=1,4
29016             AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
29017             AVE(J,I)    = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
29018             AVPT(J,I)   = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
29019             AVSWM(J,I)  = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
29020    31    CONTINUE
29021          IF (I.LE.115) THEN
29022             WRITE(LOUT,3004) ANAME(I),I,
29023      &                       AVMULT(1,I),AVMULT(2,I),
29024      &                       AVMULT(3,I),AVMULT(4,I),
29025 C    &                       AVE(1,I),AVSWM(1,I)
29026      &                       AVPT(1,I),AVSWM(1,I)
29027          ELSEIF (I.LE.119) THEN
29028             WRITE(LOUT,3004) ANAMEH(I-115),I,
29029      &                       AVMULT(1,I),AVMULT(2,I),
29030      &                       AVMULT(3,I),AVMULT(4,I),
29031 C    &                       AVE(1,I),AVSWM(1,I)
29032      &                       AVPT(1,I),AVSWM(1,I)
29033          ENDIF
29034  3004    FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29035    30 CONTINUE
29036 **temporary
29037 C     WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29038 C    &               AVMULT(3,27)+AVMULT(4,27)
29039 **
29040
29041       RETURN
29042       END
29043
29044 *$ CREATE DT_HISTAT.FOR
29045 *COPY DT_HISTAT
29046 *
29047 *===histat=============================================================*
29048 *
29049       SUBROUTINE DT_HISTAT(IDX,MODE)
29050
29051 ************************************************************************
29052 * This version dated 26.02.96 is written by S. Roesler                 *
29053 *                                                                      *
29054 * Last change 27.12.2006 by S. Roesler.                                *
29055 ************************************************************************
29056
29057       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29058       SAVE
29059
29060       PARAMETER ( LINP = 10 ,
29061      &            LOUT = 6 ,
29062      &            LDAT = 9 )
29063
29064       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29065       PARAMETER (NDIM=199)
29066
29067 * event history
29068
29069       PARAMETER (NMXHKK=200000)
29070
29071       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29072      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29073      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29074
29075 * extended event history
29076       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29077      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29078      &                IHIST(2,NMXHKK)
29079
29080 * particle properties (BAMJET index convention)
29081       CHARACTER*8  ANAME
29082       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29083      &                IICH(210),IIBAR(210),K1(210),K2(210)
29084
29085       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29086
29087 * Glauber formalism: cross sections
29088       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29089      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29090      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29091      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29092      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29093      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29094      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29095      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29096      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29097      &                BSLOPE,NEBINI,NQBINI
29098
29099 * emulsion treatment
29100       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29101      &                NCOMPO,IEMUL
29102
29103 * properties of interacting particles
29104       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29105
29106 * rejection counter
29107       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29108      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29109      &                IREXCI(3),IRDIFF(2),IRINC
29110
29111 * statistics: residual nuclei
29112       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29113      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29114      &                NINCST(2,4),NINCEV(2),
29115      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29116      &                NRESPB(2),NRESCH(2),NRESEV(4),
29117      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29118      &                NEVAFI(2,2)
29119
29120 * parameter for intranuclear cascade
29121       LOGICAL LPAULI
29122       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29123
29124 *      INCLUDE '(DIMPAR)'
29125 *     Taken from FLUKA
29126       PARAMETER ( MXXRGN =20000 )
29127       PARAMETER ( MXXMDF =  710 )
29128       PARAMETER ( MXXMDE =  702 )
29129       PARAMETER ( MFSTCK =40000 )
29130       PARAMETER ( MESTCK =  100 )
29131       PARAMETER ( MOSTCK = 2000 )
29132       PARAMETER ( MXPRSN =  100 )
29133       PARAMETER ( MXPDPM =  800 )
29134       PARAMETER ( MXPSCS =30000 )
29135       PARAMETER ( MXGLWN =  300 )
29136       PARAMETER ( MXOUTU =   50 )
29137       PARAMETER ( NALLWP =   64 )
29138       PARAMETER ( NELEMX =   80 )
29139       PARAMETER ( MPDPDX =   18 )
29140       PARAMETER ( MXHTTR =  260 )
29141       PARAMETER ( MXSEAX =   20 )
29142       PARAMETER ( MXHTNC = MXSEAX + 1 )
29143       PARAMETER ( ICOMAX = 2400 )
29144       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
29145       PARAMETER ( NSTBIS =  304 )
29146       PARAMETER ( NQSTIS =   46 )
29147       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
29148       PARAMETER ( MXPABL =  120 )
29149       PARAMETER ( IDMAXP =  450 )
29150       PARAMETER ( IDMXDC = 2000 )
29151       PARAMETER ( MXMCIN =  410 )
29152       PARAMETER ( IHYPMX =    4 )
29153       PARAMETER ( MKBMX1 =   11 )
29154       PARAMETER ( MKBMX2 =   11 )
29155       PARAMETER ( MXIRRD = 2500 )
29156       PARAMETER ( MXTRDC = 1500 )
29157       PARAMETER ( NKTL   =   17 )
29158       PARAMETER ( NBLNMX = 40000000 )
29159
29160 *      INCLUDE '(PAREVT)'
29161 *     Taken from FLUKA
29162       PARAMETER ( FRDIFF = 0.2D+00 )
29163       PARAMETER ( ETHSEA = 1.0D+00 )
29164 *
29165       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29166      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
29167      &        LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
29168      &        LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
29169       COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
29170      &                  LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29171      &                  LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29172      &                  LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
29173      &                  LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
29174      &                  LVP2XX, LV2XNW, LNWV2X, LEVFIN
29175
29176 *      INCLUDE '(FRBKCM)'
29177 *     Taken from FLUKA
29178 *  Maximum number of fragments to be emitted:
29179       PARAMETER ( MXFFBK =     6 )
29180       PARAMETER ( MXZFBK =    10 )
29181       PARAMETER ( MXNFBK =    12 )
29182       PARAMETER ( MXAFBK =    16 )
29183       PARAMETER ( MXASST =    25 )
29184       PARAMETER ( NXAFBK = MXAFBK + 1 )
29185       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 + MXASST - NXAFBK )
29186       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 + MXASST - NXAFBK )
29187       PARAMETER ( MXPSST =   700 )
29188 *  Maximum number of pre-computed break-up combinations
29189       PARAMETER ( MXPPFB = 42500 )
29190 *  Maximum number of break-up combinations, including special
29191 *  run-time ones:
29192       PARAMETER ( MXPSFB = 43000 )
29193 *  Base for J multiplicity encoding:
29194       PARAMETER ( IBFRBK =    73 )
29195 *  Maximum Ibfrbk exponent to avoid overflow of I*4(roughly at 2.1x10^9)
29196 *  it must be (Ibfrbk-1) + (Ibfrbk-1)*Ibfrbk + (Ibfrbk-1)*Ibfrbk^2 + ...
29197 *  ... + (Ibfrbk-1)*Ibfrbk^Jpwfbx < 2100000000,
29198 *  --> Ibfrbk^(Jpwfbx+1) < 2100000000
29199       PARAMETER ( JPWFBX =     4 )
29200       LOGICAL LFRMBK, LNCMSS
29201       COMMON / FRBKCM /  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29202      &          WEIFBK (MXPSST), GAMFBK (MXPSST), EXFRBK (MXPSFB),
29203      &          SDMFBK (MXPSFB), COUFBK (MXPSFB), CENFBK (MXPSFB),
29204      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, FRBKLS,
29205      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
29206      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29207      &          IPSIND (0:NXNFBK,0:NXZFBK,2), JPSIND (0:MXASST),
29208      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29209      &          IFBCHA (9,MXPSFB), IPOSST, IPOSFB, IFBSTF, IFBPSF,
29210      &          IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, LFRMBK, LNCMSS
29211
29212 *      INCLUDE '(EVAFLG)'
29213 *     Taken from FLUKA
29214       LOGICAL 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       COMMON / EVAFLG /     BRPNFR (0:2), EBRPFR (0:2), EMVBRP (0:2),
29219      &        ILVMOD, JLVMOD, JSIPFL, IMSSFR, JMSSFR, IEVFSS, MXAHEV,
29220      &        MXZHEV, IFHVFL, IFKYMX, IGMCMP, MPMODE, MSMODE, MUMODE,
29221      &        MFMODE, MEMODE, MRMODE, ITMCRR, IASYCR, IFSBCR, IFSSBR,
29222      &        LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
29223      &        LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
29224      &        LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
29225      &        LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
29226
29227 * temporary storage for one final state particle
29228       LOGICAL LFRAG,LGREY,LBLACK
29229       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29230      &                SINTHE,COSTHE,THETA,THECMS,
29231      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29232      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29233      &                LFRAG,LGREY,LBLACK
29234
29235 * event flag used for histograms
29236       COMMON /DTNORM/ ICEVT,IEVHKK
29237
29238 * statistics: double-Pomeron exchange
29239       COMMON /DTFLG2/ INTFLG,IPOPO
29240
29241       DIMENSION EMUSAM(NCOMPX)
29242
29243       CHARACTER*13 CMSG(3)
29244       DATA CMSG /'not requested','not requested','not requested'/
29245
29246       GOTO (1,2,3,4,5) MODE
29247
29248 *------------------------------------------------------------------
29249 * initialization
29250     1 CONTINUE
29251 *  emulsion treatment
29252       IF (NCOMPO.GT.0) THEN
29253          DO 10 I=1,NCOMPX
29254             EMUSAM(I) = ZERO
29255    10    CONTINUE
29256       ENDIF
29257 * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29258       NINCGE = 0
29259       DO 11 I=1,2
29260          EXCDPM(I)   = ZERO
29261          EXCDPM(I+2) = ZERO
29262          EXCEVA(I)   = ZERO
29263          NINCWO(I)   = 0
29264          NINCEV(I)   = 0
29265          NRESTO(I)   = 0
29266          NRESPR(I)   = 0
29267          NRESNU(I)   = 0
29268          NRESBA(I)   = 0
29269          NRESPB(I)   = 0
29270          NRESCH(I)   = 0
29271          NRESEV(I)   = 0
29272          NRESEV(I+2) = 0
29273          NEVAGA(I)   = 0
29274          NEVAHT(I)   = 0
29275          NEVAFI(1,I) = 0
29276          NEVAFI(2,I) = 0
29277          DO 12 J=1,6
29278             IF (J.LE.2) NINCHR(I,J) = 0
29279             IF (J.LE.3) NINCCO(I,J) = 0
29280             IF (J.LE.4) NINCST(I,J) = 0
29281             NEVA(I,J) = 0
29282    12    CONTINUE
29283          DO 13 J=1,210
29284             NEVAHY(1,I,J) = 0
29285             NEVAHY(2,I,J) = 0
29286    13    CONTINUE
29287    11 CONTINUE
29288       MAXGEN = 0
29289 **dble Po statistics.
29290       KPOPO = 0
29291
29292       RETURN
29293 *------------------------------------------------------------------
29294 * filling of histogram with event-record
29295     2 CONTINUE
29296       IF (IST.EQ.-1) THEN
29297          IF (.NOT.LFRAG) THEN
29298             IF (IDPDG.EQ.2212) THEN
29299                NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29300             ELSEIF (IDPDG.EQ.2112) THEN
29301                NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29302             ELSEIF (IDPDG.EQ.22) THEN
29303                NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29304             ELSEIF (IDPDG.EQ.80000) THEN
29305                IF (IDBJT.EQ.116) THEN
29306                   NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29307                ELSEIF (IDBJT.EQ.117) THEN
29308                   NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29309                ELSEIF (IDBJT.EQ.118) THEN
29310                   NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29311                ELSEIF (IDBJT.EQ.119) THEN
29312                   NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29313                ENDIF
29314             ENDIF
29315          ELSE
29316 *   heavy fragments (here: fission products only)
29317             NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29318             NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29319             NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29320          ENDIF
29321       ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29322          IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29323       ENDIF
29324
29325       RETURN
29326 *------------------------------------------------------------------
29327 * output
29328     3 CONTINUE
29329
29330 **dble Po statistics.
29331 C     WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29332 C    &   '# evts. / # dble-Po. evts / s_in / s_popo :',
29333 C    & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29334
29335 *  emulsion treatment
29336       IF (NCOMPO.GT.0) THEN
29337          WRITE(LOUT,3000)
29338  3000    FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29339      &          22X,'----------------------------',/,/,19X,
29340      &          'mass    charge          fraction',/,39X,
29341      &          'input     treated',/)
29342          DO 30 I=1,NCOMPO
29343             WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29344      &                       EMUSAM(I)/DBLE(ICEVT)
29345  3013       FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29346    30    CONTINUE
29347       ENDIF
29348
29349 *  i.n.c. statistics: output
29350       WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29351  3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29352      &       22X,'---------------------------------',/,/,1X,
29353      &       'no. of events for normalization: (accepted final events,',
29354      &       ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29355      &       /,1X,'no. of rejected events due to intranuclear',
29356      &       ' cascade',15X,I6,/)
29357       ICEV  = MAX(ICEVT,1)
29358       ICEV1 = ICEV
29359       IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29360       WRITE(LOUT,3002)
29361      &     (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29362      &     ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29363      &     KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29364      &    (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29365      &     (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29366      &     (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29367      &     (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29368  3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29369      &       5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29370      &       ' proj./ target (mean per evt)',/,8X,'baryons:  pos. ',
29371      &       F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,/,8X,
29372      &       'mesons:   pos. ',F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,
29373      &       /,1X,'maximum no. of generations treated (maximum allowed:'
29374      &       ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29375      &       ' interactions in proj./ target (mean per evt1)',
29376      &       F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29377      &       ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29378      &       'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29379      &       '(ap, K-, pi- only)     ',F7.3,' /',F7.3,/)
29380       WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29381      &                 IREXCI(1)+IREXCI(2)+IREXCI(3)
29382  3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29383      &       'evaporation',/,22X,'-----------------------------',
29384      &       '------------',/,/,1X,'no. of events for normal.: ',
29385      &       '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29386      &       ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29387      &       ' rejected events     (',I4,',',I4,',',I4,')',22X,I6,/)
29388
29389       WRITE(LOUT,3004)
29390  3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29391       ICEV  = MAX(NRESEV(2),1)
29392       WRITE(LOUT,3005)
29393      &     (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29394      &     (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29395      &     (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29396      &     (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29397      &     (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29398      &     (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29399      &     (EXCDPM(I)/DBLE(ICEV),I=1,2),
29400      &     (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29401  3005    FORMAT(1X,'residual nuclei:  (mean values per evt)',12X,
29402      &       'proj. / target',/,/,8X,'total number of particles',15X,
29403      &       2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29404      &       'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29405      &       'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29406      &       /,8X,'excitation energy (bef. evap.-step)   ',2E11.3,/,
29407      &       8X,'excitation energy per nucleon         ',2E11.3,/,/)
29408
29409 * evaporation / fission / fragmentation statistics: output
29410       ICEV  = MAX(NRESEV(2),1)
29411       ICEV1 = MAX(NRESEV(4),1)
29412       NTEVA1 =
29413      &   NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29414       NTEVA2 =
29415      &   NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29416       IF (LEVPRT) THEN
29417
29418          IF (IEVFSS.EQ.1) CMSG(1) = 'requested    '
29419
29420          IF (LFRMBK)     CMSG(2) = 'requested    '
29421          IF (LDEEXG)     CMSG(3) = 'requested    '
29422          WRITE(LOUT,3006)
29423      &        CMSG,
29424      &        DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29425      &        (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29426      &        (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29427      &        (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29428      &        (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29429      &        (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29430      &        (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29431      &        (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29432      &        (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29433  3006    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,'Fission:',
29434      &       13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29435      &       'deexcitation:',2X,A13,/,/,
29436      &       1X,'evaporation/deexcitation:  (mean values per evt1)  ',
29437      &       'proj. / target',/,/,8X,'total number of evap. particles',
29438      &       9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29439      &       'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29440      &       '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29441      &       2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29442      &       'heavy fragments',25X,2F9.3,/)
29443
29444          IF (IEVFSS.EQ.1) THEN
29445
29446             WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29447      &                       NEVAFI(2,1),NEVAFI(2,2),
29448      &             DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29449      &             DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29450  3007       FORMAT(1X,'Fission:   total number of events',14X,2I9,/
29451      &             12X,'out of which fission occured',8X,2I9,/,
29452      &             50X,'(',F5.2,'%) (',F5.2,'%)',/)
29453          ENDIF
29454
29455 C        IF ((LFRMBK).OR.(IEVFSS.EQ.1)) THEN
29456
29457 C           WRITE(LOUT,3008)
29458 C3008       FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29459 C    &             '       proj.   / target',/)
29460 C           DO 31 I=1,210
29461 C              IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29462 C                 WRITE(LOUT,3009) I,
29463 C    &            (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29464 C3009             FORMAT(38X,I3,3X,2E12.3)
29465 C              ENDIF
29466 C  31       CONTINUE
29467 C           WRITE(LOUT,3010)
29468 C3010       FORMAT(1X,'heavy fragments - statistics:',7X,'mass  ',
29469 C    &             '       proj.   / target',/)
29470 C           DO 32 I=1,210
29471 C              IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29472 C                 WRITE(LOUT,3011) I,
29473 C    &            (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29474 C3011             FORMAT(38X,I3,3X,2E12.3)
29475 C              ENDIF
29476 C  32       CONTINUE
29477 C           WRITE(LOUT,*)
29478 C        ENDIF
29479       ELSE
29480          WRITE(LOUT,3012)
29481  3012    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,
29482      &       'Evaporation:         not requested',/)
29483       ENDIF
29484
29485       RETURN
29486 *------------------------------------------------------------------
29487 * filling of histogram with event-record
29488     4 CONTINUE
29489 *  emulsion treatment
29490       IF (NCOMPO.GT.0) THEN
29491          DO 40 I=1,NCOMPO
29492             IF (IT.EQ.IEMUMA(I)) THEN
29493                EMUSAM(I) = EMUSAM(I)+ONE
29494             ENDIF
29495    40    CONTINUE
29496       ENDIF
29497       NINCGE = NINCGE+MAXGEN
29498       MAXGEN = 0
29499 **dble Po statistics.
29500       IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29501
29502       RETURN
29503 *------------------------------------------------------------------
29504 * filling of histogram with event-record
29505     5 CONTINUE
29506       IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29507          IB = IIBAR(IDBAM(IDX))
29508          IC = IICH(IDBAM(IDX))
29509          J  = ISTHKK(IDX)-14
29510          IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29511             NINCST(J,1) = NINCST(J,1)+1
29512          ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29513             NINCST(J,2) = NINCST(J,2)+1
29514          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29515             NINCST(J,3) = NINCST(J,3)+1
29516          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29517             NINCST(J,4) = NINCST(J,4)+1
29518          ENDIF
29519       ELSEIF (ISTHKK(IDX).EQ.17) THEN
29520          NINCWO(1) = NINCWO(1)+1
29521       ELSEIF (ISTHKK(IDX).EQ.18) THEN
29522          NINCWO(2) = NINCWO(2)+1
29523       ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29524          IB = IDRES(IDX)
29525          IC = IDXRES(IDX)
29526          IF (IC.GT.0) THEN
29527             NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29528             NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29529          ENDIF
29530          NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29531       ENDIF
29532
29533       RETURN
29534       END
29535 *$ CREATE DT_NEWHGR.FOR
29536 *COPY DT_NEWHGR
29537 *
29538 *===newhgr=============================================================*
29539 *
29540       SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29541
29542 ************************************************************************
29543 *                                                                      *
29544 *     Histogram initialization.                                        *
29545 *                                                                      *
29546 *     input:  XLIM1/XLIM2  lower/upper edge of histogram-window        *
29547 *             XLIM3        bin size                                    *
29548 *             IBIN    > 0  number of bins in equidistant lin. binning  *
29549 *                     = -1 reset histograms                            *
29550 *                     < -1 |IBIN| number of bins in equidistant log.   *
29551 *                          binning or log. binning in user def. struc. *
29552 *             XLIMB(*)     user defined bin structure                  *
29553 *                                                                      *
29554 *     The bin structure is sensitive to                                *
29555 *             XLIM1, XLIM3, IBIN     if     XLIM3 > 0   (lin.)         *
29556 *             XLIM1, XLIM2, IBIN     if     XLIM3 = 0   (lin. & log.)  *
29557 *             XLIMB, IBIN            if     XLIM3 < 0                  *
29558 *                                                                      *
29559 *                                                                      *
29560 *     output: IREFN        histogram index                             *
29561 *                          (= -1 for inconsistent histogr. request)    *
29562 *                                                                      *
29563 * This subroutine is based on a original version by R. Engel.          *
29564 * This version dated 22.4.95 is written  by S. Roesler.                *
29565 ************************************************************************
29566
29567       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29568       SAVE
29569
29570       PARAMETER ( LINP = 10 ,
29571      &            LOUT = 6 ,
29572      &            LDAT = 9 )
29573
29574       LOGICAL LSTART
29575
29576       PARAMETER (ZERO   =  0.0D0,
29577      &           TINY   =  1.0D-10)
29578
29579       DIMENSION XLIMB(*)
29580
29581 * histograms
29582
29583       PARAMETER (NHIS=150, NDIM=250)
29584
29585       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29586      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29587
29588 * auxiliary common for histograms
29589       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29590
29591       DATA LSTART /.TRUE./
29592
29593 * reset histogram counter
29594       IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29595          IHISL  = 0
29596          IF (IBIN.EQ.-1) RETURN
29597          LSTART = .FALSE.
29598       ENDIF
29599
29600       IHIS  = IHISL+1
29601 * check for maximum number of allowed histograms
29602       IF (IHIS.GT.NHIS) THEN
29603          WRITE(LOUT,1003) IHIS,NHIS,IHIS
29604  1003    FORMAT(1X,'NEWHGR:   warning!  number of histograms (',
29605      &          I4,') exceeds array size (',I4,')',/,21X,
29606      &          'histogram',I3,' skipped!')
29607          GOTO 9999
29608       ENDIF
29609
29610       IREFN = IHIS
29611       IBINS(IHIS) = ABS(IBIN)
29612 * check requested number of bins
29613       IF (IBINS(IHIS).GE.NDIM) THEN
29614          WRITE(LOUT,1000) IBIN,NDIM,NDIM
29615  1000    FORMAT(1X,'NEWHGR:   warning!  number of bins (',
29616      &          I3,') exceeds array size (',I3,')',/,21X,
29617      &          'and will be reset to ',I3)
29618          IBINS(IHIS) = NDIM
29619       ENDIF
29620       IF (IBINS(IHIS).EQ.0) THEN
29621          WRITE(LOUT,1001) IBIN,IHIS
29622  1001    FORMAT(1X,'NEWHGR:   warning!  inconsistent number of',
29623      &          ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29624          GOTO 9999
29625       ENDIF
29626
29627 * initialize arrays
29628       DO 1 I=1,NDIM
29629          DO 2 K=1,3
29630             HIST(K,IHIS,I)   = ZERO
29631             HIST(K+3,IHIS,I) = ZERO
29632             TMPHIS(K,IHIS,I) = ZERO
29633     2    CONTINUE
29634          HIST(7,IHIS,I)   = ZERO
29635     1 CONTINUE
29636       DENTRY(1,IHIS)= ZERO
29637       DENTRY(2,IHIS)= ZERO
29638       OVERF(IHIS)   = ZERO
29639       UNDERF(IHIS)  = ZERO
29640       TMPUFL(IHIS)  = ZERO
29641       TMPOFL(IHIS)  = ZERO
29642
29643 * bin str. sensitive to lower edge, bin size, and numb. of bins
29644       IF (XLIM3.GT.ZERO) THEN
29645          DO 3 K=1,IBINS(IHIS)+1
29646             HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29647     3    CONTINUE
29648          ISWI(IHIS) = 1
29649 * bin str. sensitive to lower/upper edge and numb. of bins
29650       ELSEIF (XLIM3.EQ.ZERO) THEN
29651 *   linear binning
29652          IF (IBIN.GT.0) THEN
29653             XLOW = XLIM1
29654             XHI  = XLIM2
29655             IF (XLIM2.LE.XLIM1) THEN
29656                WRITE(LOUT,1002) XLIM1,XLIM2
29657  1002          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
29658      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29659                GOTO 9999
29660             ENDIF
29661             ISWI(IHIS) = 1
29662          ELSEIF (IBIN.LT.-1) THEN
29663 *   logarithmic binning
29664             IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29665                WRITE(LOUT,1004) XLIM1,XLIM2
29666  1004          FORMAT(1X,'NEWHGR:   warning!  inconsistent log. ',
29667      &                'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29668                GOTO 9999
29669             ENDIF
29670             IF (XLIM2.LE.XLIM1) THEN
29671                WRITE(LOUT,1005) XLIM1,XLIM2
29672  1005          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
29673      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29674                GOTO 9999
29675             ENDIF
29676             XLOW = LOG10(XLIM1)
29677             XHI  = LOG10(XLIM2)
29678             ISWI(IHIS) = 3
29679          ENDIF
29680          DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29681          DO 4 K=1,IBINS(IHIS)+1
29682             HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29683     4    CONTINUE
29684       ELSE
29685 * user defined bin structure
29686          DO 5 K=1,IBINS(IHIS)+1
29687             IF (IBIN.GT.0) THEN
29688                HIST(1,IHIS,K) = XLIMB(K)
29689                ISWI(IHIS) = 2
29690             ELSEIF (IBIN.LT.-1) THEN
29691                HIST(1,IHIS,K) = LOG10(XLIMB(K))
29692                ISWI(IHIS) = 4
29693             ENDIF
29694     5    CONTINUE
29695       ENDIF
29696
29697 * histogram accepted
29698       IHISL = IHIS
29699
29700       RETURN
29701
29702  9999 CONTINUE
29703       IREFN = -1
29704       RETURN
29705       END
29706
29707 *$ CREATE DT_FILHGR.FOR
29708 *COPY DT_FILHGR
29709 *
29710 *===filhgr=============================================================*
29711 *
29712       SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29713
29714 ************************************************************************
29715 *                                                                      *
29716 *     Scoring for histogram IHIS.                                      *
29717 *                                                                      *
29718 * This subroutine is based on a original version by R. Engel.          *
29719 * This version dated 23.4.95 is written  by S. Roesler.                *
29720 ************************************************************************
29721
29722       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29723       SAVE
29724
29725       PARAMETER ( LINP = 10 ,
29726      &            LOUT = 6 ,
29727      &            LDAT = 9 )
29728
29729       PARAMETER (ZERO = 0.0D0,
29730      &           ONE  = 1.0D0,
29731      &           TINY = 1.0D-10)
29732
29733 * histograms
29734
29735       PARAMETER (NHIS=150, NDIM=250)
29736
29737       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29738      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29739
29740 * auxiliary common for histograms
29741       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29742
29743       DATA NCEVT /1/
29744
29745       X = XI
29746       Y = YI
29747
29748 * dump content of temorary arrays into histograms
29749       IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29750          CALL DT_EVTHIS(IDUM)
29751          NCEVT = NEVT
29752       ENDIF
29753
29754 * check histogram index
29755       IF (IHIS.EQ.-1) RETURN
29756       IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29757 C        WRITE(LOUT,1000) IHIS,IHISL
29758  1000    FORMAT(1X,'FILHGR:   warning!  histogram index',I4,
29759      &          ' out of range (1..',I3,')')
29760          RETURN
29761       ENDIF
29762
29763       IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29764 * bin structure not explicitly given
29765          IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29766          DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29767          IF (X.LT.HIST(1,IHIS,1)) THEN
29768             I1 = 0
29769          ELSE
29770             I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29771          ENDIF
29772
29773       ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29774 * user defined bin structure
29775          IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29776          IF (X.LT.HIST(1,IHIS,1)) THEN
29777             I1 = 0
29778          ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29779             I1 = IBINS(IHIS)+1
29780          ELSE
29781 *   binary sort algorithm
29782             KMIN = 0
29783             KMAX = IBINS(IHIS)+1
29784     1       CONTINUE
29785             IF ((KMAX-KMIN).EQ.1) GOTO 2
29786             KK = (KMAX+KMIN)/2
29787             IF (X.LE.HIST(1,IHIS,KK)) THEN
29788                KMAX=KK
29789             ELSE
29790                KMIN=KK
29791             ENDIF
29792             GOTO 1
29793     2       CONTINUE
29794             I1 = KMIN
29795          ENDIF
29796
29797       ELSE
29798          WRITE(LOUT,1001)
29799  1001    FORMAT(1X,'FILHGR:   warning!  histogram not initialized')
29800          RETURN
29801       ENDIF
29802
29803 * scoring
29804       IF (I1.LE.0) THEN
29805          TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29806       ELSEIF (I1.LE.IBINS(IHIS)) THEN
29807          TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29808          IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29809             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29810          ELSE
29811             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29812          ENDIF
29813          TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29814       ELSE
29815          TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29816       ENDIF
29817
29818       RETURN
29819       END
29820
29821 *$ CREATE DT_EVTHIS.FOR
29822 *COPY DT_EVTHIS
29823 *
29824 *===evthis=============================================================*
29825 *
29826       SUBROUTINE DT_EVTHIS(NEVT)
29827
29828 ************************************************************************
29829 * Dump content of temorary histograms into /DTHIS1/. This subroutine   *
29830 * is called after each event and for the last event before any call    *
29831 * to OUTHGR.                                                           *
29832 *         NEVT   number of events dumped, this is only needed to       *
29833 *                get the normalization after the last event            *
29834 * This version dated 23.4.95 is written  by S. Roesler.                *
29835 ************************************************************************
29836
29837       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29838       SAVE
29839
29840       PARAMETER ( LINP = 10 ,
29841      &            LOUT = 6 ,
29842      &            LDAT = 9 )
29843
29844       LOGICAL LNOETY
29845
29846       PARAMETER (ZERO = 0.0D0,
29847      &           ONE  = 1.0D0,
29848      &           TINY = 1.0D-10)
29849
29850 * histograms
29851
29852       PARAMETER (NHIS=150, NDIM=250)
29853
29854       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29855      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29856
29857 * auxiliary common for histograms
29858       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29859
29860       DATA NCEVT /0/
29861
29862       NCEVT = NCEVT+1
29863       NEVT  = NCEVT
29864
29865       DO 1 I=1,IHISL
29866          LNOETY = .TRUE.
29867          DO 2 J=1,IBINS(I)
29868             IF (TMPHIS(1,I,J).GT.ZERO) THEN
29869                LNOETY = .FALSE.
29870                HIST(2,I,J)   = HIST(2,I,J)+ONE
29871                HIST(7,I,J)   = HIST(7,I,J)+TMPHIS(1,I,J)
29872                DENTRY(2,I)   = DENTRY(2,I)+TMPHIS(1,I,J)
29873                AVX           = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29874                HIST(3,I,J)   = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29875                HIST(4,I,J)   = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29876                HIST(5,I,J)   = HIST(5,I,J)+TMPHIS(3,I,J)
29877                HIST(6,I,J)   = HIST(6,I,J)+TMPHIS(3,I,J)**2
29878                TMPHIS(1,I,J) = ZERO
29879                TMPHIS(2,I,J) = ZERO
29880                TMPHIS(3,I,J) = ZERO
29881             ENDIF
29882     2    CONTINUE
29883          IF (LNOETY) THEN
29884             IF (TMPUFL(I).GT.ZERO) THEN
29885                UNDERF(I) = UNDERF(I)+ONE
29886                TMPUFL(I) = ZERO
29887             ELSEIF (TMPOFL(I).GT.ZERO) THEN
29888                OVERF(I)  = OVERF(I)+ONE
29889                TMPOFL(I) = ZERO
29890             ENDIF
29891          ELSE
29892             DENTRY(1,I) = DENTRY(1,I)+ONE
29893          ENDIF
29894     1 CONTINUE
29895
29896       RETURN
29897       END
29898
29899 *$ CREATE DT_OUTHGR.FOR
29900 *COPY DT_OUTHGR
29901 *
29902 *===outhgr=============================================================*
29903 *
29904       SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29905      &                  ILOGY,INORM,NMODE)
29906
29907 ************************************************************************
29908 *                                                                      *
29909 *     Plot histogram(s) to standard output unit                        *
29910 *                                                                      *
29911 *         I1..6         indices of histograms to be plotted            *
29912 *         CHEAD,IHEAD   header string,integer                          *
29913 *         NEVTS         number of events                               *
29914 *         FAC           scaling factor                                 *
29915 *         ILOGY   = 1   logarithmic y-axis                             *
29916 *         INORM         normalization                                  *
29917 *                 = 0   no further normalization (FAC is obsolete)     *
29918 *                 = 1   per event and bin width                        *
29919 *                 = 2   per entry and bin width                        *
29920 *                 = 3   per bin entry                                  *
29921 *                 = 4   per event and "bin width" x1^2...x2^2          *
29922 *                 = 5   per event and "log. bin width" ln x1..ln x2    *
29923 *                 = 6   per event                                      *
29924 *         MODE    = 0   no output but normalization applied            *
29925 *                 = 1   all valid histograms separately (small frame)  *
29926 *                       all valid histograms separately (small frame)  *
29927 *                 = -1  and tables as histograms                       *
29928 *                 = 2   all valid histograms (one plot, wide frame)    *
29929 *                       all valid histograms (one plot, wide frame)    *
29930 *                 = -2  and tables as histograms                       *
29931 *                                                                      *
29932 *                                                                      *
29933 *     Note: All histograms to be plotted with one call to this         *
29934 *           subroutine and |MODE|=2 must have the same bin structure!  *
29935 *           There is no test included ensuring this fact.              *
29936 *                                                                      *
29937 * This version dated 23.4.95 is written  by S. Roesler.                *
29938 ************************************************************************
29939
29940       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29941       SAVE
29942
29943       PARAMETER ( LINP = 10 ,
29944      &            LOUT = 6 ,
29945      &            LDAT = 9 )
29946
29947       CHARACTER*72 CHEAD
29948
29949       PARAMETER (ZERO   =  0.0D0,
29950      &           IZERO  =  0,
29951      &           ONE    =  1.0D0,
29952      &           TWO    =  2.0D0,
29953      &           OHALF  =  0.5D0,
29954      &           EPS    =  1.0D-5,
29955      &           TINY   =  1.0D-8,
29956      &           SMALL  =  -1.0D8,
29957      &           RLARGE =  1.0D8 )
29958
29959 * histograms
29960
29961       PARAMETER (NHIS=150, NDIM=250)
29962
29963       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29964      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29965
29966       PARAMETER (NDIM2 = 2*NDIM)
29967       DIMENSION XX(NDIM2),YY(NDIM2)
29968
29969       PARAMETER (NHISTO = 6)
29970       DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
29971      &          IDX(NHISTO)
29972
29973       CHARACTER*43 CNORM(0:8)
29974       DATA CNORM /'no further normalization                   ',
29975      &            'per event and bin width                    ',
29976      &            'per entry1 and bin width                   ',
29977      &            'per bin entry                              ',
29978      &            'per event and "bin width" x1^2...x2^2      ',
29979      &            'per event and "log. bin width" ln x1..ln x2',
29980      &            'per event                                  ',
29981      &            'per bin entry1                             ',
29982      &            'per entry2 and bin width                   '/
29983
29984       IDX1(1) = I1
29985       IDX1(2) = I2
29986       IDX1(3) = I3
29987       IDX1(4) = I4
29988       IDX1(5) = I5
29989       IDX1(6) = I6
29990
29991       MODE = NMODE
29992
29993 * initialization if "wide frame" is requested
29994       IF (ABS(MODE).EQ.2) THEN
29995          DO 1 I=1,NHISTO
29996             DO 2 J=1,NDIM
29997                XX1(J,I) = ZERO
29998                YY1(J,I) = ZERO
29999     2       CONTINUE
30000     1    CONTINUE
30001       ENDIF
30002
30003 * plot header
30004       WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
30005
30006 * check histogram indices
30007       NHI = 0
30008       DO 3 I=1,NHISTO
30009          IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
30010             IF (ISWI(IDX1(I)).NE.0) THEN
30011                IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
30012                   WRITE(LOUT,1000)
30013      &                 IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
30014  1000             FORMAT(/,1X,'OUTHGR:   warning!  no entries in',
30015      &                   ' histogram ',I3,/,21X,'underflows:',F10.0,
30016      &                   '   overflows:  ',F10.0)
30017                ELSE
30018                   NHI = NHI+1
30019                   IDX(NHI) = IDX1(I)
30020                ENDIF
30021             ENDIF
30022          ENDIF
30023     3 CONTINUE
30024       IF (NHI.EQ.0) THEN
30025          WRITE(LOUT,1001)
30026  1001    FORMAT(/,1X,'OUTHGR:   warning!  histogram indices not valid')
30027          RETURN
30028       ENDIF
30029
30030 * check normalization request
30031       IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30032      &     ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30033      &                        (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30034      &     (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30035          WRITE(LOUT,1002) NEVTS,INORM,FAC
30036  1002    FORMAT(/,1X,'OUTHGR:   warning!  normalization request not ',
30037      &          'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30038      &          'FAC = ',E11.4)
30039          RETURN
30040       ENDIF
30041
30042       WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30043
30044 * apply normalization
30045       DO 4 N=1,NHI
30046
30047          I = IDX(N)
30048
30049          IF (ISWI(I).EQ.1) THEN
30050             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30051  1003       FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30052      &             ' to',2X,E10.4,',',2X,I3,' bins')
30053          ELSEIF (ISWI(I).EQ.2) THEN
30054             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30055             WRITE(LOUT,1007)
30056  1007       FORMAT(1X,'user defined bin structure')
30057          ELSEIF (ISWI(I).EQ.3) THEN
30058             WRITE(LOUT,1004)
30059      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30060  1004       FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30061      &             ' to',2X,E10.4,',',2X,I3,' bins')
30062          ELSEIF (ISWI(I).EQ.4) THEN
30063             WRITE(LOUT,1004)
30064      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30065             WRITE(LOUT,1007)
30066          ELSE
30067             WRITE(LOUT,1008) ISWI(I)
30068  1008       FORMAT(/,1X,'warning!  inconsistent bin structure flag ',I4)
30069          ENDIF
30070          WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30071  1005    FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30072      &          ' overfl.:',F8.0)
30073          WRITE(LOUT,1009) CNORM(INORM)
30074  1009    FORMAT(1X,'normalization: ',A,/)
30075
30076          DO 5 K=1,IBINS(I)
30077             CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30078             YMEAN = FAC*YMEAN
30079             YERR  = FAC*YERR
30080             WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30081             WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30082  1006       FORMAT(1X,5E11.3)
30083 *    small frame
30084             II = 2*K
30085             XX(II-1) = HIST(1,I,K)
30086             XX(II)   = HIST(1,I,K+1)
30087             YY(II-1) = YMEAN
30088             YY(II)   = YMEAN
30089 *    wide frame
30090             XX1(K,N) = XMEAN
30091             IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30092      &         XX1(K,N) = LOG10(XMEAN)
30093             YY1(K,N) = YMEAN
30094     5    CONTINUE
30095
30096 * plot small frame
30097          IF (ABS(MODE).EQ.1) THEN
30098             IBIN2 = 2*IBINS(I)
30099             WRITE(LOUT,'(/,1X,A)') 'Preview:'
30100             IF(ILOGY.EQ.1) THEN
30101               CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30102             ELSE
30103               CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30104             ENDIF
30105          ENDIF
30106
30107     4 CONTINUE
30108
30109 * plot wide frame
30110       IF (ABS(MODE).EQ.2) THEN
30111          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30112          NSIZE = NDIM*NHISTO
30113          DXLOW = HIST(1,IDX(1),1)
30114          DDX   = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30115          YLOW  = RLARGE
30116          YHI   = SMALL
30117          DO 6 I=1,NHISTO
30118             DO 7 J=1,NDIM
30119                IF (YY1(J,I).LT.YLOW) THEN
30120                   IF (ILOGY.EQ.1) THEN
30121                      IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30122                   ELSE
30123                      YLOW = YY1(J,I)
30124                   ENDIF
30125                ENDIF
30126                IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30127     7       CONTINUE
30128     6    CONTINUE
30129          DY = (YHI-YLOW)/DBLE(NDIM)
30130          IF (DY.LE.ZERO) THEN
30131             WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30132      &         'OUTHGR:   warning! zero bin width for histograms ',
30133      &         IDX,': ',YLOW,YHI
30134             RETURN
30135          ENDIF
30136          IF (ILOGY.EQ.1) THEN
30137             YLOW = LOG10(YLOW)
30138             DY   = (LOG10(YHI)-YLOW)/100.0D0
30139             DO 8 I=1,NHISTO
30140                DO 9 J=1,NDIM
30141                   IF (YY1(J,I).LE.ZERO) THEN
30142                      YY1(J,I) = YLOW
30143                   ELSE
30144                      YY1(J,I) = LOG10(YY1(J,I))
30145                   ENDIF
30146     9          CONTINUE
30147     8       CONTINUE
30148          ENDIF
30149          CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30150       ENDIF
30151
30152       RETURN
30153       END
30154
30155 *$ CREATE DT_GETBIN.FOR
30156 *COPY DT_GETBIN
30157 *
30158 *===getbin=============================================================*
30159 *
30160       SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30161      &                  XMEAN,YMEAN,YERR)
30162
30163 ************************************************************************
30164 * This version dated 23.4.95 is written  by S. Roesler.                *
30165 ************************************************************************
30166
30167       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30168       SAVE
30169
30170       PARAMETER ( LINP = 10 ,
30171      &            LOUT = 6 ,
30172      &            LDAT = 9 )
30173
30174       PARAMETER (ZERO   = 0.0D0,
30175      &           ONE    = 1.0D0,
30176      &           TINY35 = 1.0D-35)
30177
30178 * histograms
30179
30180       PARAMETER (NHIS=150, NDIM=250)
30181
30182       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30183      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30184
30185       XLOW = HIST(1,IHIS,IBIN)
30186       XHI  = HIST(1,IHIS,IBIN+1)
30187       IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30188          XLOW = 10**XLOW
30189          XHI  = 10**XHI
30190       ENDIF
30191       IF (NORM.EQ.2) THEN
30192          DX   = XHI-XLOW
30193          NEVT = INT(DENTRY(1,IHIS))
30194       ELSEIF (NORM.EQ.3) THEN
30195          DX   = ONE
30196          NEVT = INT(HIST(2,IHIS,IBIN))
30197       ELSEIF (NORM.EQ.4) THEN
30198          DX   = XHI**2-XLOW**2
30199          NEVT = KEVT
30200       ELSEIF (NORM.EQ.5) THEN
30201          DX   = LOG(ABS(XHI))-LOG(ABS(XLOW))
30202          NEVT = KEVT
30203       ELSEIF (NORM.EQ.6) THEN
30204          DX   = ONE
30205          NEVT = KEVT
30206       ELSEIF (NORM.EQ.7) THEN
30207          DX   = ONE
30208          NEVT = INT(HIST(7,IHIS,IBIN))
30209       ELSEIF (NORM.EQ.8) THEN
30210          DX   = XHI-XLOW
30211          NEVT = INT(DENTRY(2,IHIS))
30212       ELSE
30213          DX   = ABS(XHI-XLOW)
30214          NEVT = KEVT
30215       ENDIF
30216       IF (ABS(DX).LT.TINY35) DX = ONE
30217       NEVT   = MAX(NEVT,1)
30218       YMEAN  = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30219       YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30220       YERR   = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30221       YSUM   = HIST(5,IHIS,IBIN)
30222       IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30223 C     XMEAN  = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30224       XMEAN  = HIST(3,IHIS,IBIN)/YSUM
30225       IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30226
30227       RETURN
30228       END
30229
30230 *$ CREATE DT_JOIHIS.FOR
30231 *COPY DT_JOIHIS
30232 *
30233 *===joihis=============================================================*
30234 *
30235       SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30236
30237 ************************************************************************
30238 *                                                                      *
30239 *     Operation on histograms.                                         *
30240 *                                                                      *
30241 *     input:  IH1,IH2      histogram indices to be joined              *
30242 *             COPER        character defining the requested operation, *
30243 *                          i.e. '+', '-', '*', '/'                     *
30244 *             FAC1,FAC2    factors for joining, i.e.                   *
30245 *                          FAC1*histo1 COPER FAC2*histo2               *
30246 *                                                                      *
30247 * This version dated 23.4.95 is written  by S. Roesler.                *
30248 ************************************************************************
30249
30250       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30251       SAVE
30252
30253       PARAMETER ( LINP = 10 ,
30254      &            LOUT = 6 ,
30255      &            LDAT = 9 )
30256
30257       CHARACTER COPER*1
30258
30259       PARAMETER (ZERO   =  0.0D0,
30260      &           ONE    =  1.0D0,
30261      &           OHALF  =  0.5D0,
30262      &           TINY8  =  1.0D-8,
30263      &           SMALL  =  -1.0D8,
30264      &           RLARGE =  1.0D8 )
30265
30266 * histograms
30267
30268       PARAMETER (NHIS=150, NDIM=250)
30269
30270       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30271      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30272
30273       PARAMETER (NDIM2 = 2*NDIM)
30274       DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30275
30276       CHARACTER*43 CNORM(0:6)
30277       DATA CNORM /'no further normalization                   ',
30278      &            'per event and bin width                    ',
30279      &            'per entry and bin width                    ',
30280      &            'per bin entry                              ',
30281      &            'per event and "bin width" x1^2...x2^2      ',
30282      &            'per event and "log. bin width" ln x1..ln x2',
30283      &            'per event                                  '/
30284
30285 * check histogram indices
30286       IF ((IH1.LT.    1).OR.(IH2.LT.    1).OR.
30287      &    (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30288          WRITE(LOUT,1000) IH1,IH2,IHISL
30289  1000    FORMAT(1X,'JOIHIS:   warning!  inconsistent histogram ',
30290      &          'indices (',I3,',',I3,'),',/,21X,'valid range:  1,',I3)
30291          GOTO 9999
30292       ENDIF
30293
30294 * check bin structure of histograms to be joined
30295       IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30296          WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30297  1001    FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
30298      &          ' and ',I3,' failed',/,21X,
30299      &          'due to different numbers of bins (',I3,',',I3,')')
30300          GOTO 9999
30301       ENDIF
30302       DO 1 K=1,IBINS(IH1)+1
30303          IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30304             WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30305  1002       FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
30306      &             ' and ',I3,' failed at bin edge ',I3,/,21X,
30307      &             'X1,X2 = ',2E11.4)
30308             GOTO 9999
30309          ENDIF
30310     1 CONTINUE
30311
30312       WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30313  1003 FORMAT(1X,'JOIHIS:   joining histograms ',I3,',',I3,' with ',
30314      &       'operation ',A,/,11X,'and factors ',2E11.4)
30315       WRITE(LOUT,1004) CNORM(NORM)
30316  1004 FORMAT(1X,'normalization: ',A,/)
30317
30318       DO 2 K=1,IBINS(IH1)
30319          CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30320          CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30321          XLOW  = XLOW1
30322          XHI   = XHI1
30323          XMEAN = OHALF*(XMEAN1+XMEAN2)
30324          IF (COPER.EQ.'+') THEN
30325             YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30326          ELSEIF (COPER.EQ.'*') THEN
30327             YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30328          ELSEIF (COPER.EQ.'/') THEN
30329             IF (YMEAN2.EQ.ZERO) THEN
30330                YMEAN = ZERO
30331             ELSE
30332                IF (FAC2.EQ.ZERO) FAC2 = ONE
30333                YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30334             ENDIF
30335          ELSE
30336             GOTO 9998
30337          ENDIF
30338          WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30339          WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30340  1006    FORMAT(1X,5E11.3)
30341 *    small frame
30342          II = 2*K
30343          XX(II-1) = HIST(1,IH1,K)
30344          XX(II)   = HIST(1,IH1,K+1)
30345          YY(II-1) = YMEAN
30346          YY(II)   = YMEAN
30347 *    wide frame
30348          XX1(K) = XMEAN
30349          IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30350          YY1(K) = YMEAN
30351     2 CONTINUE
30352
30353 * plot small frame
30354       IF (ABS(MODE).EQ.1) THEN
30355          IBIN2 = 2*IBINS(IH1)
30356          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30357          IF(ILOGY.EQ.1) THEN
30358            CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30359          ELSE
30360            CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30361          ENDIF
30362       ENDIF
30363
30364 * plot wide frame
30365       IF (ABS(MODE).EQ.2) THEN
30366          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30367          NSIZE = NDIM
30368          DXLOW = HIST(1,IH1,1)
30369          DDX   = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30370          YLOW  = RLARGE
30371          YHI   = SMALL
30372          DO 3 I=1,NDIM
30373             IF (YY1(I).LT.YLOW) THEN
30374                IF (ILOGY.EQ.1) THEN
30375                   IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30376                ELSE
30377                   YLOW = YY1(I)
30378                ENDIF
30379             ENDIF
30380             IF (YY1(I).GT.YHI) YHI = YY1(I)
30381     3    CONTINUE
30382          DY = (YHI-YLOW)/DBLE(NDIM)
30383          IF (DY.LE.ZERO) THEN
30384             WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30385      &         'JOIHIS:   warning! zero bin width for histograms ',
30386      &         IH1,IH2,': ',YLOW,YHI
30387             RETURN
30388          ENDIF
30389          IF (ILOGY.EQ.1) THEN
30390             YLOW = LOG10(YLOW)
30391             DY   = (LOG10(YHI)-YLOW)/100.0D0
30392             DO 4 I=1,NDIM
30393                IF (YY1(I).LE.ZERO) THEN
30394                   YY1(I) = YLOW
30395                ELSE
30396                   YY1(I) = LOG10(YY1(I))
30397                ENDIF
30398     4       CONTINUE
30399          ENDIF
30400          CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30401       ENDIF
30402
30403       RETURN
30404
30405  9998 CONTINUE
30406       WRITE(LOUT,1005) COPER
30407  1005 FORMAT(1X,'JOIHIS:   unknown operation ',A)
30408
30409  9999 CONTINUE
30410       RETURN
30411       END
30412
30413 *$ CREATE DT_XGRAPH.FOR
30414 *COPY DT_XGRAPH
30415 *
30416 *===qgraph=============================================================*
30417 *
30418       SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30419 C***********************************************************************
30420 C
30421 C     calculate quasi graphic picture with 25 lines and 79 columns
30422 C     ranges will be chosen automatically
30423 C
30424 C     input     N          dimension of input fields
30425 C               IARG       number of curves (fields) to plot
30426 C               X          field of X
30427 C               Y1         field of Y1
30428 C               Y2         field of Y2
30429 C
30430 C This subroutine is written by R. Engel.
30431 C***********************************************************************
30432       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30433       SAVE
30434
30435       PARAMETER ( LINP = 10 ,
30436      &            LOUT = 6 ,
30437      &            LDAT = 9 )
30438
30439 C
30440       DIMENSION X(N),Y1(N),Y2(N)
30441       PARAMETER (EPS=1.D-30)
30442       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30443       CHARACTER SYMB(5)
30444       CHARACTER COL(0:149,0:49)
30445 C
30446       DATA SYMB /'0','e','z','#','x'/
30447 C
30448       ISPALT=IBREIT-10
30449 C
30450 C***  automatic range fitting
30451 C
30452       XMAX=X(1)
30453       XMIN=X(1)
30454       DO 600 I=1,N
30455          XMAX=MAX(X(I),XMAX)
30456          XMIN=MIN(X(I),XMIN)
30457  600  CONTINUE
30458       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30459 C
30460       ITEST=0
30461       DO 1100 K=0,IZEIL-1
30462          ITEST=ITEST+1
30463          IF (ITEST.EQ.IYRAST) THEN
30464             DO 1010 L=1,ISPALT-1
30465                COL(L,K)='-'
30466 1010        CONTINUE
30467             COL(ISPALT,K)='+'
30468             ITEST=0
30469             DO 1020 L=0,ISPALT-1,IXRAST
30470                COL(L,K)='+'
30471 1020        CONTINUE
30472          ELSE
30473             DO 1030 L=1,ISPALT-1
30474                COL(L,K)=' '
30475 1030        CONTINUE
30476             DO 1040 L=0,ISPALT-1,IXRAST
30477                COL(L,K)='|'
30478 1040        CONTINUE
30479             COL(ISPALT,K)='|'
30480          ENDIF
30481 1100  CONTINUE
30482 C
30483 C***  plot curve Y1
30484 C
30485       YMAX=Y1(1)
30486       YMIN=Y1(1)
30487       DO 500 I=1,N
30488          YMAX=MAX(Y1(I),YMAX)
30489          YMIN=MIN(Y1(I),YMIN)
30490 500   CONTINUE
30491       IF(IARG.GT.1) THEN
30492         DO 550 I=1,N
30493            YMAX=MAX(Y2(I),YMAX)
30494            YMIN=MIN(Y2(I),YMIN)
30495 550     CONTINUE
30496       ENDIF
30497       YMAX=(YMAX-YMIN)/40.0D0+YMAX
30498       YMIN=YMIN-(YMAX-YMIN)/40.0D0
30499       YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30500       IF(YZOOM.LT.EPS) THEN
30501         WRITE(LOUT,'(1X,A)')
30502      &    'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30503         RETURN
30504       ENDIF
30505 C
30506 C***  plot curve Y1
30507 C
30508       ILAST=-1
30509       LLAST=-1
30510       DO 1200 K=1,N
30511          L=NINT((X(K)-XMIN)/XZOOM)
30512          I=NINT((YMAX-Y1(K))/YZOOM)
30513          IF(ILAST.GE.0) THEN
30514            LD = L-LLAST
30515            ID = I-ILAST
30516            DO 55 II=0,LD,SIGN(1,LD)
30517              DO 66 KK=0,ID,SIGN(1,ID)
30518                COL(II+LLAST,KK+ILAST)=SYMB(1)
30519  66          CONTINUE
30520  55        CONTINUE
30521          ELSE
30522            COL(L,I)=SYMB(1)
30523          ENDIF
30524          ILAST = I
30525          LLAST = L
30526 1200  CONTINUE
30527 C
30528       IF(IARG.GT.1) THEN
30529 C
30530 C***  plot curve Y2
30531 C
30532         DO 1250 K=1,N
30533            L=NINT((X(K)-XMIN)/XZOOM)
30534            I=NINT((YMAX-Y2(K))/YZOOM)
30535            COL(L,I)=SYMB(2)
30536 1250    CONTINUE
30537       ENDIF
30538 C
30539 C***  write it
30540 C
30541       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30542 C
30543 C***  write range of X
30544 C
30545       XZOOM = (XMAX-XMIN)/DBLE(7)
30546       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30547 C
30548       DO 1300 K=0,IZEIL-1
30549          YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30550          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30551  110     FORMAT(1X,1PE9.2,70A1)
30552 1300  CONTINUE
30553 C
30554 C***  write range of X
30555 C
30556       XZOOM = (XMAX-XMIN)/DBLE(7)
30557       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30558       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30559  120  FORMAT(6X,7(1PE10.3))
30560       END
30561
30562 *$ CREATE DT_XGLOGY.FOR
30563 *COPY DT_XGLOGY
30564 *
30565 *===qglogy=============================================================*
30566 *
30567       SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30568 C***********************************************************************
30569 C
30570 C     calculate quasi graphic picture with 25 lines and 79 columns
30571 C     logarithmic y axis
30572 C     ranges will be chosen automatically
30573 C
30574 C     input     N          dimension of input fields
30575 C               IARG       number of curves (fields) to plot
30576 C               X          field of X
30577 C               Y1         field of Y1
30578 C               Y2         field of Y2
30579 C
30580 C This subroutine is written by R. Engel.
30581 C***********************************************************************
30582 C
30583       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30584       SAVE
30585
30586       PARAMETER ( LINP = 10 ,
30587      &            LOUT = 6 ,
30588      &            LDAT = 9 )
30589
30590       DIMENSION X(N),Y1(N),Y2(N)
30591       PARAMETER (EPS=1.D-30)
30592       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30593       CHARACTER SYMB(5)
30594       CHARACTER COL(0:149,0:49)
30595       PARAMETER (DEPS = 1.D-10)
30596 C
30597       DATA SYMB /'0','e','z','#','x'/
30598 C
30599       ISPALT=IBREIT-10
30600 C
30601 C***  automatic range fitting
30602 C
30603       XMAX=X(1)
30604       XMIN=X(1)
30605       DO 600 I=1,N
30606          XMAX=MAX(X(I),XMAX)
30607          XMIN=MIN(X(I),XMIN)
30608  600  CONTINUE
30609       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30610 C
30611       ITEST=0
30612       DO 1100 K=0,IZEIL-1
30613          ITEST=ITEST+1
30614          IF (ITEST.EQ.IYRAST) THEN
30615             DO 1010 L=1,ISPALT-1
30616                COL(L,K)='-'
30617 1010        CONTINUE
30618             COL(ISPALT,K)='+'
30619             ITEST=0
30620             DO 1020 L=0,ISPALT-1,IXRAST
30621                COL(L,K)='+'
30622 1020        CONTINUE
30623          ELSE
30624             DO 1030 L=1,ISPALT-1
30625                COL(L,K)=' '
30626 1030        CONTINUE
30627             DO 1040 L=0,ISPALT-1,IXRAST
30628                COL(L,K)='|'
30629 1040        CONTINUE
30630             COL(ISPALT,K)='|'
30631          ENDIF
30632 1100  CONTINUE
30633 C
30634 C***  plot curve Y1
30635 C
30636       YMAX=Y1(1)
30637       YMIN=MAX(Y1(1),EPS)
30638       DO 500 I=1,N
30639          YMAX =MAX(Y1(I),YMAX)
30640          IF(Y1(I).GT.EPS) THEN
30641            IF(YMIN.EQ.EPS) THEN
30642              YMIN = Y1(I)/10.D0
30643            ELSE
30644              YMIN = MIN(Y1(I),YMIN)
30645            ENDIF
30646          ENDIF
30647 500   CONTINUE
30648       IF(IARG.GT.1) THEN
30649         DO 550 I=1,N
30650            YMAX=MAX(Y2(I),YMAX)
30651            IF(Y2(I).GT.EPS) THEN
30652              IF(YMIN.EQ.EPS) THEN
30653                YMIN = Y2(I)
30654              ELSE
30655                YMIN = MIN(Y2(I),YMIN)
30656              ENDIF
30657            ENDIF
30658 550     CONTINUE
30659       ENDIF
30660 C
30661       DO 560 I=1,N
30662         Y1(I) = MAX(Y1(I),YMIN)
30663  560  CONTINUE
30664       IF(IARG.GT.1) THEN
30665         DO 570 I=1,N
30666           Y2(I) = MAX(Y2(I),YMIN)
30667  570    CONTINUE
30668       ENDIF
30669 C
30670       IF(YMAX.LE.YMIN) THEN
30671         WRITE(LOUT,'(/1X,A,2E12.3,/)')
30672      &     'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30673         WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30674         RETURN
30675       ENDIF
30676 C
30677       YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30678       YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30679       YZOOM=(YMA-YMI)/DBLE(IZEIL)
30680       IF(YZOOM.LT.EPS) THEN
30681         WRITE(LOUT,'(1X,A)')
30682      &    'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30683         RETURN
30684       ENDIF
30685 C
30686 C***  plot curve Y1
30687 C
30688       ILAST=-1
30689       LLAST=-1
30690       DO 1200 K=1,N
30691          L=NINT((X(K)-XMIN)/XZOOM)
30692          I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30693          IF(ILAST.GE.0) THEN
30694            LD = L-LLAST
30695            ID = I-ILAST
30696            DO 55 II=0,LD,SIGN(1,LD)
30697              DO 66 KK=0,ID,SIGN(1,ID)
30698                COL(II+LLAST,KK+ILAST)=SYMB(1)
30699  66          CONTINUE
30700  55        CONTINUE
30701          ELSE
30702            COL(L,I)=SYMB(1)
30703          ENDIF
30704          ILAST = I
30705          LLAST = L
30706 1200  CONTINUE
30707 C
30708       IF(IARG.GT.1) THEN
30709 C
30710 C***  plot curve Y2
30711 C
30712         DO 1250 K=1,N
30713            L=NINT((X(K)-XMIN)/XZOOM)
30714            I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30715            COL(L,I)=SYMB(2)
30716 1250    CONTINUE
30717       ENDIF
30718 C
30719 C***  write it
30720 C
30721       WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30722       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30723 C
30724 C***  write range of X
30725 C
30726       XZOOM1 = (XMAX-XMIN)/DBLE(7)
30727       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30728 C
30729       DO 1300 K=0,IZEIL-1
30730          YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30731          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30732  110     FORMAT(1X,1PE9.2,70A1)
30733 1300  CONTINUE
30734 C
30735 C***  write range of X
30736 C
30737       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30738       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30739  120  FORMAT(6X,7(1PE10.3))
30740 C
30741       END
30742
30743 *$ CREATE DT_SRPLOT.FOR
30744 *COPY DT_SRPLOT
30745 *
30746 *===plot===============================================================*
30747 *
30748       SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30749
30750       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30751       SAVE
30752
30753       PARAMETER ( LINP = 10 ,
30754      &            LOUT = 6 ,
30755      &            LDAT = 9 )
30756
30757 *
30758 *     initial version
30759 *     J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30760 *     This is a subroutine of fluka to plot Y across the page
30761 *     as a function of X down the page. Up to 37 curves can be
30762 *     plotted in the same picture with different plotting characters.
30763 *     Output of first 10 overprinted characters addad by FB 88
30764 *  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30765 *
30766 *     Input Variables:
30767 *        X   = array containing the values of X
30768 *        Y   = array containing the values of Y
30769 *        N   = number of values in X and in Y
30770 *              can exceed the fixed number of lines
30771 *        M   = number of different curves X,Y are containing
30772 *        MM  = number of points in each curve i.e. N=M*MM
30773 *        XO  = smallest value of X to be plotted
30774 *        DX  = increment of X between subsequent lines
30775 *        YO  = smallest value of Y to be plotted
30776 *        DY  = increment of Y between subsequent character spaces
30777 *
30778 *        other variables used inside:
30779 *        XX  = numbers along the X-coordinate axis
30780 *        YY  = numbers along the Y-coordinate axis
30781 *        LL  = ten lines temporary storage for the plot
30782 *        L   = character set used to plot different curves
30783 *        LOV = memorizes overprinted symbols
30784 *              the first 10 overprinted symbols are printed on
30785 *              the end of the line to avoid ambiguities
30786 *              (added by FB as considered quite helpful)
30787 *
30788 *********************************************************************
30789 *
30790       DIMENSION XX(61),YY(61),LL(101,10)
30791       DIMENSION X(N),Y(N),L(40),LOV(40,10)
30792       INTEGER*4 LL, L, LOV
30793       DATA  L/
30794      11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30795      21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30796      31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30797      41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H  /
30798 *
30799 *
30800       MN=51
30801       DO 10 I=1,MN
30802         AI=I-1
30803    10 XX(I)=XO+AI*DX
30804       DO 20 I=1,11
30805         AI=I-1
30806    20 YY(I)=YO+10.0D0*AI*DY
30807       WRITE(LOUT, 500) (YY(I),I=1,11)
30808       MMN=MN-1
30809 *
30810 *
30811       DO 90 JJ=1,MMN,10
30812         JJJ=JJ-1
30813         DO 30 I=1,101
30814           DO 30 J=1,10
30815    30   LL(I,J)=L(40)
30816         DO 40 I=1,101
30817    40   LL(I,1)=L(39)
30818         DO 50 I=1,101,10
30819           DO 50 J=1,10
30820    50   LL(I,J)=L(38)
30821         DO 60 I=1,40
30822           DO 60 J=1,10
30823    60   LOV(I,J)=L(40)
30824 *
30825 *
30826         DO 70 I=1,M
30827           DO 70 J=1,MM
30828             II=J+(I-1)*MM
30829             AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30830             AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30831             AIX=AIX-DBLE(JJJ)
30832 *           changed Sept.88 by FB to avoid INTEGER OVERFLOW
30833             IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30834      +      . AIY .LT. 102.D0) THEN
30835               IX=INT(AIX)
30836               IY=INT(AIY)
30837               IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30838      +        THEN
30839                 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30840      +          =LL(IY,IX)
30841                 LL(IY,IX)=L(I)
30842               ENDIF
30843             ENDIF
30844    70   CONTINUE
30845 *
30846 *
30847         DO 80 I=1,10
30848           II=I+JJJ
30849           III=II+1
30850           WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30851      &                    (LOV(J,I),J=1,10)
30852    80   CONTINUE
30853    90 CONTINUE
30854 *
30855 *
30856       WRITE(LOUT, 520)
30857       WRITE(LOUT, 500) (YY(I),I=1,11)
30858       RETURN
30859 *
30860   500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30861   510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30862   520 FORMAT(20X,10('1---------'),'1')
30863       END
30864 *$ CREATE DT_DEFSET.FOR
30865 *COPY DT_DEFSET
30866 *
30867 *===defset=============================================================*
30868 *
30869       BLOCK DATA DT_DEFSET
30870
30871       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30872       SAVE
30873
30874 * flags for input different options
30875       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30876       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30877      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30878
30879       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30880
30881 * emulsion treatment
30882       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30883      &                NCOMPO,IEMUL
30884
30885 * / DTFLG1 /
30886       DATA IFRAG  / 2, 1 /
30887       DATA IRESCO / 1 /
30888       DATA IMSHL  / 1 /
30889       DATA IRESRJ / 0 /
30890       DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30891       DATA LEMCCK / .FALSE. /
30892       DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30893      &              .TRUE.,.TRUE.,.TRUE./
30894       DATA LSEADI / .TRUE. /
30895       DATA LEVAPO / .TRUE. /
30896       DATA IFRAME / 1 /
30897       DATA ITRSPT / 0 /
30898
30899 * / DTCOMP /
30900       DATA EMUFRA / NCOMPX*0.0D0 /
30901       DATA IEMUMA / NCOMPX*1 /
30902       DATA IEMUCH / NCOMPX*1 /
30903       DATA NCOMPO / 0 /
30904       DATA IEMUL  / 0 /
30905
30906       END
30907
30908 *$ CREATE DT_HADPRP.FOR
30909 *COPY DT_HADPRP
30910 *
30911 *===hadprp=============================================================*
30912 *
30913       BLOCK DATA DT_HADPRP
30914
30915       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30916       SAVE
30917
30918 * auxiliary common for reggeon exchange (DTUNUC 1.x)
30919       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30920      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30921      &                IQTCHR(-6:6),MQUARK(3,39)
30922
30923 * hadron index conversion (BAMJET <--> PDG)
30924       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30925      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
30926      &                IAMCIN(210)
30927
30928 * names of hadrons used in input-cards
30929       CHARACTER*8 BTYPE
30930       COMMON /DTPAIN/ BTYPE(30)
30931
30932 * / DTQUAR /
30933 *----------------------------------------------------------------------*
30934 *                                                                      *
30935 *     Quark content of particles:                                      *
30936 *          index   quark   el. charge  bar. charge  isospin  isospin3  *
30937 *              1 = u          2/3          1/3        1/2       1/2    *
30938 *             -1 = ubar      -2/3         -1/3        1/2      -1/2    *
30939 *              2 = d         -1/3          1/3        1/2      -1/2    *
30940 *             -2 = dbar       1/3         -1/3        1/2       1/2    *
30941 *              3 = s         -1/3          1/3         0         0     *
30942 *             -3 = sbar       1/3         -1/3         0         0     *
30943 *              4 = c          2/3          1/3         0         0     *
30944 *             -4 = cbar      -2/3         -1/3         0         0     *
30945 *              5 = b         -1/3          1/3         0         0     *
30946 *             -5 = bbar       1/3         -1/3         0         0     *
30947 *              6 = t          2/3          1/3         0         0     *
30948 *             -6 = tbar      -2/3         -1/3         0         0     *
30949 *                                                                      *
30950 *         Mquark = particle quark composition (Paprop numbering)       *
30951 *         Iqechr = electric charge ( in 1/3 unit )                     *
30952 *         Iqbchr = baryonic charge ( in 1/3 unit )                     *
30953 *         Iqichr = isospin ( in 1/2 unit ), z component                *
30954 *         Iqschr = strangeness                                         *
30955 *         Iqcchr = charm                                               *
30956 *         Iquchr = beauty                                              *
30957 *         Iqtchr = ......                                              *
30958 *                                                                      *
30959 *----------------------------------------------------------------------*
30960       DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
30961       DATA IQBCHR / 6*-1, 0, 6*1 /
30962       DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
30963       DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
30964       DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
30965       DATA IQUCHR / 0, 1, 9*0, -1, 0 /
30966       DATA IQTCHR / -1, 11*0, 1 /
30967       DATA MQUARK /
30968      &   2, 1, 1,   -2,-1,-1,    0, 0, 0,    0, 0, 0,    0, 0, 0,
30969      &   0, 0, 0,    0, 0, 0,    2, 2, 1,   -2,-2,-1,    0, 0, 0,
30970      &   0, 0, 0,    0, 0, 0,    1,-2, 0,    2,-1, 0,    1,-3, 0,
30971      &   3,-1, 0,    1, 2, 3,   -1,-2,-3,    0, 0, 0,    2, 2, 3,
30972      &   1, 1, 3,    1, 2, 3,    1,-1, 0,    2,-3, 0,    3,-2, 0,
30973      &   2,-2, 0,    3,-3, 0,    0, 0, 0,    0, 0, 0,    0, 0, 0,
30974      &  -1,-1,-3,   -1,-2,-3,   -2,-2,-3,    1, 3, 3,   -1,-3,-3,
30975      &   2, 3, 3,   -2,-3,-3,    3, 3, 3,   -3,-3,-3 /
30976
30977 * / DTHAIC /
30978 * (renamed) (HAdron InDex COnversion)
30979 * translation table version filled up by r.e. 25.01.94                 *
30980       DATA IAMCIN /
30981      &2212,-2212,11,-11,12,              -12,22,2112,-2112,-13,
30982      &13,130,211,-211,321,               -321,3122,-3122,310,3112,
30983      &3222,3212,111,311,-311,            0,0,0,0,0,
30984      &221,213,113,-213,223,              323,313,-323,-313,10323,
30985      &10313,-10323,-10313,30323,30313,   -30323,-30313,3224,3214,3114,
30986      &3216,3218,2224,2214,2114,          1114,12224,12214,12114,11114,
30987      &99999,99999,22212,22112,32124,     31214,-2224,-2214,-2114,-1114,
30988      &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
30989      &5*99999,                           5*99999,
30990      &4*99999,331,                       333,3322,3312,-3222,-3212,
30991      &-3112,-3322,-3312,3224,3214,       3114,3324,3314,3334,-3224,
30992      &-3214,-3114,-3324,-3314,-3334,     421,411,-411,-421,431,
30993      &-431,441,423,413,-413,             -423,433,-433,20443,443,
30994      &-15,15,16,-16,14,                  -14,4122,4232,4132,4222,
30995      &4212,4112,3*99999,                 3*99999,-4122,-4232,
30996      &-4132,-4222,-4212,-4112,99999,     5*99999,
30997      &5*99999,                           5*99999,
30998      &10*99999,
30999      &5*99999 , 20211,20111,-20211,99999,20321,
31000      &-20321,20311,-20311,7*99999 ,
31001      &7*99999,12212,12112,99999/
31002
31003 * / DTHAIC /
31004 * (HAdron InDex COnversion)
31005       DATA (IPDG2(1,K),K=1,7)
31006      &   /   -11,   -12,   -13,   -15,   -16,   -14,     0/
31007       DATA (IBAM2(1,K),K=1,7)
31008      &   /     4,     6,    10,   131,   134,   136,     0/
31009       DATA (IPDG2(2,K),K=1,7)
31010      &   /    11,    12,    22,    13,    15,    16,    14/
31011       DATA (IBAM2(2,K),K=1,7)
31012      &   /     3,     5,     7,    11,   132,   133,   135/
31013       DATA (IPDG3(1,K),K=1,22)
31014      &   /  -211,  -321,  -311,  -213,  -323,  -313,  -411,  -421,
31015      &      -431,  -413,  -423,  -433,     0,     0,     0,     0,
31016      &         0,     0,     0,     0,     0,     0/
31017       DATA (IBAM3(1,K),K=1,22)
31018      &   /    14,    16,    25,    34,    38,    39,   118,   119,
31019      &       121,   125,   126,   128,     0,     0,     0,     0,
31020      &         0,     0,     0,     0,     0,     0/
31021       DATA (IPDG3(2,K),K=1,22)
31022      &   /   130,   211,   321,   310,   111,   311,   221,   213,
31023      &       113,   223,   323,   313,   331,   333,   421,   411,
31024      &       431,   441,   423,   413,   433,   443/
31025       DATA (IBAM3(2,K),K=1,22)
31026      &   /    12,    13,    15,    19,    23,    24,    31,    32,
31027      &        33,    35,    36,    37,    95,    96,   116,   117,
31028      &       120,   122,   123,   124,   127,   130/
31029       DATA (IPDG4(1,K),K=1,29)
31030      &   / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
31031      &     -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31032      &     -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31033      &     -4212, -4112,     0,     0,     0/
31034       DATA (IBAM4(1,K),K=1,29)
31035      &   /     2,     9,    18,    67,    68,    69,    70,    75,
31036      &        76,    99,   100,   101,   102,   103,   110,   111,
31037      &       112,   113,   114,   115,   149,   150,   151,   152,
31038      &       153,   154,     0,     0,     0/
31039       DATA (IPDG4(2,K),K=1,29)
31040      &   /  2212,  2112,  3122,  3112,  3222,  3212,  3224,  3214,
31041      &      3114,  3216,  3218,  2224,  2214,  2114,  1114,  3322,
31042      &      3312,  3224,  3214,  3114,  3324,  3314,  3334,  4122,
31043      &      4232,  4132,  4222,  4212,  4112/
31044       DATA (IBAM4(2,K),K=1,29)
31045      &   /     1,     8,    17,    20,    21,    22,    48,    49,
31046      &        50,    51,    52,    53,    54,    55,    56,    97,
31047      &        98,   104,   105,   106,   107,   108,   109,   137,
31048      &       138,   139,   140,   141,   142/
31049       DATA (IPDG5(1,K),K=1,19)
31050      &   /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31051      &    -20211,-20321,-20311,     0,     0,     0,     0,     0,
31052      &         0,     0,     0/
31053       DATA (IBAM5(1,K),K=1,19)
31054      &   /    42,    43,    46,    47,    71,    72,    73,    74,
31055      &       188,   191,   193,     0,     0,     0,     0,     0,
31056      &         0,     0,     0/
31057       DATA (IPDG5(2,K),K=1,19)
31058      &   / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31059      &     22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31060      &     20311, 12212, 12112/
31061       DATA (IBAM5(2,K),K=1,19)
31062      &   /    40,    41,    44,    45,    57,    58,    59,    60,
31063      &        63,    64,    65,    66,   129,   186,   187,   190,
31064      &       192,   208,   209/
31065
31066 * / DTPAIN /
31067 * internal particle names
31068       DATA BTYPE / 'PROTON  ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31069      &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON  ' , 'NEUTRON ' , 'ANEUTRON' ,
31070      &'MUON+   ' , 'MUON-   ' , 'KAONLONG' , 'PION+   ' , 'PION-   ' ,
31071      &'KAON+   ' , 'KAON-   ' , 'LAMBDA  ' , 'ALAMBDA ' , 'KAONSHRT' ,
31072      &'SIGMA-  ' , 'SIGMA+  ' , 'SIGMAZER' , 'PIZERO  ' , 'KAONZERO' ,
31073      &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31074      &'BLANK   ' /
31075
31076       END
31077
31078 *$ CREATE DT_BLKD46.FOR
31079 *COPY DT_BLKD46
31080 *
31081 *===blkd46=============================================================*
31082 *
31083       BLOCK DATA DT_BLKD46
31084
31085       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31086       SAVE
31087
31088       PARAMETER ( AMELCT = 0.51099906         D-03 )
31089       PARAMETER ( AMMUON = 0.105658389        D+00 )
31090
31091 * particle properties (BAMJET index convention)
31092       CHARACTER*8  ANAME
31093       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31094      &                IICH(210),IIBAR(210),K1(210),K2(210)
31095
31096 * / DTPART /
31097 * Particle  masses Engel version JETSET compatible
31098 C     DATA (AAM(K),K=1,85) /
31099 C    &   .9383D+00, .9383D+00,  AMELCT  ,  AMELCT  , .0000D+00,
31100 C    &   .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON   ,
31101 C    &   AMMUON   , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31102 C    &   .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31103 C    &   .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31104 C    &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31105 C    &   .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31106 C    &   .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31107 C    &   .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31108 C    &   .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31109 C    &   .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31110 C    &   .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31111 C    &   .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31112 C    &   .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31113 C    &   .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31114 C    &   .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31115 C    &   .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01  /
31116 C     DATA (AAM(K),K=86,183) /
31117 C    &   .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31118 C    &   .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31119 C    &   .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31120 C    &   .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31121 C    &   .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31122 C    &   .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31123 C    &   .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31124 C    &   .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31125 C    &   .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31126 C    &   .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31127 C    &   .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31128 C    &   .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31129 C    &   .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31130 C    &   .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31131 C    &   .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31132 C    &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31133 C    &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31134 C    &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31135 C    &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31136 C    &   .1250D+01, .1250D+01, .1250D+01  /
31137 C     DATA (AAM ( I ), I = 184,210 ) /
31138 C    & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31139 C    & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31140 C    & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31141 C    & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31142 C    & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31143 C    & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31144 C    & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31145 C    & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31146 C    & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31147 * sr 25.1.06: particle masses adjusted to Pythia
31148       DATA (AAM(K),K=1,85) /
31149      &   .938270E+00,.938270E+00, AMELCT    , AMELCT    ,.000000E+00,
31150      &   .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON    ,
31151      &    AMMUON    ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31152      &   .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31153      &   .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31154      &     .0000D+00,  .0000D+00,  .0000D+00 , .0000D+00,  .0000D+00,
31155      &   .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31156      &   .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31157      &   .129000E+01,.129000E+01,.129000E+01,  .1421D+01,  .1421D+01,
31158      &     .1421D+01,  .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31159      &     .1820D+01,  .2030D+01,  .1231D+01,  .1232D+01,  .1233D+01,
31160      &     .1234D+01,  .1675D+01,  .1675D+01,  .1675D+01,  .1675D+01,
31161      &     .1500D+01,  .1500D+01,  .1515D+01,  .1515D+01,  .1775D+01,
31162      &     .1775D+01,  .1231D+01,  .1232D+01,  .1233D+01,  .1234D+01,
31163      &     .1675D+01,  .1675D+01,  .1675D+01,  .1675D+01,  .1515D+01,
31164      &     .1515D+01,  .2500D+01,  .4890D+00,  .4890D+00,  .4890D+00,
31165      &     .1300D+01,  .1300D+01,  .1300D+01,  .1300D+01,  .2200D+01  /
31166       DATA (AAM(K),K=86,183) /
31167      &     .2200D+01,  .2200D+01,  .2200D+01,  .1700D+01,  .1700D+01,
31168      &     .1700D+01,  .1700D+01,  .1820D+01,  .2030D+01,.957770E+00,
31169      &   .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31170      &   .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31171      &   .138720E+01,.153180E+01,  .1535D+01,.167245E+01,.138280E+01,
31172      &   .138370E+01,.138720E+01,.153180E+01,  .1535D+01,.167245E+01,
31173      &   .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31174      &   .196850E+01,.297980E+01,.200670E+01,  .2010D+01,  .2010D+01,
31175      &   .200670E+01,.211240E+01,.211240E+01,  .3686D+01,.309688E+01,
31176      &   .177700E+01,.177700E+01,  .0000D+00,  .0000D+00,  .0000D+00,
31177      &     .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31178      &   .245350E+01,.245210E+01,  .2560D+01,  .2560D+01,  .2730D+01,
31179      &     .3610D+01,  .3610D+01,  .3790D+01,.228490E+01,.246560E+01,
31180      &     .2460D+01,.245290E+01,.245350E+01,.245210E+01,  .2560D+01,
31181      &     .2560D+01,  .2730D+01,  .3610D+01,  .3610D+01,  .3790D+01,
31182      &     .2490D+01,  .2490D+01,  .2490D+01,  .2610D+01,  .2610D+01,
31183      &     .2770D+01,  .3670D+01,  .3670D+01,  .3850D+01,  .4890D+01,
31184      &     .2490D+01,  .2490D+01,  .2490D+01,  .2610D+01,  .2610D+01,
31185      &     .2770D+01,  .3670D+01,  .3670D+01,  .3850D+01,  .4890D+01,
31186      &     .1250D+01,  .1250D+01,  .1250D+01  /
31187       DATA (AAM ( I ), I = 184,210 ) /
31188      & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31189      & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31190      & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31191      & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31192      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31193      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31194      & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31195      & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31196      & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31197 * Particle  mean lives
31198       DATA (TAU(K),K=1,183) /
31199      &   .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31200      &   .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31201      &   .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31202      &   .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31203      &   .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31204      &   70*.0000D+00,
31205      &   .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31206      &   .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31207      &   .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31208      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31209      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31210      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31211      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31212      &   .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31213      &   .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31214      &   40*.0000D+00,
31215      &   .0000D+00, .0000D+00, .0000D+00  /
31216       DATA ( TAU ( I ), I = 184,210 ) /
31217      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31218      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31219      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31220      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31221      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31222      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31223      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31224      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31225      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
31226 * Resonance width Gamma in GeV
31227       DATA (GA(K),K=  1,85) /
31228      &    30*.0000D+00,
31229      &   .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31230      &   .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31231      &   .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31232      &   .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31233      &   .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31234      &   .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31235      &   .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31236      &   .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31237      &   .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31238      &   .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31239      &   .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00  /
31240       DATA (GA(K),K= 86,183) /
31241      &   .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31242      &   .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31243      &   .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31244      &   .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31245      &   .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31246      &   .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31247      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31248      &   .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31249      &   .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31250      &   50*.0000D+00,
31251      &   .3000D+00, .3000D+00, .3000D+00  /
31252       DATA ( GA ( I ), I = 184,210 ) /
31253      & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31254      & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31255      & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31256      & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31257      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31258      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31259      & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31260      & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31261      & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31262 * Particle  names
31263 * S+1385+Sigma+(1385)    L02030+Lambda0(2030)
31264 * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31265 * designation N*@@ means N*@1(@2)
31266       DATA (ANAME(K),K=1,85) /
31267      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
31268      &  'ANUE    ','GAM     ','NEU     ','ANEU    ','MUE+    ',
31269      &  'MUE-    ','K0L     ','PI+     ','PI-     ','K+      ',
31270      &  'K-      ','LAM     ','ALAM    ','K0S     ','SIGM-   ',
31271      &  'SIGM+   ','SIGM0   ','PI0     ','K0      ','AK0     ',
31272      &  'BLANK   ','BLANK   ','BLANK   ','BLANK   ','BLANK   ',
31273      &  'ETA550  ','RHO+77  ','RHO077  ','RHO-77  ','OM0783  ',
31274      &  'K*+892  ','K*0892  ','K*-892  ','AK*089  ','KA+125  ',
31275      &  'KA0125  ','KA-125  ','AKA012  ','K*+142  ','K*0142  ',
31276      &  'K*-142  ','AK*014  ','S+1385  ','S01385  ','S-1385  ',
31277      &  'L01820  ','L02030  ','N*++12  ','N*+ 12  ','N*012   ',
31278      &  'N*-12   ','N*++16  ','N*+16   ','N*016   ','N*-16   ',
31279      &  'N*+14   ','N*014   ','N*+15   ','N*015   ','N*+18   ',
31280      &  'N*018   ','AN--12  ','AN*-12  ','AN*012  ','AN*+12  ',
31281      &  'AN--16  ','AN*-16  ','AN*016  ','AN*+16  ','AN*-15  ',
31282      &  'AN*015  ','DE*=24  ','RPI+49  ','RPI049  ','RPI-49  ',
31283      &  'PIN++   ','PIN+0   ','PIN+-   ','PIN-0   ','PPPI    ' /
31284       DATA (ANAME(K),K=86,183) /
31285      &  'PNPI    ','APPPI   ','APNPI   ','K+PPI   ','K-PPI   ',
31286      &  'K+NPI   ','K-NPI   ','S+1820  ','S-2030  ','ETA*    ',
31287      &  'PHI     ','TETA0   ','TETA-   ','ASIG-   ','ASIG0   ',
31288      &  'ASIG+   ','ATETA0  ','ATETA+  ','SIG*+   ','SIG*0   ',
31289      &  'SIG*-   ','TETA*0  ','TETA*   ','OMEGA-  ','ASIG*-  ',
31290      &  'ASIG*0  ','ASIG*+  ','ATET*0  ','ATET*+  ','OMEGA+  ',
31291      &  'D0      ','D+      ','D-      ','AD0     ','F+      ',
31292      &  'F-      ','ETAC    ','D*0     ','D*+     ','D*-     ',
31293      &  'AD*0    ','F*+     ','F*-     ','PSI     ','JPSI    ',
31294      &  'TAU+    ','TAU-    ','NUET    ','ANUET   ','NUEM    ',
31295      &  'ANUEM   ','C0+     ','A+      ','A0      ','C1++    ',
31296      &  'C1+     ','C10     ','S+      ','S0      ','T0      ',
31297      &  'XU++    ','XD+     ','XS+     ','AC0-    ','AA-     ',
31298      &  'AA0     ','AC1--   ','AC1-    ','AC10    ','AS-     ',
31299      &  'AS0     ','AT0     ','AXU--   ','AXD-    ','AXS     ',
31300      &  'C1*++   ','C1*+    ','C1*0    ','S*+     ','S*0     ',
31301      &  'T*0     ','XU*++   ','XD*+    ','XS*+    ','TETA++  ',
31302      &  'AC1*--  ','AC1*-   ','AC1*0   ','AS*-    ','AS*0    ',
31303      &  'AT*0    ','AXU*--  ','AXD*-   ','AXS*-   ','ATET--  ',
31304      &  'RO      ','R+      ','R-      '  /
31305       DATA (    ANAME ( I ), I = 184,210 ) /
31306      &'AN*-14  ','AN*014  ','PI+130  ','PI0130  ','PI-130  ','F01400  ',
31307      &'K*+146  ','K*-146  ','K*0146  ','AK0146  ','L01600  ','AL0160  ',
31308      &'S+1660  ','S01660  ','S-1660  ','AS-166  ','AS0166  ','AS+166  ',
31309      &'X01950  ','X-1950  ','AX0195  ','AX+195  ','OM-225  ','AOM+22  ',
31310      &'N*+14   ','N*014   ','BLANK   '/
31311 * Charge of particles and resonances
31312       DATA (IICH ( I ), I =   1,210 ) /
31313      &  1, -1, -1,  1,  0,  0,  0,  0,  0,  1, -1,  0,  1, -1,  1,
31314      & -1,  0,  0,  0, -1,  1,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31315      &  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0,
31316      & -1,  0,  1,  0, -1,  0,  0,  2,  1,  0, -1,  2,  1,  0, -1,
31317      &  1,  0,  1,  0,  1,  0, -2, -1,  0,  1, -2, -1,  0,  1, -1,
31318      &  0,  1,  1,  0, -1,  2,  1,  0, -1,  2,  1,  0, -1,  2,  0,
31319      &  1, -1,  1, -1,  0,  0,  0, -1, -1,  0,  1,  0,  1,  1,  0,
31320      & -1,  0, -1, -1, -1,  0,  1,  0,  1,  1,  0,  1, -1,  0,  1,
31321      & -1,  0,  0,  1, -1,  0,  1, -1,  0,  0,  1, -1,  0,  0,  0,
31322      &  0,  1,  1,  0,  2,  1,  0,  1,  0,  0,  2,  1,  1, -1, -1,
31323      &  0, -2, -1,  0, -1,  0,  0, -2, -1, -1,  2,  1,  0,  1,  0,
31324      &  0,  2,  1,  1,  2, -2, -1,  0, -1,  0,  0, -2, -1, -1, -2,
31325      &  0,  1, -1, -1,  0,  1,  0, -1,  0,  1, -1,  0,  0,  0,  0,
31326      &  1,  0, -1, -1,  0,  1,  0, -1,  0,  1, -1,  1,  1,  0,  0/
31327 * Particle  baryonic charges
31328       DATA (IIBAR ( I ), I =   1,210 ) /
31329      &  1, -1,  0,  0,  0,  0,  0,  1, -1,  0,  0,  0,  0,  0,  0,
31330      &  0,  1, -1,  0,  1,  1,  1,  0,  0,  0,  0,  0,  0,  0,  0,
31331      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31332      &  0,  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
31333      &  1,  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31334      & -1,  2,  0,  0,  0,  1,  1,  1,  1,  2,  2,  0,  0,  1,  1,
31335      &  1,  1,  1,  1,  0,  0,  1,  1, -1, -1, -1, -1, -1,  1,  1,
31336      &  1,  1,  1,  1, -1, -1, -1, -1, -1, -1,  0,  0,  0,  0,  0,
31337      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31338      &  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1, -1, -1,
31339      & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,  1,  1,  1,  1,  1,
31340      &  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31341      &  0,  0,  0, -1, -1,  0,  0,  0,  0,  0,  0,  0,  0,  1, -1,
31342      &  1,  1,  1, -1, -1, -1,  1,  1, -1, -1,  1, -1,  1,  1,  0/
31343 * First number of decay channels used for resonances
31344 * and decaying particles
31345       DATA K1/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 16, 17,
31346      &  18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31347      &   2*330, 46, 51, 52, 54, 55, 58,
31348 *                                                             50
31349      &  60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31350      & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31351      & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31352 *                                         85
31353      & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31354      & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31355      & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31356      & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31357      & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31358      & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31359      & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31360      & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31361      & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31362      & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31363      & 590, 596, 602 /
31364 * Last number of decay channels used for resonances
31365 * and decaying particles
31366       DATA K2/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 15, 16, 17,
31367      & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31368      & 2* 330, 50, 51, 53, 54, 57,
31369 *                                                                 50
31370      & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31371      & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31372      & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31373 *                                              85
31374      & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31375      & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31376      & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31377      & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31378      & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31379      & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31380      & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31381      & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31382      & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31383      & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31384      & 589, 595, 601, 602 /
31385
31386        END
31387
31388 *$ CREATE DT_BLKD47.FOR
31389 *COPY DT_BLKD47
31390 *
31391 *===blkd47=============================================================*
31392 *
31393       BLOCK DATA DT_BLKD47
31394
31395       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31396       SAVE
31397
31398 * HADRIN: decay channel information
31399       PARAMETER (IDMAX9=602)
31400       CHARACTER*8 ZKNAME
31401       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31402
31403 * Name of decay channel
31404 * Designation N*@ means N*@1(1236)
31405 * @1=# means ++,  @1 = = means --
31406 * Designation  P+/0/- means Pi+/Pi0/Pi- , respectively
31407       DATA (ZKNAME(K),K=  1, 85) /
31408      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
31409      &  'ANUE    ','GAM     ','PE-NUE  ','APEANU  ','EANUNU  ',
31410      &  'E-NUAN  ','3PI0    ','PI+-0   ','PIMUNU  ','PIE-NU  ',
31411      &  'MU+NUE  ','MU-NUE  ','MU+NUE  ','PI+PI0  ','PI++-   ',
31412      &  'PI+00   ','M+P0NU  ','E+P0NU  ','MU-NU   ','PI-0    ',
31413      &  'PI+--   ','PI-00   ','M-P0NU  ','E-P0NU  ','PPI-    ',
31414      &  'NPI0    ','PD-NUE  ','PM-NUE  ','APPI+   ','ANPI0   ',
31415      &  'APE+NU  ','APM+NU  ','PI+PI-  ','PI0PI0  ','NPI-    ',
31416      &  'PPI0    ','NPI+    ','LAGA    ','GAGA    ','GAE+E-  ',
31417      &  'GAGA    ','GAGAP0  ','PI000   ','PI+-0   ','PI+-GA  ',
31418      &  'PI+0    ','PI+-    ','PI00    ','PI-0    ','PI+-0   ',
31419      &  'PI+-    ','PI0GA   ','K+PI0   ','K0PI+   ','KOPI0   ',
31420      &  'K+PI-   ','K-PI0   ','AK0PI-  ','AK0PI0  ','K-PI+   ',
31421      &  'K+PI0   ','K0PI+   ','K0PI0   ','K+PI-   ','K-PI0   ',
31422      &  'K0PI-   ','AK0PI0  ','K-PI+   ','K+PI0   ','K0PI+   ',
31423      &  'K+89P0  ','K08PI+  ','K+RO77  ','K0RO+7  ','K+OM07  ',
31424      &  'K+E055  ','K0PI0   ','K+PI+   ','K089P0  ','K+8PI-  '  /
31425       DATA (ZKNAME(K),K= 86,170) /
31426      &  'K0R077  ','K+R-77  ','K+R-77  ','K0OM07  ','K0E055  ',
31427      &  'K-PI0   ','K0PI-   ','K-89P0  ','AK08P-  ','K-R077  ',
31428      &  'AK0R-7  ','K-OM07  ','K-E055  ','AK0PI0  ','K-PI+   ',
31429      &  'AK08P0  ','K-8PI+  ','AK0R07  ','AK0OM7  ','AK0E05  ',
31430      &  'LA0PI+  ','SI0PI+  ','SI+PI0  ','LA0PI0  ','SI+PI-  ',
31431      &  'SI-PI+  ','LA0PI-  ','SI0PI-  ','NEUAK0  ','PK-     ',
31432      &  'SI+PI-  ','SI0PI0  ','SI-PI+  ','LA0ET0  ','S+1PI-  ',
31433      &  'S-1PI+  ','SO1PI0  ','NEUAK0  ','PK-     ','LA0PI0  ',
31434      &  'LA0OM0  ','LA0RO0  ','SI+RO-  ','SI-RO+  ','SI0RO0  ',
31435      &  'LA0ET0  ','SI0ET0  ','SI+PI-  ','SI-PI+  ','SI0PI0  ',
31436      &  'K0S     ','K0L     ','K0S     ','K0L     ','P PI+   ',
31437      &  'P PI0   ','N PI+   ','P PI-   ','N PI0   ','N PI-   ',
31438      &  'P PI+   ','N*#PI0  ','N*+PI+  ','PRHO+   ','P PI0   ',
31439      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
31440      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
31441      &  'N*-PI+  ','PRHO-   ','NRHO0   ','N PI-   ','N*0PI-  ',
31442      &  'N*-PI0  ','NRHO-   ','PETA0   ','N*#PI-  ','N*+PI0  '  /
31443       DATA (ZKNAME(K),K=171,255) /
31444      &  'N*0PI+  ','PRHO0   ','NRHO+   ','NETA0   ','N*+PI-  ',
31445      &  'N*0PI0  ','N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ',
31446      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
31447      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
31448      &  'N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ','N PI+   ',
31449      &  'PRHO0   ','NRHO+   ','LAMK+   ','S+ K0   ','S0 K+   ',
31450      &  'PETA0   ','P PI-   ','N PI0   ','PRHO-   ','NRHO0   ',
31451      &  'LAMK0   ','S0 K0   ','S- K+   ','NETA/   ','APPI-   ',
31452      &  'APPI0   ','ANPI-   ','APPI+   ','ANPI0   ','ANPI+   ',
31453      &  'APPI-   ','AN*=P0  ','AN*-P-  ','APRHO-  ','APPI0   ',
31454      &  'ANPI-   ','AN*=P+  ','AN*-P0  ','AN*0P-  ','APRHO0  ',
31455      &  'ANRHO-  ','APPI+   ','ANPI0   ','AN*-P+  ','AN*0P0  ',
31456      &  'AN*+P-  ','APRHO+  ','ANRHO0  ','ANPI+   ','AN*0P+  ',
31457      &  'AN*+P0  ','ANRHO+  ','APPI0   ','ANPI-   ','AN*=P+  ',
31458      &  'AN*-P0  ','AN*0P-  ','APRHO0  ','ANRHO-  ','APPI+,  ',
31459      &  'ANPI0   ','AN*-P+  ','AN*0P0  ','AN*+P-  ','APRHO+  ',
31460      &  'ANRHO0  ','PN*014  ','NN*=14  ','PI+0    ','PI+-    '  /
31461       DATA (ZKNAME(K),K=256,340) /
31462      &  'PI-0    ','P+0     ','N++     ','P+-     ','P00     ',
31463      &  'N+0     ','N+-     ','N00     ','P-0     ','N-0     ',
31464      &  'P--     ','PPPI0   ','PNPI+   ','PNPI0   ','PPPI-   ',
31465      &  'NNPI+   ','APPPI0  ','APNPI+  ','ANNPI0  ','ANPPI-  ',
31466      &  'APNPI0  ','APPPI-  ','ANNPI-  ','K+PPI0  ','K+NPI+  ',
31467      &  'K0PPI0  ','K-PPI0  ','K-NPI+  ','AKPPI-  ','AKNPI0  ',
31468      &  'K+NPI0  ','K+PPI-  ','K0PPI0  ','K0NPI+  ','K-NPI0  ',
31469      &  'K-PPI-  ','AKNPI-  ','PAK0    ','SI+PI0  ','SI0PI+  ',
31470      &  'SI+ETA  ','S+1PI0  ','S01PI+  ','NEUK-   ','LA0PI-  ',
31471      &  'SI-OM0  ','LA0RO-  ','SI0RO-  ','SI-RO0  ','SI-ET0  ',
31472      &  'SI0PI-  ','SI-0    ','BLANC   ','BLANC   ','BLANC   ',
31473      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31474      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31475      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31476      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31477      &  'EPI+-   ','EPI00   ','GAPI+-  ','GAGA*   ','K+-     ',
31478      &  'KLKS    ','PI+-0   ','EGA     ','LPI0    ','LPI     '  /
31479       DATA (ZKNAME(K),K=341,425) /
31480      &  'APPI0   ','ANPI-   ','ALAGA   ','ANPI    ','ALPI0   ',
31481      &  'ALPI+   ','LAPI+   ','SI+PI0  ','SI0PI+  ','LAPI0   ',
31482      &  'SI+PI-  ','SI-PI+  ','LAPI-   ','SI-PI0  ','SI0PI-  ',
31483      &  'TE0PI0  ','TE-PI+  ','TE0PI-  ','TE-PI0  ','TE0PI   ',
31484      &  'TE-PI   ','LAK-    ','ALPI-   ','AS-PI0  ','AS0PI-  ',
31485      &  'ALPI0   ','AS+PI-  ','AS-PI+  ','ALPI+   ','AS+PI0  ',
31486      &  'AS0PI+  ','AT0PI0  ','AT+PI-  ','AT0PI+  ','AT+PI0  ',
31487      &  'AT0PI   ','AT+PI   ','ALK+    ','K-PI+   ','K-PI+0  ',
31488      &  'K0PI+-  ','K0PI0   ','K-PI++  ','AK0PI+  ','K+PI--  ',
31489      &  'K0PI-   ','K+PI-   ','K+PI-0  ','AKPI-+  ','AK0PI0  ',
31490      &  'ETAPIF  ','K++-    ','K+AK0   ','ETAPI-  ','K--+    ',
31491      &  'K-K0    ','PI00    ','PI+-    ','GAGA    ','D0PI0   ',
31492      &  'D0GA    ','D0PI+   ','D+PI0   ','DFGA    ','AD0PI-  ',
31493      &  'D-PI0   ','D-GA    ','AD0PI0  ','AD0GA   ','F+GA    ',
31494      &  'F+GA    ','F-GA    ','F-GA    ','PSPI+-  ','PSPI00  ',
31495      &  'PSETA   ','E+E-    ','MUE+-   ','PI+-0   ','M+NN    ',
31496      &  'E+NN    ','RHO+NT  ','PI+ANT  ','K*+ANT  ','M-NN    '  /
31497       DATA (ZKNAME(K),K=426,510) /
31498      &  'E-NN    ','RHO-NT  ','PI-NT   ','K*-NT   ','NUET    ',
31499      &  'ANUET   ','NUEM    ','ANUEM   ','SI+ETA  ','SI+ET*  ',
31500      &  'PAK0    ','TET0K+  ','SI*+ET  ','N*+AK0  ','N*++K-  ',
31501      &  'LAMRO+  ','SI0RO+  ','SI+RO0  ','SI+OME  ','PAK*0   ',
31502      &  'N*+AK*  ','N*++K*  ','SI+AK0  ','TET0PI  ','SI+AK*  ',
31503      &  'TET0RO  ','SI0AK*  ','SI+K*-  ','TET0OM  ','TET-RO  ',
31504      &  'SI*0AK  ','C0+PI+  ','C0+PI0  ','C0+PI-  ','A+GAM   ',
31505      &  'A0GAM   ','TET0AK  ','TET0K*  ','OM-RO+  ','OM-PI+  ',
31506      &  'C1++AK  ','A+PI+   ','C0+AK0  ','A0PI+   ','A+AK0   ',
31507      &  'T0PI+   ','ASI-ET  ','ASI-E*  ','APK0    ','ATET0K  ',
31508      &  'ASI*-E  ','AN*-K0  ','AN*--K  ','ALAMRO  ','ASI0RO  ',
31509      &  'ASI-RO  ','ASI-OM  ','APK*0   ','AN*-K*  ','AN*--K  ',
31510      &  'ASI-K0  ','ATETPI  ','ASI-K*  ','ATETRO  ','ASI0K*  ',
31511      &  'ASI-K*  ','ATE0OM  ','ATE+RO  ','ASI*0K  ','AC-PI-  ',
31512      &  'AC-PI0  ','AC-PI+  ','AA-GAM  ','AA0GAM  ','ATET0K  ',
31513      &  'ATE0K*  ','AOM+RO  ','AOM+PI  ','AC1--K  ','AA-PI-  ',
31514      &  'AC0-K0  ','AA0PI-  ','AA-K0   ','AT0PI-  ','C1++GA  '  /
31515       DATA (ZKNAME(K),K=511,540) /
31516      &  'C1++GA  ','C10GAM  ','S+GAM   ','S0GAM   ','T0GAM   ',
31517      &  'XU++GA  ','XD+GAM  ','XS+GAM  ','A+AKPI  ','T02PI+  ',
31518      &  'C1++2K  ','AC1--G  ','AC1-GA  ','AC10GA  ','AS-GAM  ',
31519      &  'AS0GAM  ','AT0GAM  ','AXU--G  ','AXD-GA  ','AXS-GA  ',
31520      &  'AA-KPI  ','AT02PI  ','AC1--K  ','RH-PI+  ','RH+PI-  ',
31521      &  'RH3PI0  ','RH0PI+  ','RH+PI0  ','RH0PI-  ','RH-PI0  '  /
31522       DATA (ZKNAME(I),I=541,602)/
31523      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31524      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31525      & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31526      & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31527      & 'PI+PI-','K+K-  ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31528      & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31529      & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31530      & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31531      & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31532 * Weight of decay channel
31533       DATA (WT(K),K=  1, 85) /
31534      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31535      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31536      &   .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31537      &   .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31538      &   .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31539      &   .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31540      &   .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31541      &   .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31542      &   .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31543      &   .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31544      &   .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31545      &   .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31546      &   .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31547      &   .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31548      &   .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31549      &   .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31550      &   .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00  /
31551       DATA (WT(K),K= 86,170) /
31552      &   .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31553      &   .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31554      &   .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31555      &   .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31556      &   .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31557      &   .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31558      &   .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31559      &   .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31560      &   .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31561      &   .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31562      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31563      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31564      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31565      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31566      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31567      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31568      &   .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00  /
31569       DATA (WT(K),K=171,255) /
31570      &   .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31571      &   .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31572      &   .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31573      &   .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31574      &   .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31575      &   .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31576      &   .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31577      &   .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31578      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31579      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31580      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31581      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31582      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31583      &   .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31584      &   .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31585      &   .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31586      &   .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01  /
31587       DATA (WT(K),K=256,340) /
31588      &   .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31589      &   .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31590      &   .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31591      &   .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31592      &   .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31593      &   .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31594      &   .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31595      &   .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31596      &   .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31597      &   .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31598      &   .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31599      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31600      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31601      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31602      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31603      &   .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31604      &   .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01  /
31605       DATA (WT(K),K=341,425) /
31606      &   .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31607      &   .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31608      &   .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31609      &   .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31610      &   .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31611      &   .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31612      &   .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31613      &   .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31614      &   .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31615      &   .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31616      &   .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31617      &   .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31618      &   .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31619      &   .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31620      &   .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31621      &   .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31622      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00  /
31623       DATA (WT(K),K=426,510) /
31624      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31625      &   .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31626      &   .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31627      &   .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31628      &   .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31629      &   .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31630      &   .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31631      &   .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31632      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31633      &   .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31634      &   .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31635      &   .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31636      &   .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31637      &   .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31638      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31639      &   .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31640      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01  /
31641       DATA (WT(K),K=511,540) /
31642      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31643      &   .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31644      &   .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31645      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31646      &   .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31647      &   .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00  /
31648 C
31649       DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31650      & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31651      & .125D+00,  0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31652      & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31653      & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31654      & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31655      & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31656 * Particle numbers in decay channel
31657       DATA (NZK(K,1),K=  1,170) /
31658      &     1,   2,   3,   4,   5,   6,   7,   1,   2,   4,
31659      &     3,  23,  13,  13,  13,  10,  11,  10,  13,  13,
31660      &    13,  10,   4,  11,  14,  14,  14,  11,   3,   1,
31661      &     8,   1,   1,   2,   9,   2,   2,  13,  23,   8,
31662      &     1,   8,  17,   7,   7,   7,  23,  23,  13,  13,
31663      &    13,  13,  23,  14,  13,  13,  23,  15,  24,  24,
31664      &    15,  16,  25,  25,  16,  15,  24,  24,  15,  16,
31665      &    24,  25,  16,  15,  24,  36,  37,  15,  24,  15,
31666      &    15,  24,  15,  37,  36,  24,  15,  24,  24,  16,
31667      &    24,  38,  39,  16,  25,  16,  16,  25,  16,  39,
31668      &    38,  25,  16,  25,  25,  17,  22,  21,  17,  21,
31669      &    20,  17,  22,   8,   1,  21,  22,  20,  17,  48,
31670      &    50,  49,   8,   1,  17,  17,  17,  21,  20,  22,
31671      &    17,  22,  21,  20,  22,  19,  12,  19,  12,   1,
31672      &     1,   8,   1,   8,   8,   1,  53,  54,   1,   1,
31673      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
31674      &    56,   1,   8,   8,  55,  56,   8,   1,  53,  54  /
31675       DATA (NZK(K,1),K=171,340) /
31676      &    55,   1,   8,   8,  54,  55,  56,   1,   8,   1,
31677      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
31678      &    56,   1,   8,   1,   8,   1,   8,  17,  21,  22,
31679      &     1,   1,   8,   1,   8,  17,  22,  20,   8,   2,
31680      &     2,   9,   2,   9,   9,   2,  67,  68,   2,   2,
31681      &     9,  67,  68,  69,   2,   9,   2,   9,  68,  69,
31682      &    70,   2,   9,   9,  69,  70,   9,   2,   9,  67,
31683      &    68,  69,   2,   9,   2,   9,  68,  69,  70,   2,
31684      &     9,   1,   8,  13,  13,  14,   1,   8,   1,   1,
31685      &     8,   8,   8,   1,   8,   1,   1,   1,   1,   1,
31686      &     8,   2,   2,   9,   9,   2,   2,   9,  15,  15,
31687      &    24,  16,  16,  25,  25,  15,  15,  24,  24,  16,
31688      &    16,  25,   1,  21,  22,  21,  48,  49,   8,  17,
31689      &    20,  17,  22,  20,  20,  22,  20,   0,   0,   0,
31690      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31691      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31692      &    31,  31,  13,   7,  15,  12,  13,  31,  17,  17  /
31693       DATA (NZK(K,1),K=341,510) /
31694      &     2,   9,  18,   9,  18,  18,  17,  21,  22,  17,
31695      &    21,  20,  17,  20,  22,  97,  98,  97,  98,  97,
31696      &    98,  17,  18,  99, 100,  18, 101,  99,  18, 101,
31697      &   100, 102, 103, 102, 103, 102, 103,  18,  16,  16,
31698      &    24,  24,  16,  25,  15,  24,  15,  15,  25,  25,
31699      &    31,  15,  15,  31,  16,  16,  23,  13,   7, 116,
31700      &   116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31701      &   120, 121, 121, 130, 130, 130,   4,  10,  13,  10,
31702      &     4,  32,  13,  36,  11,   3,  34,  14,  38, 133,
31703      &   134, 135, 136,  21,  21,   1,  97, 104,  54,  53,
31704      &    17,  22,  21,  21,   1,  54,  53,  21,  97,  21,
31705      &    97,  22,  21,  97,  98, 105, 137, 137, 137, 138,
31706      &   139,  97,  97, 109, 109, 140, 138, 137, 139, 138,
31707      &   145,  99,  99,   2, 102, 110,  68,  67,  18, 100,
31708      &    99,  99,   2,  68,  67,  99, 102,  99, 102, 100,
31709      &    99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31710      &   113, 115, 115, 152, 150, 149, 151, 150, 157, 140  /
31711       DATA (NZK(K,1),K=511,540) /
31712      &   141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31713      &   140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31714      &   150, 157, 152,  34,  32,  33,  33,  32,  33,  34  /
31715       DATA (NZK(I,1),I=541,602) /  2, 67, 68, 69,  2,  9,  9, 68, 69,
31716      & 70,  2,  9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31717      & 14, 189, 23, 13, 15, 24,  36,  38,  37,  39, 194, 195, 196, 197,
31718      & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31719      & 55, 8, 1, 8, 8, 54, 55, 210/
31720       DATA (NZK(K,2),K=  1,170) /
31721      &     0,   0,   0,   0,   0,   0,   0,   3,   4,   6,
31722      &     5,  23,  14,  11,   3,   5,   5,   5,  23,  13,
31723      &    23,  23,  23,   5,  23,  13,  23,  23,  23,  14,
31724      &    23,   3,  11,  13,  23,   4,  10,  14,  23,  14,
31725      &    23,  13,   7,   7,   4,   7,   7,  23,  14,  14,
31726      &    23,  14,  23,  23,  14,  14,   7,  23,  13,  23,
31727      &    14,  23,  14,  23,  13,  23,  13,  23,  14,  23,
31728      &    14,  23,  13,  23,  13,  23,  13,  33,  32,  35,
31729      &    31,  23,  14,  23,  14,  33,  34,  35,  31,  23,
31730      &    14,  23,  14,  33,  34,  35,  31,  23,  13,  23,
31731      &    13,  33,  32,  35,  31,  13,  13,  23,  23,  14,
31732      &    13,  14,  14,  25,  16,  14,  23,  13,  31,  14,
31733      &    13,  23,  25,  16,  23,  35,  33,  34,  32,  33,
31734      &    31,  31,  14,  13,  23,   0,   0,   0,   0,  13,
31735      &    23,  13,  14,  23,  14,  13,  23,  13,  78,  23,
31736      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
31737      &    13,  80,  79,  14,  14,  23,  80,  31,  14,  23  /
31738       DATA (NZK(K,2),K=171,340) /
31739      &    13,  79,  78,  31,  14,  23,  13,  80,  79,  23,
31740      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
31741      &    13,  80,  79,  23,  13,  33,  32,  15,  24,  15,
31742      &    31,  14,  23,  34,  33,  24,  24,  15,  31,  14,
31743      &    23,  14,  13,  23,  13,  14,  23,  14,  80,  23,
31744      &    14,  13,  23,  14,  79,  80,  13,  23,  13,  23,
31745      &    14,  78,  79,  13,  13,  23,  78,  23,  14,  13,
31746      &    23,  14,  79,  80,  13,  23,  13,  23,  14,  78,
31747      &    79,  62,  61,  23,  14,  23,  13,  13,  13,  23,
31748      &    13,  13,  23,  14,  14,  14,   1,   8,   8,   1,
31749      &     8,   1,   8,   8,   1,   8,   1,   8,   1,   8,
31750      &     1,   1,   8,   1,   8,   8,   1,   1,   8,   8,
31751      &     1,   8,  25,  23,  13,  31,  23,  13,  16,  14,
31752      &    35,  34,  34,  33,  31,  14,  23,   0,   0,   0,
31753      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31754      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31755      &    13,  23,  14,   7,  16,  19,  14,   7,  23,  14  /
31756       DATA (NZK(K,2),K=341,510) /
31757      &    23,  14,   7,  13,  23,  13,  13,  23,  13,  23,
31758      &    14,  13,  14,  23,  14,  23,  13,  14,  23,  14,
31759      &    23,  16,  14,  23,  14,  23,  14,  13,  13,  23,
31760      &    13,  23,  14,  13,  23,  13,  23,  15,  13,  13,
31761      &    13,  23,  13,  13,  14,  14,  14,  14,  14,  23,
31762      &    13,  16,  25,  14,  15,  24,  23,  14,   7,  23,
31763      &     7,  13,  23,   7,  14,  23,   7,  23,   7,   7,
31764      &     7,   7,   7,  13,  23,  31,   3,  11,  14, 135,
31765      &     5, 134, 134, 134, 136,   6, 133, 133, 133,   0,
31766      &     0,   0,   0,  31,  95,  25,  15,  31,  95,  16,
31767      &    32,  32,  33,  35,  39,  39,  38,  25,  13,  39,
31768      &    32,  39,  38,  35,  32,  39,  13,  23,  14,   7,
31769      &     7,  25,  37,  32,  13,  25,  13,  25,  13,  25,
31770      &    13,  31,  95,  24,  16,  31,  24,  15,  34,  34,
31771      &    33,  35,  37,  37,  36,  24,  14,  37,  34,  37,
31772      &    36,  35,  34,  37,  14,  23,  13,   7,   7,  24,
31773      &    39,  34,  14,  24,  14,  24,  14,  24,  14,   7  /
31774       DATA (NZK(K,2),K=511,540) /
31775      &     7,   7,   7,   7,   7,   7,   7,   7,  25,  13,
31776      &    25,   7,   7,   7,   7,   7,   7,   7,   7,   7,
31777      &    24,  14,  24,  13,  14,  23,  13,  23,  14,  23  /
31778       DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31779      & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31780      & 14, 14, 23, 14, 16, 25,
31781      & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31782      & 23, 13, 14, 23,  0 /
31783       DATA (NZK(K,3),K=  1,170) /
31784      &     0,   0,   0,   0,   0,   0,   0,   5,   6,   5,
31785      &     6,  23,  23,   5,   5,   0,   0,   0,   0,  14,
31786      &    23,   5,   5,   0,   0,  14,  23,   5,   5,   0,
31787      &     0,   5,   5,   0,   0,   5,   5,   0,   0,   0,
31788      &     0,   0,   0,   0,   3,   0,   7,  23,  23,   7,
31789      &     0,   0,   0,   0,  23,   0,   0,   0,   0,   0,
31790      &     110*0   /
31791       DATA (NZK(K,3),K=171,340) /
31792      &     80*0,
31793      &     0,   0,   0,   0,   0,   0,  23,  13,  14,  23,
31794      &    23,  14,  23,  23,  23,  14,  23,  13,  23,  14,
31795      &    13,  23,  13,  23,  14,  23,  14,  14,  23,  13,
31796      &    13,  23,  13,  14,  23,  23,  14,  23,  13,  23,
31797      &    14,  14,   0,   0,   0,   0,   0,   0,   0,   0,
31798      &     30*0,
31799      &    14,  23,   7,   0,   0,   0,  23,   0,   0,   0  /
31800       DATA (NZK(K,3),K=341,510) /
31801      &     30*0,
31802      &     0,   0,   0,   0,   0,   0,   0,   0,   0,  23,
31803      &    14,   0,  13,   0,  14,   0,   0,  23,  13,   0,
31804      &     0,  15,   0,   0,  16,   0,   0,   0,   0,   0,
31805      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31806      &     0,   0,   0,  14,  23,   0,   0,   0,  23, 134,
31807      &   134,   0,   0,   0, 133, 133,   0,   0,   0,   0,
31808      &     80*0  /
31809       DATA (NZK(K,3),K=511,540) /
31810      &     0,   0,   0,   0,   0,   0,   0,   0,  13,  13,
31811      &    25,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31812      &    14,  14,  24,   0,   0,   0,   0,   0,   0,   0  /
31813       DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31814      & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31815
31816       END
31817
31818 *$ CREATE DT_XHOINI.FOR
31819 *COPY DT_XHOINI
31820 *
31821 *====phoini============================================================*
31822 *
31823       SUBROUTINE DT_XHOINI
31824 C     SUBROUTINE DT_PHOINI
31825
31826       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31827       SAVE
31828
31829       PARAMETER ( LINP = 10 ,
31830      &            LOUT = 6 ,
31831      &            LDAT = 9 )
31832
31833       RETURN
31834       END
31835
31836 *$ CREATE DT_XVENTB.FOR
31837 *COPY DT_XVENTB
31838 *
31839 *====eventb============================================================*
31840 *
31841       SUBROUTINE DT_XVENTB(NCSY,IREJ)
31842 C     SUBROUTINE DT_EVENTB(NCSY,IREJ)
31843
31844       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31845       SAVE
31846
31847       PARAMETER ( LINP = 10 ,
31848      &            LOUT = 6 ,
31849      &            LDAT = 9 )
31850
31851       WRITE(LOUT,1000)
31852  1000 FORMAT(1X,'EVENTB:   PHOJET-package requested but not linked!')
31853       STOP
31854
31855       END
31856
31857 *$ CREATE DT_XVENT.FOR
31858 *COPY DT_XVENT
31859 *
31860 *===event==============================================================*
31861 *
31862       SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
31863 C     SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
31864
31865       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31866       SAVE
31867
31868       DIMENSION PP(4),PT(4)
31869
31870       RETURN
31871       END
31872
31873 *$ CREATE DT_XOHISX.FOR
31874 *COPY DT_XOHISX
31875 *
31876 *===pohisx=============================================================*
31877 *
31878       SUBROUTINE DT_XOHISX(I,X)
31879 C     SUBROUTINE POHISX(I,X)
31880
31881       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31882       SAVE
31883
31884       RETURN
31885       END
31886
31887 *$ CREATE PHO_LHIST.FOR
31888 *COPY PHO_LHIST
31889 *
31890 *===poluhi=============================================================*
31891 *
31892       SUBROUTINE PHO_LHIST(I,X)
31893
31894 **
31895
31896       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31897       SAVE
31898
31899       RETURN
31900       END
31901
31902 *$ CREATE PDFSET.FOR
31903 *COPY PDFSET
31904 *
31905 C**********************************************************************
31906 C
31907 C   dummy subroutines, remove to link PDFLIB
31908 C
31909 C**********************************************************************
31910       SUBROUTINE PDFSET(PARAM,VALUE)
31911       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31912       DIMENSION PARAM(20),VALUE(20)
31913       CHARACTER*20 PARAM
31914       END
31915
31916 *$ CREATE STRUCTM.FOR
31917 *COPY STRUCTM
31918 *
31919       SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31920       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31921       END
31922
31923 *$ CREATE STRUCTP.FOR
31924 *COPY STRUCTP
31925 *
31926       SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31927       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31928       END
31929
31930 *$ CREATE DT_DIQBRK.FOR
31931 *COPY DT_DIQBRK
31932 *
31933 *===diqbrk=============================================================*
31934 *
31935       SUBROUTINE DT_XIQBRK
31936 C     SUBROUTINE DT_DIQBRK
31937
31938       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31939       SAVE
31940
31941       STOP 'diquark-breaking not implemeted !'
31942
31943       RETURN
31944       END
31945 *$ CREATE DT_ELHAIN.FOR
31946 *COPY DT_ELHAIN
31947 *
31948 *===elhain=============================================================*
31949 *
31950       SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
31951
31952 ************************************************************************
31953 * Elastic hadron-hadron scattering.                                    *
31954 * This is a revised version of the original.                           *
31955 * This version dated 03.04.98 is written by S. Roesler                 *
31956 ************************************************************************
31957
31958       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31959       SAVE
31960
31961       PARAMETER ( LINP = 10 ,
31962      &            LOUT = 6 ,
31963      &            LDAT = 9 )
31964
31965       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
31966      &           TINY10=1.0D-10)
31967
31968       PARAMETER (ENNTHR = 3.5D0)
31969       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
31970      &           BLOWB=0.05D0,BHIB=0.2D0,
31971      &           BLOWM=0.1D0, BHIM=2.0D0)
31972
31973 * particle properties (BAMJET index convention)
31974       CHARACTER*8  ANAME
31975       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31976      &                IICH(210),IIBAR(210),K1(210),K2(210)
31977
31978 * final state from HADRIN interaction
31979       PARAMETER (MAXFIN=10)
31980       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
31981      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
31982
31983 C     DATA TSLOPE /10.0D0/
31984
31985       IREJ = 0
31986
31987     1 CONTINUE
31988
31989       PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
31990       EKIN = ELAB-AAM(IP)
31991 *   kinematical quantities in cms of the hadrons
31992       AMP2 = AAM(IP)**2
31993       AMT2 = AAM(IT)**2
31994       S    = AMP2+AMT2+TWO*ELAB*AAM(IT)
31995       ECM  = SQRT(S)
31996       ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
31997       PCM  = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
31998
31999 * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
32000       IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
32001      &     ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
32002 *   TSAMCS treats pp and np only, therefore change pn into np and
32003 *   nn into pp
32004          IF (IT.EQ.1) THEN
32005             KPROJ = IP
32006          ELSE
32007             KPROJ = 8
32008             IF (IP.EQ.8) KPROJ = 1
32009          ENDIF
32010          CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
32011          T = TWO*PCM**2*(CTCMS-ONE)
32012
32013 * very crude treatment otherwise: sample t from exponential dist.
32014       ELSE
32015 *   momentum transfer t
32016          TMAX = TWO*TWO*PCM**2
32017          RR = (PLAB-PLOWH)/(PHIH-PLOWH)
32018          IF (IIBAR(IP).NE.0) THEN
32019             TSLOPE = BLOWB+RR*(BHIB-BLOWB)
32020          ELSE
32021             TSLOPE = BLOWM+RR*(BHIM-BLOWM)
32022          ENDIF
32023          FMAX = EXP(-TSLOPE*TMAX)-ONE
32024          R = DT_RNDM(RR)
32025          T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
32026          IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
32027       ENDIF
32028
32029 *   target hadron in Lab after scattering
32030       ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
32031       PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
32032       IF (PLRH(2).LE.TINY10) THEN
32033 C        WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
32034          GOTO 1
32035       ENDIF
32036 *   projectile hadron in Lab after scattering
32037       ELRH(1) = ELAB+AAM(IT)-ELRH(2)
32038       PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
32039 *   scattering angle of projectile in Lab
32040       CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
32041       STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
32042       CALL DT_DSFECF(SPLABP,CPLABP)
32043 *   direction cosines of projectile in Lab
32044       CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
32045      &                          CXRH(1),CYRH(1),CZRH(1))
32046 *   scattering angle of target in Lab
32047       PLLABT = PLAB-CTLABP*PLRH(1)
32048       CTLABT = PLLABT/PLRH(2)
32049       STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
32050 *   direction cosines of target in Lab
32051       CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
32052      &                            CXRH(2),CYRH(2),CZRH(2))
32053 *   fill /HNFSPA/
32054       IRH = 2
32055       ITRH(1) = IP
32056       ITRH(2) = IT
32057
32058       RETURN
32059       END
32060
32061 *$ CREATE DT_TSAMCS.FOR
32062 *COPY DT_TSAMCS
32063 *
32064 *===tsamcs=============================================================*
32065 *
32066       SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
32067
32068 ************************************************************************
32069 * Sampling of cos(theta) for nucleon-proton scattering according to    *
32070 * hetkfa2/bertini parametrization.                                     *
32071 * This is a revised version of the original (HJM 24/10/88)             *
32072 * This version dated 28.10.95 is written by S. Roesler                 *
32073 ************************************************************************
32074
32075       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32076       SAVE
32077
32078       PARAMETER ( LINP = 10 ,
32079      &            LOUT = 6 ,
32080      &            LDAT = 9 )
32081
32082       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
32083      &           TINY10=1.0D-10)
32084
32085       DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
32086       DIMENSION PDCI(60),PDCH(55)
32087
32088       DATA (DCLIN(I),I=1,80) /
32089      &     5.000D-01,  1.000D+00,  0.000D+00,  1.000D+00,  0.000D+00,
32090      &     4.993D-01,  9.881D-01,  5.963D-02,  9.851D-01,  5.945D-02,
32091      &     4.936D-01,  8.955D-01,  5.224D-01,  8.727D-01,  5.091D-01,
32092      &     4.889D-01,  8.228D-01,  8.859D-01,  7.871D-01,  8.518D-01,
32093      &     4.874D-01,  7.580D-01,  1.210D+00,  7.207D-01,  1.117D+00,
32094      &     4.912D-01,  6.969D-01,  1.516D+00,  6.728D-01,  1.309D+00,
32095      &     5.075D-01,  6.471D-01,  1.765D+00,  6.667D-01,  1.333D+00,
32096      &     5.383D-01,  6.054D-01,  1.973D+00,  7.059D-01,  1.176D+00,
32097      &     5.397D-01,  5.990D-01,  2.005D+00,  7.023D-01,  1.191D+00,
32098      &     5.336D-01,  6.083D-01,  1.958D+00,  6.959D-01,  1.216D+00,
32099      &     5.317D-01,  6.075D-01,  1.962D+00,  6.897D-01,  1.241D+00,
32100      &     5.300D-01,  6.016D-01,  1.992D+00,  6.786D-01,  1.286D+00,
32101      &     5.281D-01,  6.063D-01,  1.969D+00,  6.786D-01,  1.286D+00,
32102      &     5.280D-01,  5.960D-01,  2.020D+00,  6.667D-01,  1.333D+00,
32103      &     5.273D-01,  5.920D-01,  2.040D+00,  6.604D-01,  1.358D+00,
32104      &     5.273D-01,  5.862D-01,  2.069D+00,  6.538D-01,  1.385D+00/
32105       DATA (DCLIN(I),I=81,160) /
32106      &     5.223D-01,  5.980D-01,  2.814D+00,  6.538D-01,  1.385D+00,
32107      &     5.202D-01,  5.969D-01,  2.822D+00,  6.471D-01,  1.412D+00,
32108      &     5.183D-01,  5.881D-01,  2.883D+00,  6.327D-01,  1.469D+00,
32109      &     5.159D-01,  5.866D-01,  2.894D+00,  6.250D-01,  1.500D+00,
32110      &     5.133D-01,  5.850D-01,  2.905D+00,  6.170D-01,  1.532D+00,
32111      &     5.106D-01,  5.833D-01,  2.917D+00,  6.087D-01,  1.565D+00,
32112      &     5.084D-01,  5.801D-01,  2.939D+00,  6.000D-01,  1.600D+00,
32113      &     5.063D-01,  5.763D-01,  2.966D+00,  5.909D-01,  1.636D+00,
32114      &     5.036D-01,  5.730D-01,  2.989D+00,  5.814D-01,  1.674D+00,
32115      &     5.014D-01,  5.683D-01,  3.022D+00,  5.714D-01,  1.714D+00,
32116      &     4.986D-01,  5.641D-01,  3.051D+00,  5.610D-01,  1.756D+00,
32117      &     4.964D-01,  5.580D-01,  3.094D+00,  5.500D-01,  1.800D+00,
32118      &     4.936D-01,  5.573D-01,  3.099D+00,  5.431D-01,  1.827D+00,
32119      &     4.909D-01,  5.509D-01,  3.144D+00,  5.313D-01,  1.875D+00,
32120      &     4.885D-01,  5.512D-01,  3.142D+00,  5.263D-01,  1.895D+00,
32121      &     4.857D-01,  5.437D-01,  3.194D+00,  5.135D-01,  1.946D+00/
32122       DATA (DCLIN(I),I=161,195) /
32123      &     4.830D-01,  5.353D-01,  3.253D+00,  5.000D-01,  2.000D+00,
32124      &     4.801D-01,  5.323D-01,  3.274D+00,  4.915D-01,  2.034D+00,
32125      &     4.770D-01,  5.228D-01,  3.341D+00,  4.767D-01,  2.093D+00,
32126      &     4.738D-01,  5.156D-01,  3.391D+00,  4.643D-01,  2.143D+00,
32127      &     4.701D-01,  5.010D-01,  3.493D+00,  4.444D-01,  2.222D+00,
32128      &     4.672D-01,  4.990D-01,  3.507D+00,  4.375D-01,  2.250D+00,
32129      &     4.634D-01,  4.856D-01,  3.601D+00,  4.194D-01,  2.323D+00/
32130
32131       DATA PDCI /
32132      &     4.400D+02,  1.896D-01,  1.931D-01,  1.982D-01,  1.015D-01,
32133      &     1.029D-01,  4.180D-02,  4.228D-02,  4.282D-02,  4.350D-02,
32134      &     2.204D-02,  2.236D-02,  5.900D+02,  1.433D-01,  1.555D-01,
32135      &     1.774D-01,  1.000D-01,  1.128D-01,  5.132D-02,  5.600D-02,
32136      &     6.158D-02,  6.796D-02,  3.660D-02,  3.820D-02,  6.500D+02,
32137      &     1.192D-01,  1.334D-01,  1.620D-01,  9.527D-02,  1.141D-01,
32138      &     5.283D-02,  5.952D-02,  6.765D-02,  7.878D-02,  4.796D-02,
32139      &     6.957D-02,  8.000D+02,  4.872D-02,  6.694D-02,  1.152D-01,
32140      &     9.348D-02,  1.368D-01,  6.912D-02,  7.953D-02,  9.577D-02,
32141      &     1.222D-01,  7.755D-02,  9.525D-02,  1.000D+03,  3.997D-02,
32142      &     5.456D-02,  9.804D-02,  8.084D-02,  1.208D-01,  6.520D-02,
32143      &     8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,  1.093D-01/
32144
32145       DATA PDCH /
32146      &     1.000D+03,  9.453D-02,  9.804D-02,  8.084D-02,  1.208D-01,
32147      &     6.520D-02,  8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,
32148      &     1.093D-01,  1.400D+03,  1.072D-01,  7.450D-02,  6.645D-02,
32149      &     1.136D-01,  6.750D-02,  8.580D-02,  1.110D-01,  1.530D-01,
32150      &     1.010D-01,  1.350D-01,  2.170D+03,  4.004D-02,  3.013D-02,
32151      &     2.664D-02,  5.511D-02,  4.240D-02,  7.660D-02,  1.364D-01,
32152      &     2.300D-01,  1.670D-01,  2.010D-01,  2.900D+03,  1.870D-02,
32153      &     1.804D-02,  1.320D-02,  2.970D-02,  2.860D-02,  5.160D-02,
32154      &     1.020D-01,  2.400D-01,  2.250D-01,  3.370D-01,  4.400D+03,
32155      &     1.196D-03,  8.784D-03,  1.517D-02,  2.874D-02,  2.488D-02,
32156      &     4.464D-02,  8.330D-02,  2.008D-01,  2.360D-01,  3.567D-01/
32157
32158       DATA (DCHN(I),I=1,90) /
32159      &     4.770D-01,  4.750D-01,  4.715D-01,  4.685D-01,  4.650D-01,
32160      &     4.610D-01,  4.570D-01,  4.550D-01,  4.500D-01,  4.450D-01,
32161      &     4.405D-01,  4.350D-01,  4.300D-01,  4.250D-01,  4.200D-01,
32162      &     4.130D-01,  4.060D-01,  4.000D-01,  3.915D-01,  3.840D-01,
32163      &     3.760D-01,  3.675D-01,  3.580D-01,  3.500D-01,  3.400D-01,
32164      &     3.300D-01,  3.200D-01,  3.100D-01,  3.000D-01,  2.900D-01,
32165      &     2.800D-01,  2.700D-01,  2.600D-01,  2.500D-01,  2.400D-01,
32166      &     2.315D-01,  2.240D-01,  2.150D-01,  2.060D-01,  2.000D-01,
32167      &     1.915D-01,  1.850D-01,  1.780D-01,  1.720D-01,  1.660D-01,
32168      &     1.600D-01,  1.550D-01,  1.500D-01,  1.450D-01,  1.400D-01,
32169      &     1.360D-01,  1.320D-01,  1.280D-01,  1.250D-01,  1.210D-01,
32170      &     1.180D-01,  1.150D-01,  1.120D-01,  1.100D-01,  1.070D-01,
32171      &     1.050D-01,  1.030D-01,  1.010D-01,  9.900D-02,  9.700D-02,
32172      &     9.550D-02,  9.480D-02,  9.400D-02,  9.200D-02,  9.150D-02,
32173      &     9.100D-02,  9.000D-02,  8.990D-02,  8.900D-02,  8.850D-02,
32174      &     8.750D-02,  8.700D-02,  8.650D-02,  8.550D-02,  8.500D-02,
32175      &     8.499D-02,  8.450D-02,  8.350D-02,  8.300D-02,  8.250D-02,
32176      &     8.150D-02,  8.100D-02,  8.030D-02,  8.000D-02,  7.990D-02/
32177       DATA (DCHN(I),I=91,143) /
32178      &     7.980D-02,  7.950D-02,  7.900D-02,  7.860D-02,  7.800D-02,
32179      &     7.750D-02,  7.650D-02,  7.620D-02,  7.600D-02,  7.550D-02,
32180      &     7.530D-02,  7.500D-02,  7.499D-02,  7.498D-02,  7.480D-02,
32181      &     7.450D-02,  7.400D-02,  7.350D-02,  7.300D-02,  7.250D-02,
32182      &     7.230D-02,  7.200D-02,  7.100D-02,  7.050D-02,  7.020D-02,
32183      &     7.000D-02,  6.999D-02,  6.995D-02,  6.993D-02,  6.991D-02,
32184      &     6.990D-02,  6.870D-02,  6.850D-02,  6.800D-02,  6.780D-02,
32185      &     6.750D-02,  6.700D-02,  6.650D-02,  6.630D-02,  6.600D-02,
32186      &     6.550D-02,  6.525D-02,  6.510D-02,  6.500D-02,  6.499D-02,
32187      &     6.498D-02,  6.496D-02,  6.494D-02,  6.493D-02,  6.490D-02,
32188      &     6.488D-02,  6.485D-02,  6.480D-02/
32189
32190       DATA DCHNA /
32191      &     6.300D+02,  7.810D-02,  1.421D-01,  1.979D-01,  2.479D-01,
32192      &     3.360D-01,  5.400D-01,  7.236D-01,  1.000D+00,  1.540D+03,
32193      &     2.225D-01,  3.950D-01,  5.279D-01,  6.298D-01,  7.718D-01,
32194      &     9.405D-01,  9.835D-01,  1.000D+00,  2.560D+03,  2.625D-01,
32195      &     4.550D-01,  5.963D-01,  7.020D-01,  8.380D-01,  9.603D-01,
32196      &     9.903D-01,  1.000D+00,  3.520D+03,  4.250D-01,  6.875D-01,
32197      &     8.363D-01,  9.163D-01,  9.828D-01,  1.000D+00,  1.000D+00,
32198      &     1.000D+00/
32199
32200       DATA DCHNB /
32201      &     6.300D+02,  3.800D-02,  7.164D-02,  1.275D-01,  2.171D-01,
32202      &     3.227D-01,  4.091D-01,  5.051D-01,  6.061D-01,  7.074D-01,
32203      &     8.434D-01,  1.000D+00,  2.040D+03,  1.200D-01,  2.115D-01,
32204      &     3.395D-01,  5.295D-01,  7.251D-01,  8.511D-01,  9.487D-01,
32205      &     9.987D-01,  1.000D+00,  1.000D+00,  1.000D+00,  2.200D+03,
32206      &     1.344D-01,  2.324D-01,  3.754D-01,  5.674D-01,  7.624D-01,
32207      &     8.896D-01,  9.808D-01,  1.000D+00,  1.000D+00,  1.000D+00,
32208      &     1.000D+00,  2.850D+03,  2.330D-01,  4.130D-01,  6.610D-01,
32209      &     9.010D-01,  9.970D-01,  1.000D+00,  1.000D+00,  1.000D+00,
32210      &     1.000D+00,  1.000D+00,  1.000D+00,  3.500D+03,  3.300D-01,
32211      &     5.450D-01,  7.950D-01,  1.000D+00,  1.000D+00,  1.000D+00,
32212      &     1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00/
32213
32214       CST = ONE
32215       IF (EKIN.GT.3.5D0) RETURN
32216 C
32217       IF(KPROJ.EQ.8) GOTO 101
32218       IF(KPROJ.EQ.1) GOTO 102
32219 C*                                             INVALID REACTION
32220       WRITE(LOUT,'(A,I5/A)')
32221      &        ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
32222      &        ' COS(THETA) = 1D0 RETURNED'
32223       RETURN
32224 C-------------------------------- NP ELASTIC SCATTERING----------
32225 101   CONTINUE
32226       IF (EKIN.GT.0.740D0)GOTO 1000
32227       IF (EKIN.LT.0.300D0)THEN
32228 C                                 EKIN .LT. 300 MEV
32229          IDAT=1
32230       ELSE
32231 C                                 300 MEV < EKIN < 740 MEV
32232          IDAT=6
32233       END IF
32234 C
32235       ENER=EKIN
32236       IE=INT(ABS(ENER/0.020D0))
32237       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32238 C                                            FORWARD/BACKWARD DECISION
32239       K=IDAT+5*IE
32240       BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32241       IF (DT_RNDM(CST).LT.BWFW)THEN
32242          VALUE2=-1D0
32243          K=K+1
32244       ELSE
32245          VALUE2=1D0
32246          K=K+3
32247       END IF
32248 C
32249       COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32250       RND=DT_RNDM(COEF)
32251 C
32252       IF(RND.LT.COEF)THEN
32253          CST=DT_RNDM(RND)
32254          CST=CST*VALUE2
32255       ELSE
32256          R1=DT_RNDM(CST)
32257          R2=DT_RNDM(R1)
32258          R3=DT_RNDM(R2)
32259          R4=DT_RNDM(R3)
32260 C
32261          IF(VALUE2.GT.0.0)THEN
32262             CST=MAX(R1,R2,R3,R4)
32263             GOTO 1500
32264          ELSE
32265             R5=DT_RNDM(R4)
32266 C
32267             IF (IDAT.EQ.1)THEN
32268                CST=-MAX(R1,R2,R3,R4,R5)
32269             ELSE
32270                R6=DT_RNDM(R5)
32271                R7=DT_RNDM(R6)
32272                CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
32273             END IF
32274 C
32275          END IF
32276 C
32277       END IF
32278 C
32279       GOTO 1500
32280 C
32281 C********                                EKIN  .GT.  0.74 GEV
32282 C
32283 1000  ENER=EKIN - 0.66D0
32284 C     IE=ABS(ENER/0.02)
32285       IE=INT(ENER/0.02D0)
32286       EMEV=EKIN*1D3
32287 C
32288       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32289       K=IE
32290       BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
32291       RND=DT_RNDM(BWFW)
32292 C                                        FORWARD NEUTRON
32293       IF (RND.GE.BWFW)THEN
32294          DO 1200 K=10,36,9
32295            IF (DCHNA(K).GT.EMEV) THEN
32296               UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
32297               UNIV=DT_RNDM(UNIVE)
32298               DO 1100 I=1,8
32299                  II=K+I
32300                  P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
32301 C
32302                  IF (P.GT.UNIV)THEN
32303                     UNIV=DT_RNDM(UNIVE)
32304                     FLTI=DBLE(I)-UNIV
32305                     GOTO(290,290,290,290,330,340,350,360) I
32306                  END IF
32307  1100         CONTINUE
32308            END IF
32309  1200    CONTINUE
32310 C
32311       ELSE
32312 C                                        BACKWARD NEUTRON
32313          DO 1400 K=13,60,12
32314             IF (DCHNB(K).GT.EMEV) THEN
32315                UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
32316                UNIV=DT_RNDM(UNIVE)
32317                DO 1300 I=1,11
32318                  II=K+I
32319                  P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
32320 C
32321                  IF (P.GT.UNIV)THEN
32322                    UNIV=DT_RNDM(P)
32323                    FLTI=DBLE(I)-UNIV
32324                    GOTO(120,120,140,150,160,160,180,190,200,210,220) I
32325                  END IF
32326  1300          CONTINUE
32327             END IF
32328  1400    CONTINUE
32329       END IF
32330 C
32331 120   CST=1.0D-2*FLTI-1.0D0
32332       GOTO 1500
32333 140   CST=2.0D-2*UNIV-0.98D0
32334       GOTO 1500
32335 150   CST=4.0D-2*UNIV-0.96D0
32336       GOTO 1500
32337 160   CST=6.0D-2*FLTI-1.16D0
32338       GOTO 1500
32339 180   CST=8.0D-2*UNIV-0.80D0
32340       GOTO 1500
32341 190   CST=1.0D-1*UNIV-0.72D0
32342       GOTO 1500
32343 200   CST=1.2D-1*UNIV-0.62D0
32344       GOTO 1500
32345 210   CST=2.0D-1*UNIV-0.50D0
32346       GOTO 1500
32347 220   CST=3.0D-1*(UNIV-1.0D0)
32348       GOTO 1500
32349 C
32350 290   CST=1.0D0-2.5d-2*FLTI
32351       GOTO 1500
32352 330   CST=0.85D0+0.5D-1*UNIV
32353       GOTO 1500
32354 340   CST=0.70D0+1.5D-1*UNIV
32355       GOTO 1500
32356 350   CST=0.50D0+2.0D-1*UNIV
32357       GOTO 1500
32358 360   CST=0.50D0*UNIV
32359 C
32360 1500  RETURN
32361 C
32362 C-----------------------------------  PP ELASTIC SCATTERING -------
32363 C
32364  102  CONTINUE
32365       EMEV=EKIN*1D3
32366 C
32367       IF (EKIN.LE.0.500D0) THEN
32368          RND=DT_RNDM(EMEV)
32369          CST=2.0D0*RND-1.0D0
32370          RETURN
32371 C
32372       ELSEIF (EKIN.LT.1.0D0) THEN
32373          DO 2200 K=13,60,12
32374             IF (PDCI(K).GT.EMEV) THEN
32375                UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
32376                UNIV=DT_RNDM(UNIVE)
32377                SUM=0
32378                DO 2100 I=1,11
32379                  II=K+I
32380                  SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
32381 C
32382                  IF (UNIV.LT.SUM)THEN
32383                    UNIV=DT_RNDM(SUM)
32384                    FLTI=DBLE(I)-UNIV
32385                    GOTO(55,55,55,60,60,65,65,65,65,70,70) I
32386                  END IF
32387  2100          CONTINUE
32388             END IF
32389  2200    CONTINUE
32390       ELSE
32391          DO 2400 K=12,55,11
32392             IF (PDCH(K).GT.EMEV) THEN
32393               UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
32394               UNIV=DT_RNDM(UNIVE)
32395               SUM=0.0D0
32396               DO 2300 I=1,10
32397                 II=K+I
32398                 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
32399 C
32400                 IF (UNIV.LT.SUM)THEN
32401                   UNIV=DT_RNDM(SUM)
32402                   FLTI=UNIV+DBLE(I)
32403                   GOTO(50,55,60,60,65,65,65,65,70,70) I
32404                 END IF
32405  2300         CONTINUE
32406             END IF
32407  2400    CONTINUE
32408       END IF
32409 C
32410 50    CST=0.4D0*UNIV
32411       GOTO 2500
32412 55    CST=0.2D0*FLTI
32413       GOTO 2500
32414 60    CST=0.3D0+0.1D0*FLTI
32415       GOTO 2500
32416 65    CST=0.6D0+0.04D0*FLTI
32417       GOTO 2500
32418 70    CST=0.78D0+0.02D0*FLTI
32419 C
32420 2500  CONTINUE
32421       IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
32422 C
32423       RETURN
32424       END
32425
32426 *$ CREATE DT_DHADRI.FOR
32427 *COPY DT_DHADRI
32428 *
32429 *===dhadri=============================================================*
32430 *
32431       SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
32432
32433       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32434       SAVE
32435
32436       PARAMETER ( LINP = 10 ,
32437      &            LOUT = 6 ,
32438      &            LDAT = 9 )
32439
32440 C
32441 C-----------------------------
32442 C*** INPUT VARIABLES LIST:
32443 C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
32444 C*** GEV/C LABORATORY MOMENTUM REGION
32445 C*** N    - PROJECTILE HADRON INDEX
32446 C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
32447 C*** ELAB - LABORATORY ENERGY OF N (GEV)
32448 C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
32449 C*** ITTA - TARGET NUCLEON INDEX
32450 C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
32451 C  IR COUNTS THE NUMBER OF PRODUCED PARTICLES
32452 C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
32453 C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
32454 C*** RESPECT., UNITS (GEV/C AND GEV)
32455 C----------------------------
32456
32457       COMMON /HNGAMR/ REDU,AMO,AMM(15)
32458
32459       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32460
32461       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
32462      &                NRK(2,268),NURE(30,2)
32463
32464 * particle properties (BAMJET index convention),
32465 * (dublicate of DTPART for HADRIN)
32466       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32467      &                K1H(110),K2H(110)
32468
32469       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
32470
32471       COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
32472      &                ITS(149),IS
32473
32474       COMMON /HNDRUN/ RUNTES,EFTES
32475
32476 * particle properties (BAMJET index convention)
32477       CHARACTER*8  ANAME
32478       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
32479      &                IICH(210),IIBAR(210),K1(210),K2(210)
32480
32481 * final state from HADRIN interaction
32482       PARAMETER (MAXFIN=10)
32483       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
32484      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
32485
32486       DIMENSION ITPRF(110)
32487       DATA NNN/0/
32488       DATA UMODA/0./
32489       DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
32490       LOWP=0
32491       IF (N.LE.0.OR.N.GE.111)N=1
32492       IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
32493         GOTO 280
32494 *       WRITE (6,1000)
32495 *    +  ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
32496 *       STOP
32497 *1000   FORMAT (3(5H ****/),A,2I4,3(5H ****/))
32498 *    +  45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
32499       ENDIF
32500       IATMPT=0
32501       IF (ABS(PLAB-5.0D0).LT.4.99999D0)                        GO TO 20
32502 C     IF(IPRI.GE.1) WRITE (6,1010) PLAB
32503 C     STOP
32504  1010 FORMAT ( '  PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
32505      + ALLOWED REGION, PLAB=',1E15.5)
32506
32507    20 CONTINUE
32508       UMODAT=N*1.11111D0+ITTA*2.19291D0
32509       IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
32510       UMODA=UMODAT
32511    30 IATMPT=0
32512       LOWP=LOWP+1
32513    40 CONTINUE
32514       IMACH=0
32515       REDU=2.0D0
32516       IF (LOWP.GT.20) THEN
32517 C        WRITE(LOUT,*) ' jump 1'
32518          GO TO 280
32519       ENDIF
32520       NNN=N
32521       IF (NNN.EQ.N)                                             GO TO 50
32522       RUNTES=0.0D0
32523       EFTES=0.0D0
32524    50 CONTINUE
32525       IS=1
32526       IRH=0
32527       IST=1
32528       NSTAB=23
32529       IRE=NURE(N,1)
32530       IF(ITTA.GT.1) IRE=NURE(N,2)
32531 C
32532 C-----------------------------
32533 C*** IE,AMT,ECM,SI DETERMINATION
32534 C----------------------------
32535       CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
32536       IANTH=-1
32537 **sr
32538 C     IF (AMH(1).NE.0.93828D0) IANTH=1
32539       IF (AMH(1).NE.0.9383D0) IANTH=1
32540 **
32541       IF (IANTH.GE.0) SI=1.0D0
32542       ECMMH=ECM
32543 C
32544 C-----------------------------
32545 C    ENERGY INDEX
32546 C  IRE CHARACTERIZES THE REACTION
32547 C  IE IS THE ENERGY INDEX
32548 C----------------------------
32549       IF (SI.LT.1.D-6) THEN
32550 C        WRITE(LOUT,*) ' jump 2'
32551          GO TO 280
32552       ENDIF
32553       IF (N.LE.NSTAB)                                           GO TO 60
32554       RUNTES=RUNTES+1.0D0
32555       IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
32556  1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
32557       IF(IBARH(N).EQ.1) N=8
32558       IF(IBARH(N).EQ.-1)  N=9
32559    60 CONTINUE
32560       IMACH=IMACH+1
32561 **sr 19.2.97: loop for direct channel suppression
32562 C     IF (IMACH.GT.10) THEN
32563       IF (IMACH.GT.1000) THEN
32564 **
32565 C        WRITE(LOUT,*) ' jump 3'
32566          GO TO 280
32567       ENDIF
32568       ECM =ECMMH
32569       AMN2=AMN**2
32570       AMT2=AMT**2
32571       ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM    )
32572       IF(ECMN.LE.AMN) ECMN=AMN
32573       PCMN=SQRT(ECMN**2-AMN2)
32574       GAM=(ELAB+AMT)/ECM
32575       BGAM=PLAB/ECM
32576       IF (IANTH.GE.0) ECM=2.1D0
32577 C
32578 C-----------------------------
32579 C*** RANDOM CHOICE OF REACTION CHANNEL
32580 C----------------------------
32581       IST=0
32582       VV=DT_RNDM(AMN2)
32583       VV=VV-1.D-17
32584 C
32585 C-----------------------------
32586 C***  PLACE REDUCED VERSION
32587 C----------------------------
32588       IIEI=IEII(IRE)
32589       IDWK=IEII(IRE+1)-IIEI
32590       IIWK=IRII(IRE)
32591       IIKI=IKII(IRE)
32592 C
32593 C-----------------------------
32594 C***  SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
32595 C----------------------------
32596       HECM=ECM
32597       HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
32598       IF (HUMO.LT.ECM) ECM=HUMO
32599 C
32600 C-----------------------------
32601 C*** INTERPOLATION PREPARATION
32602 C----------------------------
32603       ECMO=UMO(IE)
32604       ECM1=UMO(IE-1)
32605       DECM=ECMO-ECM1
32606       DEC=ECMO-ECM
32607 C
32608 C-----------------------------
32609 C*** RANDOM LOOP
32610 C----------------------------
32611       IK=0
32612       WKK=0.0D0
32613       WICOR=0.0D0
32614    70 IK=IK+1
32615       IWK=IIWK+(IK-1)*IDWK+IE-IIEI
32616       WOK=WK(IWK)
32617       WDK=WOK-WK(IWK-1)
32618 C
32619 C-----------------------------
32620 C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
32621 C    GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
32622 C    CONTRIBUTE
32623 C----------------------------
32624       IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
32625       WICO=WOK*1.23459876D0+WDK*1.735218469D0
32626       IF (WICO.EQ.WICOR)                                        GO TO 70
32627       IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
32628       WICOR=WICO
32629 C
32630 C-----------------------------
32631 C*** INTERPOLATION IN CHANNEL WEIGHTS
32632 C----------------------------
32633       EKLIM=-THRESH(IIKI+IK)
32634       IELIM=IDT_IEFUND(EKLIM,IRE)
32635       DELIM=UMO(IELIM)+EKLIM
32636      *+1.D-16
32637       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
32638       IF (DELIM*DELIM-DETE*DETE) 90,90,80
32639    80 DECC=DELIM
32640                                                                GO TO 100
32641    90 DECC=DECM
32642   100 CONTINUE
32643       WKK=WOK-WDK*DEC/(DECC+1.D-9)
32644 C
32645 C-----------------------------
32646 C*** RANDOM CHOICE
32647 C----------------------------
32648 C
32649       IF (VV.GT.WKK)                                            GO TO 70
32650 C
32651 C***IK IS THE REACTION CHANNEL
32652 C----------------------------
32653       INRK=IKII(IRE)+IK
32654       ECM=HECM
32655       I1001 =0
32656 C
32657   110 CONTINUE
32658       IT1=NRK(1,INRK)
32659       AM1=DT_DAMG(IT1)
32660       IT2=NRK(2,INRK)
32661       AM2=DT_DAMG(IT2)
32662       AMS=AM1+AM2
32663       I1001=I1001+1
32664       IF (I1001.GT.50)                                          GO TO 60
32665 C
32666       IF (IT2*AMS.GT.IT2*ECM)                                  GO TO 110
32667       IT11=IT1
32668       IT22=IT2
32669       IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
32670       AM11=AM1
32671       AM22=AM2
32672       IF (IT2.GT.0)                                            GO TO 120
32673 **sr 19.2.97: supress direct channel for pp-collisions
32674       IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
32675          RR = DT_RNDM(AM11)
32676          IF (RR.LE.0.75D0) GOTO 60
32677       ENDIF
32678 **
32679 C
32680 C-----------------------------
32681 C  INCLUSION OF DIRECT RESONANCES
32682 C  RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE  IT1
32683 C------------------------
32684       KZ1=K1H(IT1)
32685       IST=IST+1
32686       IECO=0
32687       ECO=ECM
32688       GAM=(ELAB+AMT)/ECO
32689       BGAM=PLAB/ECO
32690       CXS(1)=CX
32691       CYS(1)=CY
32692       CZS(1)=CZ
32693                                                                GO TO 170
32694   120 CONTINUE
32695       WW=DT_RNDM(ECO)
32696       IF(WW.LT. 0.5D0)                                         GO TO 130
32697       IT1=IT22
32698       IT2=IT11
32699       AM1=AM22
32700       AM2=AM11
32701   130 CONTINUE
32702 C
32703 C-----------------------------
32704 C   THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
32705       IBN=IBARH(N)
32706       IB1=IBARH(IT1)
32707       IT11=IT1
32708       IT22=IT2
32709       AM11=AM1
32710       AM22=AM2
32711       IF(IB1.EQ.IBN)                                           GO TO 140
32712       IT1=IT22
32713       IT2=IT11
32714       AM1=AM22
32715       AM2=AM11
32716   140 CONTINUE
32717 C-----------------------------
32718 C***IT1,IT2 ARE THE CREATED PARTICLES
32719 C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
32720 C------------------------
32721       CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
32722      *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
32723       IST=IST+1
32724       ITS(IST)=IT1
32725       AMM(IST)=AM1
32726 C
32727 C-----------------------------
32728 C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
32729 C----------------------------
32730       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
32731      &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32732       IST=IST+1
32733       ITS(IST)=IT2
32734       AMM(IST)=AM2
32735       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
32736      *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32737   150 CONTINUE
32738 C
32739 C-----------------------------
32740 C***TEST   STABLE OR UNSTABLE
32741 C----------------------------
32742       IF(ITS(IST).GT.NSTAB)                                    GO TO 160
32743       IRH=IRH+1
32744 C
32745 C-----------------------------
32746 C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
32747 C----------------------------
32748 C*    IF (REDU.LT.0.D0) GO TO 1009
32749       ITRH(IRH)=ITS(IST)
32750       PLRH(IRH)=PLS(IST)
32751       CXRH(IRH)=CXS(IST)
32752       CYRH(IRH)=CYS(IST)
32753       CZRH(IRH)=CZS(IST)
32754       ELRH(IRH)=ELS(IST)
32755       IST=IST-1
32756       IF(IST.GE.1)                                             GO TO 150
32757                                                                GO TO 260
32758   160 CONTINUE
32759 C
32760 C  RANDOM CHOICE OF DECAY CHANNELS
32761 C----------------------------
32762 C
32763       IT=ITS(IST)
32764       ECO=AMM(IST)
32765       GAM=ELS(IST)/ECO
32766       BGAM=PLS(IST)/ECO
32767       IECO=0
32768       KZ1=K1H(IT)
32769   170 CONTINUE
32770       IECO=IECO+1
32771       VV=DT_RNDM(GAM)
32772       VV=VV-1.D-17
32773       IIK=KZ1-1
32774   180 IIK=IIK+1
32775       IF (VV.GT.WTI(IIK))                                      GO TO 180
32776 C
32777 C  IIK IS THE DECAY CHANNEL
32778 C----------------------------
32779       IT1=NZKI(IIK,1)
32780       I310=0
32781   190 CONTINUE
32782       I310=I310+1
32783       AM1=DT_DAMG(IT1)
32784       IT2=NZKI(IIK,2)
32785       AM2=DT_DAMG(IT2)
32786       IF (IT2-1.LT.0)                                          GO TO 240
32787       IT3=NZKI(IIK,3)
32788       AM3=DT_DAMG(IT3)
32789       AMS=AM1+AM2+AM3
32790 C
32791 C  IF  IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
32792 C----------------------------
32793       IF (IECO.LE.10)                                          GO TO 200
32794       IATMPT=IATMPT+1
32795       IF(IATMPT.GT.3) THEN
32796 C        WRITE(LOUT,*) ' jump 4'
32797          GO TO 280
32798       ENDIF
32799                                                                 GO TO 40
32800   200 CONTINUE
32801       IF (I310.GT.50)                                          GO TO 170
32802       IF (AMS.GT.ECO)                                          GO TO 190
32803 C
32804 C  FOR THE DECAY CHANNEL
32805 C  IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM  IT
32806 C----------------------------
32807       IF (REDU.LT.0.D0)                                        GO TO 30
32808       ITWTHC=0
32809       REDU=2.0D0
32810       IF(IT3.EQ.0)                                             GO TO 220
32811   210 CONTINUE
32812       ITWTH=1
32813       CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
32814      *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
32815                                                                GO TO 230
32816   220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
32817      &COD2,COF2,SIF2,AM1,AM2)
32818       ITWTH=-1
32819       IT3=0
32820   230 CONTINUE
32821       ITWTHC=ITWTHC+1
32822       IF (REDU.GT.0.D0)                                        GO TO 240
32823       REDU=2.0D0
32824       IF (ITWTHC.GT.100)                                        GO TO 30
32825       IF (ITWTH) 220,220,210
32826   240 CONTINUE
32827       ITS(IST  )=IT1
32828       IF (IT2-1.LT.0)                                          GO TO 250
32829       ITS(IST+1)  =IT2
32830       ITS(IST+2)=IT3
32831       RX=CXS(IST)
32832       RY=CYS(IST)
32833       RZ=CZS(IST)
32834       AMM(IST)=AM1
32835       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
32836      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32837       IST=IST+1
32838       AMM(IST)=AM2
32839       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
32840      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32841       IF (IT3.LE.0)                                            GO TO 250
32842       IST=IST+1
32843       AMM(IST)=AM3
32844       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
32845      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32846   250 CONTINUE
32847                                                                GO TO 150
32848   260 CONTINUE
32849   270 CONTINUE
32850       RETURN
32851   280 CONTINUE
32852 C
32853 C----------------------------
32854 C
32855 C   ZERO CROSS SECTION CASE
32856 C----------------------------
32857 C
32858       IRH=1
32859       ITRH(1)=N
32860       CXRH(1)=CX
32861       CYRH(1)=CY
32862       CZRH(1)=CZ
32863       ELRH(1)=ELAB
32864       PLRH(1)=PLAB
32865       RETURN
32866       END
32867
32868 *$ CREATE DT_RUNTT.FOR
32869 *COPY DT_RUNTT
32870 *
32871 *===runtt==============================================================*
32872 *
32873       BLOCK DATA DT_RUNTT
32874
32875       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32876       SAVE
32877
32878       COMMON /HNDRUN/ RUNTES,EFTES
32879
32880       DATA RUNTES,EFTES /100.D0,100.D0/
32881
32882       END
32883
32884 *$ CREATE DT_NONAME.FOR
32885 *COPY DT_NONAME
32886 *
32887 *===noname=============================================================*
32888 *
32889       BLOCK DATA DT_NONAME
32890
32891       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32892       SAVE
32893
32894 * slope parameters for HADRIN interactions
32895       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
32896
32897       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32898
32899 C     DATAS     DATAS    DATAS      DATAS     DATAS
32900 C******          *********
32901       DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
32902      &           207, 224, 241, 252, 268 /
32903       DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
32904      &           220, 241, 262, 279, 296 /
32905       DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
32906      &           3364, 3507, 4011, 4368, 4725, 4912, 5184/
32907
32908 C
32909 C     MASSES FOR THE SLOPE B(M) IN GEV
32910 C     SLOPE B(M) FOR AN MESONIC SYSTEM
32911 C     SLOPE B(M) FOR A BARYONIC SYSTEM
32912
32913 *
32914       DATA SM,BBM,BBB/  0.8D0, 0.85D0,  0.9D0, 0.95D0, 1.D0,
32915      &     1.05D0,  1.1D0, 1.15D0,  1.2D0, 1.25D0,
32916      &      1.3D0,  1.35D0, 1.4D0,  1.45D0,  1.5D0,
32917      &     1.55D0,  1.6D0,  1.65D0, 1.7D0,   1.75D0,
32918      &      1.8D0,  1.85D0, 1.9D0,  1.95D0,  2.D0,
32919      &     15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
32920      &    12.35D0, 11.7D0, 10.85D0, 10.D0,  9.15D0,
32921      &      8.3D0,  7.8D0,  7.3D0,  7.25D0,  7.2D0,
32922      &     6.95D0,  6.7D0,  6.6D0,  6.5D0,   6.3D0,
32923      &      6.1D0,  5.85D0, 5.6D0,  5.35D0,  5.1D0,
32924      &      15.D0,   15.D0, 15.D0,  15.D0,   15.D0, 15.D0, 15.D0,
32925      &     14.2D0,  13.4D0, 12.6D0,
32926      &     11.8D0, 11.2D0, 10.6D0,  9.8D0,    9.D0,
32927      &     8.25D0,  7.5D0, 6.25D0,  5.D0,    4.5D0, 5*4.D0 /
32928 *
32929       END
32930
32931 *$ CREATE DT_DAMG.FOR
32932 *COPY DT_DAMG
32933 *
32934 *===damg===============================================================*
32935 *
32936       DOUBLE PRECISION FUNCTION DT_DAMG(IT)
32937
32938       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32939       SAVE
32940
32941 * particle properties (BAMJET index convention),
32942 * (dublicate of DTPART for HADRIN)
32943       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32944      &                K1H(110),K2H(110)
32945
32946       DIMENSION GASUNI(14)
32947       DATA GASUNI/
32948      *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
32949      *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
32950       DATA GAUNO/2.352D0/
32951       DATA GAUNON/2.4D0/
32952       DATA IO/14/
32953       DATA NSTAB/23/
32954
32955       I=1
32956       IF (IT.LE.0)                                              GO TO 30
32957       IF (IT.LE.NSTAB)                                          GO TO 20
32958       DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
32959       VV=DT_RNDM(DGAUNI)
32960       VV=VV*2.0D0-1.0D0+1.D-16
32961    10 CONTINUE
32962       VO=GASUNI(I)
32963       I=I+1
32964       V1=GASUNI(I)
32965       IF (VV.GT.V1)                                             GO TO 10
32966       UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
32967      &      (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
32968       DAM=GAH(IT)*UNIGA/GAUNO
32969       AAM=AMH(IT)+DAM
32970       DT_DAMG=AAM
32971       RETURN
32972    20 CONTINUE
32973       DT_DAMG=AMH(IT)
32974       RETURN
32975    30 CONTINUE
32976       DT_DAMG=0.0D0
32977       RETURN
32978       END
32979
32980 *$ CREATE DT_DCALUM.FOR
32981 *COPY DT_DCALUM
32982 *
32983 *===dcalum=============================================================*
32984 *
32985       SUBROUTINE DT_DCALUM(N,ITTA)
32986
32987       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32988       SAVE
32989
32990 C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
32991
32992 * particle properties (BAMJET index convention),
32993 * (dublicate of DTPART for HADRIN)
32994       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32995      &                K1H(110),K2H(110)
32996
32997       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32998
32999       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33000
33001       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33002      &                NRK(2,268),NURE(30,2)
33003
33004       IRE=NURE(N,ITTA/8+1)
33005       IEO=IEII(IRE)+1
33006       IEE=IEII(IRE +1)
33007       AM1=AMH(N   )
33008       AM12=AM1**2
33009       AM2=AMH(ITTA)
33010       AM22=AM2**2
33011       DO 10 IE=IEO,IEE
33012         PLAB2=PLABF(IE)**2
33013         ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
33014         UMO(IE)=ELAB
33015    10 CONTINUE
33016       IKO=IKII(IRE)+1
33017       IKE=IKII(IRE +1)
33018       UMOO=UMO(IEO)
33019       DO 30 IK=IKO,IKE
33020         IF(NRK(2,IK).GT.0)                                      GO TO 30
33021         IKI=NRK(1,IK)
33022         AMSS=5.0D0
33023         K11=K1H(IKI)
33024         K22=K2H(IKI)
33025         DO 20 IK1=K11,K22
33026           IN=NZKI(IK1,1)
33027           AMS=AMH(IN)
33028           IN=NZKI(IK1,2)
33029           IF(IN.GT.0)AMS=AMS+AMH(IN)
33030           IN=NZKI(IK1,3)
33031           IF(IN.GT.0) AMS=AMS+AMH(IN)
33032           IF (AMS.LT.AMSS) AMSS=AMS
33033    20   CONTINUE
33034         IF(UMOO.LT.AMSS) UMOO=AMSS
33035         THRESH(IK)=UMOO
33036    30 CONTINUE
33037       RETURN
33038       END
33039
33040 *$ CREATE DT_DCHANH.FOR
33041 *COPY DT_DCHANH
33042 *
33043 *===dchanh=============================================================*
33044 *
33045       SUBROUTINE DT_DCHANH
33046
33047       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33048       SAVE
33049
33050       PARAMETER ( LINP = 10 ,
33051      &            LOUT = 6 ,
33052      &            LDAT = 9 )
33053
33054 * particle properties (BAMJET index convention),
33055 * (dublicate of DTPART for HADRIN)
33056       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33057      &                K1H(110),K2H(110)
33058
33059       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33060
33061       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33062
33063       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33064      &                NRK(2,268),NURE(30,2)
33065
33066       DIMENSION HWT(460),HWK(40),SI(5184)
33067       EQUIVALENCE (WK(1),SI(1))
33068 C--------------------
33069 C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
33070 C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
33071 C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
33072 C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
33073 C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
33074 C--------------------------
33075       IREG=16
33076       DO 90 IRE=1,IREG
33077         IWKO=IRII(IRE)
33078         IEE=IEII(IRE+1)-IEII(IRE)
33079         IKE=IKII(IRE+1)-IKII(IRE)
33080         IEO=IEII(IRE)+1
33081         IIKA=IKII(IRE)
33082 *   modifications to suppress elestic scattering  24/07/91
33083         DO 80 IE=1,IEE
33084           SIS=1.D-14
33085           SINORC=0.0D0
33086           DO 10 IK=1,IKE
33087             IWK=IWKO+IEE*(IK-1)+IE
33088             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33089             SIS=SIS+SI(IWK)*SINORC
33090    10     CONTINUE
33091           SIIN(IEO+IE-1)=SIS
33092           SIO=0.D0
33093           IF (SIS.GE.1.D-12)                                    GO TO 20
33094           SIS=1.D0
33095           SIO=1.D0
33096    20     CONTINUE
33097           SINORC=0.0D0
33098           DO 30 IK=1,IKE
33099             IWK=IWKO+IEE*(IK-1)+IE
33100             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33101             SIO=SIO+SI(IWK)*SINORC/SIS
33102             HWK(IK)=SIO
33103    30     CONTINUE
33104           DO 40 IK=1,IKE
33105             IWK=IWKO+IEE*(IK-1)+IE
33106    40     WK(IWK)=HWK(IK)
33107           IIKI=IKII(IRE)
33108           DO 70 IK=1,IKE
33109             AM111=0.D0
33110             INRK1=NRK(1,IIKI+IK)
33111             IF (INRK1.GT.0) AM111=AMH(INRK1)
33112             AM222=0.D0
33113             INRK2=NRK(2,IIKI+IK)
33114             IF (INRK2.GT.0) AM222=AMH(INRK2)
33115             THRESH(IIKI+IK)=AM111 +AM222
33116             IF (INRK2-1.GE.0)                                   GO TO 60
33117             INRKK=K1H(INRK1)
33118             AMSS=5.D0
33119             INRKO=K2H(INRK1)
33120             DO 50 INRK1=INRKK,INRKO
33121               INZK1=NZKI(INRK1,1)
33122               INZK2=NZKI(INRK1,2)
33123               INZK3=NZKI(INRK1,3)
33124               IF (INZK1.LE.0.OR.INZK1.GT.110)                   GO TO 50
33125               IF (INZK2.LE.0.OR.INZK2.GT.110)                   GO TO 50
33126               IF (INZK3.LE.0.OR.INZK3.GT.110)                   GO TO 50
33127 C     WRITE (6,310)INRK1,INZK1,INZK2,INZK3
33128  1000 FORMAT (4I10)
33129               AMS=AMH(INZK1)+AMH(INZK2)
33130               IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
33131               IF (AMSS.GT.AMS) AMSS=AMS
33132    50       CONTINUE
33133             AMS=AMSS
33134             IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
33135             THRESH(IIKI+IK)=AMS
33136    60       CONTINUE
33137    70     CONTINUE
33138    80   CONTINUE
33139    90 CONTINUE
33140       DO 100 J=1,460
33141   100 HWT(J)=0.D0
33142       DO 120 I=1,110
33143         IK1=K1H(I)
33144         IK2=K2H(I)
33145         HV=0.D0
33146         IF (IK2.GT.460)IK2=460
33147         IF (IK1.LE.0)IK1=1
33148         DO 110 J=IK1,IK2
33149           HV=HV+WTI(J)
33150           HWT(J)=HV
33151           JI=J
33152   110   CONTINUE
33153         IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
33154  1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
33155   120 CONTINUE
33156       DO 130 J=1,460
33157   130 WTI(J)=HWT(J)
33158       RETURN
33159       END
33160
33161 *$ CREATE DT_DHADDE.FOR
33162 *COPY DT_DHADDE
33163 *
33164 *===dhadde=============================================================*
33165 *
33166       SUBROUTINE DT_DHADDE
33167
33168       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33169       SAVE
33170
33171 * particle properties (BAMJET index convention)
33172       CHARACTER*8  ANAME
33173       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33174      &                IICH(210),IIBAR(210),K1(210),K2(210)
33175
33176 * HADRIN: decay channel information
33177       PARAMETER (IDMAX9=602)
33178       CHARACTER*8 ZKNAME
33179       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
33180
33181 * particle properties (BAMJET index convention),
33182 * (dublicate of DTPART for HADRIN)
33183       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33184      &                K1H(110),K2H(110)
33185
33186       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33187
33188 * decay channel information for HADRIN
33189       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33190      &                K1Z(16),K2Z(16),WTZ(153),II22,
33191      &                NZK1(153),NZK2(153),NZK3(153)
33192
33193       DATA IRETUR/0/
33194
33195       IRETUR=IRETUR+1
33196       AMH(31)=0.48D0
33197       IF (IRETUR.GT.1) RETURN
33198       DO 10 I=1,94
33199         AMH(I)   = AAM(I)
33200         GAH(I)   = GA(I)
33201         TAUH(I)  = TAU(I)
33202         ICHH(I)  = IICH(I)
33203         IBARH(I) = IIBAR(I)
33204         K1H(I)   = K1(I)
33205         K2H(I)   = K2(I)
33206    10 CONTINUE
33207 **sr
33208 C     AMH(1)=0.93828D0
33209       AMH(1)=0.9383D0
33210 **
33211       AMH(2)=AMH(1)
33212       DO 20 I=26,30
33213         K1H(I)=452
33214         K2H(I)=452
33215    20 CONTINUE
33216       DO 30 I=1,307
33217         WTI(I)    = WT(I)
33218         NZKI(I,1) = NZK(I,1)
33219         NZKI(I,2) = NZK(I,2)
33220         NZKI(I,3) = NZK(I,3)
33221    30 CONTINUE
33222       DO 40 I=1,16
33223         L=I+94
33224         AMH(L)=AMZ(I)
33225         GAH( L)=GAZ(I)
33226         TAUH( L)=TAUZ(I)
33227         ICHH( L)=ICHZ(I)
33228         IBARH( L)=IBARZ(I)
33229         K1H( L)=K1Z(I)
33230         K2H( L)=K2Z(I)
33231    40 CONTINUE
33232       DO 50 I=1,153
33233         L=I+307
33234         WTI(L)    = WTZ(I)
33235         NZKI(L,3) = NZK3(I)
33236         NZKI(L,2) = NZK2(I)
33237         NZKI(L,1) = NZK1(I)
33238    50 CONTINUE
33239       RETURN
33240       END
33241
33242 *$ CREATE IDT_IEFUND.FOR
33243 *COPY IDT_IEFUND
33244 *
33245 *===iefund=============================================================*
33246 *
33247       INTEGER FUNCTION IDT_IEFUND(PL,IRE)
33248
33249       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33250       SAVE
33251
33252 C*****IEFUN CALCULATES A MOMENTUM INDEX
33253
33254       PARAMETER ( LINP = 10 ,
33255      &            LOUT = 6 ,
33256      &            LDAT = 9 )
33257
33258       COMMON /HNDRUN/ RUNTES,EFTES
33259
33260       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33261
33262       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33263      &                NRK(2,268),NURE(30,2)
33264
33265       IPLA=IEII(IRE)+1
33266      *+1
33267       IPLE=IEII(IRE+1)
33268       IF (PL.LT.0.)                                             GO TO 30
33269       DO 10 I=IPLA,IPLE
33270         J=I-IPLA+1
33271         IF (PL.LE.PLABF(I))                                     GO TO 60
33272    10 CONTINUE
33273       I=IPLE
33274       IF ( EFTES.GT.40.D0)                                      GO TO 20
33275       EFTES=EFTES+1.0D0
33276       WRITE(LOUT,1000)PL,J
33277    20 CONTINUE
33278                                                                 GO TO 70
33279    30 CONTINUE
33280       DO 40 I=IPLA,IPLE
33281         J=I-IPLA+1
33282         IF (-PL.LE.UMO(I))                                      GO TO 60
33283    40 CONTINUE
33284       I=IPLE
33285       IF ( EFTES.GT.40.D0)                                      GO TO 50
33286       EFTES=EFTES+1.0D0
33287       WRITE(LOUT,1000)PL,I
33288    50 CONTINUE
33289    60 CONTINUE
33290    70 CONTINUE
33291       IDT_IEFUND=I
33292       RETURN
33293  1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
33294      +7H IEFUN=,I5)
33295       END
33296
33297 *$ CREATE DT_DSIGIN.FOR
33298 *COPY DT_DSIGIN
33299 *
33300 *===dsigin=============================================================*
33301 *
33302       SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
33303
33304       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33305       SAVE
33306
33307 * particle properties (BAMJET index convention),
33308 * (dublicate of DTPART for HADRIN)
33309       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33310      &                K1H(110),K2H(110)
33311
33312       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33313
33314       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33315      &                NRK(2,268),NURE(30,2)
33316
33317       IE=IDT_IEFUND(PLAB,IRE)
33318       IF (IE.LE.IEII(IRE)) IE=IE+1
33319       AMT=AMH(ITAR)
33320       AMN=AMH(N)
33321       AMN2=AMN*AMN
33322       AMT2=AMT*AMT
33323       ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
33324 C*** INTERPOLATION PREPARATION
33325       ECMO=UMO(IE)
33326       ECM1=UMO(IE-1)
33327       DECM=ECMO-ECM1
33328       DEC=ECMO-ECM
33329       IIKI=IKII(IRE)+1
33330       EKLIM=-THRESH(IIKI)
33331       WOK=SIIN(IE)
33332       WDK=WOK-SIIN(IE-1)
33333       IF (ECM.GT.ECMO) WDK=0.0D0
33334 C*** INTERPOLATION IN CHANNEL WEIGHTS
33335       IELIM=IDT_IEFUND(EKLIM,IRE)
33336       DELIM=UMO(IELIM)+EKLIM
33337      *+1.D-16
33338       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
33339       IF (DELIM*DELIM-DETE*DETE) 20,20,10
33340    10 DECC=DELIM
33341                                                                 GO TO 30
33342    20 DECC=DECM
33343    30 CONTINUE
33344       WKK=WOK-WDK*DEC/(DECC+1.D-9)
33345       IF (WKK.LT.0.0D0) WKK=0.0D0
33346       SI=WKK+1.D-12
33347       IF (-EKLIM.GT.ECM) SI=1.D-14
33348       RETURN
33349       END
33350
33351 *$ CREATE DT_DTCHOI.FOR
33352 *COPY DT_DTCHOI
33353 *
33354 *===dtchoi=============================================================*
33355 *
33356       SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
33357
33358       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33359       SAVE
33360
33361 C     ****************************
33362 C     TCHOIC CALCULATES A RANDOM VALUE
33363 C     FOR THE FOUR-MOMENTUM-TRANSFER T
33364 C     ****************************
33365
33366 * particle properties (BAMJET index convention),
33367 * (dublicate of DTPART for HADRIN)
33368       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33369      &                K1H(110),K2H(110)
33370
33371 * slope parameters for HADRIN interactions
33372       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
33373
33374       AMA=AM1
33375       AMB=AM2
33376       IF (I.GT.30.AND.II.GT.30)                                 GO TO 20
33377       III=II
33378       AM3=AM2
33379       IF (I.LE.30)                                              GO TO 10
33380       III=I
33381       AM3=AM1
33382    10 CONTINUE
33383                                                                 GO TO 30
33384    20 CONTINUE
33385       III=II
33386       AM3=AM2
33387       IF (AMA.LE.AMB)                                           GO TO 30
33388       III=I
33389       AM3=AM1
33390    30 CONTINUE
33391       IB=IBARH(III)
33392       AMA=AM3
33393       K=INT((AMA-0.75D0)/0.05D0)
33394       IF (K-2.LT.0) K=1
33395       IF (K-26.GE.0) K=25
33396       IF (IB)50,40,50
33397    40 BM=BBM(K)
33398                                                                 GO TO 60
33399    50 BM=BBB(K)
33400    60 CONTINUE
33401 C     NORMALIZATION
33402       TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1  **2
33403       TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1  **2
33404       VB=DT_RNDM(TMIN)
33405 **sr test
33406 C     IF (VB.LT.0.2D0) BM=BM*0.1
33407 C    **0.5
33408       BM = BM*5.05D0
33409 **
33410       TMI=BM*TMIN
33411       TMA=BM*TMAX
33412       ETMA=0.D0
33413       IF (ABS(TMA).GT.120.D0)                                   GO TO 70
33414       ETMA=EXP(TMA)
33415    70 CONTINUE
33416       AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
33417 C*** RANDOM CHOICE OF THE T - VALUE
33418       R=DT_RNDM(TMI)
33419       T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
33420       RETURN
33421       END
33422
33423 *$ CREATE DT_DTWOPA.FOR
33424 *COPY DT_DTWOPA
33425 *
33426 *===dtwopa=============================================================*
33427 *
33428       SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
33429      &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
33430
33431       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33432       SAVE
33433
33434 C     ******************************************************
33435 C     QUASI TWO PARTICLE PRODUCTION
33436 C     TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
33437 C     FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
33438 C     IN THE CM - SYSTEM
33439 C     COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
33440 C     SPHERICAL COORDINATES
33441 C     ******************************************************
33442
33443 * particle properties (BAMJET index convention),
33444 * (dublicate of DTPART for HADRIN)
33445       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33446      &                K1H(110),K2H(110)
33447
33448       AMA=AM1
33449       AMB=AM2
33450       AMA2=AMA*AMA
33451       E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
33452       E2=UMOO - E1
33453       IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
33454       AMTE=(E1-AMA)*(E1+AMA)
33455       AMTE=AMTE+1.D-18
33456       P1=SQRT(AMTE)
33457       P2=P1
33458 C     / P2 / = / P1 /  BUT OPPOSITE DIRECTIONS
33459 C     DETERMINATION  OF  THE ANGLES
33460 C     COS(THETA1)=COD1      COS(THETA2)=COD2
33461 C     SIN(PHI1)=SIF1        SIN(PHI2)=SIF2
33462 C     COS(PHI1)=COF1        COS(PHI2)=COF2
33463 C     PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
33464       CALL DT_DSFECF(COF1,SIF1)
33465       COF2=-COF1
33466       SIF2=-SIF1
33467 C     CALCULATION OF THETA1
33468       CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
33469       COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
33470       IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
33471       COD2=-COD1
33472       RETURN
33473       END
33474
33475 *$ CREATE DT_ZK.FOR
33476 *COPY DT_ZK
33477 *
33478 *===zk=================================================================*
33479 *
33480       BLOCK DATA DT_ZK
33481
33482       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33483       SAVE
33484
33485 * decay channel information for HADRIN
33486       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33487      &                K1Z(16),K2Z(16),WTZ(153),II22,
33488      &                NZK1(153),NZK2(153),NZK3(153)
33489
33490 * decay channel information for HADRIN
33491       CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
33492       COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
33493
33494 *     Particle masses in GeV                                           *
33495       DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
33496      &          2*1.7D0, 3*0.D0/
33497 *     Resonance width Gamma in GeV                                     *
33498       DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
33499 *     Mean life time in seconds                                        *
33500       DATA TAUZ / 16*0.D0 /
33501 *     Charge of particles and resonances                               *
33502       DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
33503 *     Baryonic charge                                                  *
33504       DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
33505 *     First number of decay channels used for resonances               *
33506 *     and decaying particles                                           *
33507       DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
33508      &          3*460/
33509 *     Last number of decay channels used for resonances                *
33510 *     and decaying particles                                           *
33511       DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
33512      &          3*460/
33513 *     Weight of decay channel                                          *
33514       DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
33515      & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
33516      & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
33517      & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
33518      & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
33519      & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
33520      & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
33521      & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
33522      & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
33523      & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
33524      & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
33525      & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
33526      & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
33527      & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
33528      & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
33529      & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
33530      & .05D0, .65D0, 9*1.D0 /
33531 *     Particle numbers in decay channel                                *
33532       DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
33533      & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
33534      & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
33535      & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
33536      & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
33537      & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
33538      & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
33539      & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
33540       DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
33541      & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
33542      & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
33543      & 4*33, 32, 3*35,  2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
33544      & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
33545      & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
33546      & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
33547      & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
33548      & 1, 8, 1, 8, 1, 9*0 /
33549       DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
33550      & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
33551      & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
33552      & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
33553      & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
33554      & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
33555 *     Particle  names                                                  *
33556       DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS  ',' PAP  ',' PAN  ',
33557      & 'APN', 'DEO   ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
33558      & 3*'BLANK' /
33559 *     Name of decay channel                                            *
33560       DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
33561      & 'ANNPI0','APPPI0','ANPPI-'/
33562       DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K-  ','K0AK0 ',
33563      & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET  ','&0R0  ','P-R+  ',
33564      & 'P+R-  ','POOM  ',' ETET ','ETSP0 ','R0ET  ',' R0R0 ','R+R-  ',
33565      & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
33566      & 'P+R-R0','R0OM  ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
33567      & 'P+R-OM','OMOM  ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
33568      & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
33569      & 'OMOMOM',
33570      & ' P+PO ','P+POPO','P+P+P-','P+ET  ','P0R+  ','P+R0  ','ETSP+ ',
33571      & 'R+ET  ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
33572      & 'P+R-R+','R+OM  ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
33573      & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
33574      & 'P-PO  ','P-POPO','P-P-P+','P-ET  ','POR-  ','P-R0  ','ETSP- ',
33575      & 'R-ET  ','R-R0  ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
33576       DATA ZKNAM6/'P+R-R-','R-OM  ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
33577      & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
33578      & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO  ','LPI+  ',
33579      & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
33580      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
33581      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
33582      & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
33583      & 9*'BLANK'/
33584 *=                                               end*block.zk      *
33585       END
33586
33587 *$ CREATE DT_BLKD43.FOR
33588 *COPY DT_BLKD43
33589 *
33590 *===blkd43=============================================================*
33591 *
33592       BLOCK DATA DT_BLKD43
33593
33594       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33595       SAVE
33596
33597 *
33598 *=== reac =============================================================*
33599 *
33600 *----------------------------------------------------------------------*
33601 *                                                                      *
33602 *     Created on 10 december 1991  by    Alfredo Ferrari & Paola Sala  *
33603 *                                                   Infn - Milan       *
33604 *                                                                      *
33605 *     Last change on 10-dec-91     by    Alfredo Ferrari               *
33606 *                                                                      *
33607 *     This is the original common reac of Hadrin                       *
33608 *                                                                      *
33609 *----------------------------------------------------------------------*
33610 *
33611
33612       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33613      &                NRK(2,268),NURE(30,2)
33614
33615       DIMENSION
33616      & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
33617      & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
33618      & SPIKP1(315), SPIKPU(278), SPIKPV(372),
33619      & SPIKPW(278), SPIKPX(372), SPIKP4(315),
33620      & SPIKP5(187), SPIKP6(289),
33621      & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
33622      & SPIKP9(143), SPIKP0(169), SPKPV(143),
33623      & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
33624      & SANPEL(84) , SPIKPF(273),
33625      & SPKP15(187), SPKP16(272),
33626      & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
33627      & NURELN(60)
33628 *
33629        DIMENSION NRKLIN(532)
33630        EQUIVALENCE (NRK(1,1), NRKLIN(1))
33631        EQUIVALENCE (   UMO(  1),  UMOPI(1)), (   UMO( 93),  UMOKC(1))
33632        EQUIVALENCE (   UMO(161),   UMOP(1)), (   UMO(200),   UMON(1))
33633        EQUIVALENCE (   UMO(263),  UMOK0(1))
33634        EQUIVALENCE ( PLABF(  1),  PLAPI(1)), ( PLABF( 93),  PLAKC(1))
33635        EQUIVALENCE ( PLABF(161),   PLAP(1)), ( PLABF(200),   PLAN(1))
33636        EQUIVALENCE ( PLABF(263),  PLAK0(1))
33637        EQUIVALENCE (   WK(   1), SPIKP1(1)), (   WK( 316), SPIKPU(1))
33638        EQUIVALENCE (   WK( 594), SPIKPV(1)), (   WK( 966), SPIKPW(1))
33639        EQUIVALENCE (   WK(1244), SPIKPX(1)), (   WK(1616), SPIKP4(1))
33640        EQUIVALENCE (   WK(1931), SPIKP5(1)), (   WK(2118), SPIKP6(1))
33641        EQUIVALENCE (   WK(2407), SKMPEL(1)), (   WK(2509), SPIKP7(1))
33642        EQUIVALENCE (   WK(2798), SKMNEL(1)), (   WK(2866), SPIKP8(1))
33643        EQUIVALENCE (   WK(3053), SPIKP9(1)), (   WK(3196), SPIKP0(1))
33644        EQUIVALENCE (   WK(3365),  SPKPV(1)), (   WK(3508), SAPPEL(1))
33645        EQUIVALENCE (   WK(3613), SPIKPE(1)), (   WK(4012), SAPNEL(1))
33646        EQUIVALENCE (   WK(4096), SPIKPZ(1)), (   WK(4369), SANPEL(1))
33647        EQUIVALENCE (   WK(4453), SPIKPF(1)), (   WK(4726), SPKP15(1))
33648        EQUIVALENCE (   WK(4913), SPKP16(1))
33649        EQUIVALENCE (NRK(1,1), NRKLIN(1))
33650        EQUIVALENCE (NRKLIN(   1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
33651        EQUIVALENCE (NRKLIN( 297),  NRKP(1)), (NRKLIN( 367),  NRKN(1))
33652        EQUIVALENCE (NRKLIN( 483), NRKK0(1))
33653        EQUIVALENCE (NURE(1,1), NURELN(1))
33654 *
33655 **** pi- p data                                                        *
33656 **** pi+ n data                                                        *
33657       DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
33658      & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
33659      & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
33660      & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
33661      & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
33662      & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
33663      & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
33664      & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
33665      & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
33666      & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
33667       DATA PLAKC /
33668      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33669      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33670      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33671      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33672      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33673      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33674      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33675      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33676      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33677      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33678      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33679      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
33680       DATA PLAK0 /
33681      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33682      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33683      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33684      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33685      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33686      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
33687 *                 pp   pn   np   nn                                    *
33688       DATA PLAP /
33689      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33690      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33691      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33692      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33693      &   0.D0, 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 *    app   apn   anp   ann                                             *
33696       DATA PLAN /
33697      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
33698      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33699      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33700      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
33701      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33702      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33703      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
33704      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33705      & 3.43D0, 3.75D0, 4.07D0, 4.43D0  /
33706       DATA SIIN / 296*0.D0 /
33707       DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
33708      & 1.557D0,1.615D0,1.6435D0,
33709      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33710      & 2.286D0,2.366D0,2.482D0,2.56D0,
33711      & 2.735D0,2.90D0,
33712      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
33713      & 1.496D0,1.527D0,1.557D0,
33714      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
33715      & 2.071D0,2.159D0,2.286D0,2.366D0,
33716      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
33717      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
33718      & 1.496D0,1.527D0,1.557D0,
33719      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
33720      & 2.071D0,2.159D0,2.286D0,2.366D0,
33721      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
33722      &                   1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
33723      & 1.557D0,1.615D0,1.6435D0,
33724      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33725      & 2.286D0,2.366D0,2.482D0,2.56D0,
33726      &  2.735D0, 2.90D0/
33727       DATA UMOKC/ 1.44D0,
33728      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33729      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33730      & 3.1D0,1.44D0,
33731      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33732      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33733      & 3.1D0,1.44D0,
33734      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33735      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33736      & 3.1D0,1.44D0,
33737      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33738      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33739      &  3.1D0/
33740       DATA UMOK0/ 1.44D0,
33741      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33742      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33743      & 3.1D0,1.44D0,
33744      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33745      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33746      &  3.1D0/
33747 *                 pp   pn   np   nn                                    *
33748       DATA UMOP/
33749      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33750      & 3.D0,3.1D0,3.2D0,
33751      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33752      & 3.D0,3.1D0,3.2D0,
33753      & 1.88D0,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 *    app   apn   anp   ann                                             *
33756       DATA UMON /
33757      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33758      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33759      & 3.D0,3.1D0,3.2D0,
33760      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33761      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33762      & 3.D0,3.1D0,3.2D0,
33763      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33764      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33765      &  3.D0,3.1D0,3.2D0/
33766 **** reaction channel state particles                                  *
33767       DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
33768      & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
33769      & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
33770      & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
33771      & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
33772      & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
33773      & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
33774      & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
33775      & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
33776      & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
33777       DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
33778      & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
33779      & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
33780      & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
33781      & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
33782      & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
33783      & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
33784      & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
33785 *                                                                      *
33786 *   k0 p   k0 n   ak0 p   ak/ n                                        *
33787 *                                                                      *
33788       DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
33789      & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13,   22, 13, 21, 23,
33790      & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
33791      & 53, 47, 1, 103, 0, 93, 0/
33792 *   pp  pn   np   nn                                                   *
33793       DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
33794      & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
33795      & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
33796      & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
33797 *     app   apn   anp   ann                                            *
33798       DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
33799      & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
33800      & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
33801      & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
33802      & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
33803      & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
33804      & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
33805 **** channel cross section                                             *
33806       DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
33807      & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
33808      & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
33809      & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
33810      & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
33811      &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
33812      & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
33813      & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
33814      &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
33815      & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
33816      & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
33817      & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
33818      & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
33819      & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
33820      & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
33821      & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
33822      & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
33823      & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
33824      & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
33825      & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
33826 **** pi+ n data                                                        *
33827       DATA SPIKPU/   0.D0, 25.D0, 13.D0,  11.D0, 10.5D0, 14.D0,  20.D0,
33828      & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33829      & 10.D0, 10.D0, 9.5D0,  9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33830      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0,   5.5D0,  4.8D0,
33831      & 4.2D0, 7.5D0, 3.4D0,  2.5D0, 2.5D0, 2.1D0, 1.4D0,   1.D0,   .8D0,
33832      &  .6D0, .46D0,  .3D0, .2D0, .15D0, .13D0, 11*0.D0,  .95D0,  .65D0,
33833      & .48D0, .35D0,  .2D0, .18D0, .17D0, .16D0,  .15D0,   .1D0,  .09D0,
33834      & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0,  .2D0,   .1D0,
33835      & .08D0, .06D0, .045D0,   .03D0, .02D0, .01D0,      .005D0, .003D0,
33836      & 12*0.D0, .3D0, .24D0,   .18D0, .15D0, .13D0,  .12D0, .11D0, .1D0,
33837      & .09D0,  .08D0, .05D0,   .04D0, .03D0,  0.D0, 0.16D0, .7D0, 1.3D0,
33838      & 3.1D0,  4.5D0,  2.D0, 18*0.D0, 3*.0D0,  0.D0, 0.D0, 4.0D0, 11.D0,
33839      & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0,  1.5D0, .9D0, .55D0,
33840      &  .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0,   2.25D0, 3.3D0,
33841      & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
33842      & .64D0,  1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0,  4.4D0,   3.D0, 1.8D0,
33843      &  .9D0, .53D0, .28D0,      10*0.D0, 2*0.D0,  .25D0,  .82D0,
33844      & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0,  5.7D0, 3.9D0, 2.35D0, 1.15D0,
33845      & .69D0, .37D0, 10*0.D0,     7*0.D0,   .0D0, .34D0,  1.5D0, 3.47D0,
33846      & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0,  .3D0,  .15D0, 6*0.D0/
33847 *
33848       DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33849      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
33850      & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
33851      & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
33852      & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
33853      & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
33854      & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
33855      & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
33856      & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
33857      & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
33858      & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
33859      & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
33860      & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
33861      & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
33862      & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
33863      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33864      & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
33865      & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
33866      & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
33867      & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
33868 **** pi- p data                                                        *
33869       DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
33870      & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33871      & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33872      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
33873      & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
33874      & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
33875      & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
33876      & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
33877      & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
33878      & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
33879      & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
33880      & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
33881      & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
33882      & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
33883      & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
33884      & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
33885      & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
33886      & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
33887      & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
33888 *
33889       DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33890      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
33891      & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
33892      & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
33893      & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
33894      & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
33895      & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
33896      & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
33897      & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
33898      & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
33899      & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
33900      & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
33901      & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
33902      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33903      & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
33904      & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
33905      & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
33906      & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
33907      & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
33908      & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
33909 **** pi- n data                                                        *
33910       DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
33911      & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
33912      & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
33913      & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
33914      & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
33915      & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
33916      & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
33917      & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
33918      & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
33919      & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
33920      & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
33921      & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
33922      & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
33923      & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
33924      & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
33925      & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
33926      & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
33927      & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
33928      & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
33929      & 3.3D0, 5.4D0, 7.D0 /
33930 **** k+  p data                                                        *
33931       DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
33932      & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
33933      & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
33934      & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
33935      & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33936      & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
33937      & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
33938      & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
33939      & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
33940      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33941      & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
33942      & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
33943      & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
33944 **** k+  n data                                                        *
33945       DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
33946      & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
33947      & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
33948      & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
33949      & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33950      & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
33951      & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
33952      & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
33953      & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
33954      & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
33955      & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
33956      & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
33957      & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
33958      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33959      & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
33960      & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
33961      & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
33962      & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
33963      & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
33964 **** k-  p data                                                        *
33965       DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
33966      &     7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
33967      &    0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
33968      &    .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
33969      &    0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
33970      &    .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
33971      &    0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
33972      &    .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
33973      &    0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
33974      &    .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
33975      &    0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
33976      &    .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
33977       DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
33978      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
33979      & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
33980      & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
33981      & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,  3*0.D0, 1.0D0, 3.03D0,
33982      & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
33983      & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
33984      & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
33985      & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
33986      & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
33987      & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
33988      & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
33989      & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
33990      & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
33991      & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
33992      & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
33993      & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
33994      & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
33995      & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
33996      & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
33997      & 10*0.D0/
33998 ***** k- n data                                                        *
33999       DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
34000      &        3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
34001      &        0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
34002      &        1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
34003      &        0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
34004      &        .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
34005      &        0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
34006      &       .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
34007       DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
34008      &  14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
34009      &  1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
34010      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
34011      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
34012      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
34013      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
34014      &  7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
34015      &  .39D0, .22D0, .07D0, 0.D0,
34016      &  6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
34017      &  4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
34018      &  10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
34019      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
34020      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
34021      &  9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
34022      &  5.10D0, 5.44D0, 5.3D0,
34023      &  4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
34024 *****  p p data                                                        *
34025       DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34026      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34027      &              0.D0, 3.6D0, 1.7D0, 10*0.D0,
34028      &              .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
34029      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
34030      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
34031      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34032      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34033      &              16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
34034      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
34035      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
34036      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34037      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34038      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34039      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34040 *****  p n data                                                        *
34041       DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34042      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34043      &              0.D0, 1.8D0, .2D0,  12*0.D0,
34044      &              3.2D0, 6.05D0, 9.9D0, 5.1D0,
34045      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34046      &              2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
34047      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34048      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34049      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34050      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34051      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34052      &              10*0.D0, .7D0, 5.1D0, 8.D0,
34053      &              10*0.D0, .7D0, 5.1D0, 8.D0,
34054      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
34055      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
34056      &              7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
34057      &              7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
34058      &              5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
34059 *   nn - data                                                          *
34060 *                                                                      *
34061       DATA SPKPV/  0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34062      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34063      &              0.D0, 3.6D0, 1.7D0, 12*0.D0,
34064      &              8.7D0, 17.7D0, 18.8D0, 15.9D0,
34065      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
34066      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
34067      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34068      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
34069      &              11.D0, 5.5D0, 3.5D0,
34070      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
34071      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
34072      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34073      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34074      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34075      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34076 ****************   ap - p - data                                       *
34077       DATA SAPPEL/ 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
34078      &  50.D0,  50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34079      &  25.D0,  22.D0, 21.D0, 20.D0, 18.D0, 17.D0,  11*0.D0,
34080      &  .05D0,  .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
34081      &  0.D0,  1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
34082      &  .1D0,  .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34083      &  0.D0,  55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
34084      &  10.D0,  7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
34085      &  1.55D0,  1.3D0, .95D0, .75D0,
34086      &  0.D0,  3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
34087      &  .25D0,  .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34088      & .01D0,  .008D0, .006D0, .005D0/
34089       DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34090      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34091      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
34092      & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
34093      & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
34094      & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
34095      & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
34096      & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
34097      & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
34098      & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
34099      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34100      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34101      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34102      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
34103      & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
34104      & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
34105      & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
34106      & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
34107      & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
34108      & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
34109 ****************   ap - n - data                                       *
34110       DATA SAPNEL/
34111      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0,  68.D0, 65.D0,
34112      & 50.D0, 50.D0,  43.D0,  42.D0,  40.5D0, 35.D0, 30.D0,  28.D0,
34113      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0,  17.D0, 11*0.D0,
34114      & .05D0, .15D0, .18D0,  .2D0,    .2D0,  .3D0,  .4D0,   .6D0,  .7D0,
34115      & .85D0,  0.D0,  1.D0,  .9D0,    .46D0, .3D0,  .23D0, .18D0, .16D0,
34116      & .14D0,  .1D0, .08D0, .05D0,    .02D0, .015D0, 4*.011D0, 3*.005D0,
34117      & 0.D0,  3.3D0,  3.D0, 1.5D0,     1.D0, .7D0,  .4D0,  .35D0, .4D0,
34118      & .25D0, .18D0, .08D0, .04D0,    .03D0, .023D0, .016D0, .014D0,
34119      & .01D0, .008D0, .006D0, .005D0 /
34120        DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34121      &  84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34122      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
34123      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34124      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
34125      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
34126      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
34127      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34128      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34129      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34130      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
34131      & 4.9D0, 8.5D0,  15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
34132      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
34133      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
34134 *                                                                      *
34135 *                                                                      *
34136 ****************   an - p - data                                       *
34137 *                                                                      *
34138       DATA SANPEL/
34139      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
34140      & 50.D0, 43.D0,  42.D0,  40.5D0, 35.D0, 30.D0, 28.D0,
34141      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0, 17.D0, 11*0.D0, .05D0,
34142      & .15D0, .18D0,   .2D0,   .2D0,   .3D0,  .4D0, .6D0,   .7D0, .85D0,
34143      & 0.D0,   1.D0,   .9D0,  .46D0,  .3D0,  .23D0, .18D0, .16D0, .14D0,
34144      & .1D0,  .08D0,  .05D0,  .02D0, .015D0, 4*.011D0, 3*.005D0,
34145      & 0.D0,  3.3D0,  3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
34146      & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34147      & .01D0, .008D0, .006D0, .005D0 /
34148       DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34149      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34150      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
34151      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34152      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
34153      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
34154      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
34155      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34156      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34157      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34158      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
34159      & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
34160      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
34161      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
34162 ****  ko - n - data                                                    *
34163       DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
34164      &      6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
34165      &      0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
34166      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34167      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34168      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34169      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34170      &    4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
34171      &     1.4D0, 1.2D0, 1.05D0, .9D0, .66D0,  .5D0,
34172      &    7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
34173      &   11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
34174      &    4.85D0, 4.9D0,
34175      &   10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
34176      &    6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
34177      &    2.85D0, 2.35D0, 2.01D0, 1.8D0,
34178      &   12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
34179      &   12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0  /
34180 **** ako - p - data                                                    *
34181       DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
34182      & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
34183      & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
34184      & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
34185      & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
34186      & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
34187      & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
34188      & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
34189      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
34190      & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
34191      & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
34192      & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
34193      & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
34194      & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
34195      & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
34196      & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
34197      & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
34198      & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
34199      & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
34200      & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
34201      & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
34202       DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
34203      & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
34204 *=                                               end*block.blkdt3      *
34205       END
34206 *$ CREATE DT_QEL_POL.FOR
34207 *COPY DT_QEL_POL
34208 *
34209 *===qel_pol============================================================*
34210 *
34211       SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
34212
34213       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34214       SAVE
34215
34216       CALL DT_MASS_INI
34217       CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34218
34219       RETURN
34220       END
34221
34222 *$ CREATE DT_GEN_QEL.FOR
34223 *COPY DT_GEN_QEL
34224 C==================================================================
34225 C   Generation of  a Quasi-Elastic neutrino scattering
34226 C==================================================================
34227 *
34228 *===gen_qel============================================================*
34229 *
34230       SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34231
34232 C...Generate a quasi-elastic   neutrino/antineutrino
34233 C.  Interaction on a nuclear target
34234 C.  INPUT  : LTYP = neutrino type (1,...,6)
34235 C.           ENU (GeV) = neutrino energy
34236 C----------------------------------------------------
34237
34238       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34239       SAVE
34240
34241       PARAMETER ( LINP = 10 ,
34242      &            LOUT = 6 ,
34243      &            LDAT = 9 )
34244       PARAMETER (MAXLND=4000)
34245       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34246
34247 * nuclear potential
34248       LOGICAL LFERMI
34249       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
34250      &                EBINDP(2),EBINDN(2),EPOT(2,210),
34251      &                ETACOU(2),ICOUL,LFERMI
34252
34253 * steering flags for qel neutrino scattering modules
34254       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34255 **sr - removed (not needed)
34256 C     COMMON /CBAD/  LBAD, NBAD
34257 C     COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
34258 **
34259
34260       DIMENSION PI(3),PO(3)
34261 CJR+
34262       DATA ININU/0/
34263 CJR-
34264 C     REAL*8 DBETA(3)
34265 C     REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
34266       DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
34267       DATA AMN  /0.93827231D0, 0.93956563D0/
34268       DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
34269       DATA INIPRI/0/
34270
34271 C     DATA PFERMI/0.22D0/
34272 CGB+...Binding Energy
34273       DATA EBIND/0.008D0/
34274 CGB-...
34275
34276       ININU=ININU+1
34277       IF(ININU.EQ.1)NDSIG=0
34278       LBAD = 0
34279       enu0=enu
34280 c      write(*,*) enu0
34281 C...Lepton mass
34282       AML = AML0(LTYP)       !  massa leptoni
34283       AML2 = AML**2          !  massa leptoni **2
34284 C...Particle labels (LUND)
34285       N = 5
34286       K(1,1) = 21
34287       K(2,1) = 21
34288       K(3,1) = 21
34289       K(3,3) = 1
34290       K(4,1) = 1
34291       K(4,3) = 1
34292       K(5,1) = 1
34293       K(5,3) = 2
34294       K0 = (LTYP-1)/2          !  2
34295       K1 = LTYP/2              !  2
34296       KA = 12 + 2*K0           !  16
34297       IS = -1 + 2*LTYP - 4*K1  !  -1 +10 -8 = 1
34298       K(1,2) = IS*KA
34299       K(4,2) = IS*(KA-1)
34300       K(3,2) = IS*24
34301       LNU = 2 - LTYP + 2*K1    !  2 - 5 + 2 = - 1
34302       IF (LNU .EQ. 2)  THEN
34303         K(2,2) = 2212
34304         K(5,2) = 2112
34305         AMI = AMN(1)
34306         AMF = AMN(2)
34307 CJR+
34308         PFERMI=PFERMN(2)
34309 CJR-
34310       ELSE
34311         K(2,2) = 2112
34312         K(5,2) = 2212
34313         AMI = AMN(2)
34314         AMF = AMN(1)
34315 CJR+
34316         PFERMI=PFERMP(2)
34317 CJR-
34318       ENDIF
34319       AMI2 = AMI**2
34320       AMF2 = AMF**2
34321
34322       DO IGB=1,5
34323         P(3,IGB) = 0.
34324         P(4,IGB) = 0.
34325         P(5,IGB) = 0.
34326       END DO
34327
34328       NTRY = 0
34329 CGB+...
34330       EFMAX  = SQRT(PFERMI**2 + AMI2) -AMI             ! max. Fermi Energy
34331       ENWELL = EFMAX + EBIND ! depth of nuclear potential well
34332 CGB-...
34333
34334   100 CONTINUE
34335
34336 C...4-momentum initial lepton
34337       P(1,5) = 0.     ! massa
34338       P(1,4) = ENU0    ! energia
34339       P(1,1) = 0.     ! px
34340       P(1,2) = 0.     ! py
34341       P(1,3) = ENU0    ! pz
34342
34343 C     PF = PFERMI*PYR(0)**(1./3.)
34344 c       write(23,*) PYR(0)
34345 c      write(*,*) 'Pfermi=',PF
34346 c      PF = 0.
34347       NTRY=NTRY+1
34348 C     IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
34349       IF (NTRY .GT. 500)  THEN
34350         LBAD = 1
34351         WRITE (LOUT,1001)  NBAD, ENU
34352         RETURN
34353       ENDIF
34354 C     CT = -1. + 2.*PYR(0)
34355 c      CT = -1.
34356 C     ST =  SQRT(1.-CT*CT)
34357 C     F = 2.*3.1415926*PYR(0)
34358 c      F = 0.
34359
34360 C     P(2,4) = SQRT(PF*PF + MI2) - EBIND  ! energia
34361 C     P(2,1) = PF*ST*COS(F)               ! px
34362 C     P(2,2) = PF*ST*SIN(F)               ! py
34363 C     P(2,3) = PF*CT                      ! pz
34364 C     P(2,5) = SQRT(P(2,4)**2-PF*PF)      ! massa
34365        P(2,1) = P21
34366        P(2,2) = P22
34367        P(2,3) = P23
34368        P(2,4) = P24
34369        P(2,5) = P25
34370       beta1=-p(2,1)/p(2,4)
34371       beta2=-p(2,2)/p(2,4)
34372       beta3=-p(2,3)/p(2,4)
34373       N=2
34374 C      WRITE(6,*)' before transforming into target rest frame'
34375
34376       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
34377
34378 C      print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
34379       N=5
34380
34381       phi11=atan(p(1,2)/p(1,3))
34382       pi(1)=p(1,1)
34383       pi(2)=p(1,2)
34384       pi(3)=p(1,3)
34385
34386       CALL DT_TESTROT(PI,Po,PHI11,1)
34387       DO ll=1,3
34388         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34389       END DO
34390 c        WRITE(*,*) po
34391       p(1,1)=po(1)
34392       p(1,2)=po(2)
34393       p(1,3)=po(3)
34394       phi12=atan(p(1,1)/p(1,3))
34395
34396       pi(1)=p(1,1)
34397       pi(2)=p(1,2)
34398       pi(3)=p(1,3)
34399       CALL DT_TESTROT(Pi,Po,PHI12,2)
34400       DO ll=1,3
34401         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34402       END DO
34403 c        WRITE(*,*) po
34404       p(1,1)=po(1)
34405       p(1,2)=po(2)
34406       p(1,3)=po(3)
34407
34408       enu=p(1,4)
34409
34410 C...Kinematical limits in Q**2
34411 c      S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) !            ????
34412       S = P(2,5)**2 + 2.*ENU*P(2,5)
34413       SQS = SQRT(S)                          ! E centro massa
34414       IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
34415       ELF = (S-AMF2+AML2)/(2.*SQS)           ! energia leptone finale p
34416       PSTAR = (S-P(2,5)**2)/(2.*SQS)       ! p* neutrino nel c.m.
34417       PLF = SQRT(ELF**2-AML2)               ! 3-momento leptone finale
34418       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)    ! + o -
34419       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)    ! according con cos(theta)
34420       IF (Q2MIN .LT. 0.)   Q2MIN = 0.      ! ??? non fisico
34421
34422 C...Generate Q**2
34423       DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
34424   200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
34425       DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
34426       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
34427       CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
34428       NDSIG=NDSIG+1
34429 C     WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
34430 C    &Q2,Q2min,Q2MAX,DSIGEV
34431
34432 C...c.m. frame. Neutrino along z axis
34433       DETOT = (P(1,4)) + (P(2,4)) ! e totale
34434       DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
34435       DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
34436       DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
34437 c      WRITE(*,*)
34438 c      WRITE(*,*)
34439 C      WRITE(*,*) 'Input values laboratory frame'
34440       N=2
34441
34442       CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
34443
34444       N=5
34445 c      STHETA = ULANGL(P(1,3),P(1,1))
34446 c      write(*,*) 'stheta' ,stheta
34447 c      stheta=0.
34448 c      CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
34449 c      WRITE(*,*)
34450 c      WRITE(*,*)
34451 C      WRITE(*,*) 'Output values cm frame'
34452 C...Kinematic in c.m. frame
34453       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
34454       STSTAR = SQRT(1.-CTSTAR**2)
34455       PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
34456       P(4,5) = AML                  ! massa leptone
34457       P(4,4) = ELF                 ! e leptone
34458       P(4,3) = PLF*CTSTAR          ! px
34459       P(4,1) = PLF*STSTAR*COS(PHI) ! py
34460       P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
34461
34462       P(5,5) = AMF                  ! barione
34463       P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
34464       P(5,3) = -P(4,3)             ! px
34465       P(5,1) = -P(4,1)             ! py
34466       P(5,2) = -P(4,2)             ! pz
34467
34468       P(3,5) = -Q2
34469       P(3,1) = P(1,1)-P(4,1)
34470       P(3,2) = P(1,2)-P(4,2)
34471       P(3,3) = P(1,3)-P(4,3)
34472       P(3,4) = P(1,4)-P(4,4)
34473
34474 C...Transform back to laboratory  frame
34475 C      WRITE(*,*) 'before going back to nucl rest frame'
34476 c      CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
34477       N=5
34478
34479       CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
34480
34481 C      WRITE(*,*) 'Now back in nucl rest frame'
34482       IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
34483
34484 c********************************************
34485
34486       DO kw=1,5
34487         pi(1)=p(kw,1)
34488         pi(2)=p(kw,2)
34489         pi(3)=p(kw,3)
34490         CALL DT_TESTROT(Pi,Po,PHI12,3)
34491         DO ll=1,3
34492           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34493         END DO
34494         p(kw,1)=po(1)
34495         p(kw,2)=po(2)
34496         p(kw,3)=po(3)
34497       END DO
34498 c********************************************
34499
34500       DO kw=1,5
34501         pi(1)=p(kw,1)
34502         pi(2)=p(kw,2)
34503         pi(3)=p(kw,3)
34504         CALL DT_TESTROT(Pi,Po,PHI11,4)
34505         DO ll=1,3
34506           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34507         END DO
34508         p(kw,1)=po(1)
34509         p(kw,2)=po(2)
34510         p(kw,3)=po(3)
34511       END DO
34512
34513 c********************************************
34514
34515 C      WRITE(*,*) 'Now back in lab frame'
34516
34517       CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
34518
34519 CGB+...
34520 C...test (on final momentum of nucleon) if Fermi-blocking
34521 C...is operating
34522       ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
34523      &  - P(5,5)
34524       IF (ENUCL.LT. EFMAX) THEN
34525         IF(INIPRI.LT.10)THEN
34526           INIPRI=INIPRI+1
34527 C         WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
34528 C...the interaction is not possible due to Pauli-Blocking and
34529 C...it must be resampled
34530         ENDIF
34531         GOTO 100
34532       ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
34533         IF(INIPRI.LT.10)THEN
34534           INIPRI=INIPRI+1
34535 C     WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
34536         ENDIF
34537 C                      Reject (J:R) here all these events
34538 C                      are otherwise rejected in dpmjet
34539         GOTO 100
34540 C...the interaction is possible, but the nucleon remains inside
34541 C...the nucleus. The nucleus is therefore left excited.
34542 C...We treat this case as a nucleon with 0 kinetic energy.
34543 C       P(5,5) = AMF
34544 C       P(5,4) = AMF
34545 C       P(5,1) = 0.
34546 C       P(5,2) = 0.
34547 C       P(5,3) = 0.
34548       ELSE IF (ENUCL.GE.ENWELL) THEN
34549 C     WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
34550 C...the interaction is possible, the nucleon can exit the nucleus
34551 C...but the nuclear well depth must be subtracted. The nucleus could be
34552 C...left in an excited state.
34553         Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
34554 C       P(5,4) = ENUCL-ENWELL + AMF
34555         Pnucl = SQRT(P(5,4)**2-AMF**2)
34556 C...The 3-momentum is scaled assuming that the direction remains
34557 C...unaffected
34558         P(5,1) = P(5,1) * Pnucl/Pstart
34559         P(5,2) = P(5,2) * Pnucl/Pstart
34560         P(5,3) = P(5,3) * Pnucl/Pstart
34561 C     WRITE(6,*)' qel new P(5,4) ',P(5,4)
34562       ENDIF
34563 CGB-...
34564       DSIGSU=DSIGSU+DSIGEV
34565
34566          GA=P(4,4)/P(4,5)
34567          BGX=P(4,1)/P(4,5)
34568          BGY=P(4,2)/P(4,5)
34569          BGZ=P(4,3)/P(4,5)
34570 *
34571          DBETB(1)=BGX/GA
34572          DBETB(2)=BGY/GA
34573          DBETB(3)=BGZ/GA
34574          IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
34575
34576             CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
34577
34578          ENDIF
34579 c
34580 C      PRINT*,' FINE   EVENTO '
34581       enu=enu0
34582       RETURN
34583
34584  1001 FORMAT(2X, 'DT_GEN_QEL   : event rejected ', I5,  G10.3)
34585       END
34586
34587 *$ CREATE DT_MASS_INI.FOR
34588 *COPY DT_MASS_INI
34589 C====================================================================
34590 C.  Masses
34591 C====================================================================
34592 *
34593 *===mass_ini===========================================================*
34594 *
34595       SUBROUTINE DT_MASS_INI
34596 C...Initialize  the kinematics for the quasi-elastic cross section
34597
34598       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34599       SAVE
34600
34601 * particle masses used in qel neutrino scattering modules
34602       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34603      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34604      &                EMPROTSQ,EMNEUTSQ,EMNSQ
34605
34606       EML(1) = 0.51100D-03   ! e-
34607       EML(2) = EML(1)        ! e+
34608       EML(3) = 0.105659D0      ! mu-
34609       EML(4) = EML(3)        ! mu+
34610       EML(5) = 1.7777D0        ! tau-
34611       EML(6) = EML(5)        ! tau+
34612       EMPROT = 0.93827231D0    ! p
34613       EMNEUT = 0.93956563D0    ! n
34614       EMPROTSQ = EMPROT**2
34615       EMNEUTSQ = EMNEUT**2
34616       EMN = (EMPROT + EMNEUT)/2.
34617       EMNSQ = EMN**2
34618       DO J=1,3
34619         J0 = 2*(J-1)
34620         EMN1(J0+1) = EMNEUT
34621         EMN1(J0+2) = EMPROT
34622         EMN2(J0+1) = EMPROT
34623         EMN2(J0+2) = EMNEUT
34624       ENDDO
34625       DO J=1,6
34626         EMLSQ(J) = EML(J)**2
34627         ETQE(J)  = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
34628       ENDDO
34629       RETURN
34630       END
34631
34632 *$ CREATE DT_DSQEL_Q2.FOR
34633 *COPY DT_DSQEL_Q2
34634 *
34635 *===dsqel_q2===========================================================*
34636 *
34637       DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
34638
34639 C...differential cross section for  Quasi-Elastic scattering
34640 C.       nu + N -> l + N'
34641 C.  From Llewellin Smith  Phys.Rep.  3C, 261, (1971).
34642 C.
34643 C.  INPUT :  JTYP = 1,...,6    nu_e, ...., nubar_tau
34644 C.           ENU (GeV) =  Neutrino energy
34645 C.           Q2  (GeV**2) =  (Transfer momentum)**2
34646 C.
34647 C.  OUTPUT : DSQEL_Q2  = differential  cross section :
34648 C.                       dsigma/dq**2  (10**-38 cm+2/GeV**2)
34649 C------------------------------------------------------------------
34650
34651       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34652       SAVE
34653
34654 * particle masses used in qel neutrino scattering modules
34655       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34656      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34657      &                EMPROTSQ,EMNEUTSQ,EMNSQ
34658 **sr - removed (not needed)
34659 C     COMMON /CAXIAL/ FA0, AXIAL2
34660 **
34661
34662       DIMENSION SS(6)
34663       DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34664       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34665       DATA AXIAL2 /1.03D0/  ! to be checked
34666
34667       FA0=-1.253D0
34668       CSI = 3.71D0                   !  ???
34669       GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2   ! G_e(q**2)
34670       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
34671       X = Q2/(EMN*EMN)     ! emn=massa barione
34672       XA = X/4.D0
34673       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34674       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34675       FA = FA0/(1.D0 + Q2/AXIAL2)**2
34676       FFA = FA*FA
34677       FFV1 = FV1*FV1
34678       FFV2 = FV2*FV2
34679       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
34680       A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
34681       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
34682       AA = (XA+0.25D0*RM)*(A1 + A2)
34683       BB = -X*FA*(FV1 + FV2)
34684       CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
34685       SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34686       DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU)  !
34687       IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
34688
34689       RETURN
34690       END
34691
34692 *$ CREATE DT_PREPOLA.FOR
34693 *COPY DT_PREPOLA
34694 *
34695 *===prepola============================================================*
34696 *
34697       SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
34698
34699       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34700       SAVE
34701 c
34702 c By G. Battistoni and E. Scapparone (sept. 1997)
34703 c According to:
34704 c     Albright & Jarlskog, Nucl Phys B84 (1975) 467
34705 c
34706 c
34707       PARAMETER (MAXLND=4000)
34708       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34709
34710       COMMON /QNPOL/ POLARX(4),PMODUL
34711
34712 * particle masses used in qel neutrino scattering modules
34713       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34714      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34715      &                EMPROTSQ,EMNEUTSQ,EMNSQ
34716
34717 * steering flags for qel neutrino scattering modules
34718       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34719 **sr - removed (not needed)
34720 C     COMMON /CAXIAL/ FA0, AXIAL2
34721 C     COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
34722 C    &        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
34723 **
34724       REAL*8 POL(4,4),BB2(3)
34725       DIMENSION SS(6)
34726 C     DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34727       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34728 **sr uncommented since common block CAXIAL is now commented
34729       DATA AXIAL2 /1.03D0/  ! to be checked
34730 **
34731
34732       RML=P(4,5)
34733       RMM=0.93960D+00
34734       FM2 = RMM**2
34735       MPI = 0.135D+00
34736       OLDQ2=Q2
34737       FA0=-1.253D+00
34738       CSI = 3.71D+00                      !
34739       GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2   ! G_e(q**2)
34740       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
34741       X = Q2/(EMN*EMN)     ! emn=massa barione
34742       XA = X/4.D0
34743       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34744       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34745       FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
34746       FFA = FA*FA
34747       FFV1 = FV1*FV1
34748       FFV2 = FV2*FV2
34749       FP=2.D0*FA*RMM/(MPI**2 + Q2)
34750       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
34751       A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
34752       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
34753       AA = (XA+0.25D+00*RM)*(A1 + A2)
34754       BB = -X*FA*(FV1 + FV2)
34755       CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
34756       SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34757
34758       OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2   )  ! articolo di ll...-smith
34759       OMEGA2=4.D+00*CC
34760       OMEGA3=2.D+00*FA*(FV1+FV2)
34761       OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
34762      1     (Q2/FM2))*FP**2)
34763       OMEGA5=OMEGA2
34764       OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
34765       WW1=2.D+00*OMEGA1*EMN**2
34766       WW2=2.D+00*OMEGA2*EMN**2
34767       WW3=2.D+00*OMEGA3*EMN**2
34768       WW4=2.D+00*OMEGA4*EMN**2
34769       WW5=2.D+00*OMEGA5*EMN**2
34770
34771       DO I=1,3
34772         BB2(I)=-P(4,I)/P(4,4)
34773       END DO
34774 c      WRITE(*,*)
34775 c      WRITE(*,*)
34776 c      WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
34777       N=5
34778
34779       CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
34780
34781 * NOW PARTICLES ARE IN THE SCATTERED LEPTON  REST FRAME
34782 c      WRITE(*,*)
34783 c      WRITE(*,*)
34784 c      WRITE(*,*) 'Prepola: now in lepton rest frame'
34785       EE=ENU
34786       QM2=Q2+RML**2
34787       U=Q2/(2.*RMM)
34788       FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
34789      +     (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
34790      +     ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
34791
34792       FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
34793      +     - ((RML**2)/FM2)*WW4                        !<=FM2 inv di RMM!!
34794
34795       FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
34796
34797       DO I=1,3
34798         POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
34799         POLARX(I)=POL(4,I)
34800       END DO
34801
34802       PMODUL=0.D0
34803       DO I=1,3
34804         PMODUL=PMODUL+POL(4,I)**2
34805       END DO
34806
34807       IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
34808          IF(NEUDEC.EQ.1) THEN
34809             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
34810      +        ETL,PXL,PYL,PZL,
34811      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34812 c
34813 c     Tau has decayed in muon
34814 c
34815          ENDIF
34816          IF(NEUDEC.EQ.2) THEN
34817             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
34818      +        ETL,PXL,PYL,PZL,
34819      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34820 c
34821 c     Tau has decayed in electron
34822 c
34823          ENDIF
34824          K(4,1)=15
34825          K(4,4) = 6
34826          K(4,5) = 8
34827          N=N+3
34828 c
34829 c     fill common for muon(electron)
34830 c
34831          P(6,1)=PXL
34832          P(6,2)=PYL
34833          P(6,3)=PZL
34834          P(6,4)=ETL
34835          K(6,1)=1
34836          IF(JTYP.EQ.5) THEN
34837             IF(NEUDEC.EQ.1) THEN
34838                P(6,5)=EML(JTYP-2)
34839                K(6,2)=13
34840             ELSEIF(NEUDEC.EQ.2) THEN
34841                P(6,5)=EML(JTYP-4)
34842                K(6,2)=11
34843             ENDIF
34844          ELSEIF(JTYP.EQ.6) THEN
34845             IF(NEUDEC.EQ.1) THEN
34846                K(6,2)=-13
34847             ELSEIF(NEUDEC.EQ.2) THEN
34848                K(6,2)=-11
34849             ENDIF
34850          END IF
34851          K(6,3)=4
34852          K(6,4)=0
34853          K(6,5)=0
34854 c
34855 c     fill common for tau_(anti)neutrino
34856 c
34857          P(7,1)=PXB
34858          P(7,2)=PYB
34859          P(7,3)=PZB
34860          P(7,4)=ETB
34861          P(7,5)=0.
34862          K(7,1)=1
34863          IF(JTYP.EQ.5) THEN
34864             K(7,2)=16
34865          ELSEIF(JTYP.EQ.6) THEN
34866             K(7,2)=-16
34867          END IF
34868          K(7,3)=4
34869          K(7,4)=0
34870          K(7,5)=0
34871 c
34872 c     Fill common for muon(electron)_(anti)neutrino
34873 c
34874          P(8,1)=PXN
34875          P(8,2)=PYN
34876          P(8,3)=PZN
34877          P(8,4)=ETN
34878          P(8,5)=0.
34879          K(8,1)=1
34880          IF(JTYP.EQ.5) THEN
34881             IF(NEUDEC.EQ.1) THEN
34882                K(8,2)=-14
34883             ELSEIF(NEUDEC.EQ.2) THEN
34884                K(8,2)=-12
34885             ENDIF
34886          ELSEIF(JTYP.EQ.6) THEN
34887             IF(NEUDEC.EQ.1) THEN
34888                K(8,2)=14
34889             ELSEIF(NEUDEC.EQ.2) THEN
34890                K(8,2)=12
34891             ENDIF
34892          END IF
34893          K(8,3)=4
34894          K(8,4)=0
34895          K(8,5)=0
34896       ENDIF
34897 c      WRITE(*,*)
34898 c      WRITE(*,*)
34899
34900 c      IF(PMODUL.GE.1.D+00) THEN
34901 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34902 c        write(*,*) pmodul
34903 c        DO I=1,3
34904 c          POL(4,I)=POL(4,I)/PMODUL
34905 c          POLARX(I)=POL(4,I)
34906 c        END DO
34907 c        PMODUL=0.
34908 c        DO I=1,3
34909 c          PMODUL=PMODUL+POL(4,I)**2
34910 c        END DO
34911 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34912 c
34913 c      ENDIF
34914
34915 c      WRITE(*,*) 'PMODUL = ',PMODUL
34916
34917 c      WRITE(*,*)
34918 c      WRITE(*,*)
34919 c      WRITE(*,*) 'prepola: Now back to nucl rest frame'
34920
34921       CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
34922
34923       XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
34924       YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
34925       ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
34926       DO NDC =6,8
34927          V(NDC,1) = XDC
34928          V(NDC,2) = YDC
34929          V(NDC,3) = ZDC
34930       END DO
34931
34932       RETURN
34933       END
34934
34935 *$ CREATE DT_TESTROT.FOR
34936 *COPY DT_TESTROT
34937 *
34938 *===testrot============================================================*
34939 *
34940       SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
34941
34942       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34943       SAVE
34944
34945       DIMENSION ROT(3,3),PI(3),PO(3)
34946
34947       IF (MODE.EQ.1) THEN
34948          ROT(1,1) = 1.D0
34949          ROT(1,2) = 0.D0
34950          ROT(1,3) = 0.D0
34951          ROT(2,1) = 0.D0
34952          ROT(2,2) = COS(PHI)
34953          ROT(2,3) = -SIN(PHI)
34954          ROT(3,1) = 0.D0
34955          ROT(3,2) = SIN(PHI)
34956          ROT(3,3) = COS(PHI)
34957       ELSEIF (MODE.EQ.2) THEN
34958          ROT(1,1) = 0.D0
34959          ROT(1,2) = 1.D0
34960          ROT(1,3) = 0.D0
34961          ROT(2,1) = COS(PHI)
34962          ROT(2,2) = 0.D0
34963          ROT(2,3) = -SIN(PHI)
34964          ROT(3,1) = SIN(PHI)
34965          ROT(3,2) = 0.D0
34966          ROT(3,3) = COS(PHI)
34967       ELSEIF (MODE.EQ.3) THEN
34968          ROT(1,1) = 0.D0
34969          ROT(2,1) = 1.D0
34970          ROT(3,1) = 0.D0
34971          ROT(1,2) = COS(PHI)
34972          ROT(2,2) = 0.D0
34973          ROT(3,2) = -SIN(PHI)
34974          ROT(1,3) = SIN(PHI)
34975          ROT(2,3) = 0.D0
34976          ROT(3,3) = COS(PHI)
34977       ELSEIF (MODE.EQ.4) THEN
34978          ROT(1,1) = 1.D0
34979          ROT(2,1) = 0.D0
34980          ROT(3,1) = 0.D0
34981          ROT(1,2) = 0.D0
34982          ROT(2,2) = COS(PHI)
34983          ROT(3,2) = -SIN(PHI)
34984          ROT(1,3) = 0.D0
34985          ROT(2,3) = SIN(PHI)
34986          ROT(3,3) = COS(PHI)
34987       ELSE
34988          STOP ' TESTROT: mode not supported!'
34989       ENDIF
34990       DO 1 J=1,3
34991         PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
34992     1 CONTINUE
34993
34994       RETURN
34995       END
34996
34997 *$ CREATE DT_LEPDCYP.FOR
34998 *COPY DT_LEPDCYP
34999 *
35000 *===lepdcyp============================================================*
35001 *
35002       SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
35003      &                      ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
35004 C
35005 C-----------------------------------------------------------------
35006 C
35007 C   Author   :- G. Battistoni         10-NOV-1995
35008 C
35009 C=================================================================
35010 C
35011 C   Purpose   : performs decay of polarized lepton in
35012 C               its rest frame: a => b + l + anti-nu
35013 C               (Example: mu- => nu-mu + e- + anti-nu-e)
35014 C               Polarization is assumed along Z-axis
35015 C               WARNING:
35016 C               1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
35017 C                  OF NEGLIGIBLE MASS
35018 C               2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
35019 C                  IN THIS VERSION
35020 C
35021 C   Method    : modifies phase space distribution obtained
35022 C               by routine EXPLOD using a rejection against the
35023 C               matrix element for unpolarized lepton decay
35024 C
35025 C   Inputs    : Mass of a :  AMA
35026 C               Mass of l :  AML
35027 C               Polar. of a: POL
35028 C               (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
35029 C                                                 POL = -1)
35030 C
35031 C   Outputs   : kinematic variables in the rest frame of decaying lepton
35032 C               ETL,PXL,PYL,PZL 4-moment of l
35033 C               ETB,PXB,PYB,PZB 4-moment of b
35034 C               ETN,PXN,PYN,PZN 4-moment of anti-nu
35035 C
35036 C============================================================
35037 C +
35038 C Declarations.
35039 C -
35040       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35041       SAVE
35042
35043       PARAMETER ( LINP = 10 ,
35044      &            LOUT = 6 ,
35045      &            LDAT = 9 )
35046
35047       PARAMETER ( KALGNM = 2 )
35048       PARAMETER ( ANGLGB = 5.0D-16 )
35049       PARAMETER ( ANGLSQ = 2.5D-31 )
35050       PARAMETER ( AXCSSV = 0.2D+16 )
35051       PARAMETER ( ANDRFL = 1.0D-38 )
35052       PARAMETER ( AVRFLW = 1.0D+38 )
35053       PARAMETER ( AINFNT = 1.0D+30 )
35054       PARAMETER ( AZRZRZ = 1.0D-30 )
35055       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
35056       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
35057       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
35058       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
35059       PARAMETER ( CSNNRM = 2.0D-15 )
35060       PARAMETER ( DMXTRN = 1.0D+08 )
35061       PARAMETER ( ZERZER = 0.D+00 )
35062       PARAMETER ( ONEONE = 1.D+00 )
35063       PARAMETER ( TWOTWO = 2.D+00 )
35064       PARAMETER ( THRTHR = 3.D+00 )
35065       PARAMETER ( FOUFOU = 4.D+00 )
35066       PARAMETER ( FIVFIV = 5.D+00 )
35067       PARAMETER ( SIXSIX = 6.D+00 )
35068       PARAMETER ( SEVSEV = 7.D+00 )
35069       PARAMETER ( EIGEIG = 8.D+00 )
35070       PARAMETER ( ANINEN = 9.D+00 )
35071       PARAMETER ( TENTEN = 10.D+00 )
35072       PARAMETER ( HLFHLF = 0.5D+00 )
35073       PARAMETER ( ONETHI = ONEONE / THRTHR )
35074       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
35075       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
35076       PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
35077       PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
35078       PARAMETER ( CLIGHT = 2.99792458         D+10 )
35079       PARAMETER ( AVOGAD = 6.0221367          D+23 )
35080       PARAMETER ( AMELGR = 9.1093897          D-28 )
35081       PARAMETER ( PLCKBR = 1.05457266         D-27 )
35082       PARAMETER ( ELCCGS = 4.8032068          D-10 )
35083       PARAMETER ( ELCMKS = 1.60217733         D-19 )
35084       PARAMETER ( AMUGRM = 1.6605402          D-24 )
35085       PARAMETER ( AMMUMU = 0.113428913        D+00 )
35086       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
35087       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
35088       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
35089       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
35090       PARAMETER ( PLABRC = 0.197327053        D+00 )
35091       PARAMETER ( AMELCT = 0.51099906         D-03 )
35092       PARAMETER ( AMUGEV = 0.93149432         D+00 )
35093       PARAMETER ( AMMUON = 0.105658389        D+00 )
35094       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
35095       PARAMETER ( GEVMEV = 1.0                D+03 )
35096       PARAMETER ( EMVGEV = 1.0                D-03 )
35097       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
35098       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
35099       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
35100 C +
35101 C    variables for EXPLOD
35102 C -
35103       PARAMETER ( KPMX = 10 )
35104       DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
35105      &          PZEXPL (KPMX), ETEXPL (KPMX)
35106 C +
35107 C      test variables
35108 C -
35109 **sr - removed (not needed)
35110 C     COMMON /GBATNU/ ELERAT,NTRY
35111 **
35112 C +
35113 C     Initializes test variables
35114 C -
35115       NTRY = 0
35116       ELERAT = 0.D+00
35117 C +
35118 C     Maximum value for matrix element
35119 C -
35120       ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
35121      &  SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
35122 C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
35123 C     Inputs for EXPLOD
35124 C part. no. 1 is l       (e- in mu- decay)
35125 C part. no. 2 is b       (nu-mu in mu- decay)
35126 C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
35127 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
35128       NPEXPL = 3
35129       ETOTEX = AMA
35130       AMEXPL(1) = AML
35131       AMEXPL(2) = 0.D+00
35132       AMEXPL(3) = 0.D+00
35133 C +
35134 C     phase space distribution
35135 C -
35136   100 CONTINUE
35137       NTRY = NTRY + 1
35138
35139       CALL EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
35140      &              PYEXPL, PZEXPL )
35141
35142 C +
35143 C  Calculates matrix element:
35144 C  64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
35145 C  Here CTH is the cosine of the angle between anti-nu and Z axis
35146 C -
35147       CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
35148      &  PZEXPL(3)**2 )
35149       PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
35150       PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
35151      &     PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
35152       ELEMAT = 16.D+00 * PROD1 * PROD2
35153       IF(ELEMAT.GT.ELEMAX) THEN
35154         WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
35155         STOP
35156       ENDIF
35157 C +
35158 C     Here performs the rejection
35159 C -
35160       TEST = DT_RNDM(ETOTEX) * ELEMAX
35161       IF ( TEST .GT. ELEMAT ) GO TO 100
35162 C +
35163 C     final assignment of variables
35164 C -
35165       ELERAT = ELEMAT/ELEMAX
35166       ETL = ETEXPL(1)
35167       PXL = PXEXPL(1)
35168       PYL = PYEXPL(1)
35169       PZL = PZEXPL(1)
35170       ETB = ETEXPL(2)
35171       PXB = PXEXPL(2)
35172       PYB = PYEXPL(2)
35173       PZB = PZEXPL(2)
35174       ETN = ETEXPL(3)
35175       PXN = PXEXPL(3)
35176       PYN = PYEXPL(3)
35177       PZN = PZEXPL(3)
35178   999 RETURN
35179       END
35180
35181 *$ CREATE DT_GEN_DELTA.FOR
35182 *COPY DT_GEN_DELTA
35183 C==================================================================
35184 C.  Generation of  Delta resonance events
35185 C==================================================================
35186 *
35187 *===gen_delta==========================================================*
35188 *
35189       SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
35190
35191       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35192       SAVE
35193
35194       PARAMETER ( LINP = 10 ,
35195      &            LOUT = 6 ,
35196      &            LDAT = 9 )
35197
35198 C...Generate a Delta-production neutrino/antineutrino
35199 C.  CC-interaction on a nucleon
35200 C
35201 C.  INPUT  ENU (GeV) = Neutrino Energy
35202 C.         LLEP = neutrino type
35203 C.         LTARG = nucleon target type 1=p, 2=n.
35204 C.         JINT = 1:CC, 2::NC
35205 C.
35206 C.  OUTPUT PPL(4)  4-monentum of final lepton
35207 C----------------------------------------------------
35208       PARAMETER (MAXLND=4000)
35209       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35210
35211 **sr - removed (not needed)
35212 C     COMMON /CBAD/  LBAD, NBAD
35213 **
35214
35215       DIMENSION PI(3),PO(3)
35216 C     REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
35217       DIMENSION AML0(6),AMN(2)
35218       DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
35219       DATA AMN  /0.93827231, 0.93956563/
35220       DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
35221
35222 c     WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
35223       LBAD = 0
35224 C...Final lepton mass
35225       IF (JINT.EQ.1) THEN
35226         AML = AML0(LLEP)
35227       ELSE
35228         AML = 0.
35229       ENDIF
35230       AML2 = AML**2
35231
35232 C...Particle labels (LUND)
35233       N = 5
35234       K(1,1) = 21
35235       K(2,1) = 21
35236       K(3,1) = 21
35237       K(4,1) = 1
35238       K(3,3) = 1
35239       K(4,3) = 1
35240       IF (LTARG .EQ. 1)  THEN
35241          K(2,2) = 2212
35242       ELSE
35243          K(2,2) = 2112
35244       ENDIF
35245       K0 = (LLEP-1)/2
35246       K1 = LLEP/2
35247       KA = 12 + 2*K0
35248       IS = -1 + 2*LLEP - 4*K1
35249       LNU = 2 - LLEP + 2*K1
35250       K(1,2) = IS*KA
35251       K(5,1) = 1
35252       K(5,3) = 2
35253       IF (JINT .EQ. 1)  THEN                    ! CC interactions
35254          K(3,2) = IS*24
35255          K(4,2) = IS*(KA-1)
35256         IF(LNU.EQ.1) THEN
35257           IF (LTARG .EQ. 1)  THEN
35258               K(5,2) = 2224
35259           ELSE
35260               K(5,2) = 2214
35261           ENDIF
35262         ELSE
35263           IF (LTARG .EQ. 1)  THEN
35264               K(5,2) = 2114
35265           ELSE
35266               K(5,2) = 1114
35267           ENDIF
35268         ENDIF
35269       ELSE
35270          K(3,2) = 23                           ! NC (Z0) interactions
35271          K(4,2) = K(1,2)
35272 **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
35273 *                                Delta0 for neutron (LTARG=2)
35274 C        IF (LTARG .EQ. 1)  THEN
35275 C           K(5,2) = 2114
35276 C        ELSE
35277 C           K(5,2) = 2214
35278 C        ENDIF
35279          IF (LTARG .EQ. 1)  THEN
35280             K(5,2) = 2214
35281          ELSE
35282             K(5,2) = 2114
35283          ENDIF
35284 **
35285       ENDIF
35286
35287 C...4-momentum initial lepton
35288       P(1,5) = 0.
35289       P(1,4) = ENU
35290       P(1,1) = 0.
35291       P(1,2) = 0.
35292       P(1,3) = ENU
35293 C...4-momentum initial nucleon
35294       P(2,5) = AMN(LTARG)
35295 C     P(2,4) = P(2,5)
35296 C     P(2,1) = 0.
35297 C     P(2,2) = 0.
35298 C     P(2,3) = 0.
35299        P(2,1) = P21
35300        P(2,2) = P22
35301        P(2,3) = P23
35302        P(2,4) = P24
35303        P(2,5) = P25
35304       N=2
35305       beta1=-p(2,1)/p(2,4)
35306       beta2=-p(2,2)/p(2,4)
35307       beta3=-p(2,3)/p(2,4)
35308       N=2
35309
35310       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35311
35312 C     print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35313
35314       phi11=atan(p(1,2)/p(1,3))
35315       pi(1)=p(1,1)
35316       pi(2)=p(1,2)
35317       pi(3)=p(1,3)
35318
35319       CALL DT_TESTROT(PI,Po,PHI11,1)
35320       DO ll=1,3
35321        IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35322       END DO
35323       p(1,1)=po(1)
35324       p(1,2)=po(2)
35325       p(1,3)=po(3)
35326       phi12=atan(p(1,1)/p(1,3))
35327
35328       pi(1)=p(1,1)
35329       pi(2)=p(1,2)
35330       pi(3)=p(1,3)
35331       CALL DT_TESTROT(Pi,Po,PHI12,2)
35332       DO ll=1,3
35333         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35334       END DO
35335       p(1,1)=po(1)
35336       p(1,2)=po(2)
35337       p(1,3)=po(3)
35338
35339       ENUU=P(1,4)
35340
35341 C...Generate the Mass of the Delta
35342       NTRY = 0
35343 100   R = PYR(0)
35344       AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
35345       NTRY = NTRY + 1
35346       IF (NTRY .GT. 1000)  THEN
35347          LBAD = 1
35348          WRITE (LOUT,1001)  NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
35349          RETURN
35350       ENDIF
35351       IF (AMD .LT. AMDMIN)  GOTO 100
35352       ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
35353       IF (ENUU .LT. ET) GOTO 100
35354
35355 C...Kinematical  limits in Q**2
35356       S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
35357       SQS = SQRT(S)
35358       PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
35359       ELF = (S - AMD**2 + AML2)/(2.*SQS)
35360       PLF = SQRT(ELF**2 - AML2)
35361       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
35362       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
35363       IF (Q2MIN .LT. 0.)   Q2MIN = 0.
35364
35365       DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
35366 200   Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35367       DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
35368       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
35369
35370 C...Generate the kinematics of the final particles
35371       EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
35372       GAM = EISTAR/AMN(LTARG)
35373       BET = PSTAR/EISTAR
35374       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
35375       EL  = GAM*(ELF + BET*PLF*CTSTAR)
35376       PLZ = GAM*(PLF*CTSTAR + BET*ELF)
35377       PL  = SQRT(EL**2 - AML2)
35378       PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
35379       PHI = 6.28319*PYR(0)
35380       P(4,1) = PLT*COS(PHI)
35381       P(4,2) = PLT*SIN(PHI)
35382       P(4,3) = PLZ
35383       P(4,4) = EL
35384       P(4,5) = AML
35385
35386 C...4-momentum of Delta
35387       P(5,1) = -P(4,1)
35388       P(5,2) = -P(4,2)
35389       P(5,3) = ENUU-P(4,3)
35390       P(5,4) = ENUU+AMN(LTARG)-P(4,4)
35391       P(5,5) = AMD
35392
35393 C...4-momentum  of intermediate boson
35394       P(3,5) = -Q2
35395       P(3,4) = P(1,4)-P(4,4)
35396       P(3,1) = P(1,1)-P(4,1)
35397       P(3,2) = P(1,2)-P(4,2)
35398       P(3,3) = P(1,3)-P(4,3)
35399       N=5
35400
35401       DO kw=1,5
35402         pi(1)=p(kw,1)
35403         pi(2)=p(kw,2)
35404         pi(3)=p(kw,3)
35405         CALL DT_TESTROT(Pi,Po,PHI12,3)
35406         DO ll=1,3
35407           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35408         END DO
35409         p(kw,1)=po(1)
35410         p(kw,2)=po(2)
35411         p(kw,3)=po(3)
35412       END DO
35413
35414 c********************************************
35415
35416         DO kw=1,5
35417           pi(1)=p(kw,1)
35418           pi(2)=p(kw,2)
35419           pi(3)=p(kw,3)
35420           CALL DT_TESTROT(Pi,Po,PHI11,4)
35421           DO ll=1,3
35422             IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35423           END DO
35424           p(kw,1)=po(1)
35425           p(kw,2)=po(2)
35426           p(kw,3)=po(3)
35427        END DO
35428 c********************************************
35429 C         transform back into Lab.
35430
35431       CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35432
35433 C     WRITE(6,*)' Lab fram ( fermi incl.) '
35434       N=5
35435       CALL PYEXEC
35436
35437       RETURN
35438 1001  FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5,  6G10.3)
35439       END
35440
35441 *$ CREATE DT_DSIGMA_DELTA.FOR
35442 *COPY DT_DSIGMA_DELTA
35443 *
35444 *===dsigma_delta=======================================================*
35445 *
35446       DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
35447
35448       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35449       SAVE
35450
35451 C...Reaction nu + N -> lepton + Delta
35452 C.  returns the  cross section
35453 C.  dsigma/dt
35454 C.  INPUT  LNU = 1, 2  (neutrino-antineutrino)
35455 C.         QQ = t (always negative)  GeV**2
35456 C.         S  = (c.m energy)**2      GeV**2
35457 C.  OUTPUT =  10**-38 cm+2/GeV**2
35458 C-----------------------------------------------------
35459       REAL*8 MN, MN2, MN4, MD,MD2, MD4
35460       DATA MN /0.938/
35461       DATA PI /3.1415926/
35462
35463       GF = (1.1664 * 1.97)
35464       GF2 = GF*GF
35465       MN2 = MN*MN
35466       MN4 = MN2*MN2
35467       MD2 = MD*MD
35468       MD4 = MD2*MD2
35469       AML2 = AML*AML
35470       AML4 = AML2*AML2
35471       VQ  = (MN2 - MD2 - QQ)/2.
35472       VPI = (MN2 + MD2 - QQ)/2.
35473       VK  = (S + QQ - MN2 - AML2)/2.
35474       PIK = (S - MN2)/2.
35475       QK = (AML2 - QQ)/2.
35476       PIQ = (QQ + MN2 - MD2)/2.
35477       Q = SQRT(-QQ)
35478       C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
35479       C3 = SQRT(3.)*C3V/MN
35480       C4 = -C3/MD             ! attenzione al segno
35481       C5A = 1.18/(1.-QQ/0.4225)**2
35482       C32 = C3**2
35483       C42 = C4**2
35484       C5A2 = C5A**2
35485
35486       IF (LNU .EQ. 1)  THEN
35487       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
35488      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
35489      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
35490      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
35491       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
35492      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
35493      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
35494      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
35495      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
35496      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
35497      . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
35498      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
35499      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
35500      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
35501      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
35502      . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
35503      . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
35504      . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
35505      . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
35506      . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
35507      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
35508      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
35509      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
35510       ELSE
35511       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
35512      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
35513      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
35514      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
35515       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
35516      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
35517      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
35518      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
35519      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
35520      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
35521      . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
35522      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
35523      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
35524      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
35525      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
35526      . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
35527      . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
35528      . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
35529      . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
35530      . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
35531      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
35532      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
35533      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
35534       ENDIF
35535       ANS1=32.*ANS2
35536       ANS=ANS1/(3.*MD2)
35537       P1CM = (S-MN2)/(2.*SQRT(S))
35538       DT_DSIGMA_DELTA  = GF2/2. * ANS/(64.*PI*S*P1CM**2)
35539
35540       RETURN
35541       END
35542
35543 *$ CREATE DT_QGAUS.FOR
35544 *COPY DT_QGAUS
35545 *
35546 *===qgaus==============================================================*
35547 *
35548       SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
35549
35550       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35551       SAVE
35552
35553       DIMENSION X(5),W(5)
35554       DATA X/.1488743389D0,.4333953941D0,
35555      & .6794095682D0,.8650633666D0,.9739065285D0
35556      */
35557       DATA W/.2955242247D0,.2692667193D0,
35558      & .2190863625D0,.1494513491D0,.0666713443D0
35559      */
35560       XM=0.5D0*(B+A)
35561       XR=0.5D0*(B-A)
35562       SS=0
35563       DO 11 J=1,5
35564         DX=XR*X(J)
35565         SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
35566      &  DT_DSQEL_Q2(LTYP,ENU,XM-DX))
35567 11    CONTINUE
35568       SS=XR*SS
35569
35570       RETURN
35571       END
35572 *$ CREATE DT_DIQBRK.FOR
35573 *COPY DT_DIQBRK
35574 *
35575 *===diqbrk=============================================================*
35576 *
35577       SUBROUTINE DT_DIQBRK
35578
35579       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35580       SAVE
35581
35582 * event history
35583
35584       PARAMETER (NMXHKK=200000)
35585
35586       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35587      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35588      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35589
35590 * extended event history
35591       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35592      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35593      &                IHIST(2,NMXHKK)
35594
35595 * event flag
35596       COMMON /DTEVNO/ NEVENT,ICASCA
35597
35598 C     IF(DT_RNDM(VV).LE.0.5D0)THEN
35599 C       CALL GSQBS1(NHKK)
35600 C       CALL GSQBS2(NHKK)
35601 C       CALL USQBS1(NHKK)
35602 C       CALL USQBS2(NHKK)
35603 C       CALL GSABS1(NHKK)
35604 C       CALL GSABS2(NHKK)
35605 C       CALL USABS1(NHKK)
35606 C       CALL USABS2(NHKK)
35607 C     ELSE
35608 C       CALL GSQBS2(NHKK)
35609 C       CALL GSQBS1(NHKK)
35610 C       CALL USQBS2(NHKK)
35611 C       CALL USQBS1(NHKK)
35612 C       CALL GSABS2(NHKK)
35613 C       CALL GSABS1(NHKK)
35614 C       CALL USABS2(NHKK)
35615 C       CALL USABS1(NHKK)
35616 C     ENDIF
35617
35618       IF(DT_RNDM(VV).LE.0.5D0) THEN
35619         CALL DT_DBREAK(1)
35620         CALL DT_DBREAK(2)
35621         CALL DT_DBREAK(3)
35622         CALL DT_DBREAK(4)
35623         CALL DT_DBREAK(5)
35624         CALL DT_DBREAK(6)
35625         CALL DT_DBREAK(7)
35626         CALL DT_DBREAK(8)
35627       ELSE
35628         CALL DT_DBREAK(2)
35629         CALL DT_DBREAK(1)
35630         CALL DT_DBREAK(4)
35631         CALL DT_DBREAK(3)
35632         CALL DT_DBREAK(6)
35633         CALL DT_DBREAK(5)
35634         CALL DT_DBREAK(8)
35635         CALL DT_DBREAK(7)
35636       ENDIF
35637
35638       RETURN
35639       END
35640
35641 *$ CREATE MUSQBS2.FOR
35642 *COPY MUSQBS2
35643 C
35644 C
35645 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
35646       SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35647      *              IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
35648 C
35649 C                  USQBS-2 diagram (split target diquark)
35650 C
35651       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35652       SAVE
35653
35654       PARAMETER ( LINP = 10 ,
35655      &            LOUT = 6 ,
35656      &            LDAT = 9 )
35657
35658 * event history
35659
35660       PARAMETER (NMXHKK=200000)
35661
35662       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35663      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35664      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35665
35666 * extended event history
35667       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35668      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35669      &                IHIST(2,NMXHKK)
35670
35671 * Lorentz-parameters of the current interaction
35672       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
35673      &                UMO,PPCM,EPROJ,PPROJ
35674
35675 * diquark-breaking mechanism
35676       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
35677
35678 C
35679       PARAMETER (NTMHKK= 300)
35680       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35681      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35682      +(4,NTMHKK)
35683 *KEEP,XSEADI.
35684       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
35685      +SSMIMQ,VVMTHR
35686 *KEEP,DPRIN.
35687       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
35688       COMMON /EVFLAG/ NUMEV
35689 C
35690 C                  USQBS-2 diagram (split target diquark)
35691 C
35692 C
35693 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
35694 C     Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
35695 C
35696 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
35697 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35698 C
35699 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35700 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35701 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35702 C
35703 C
35704 C       Put new chains into COMMON /HKKTMP/
35705 C
35706       IIGLU1=NC1T-NC1P-1
35707       IIGLU2=NC2T-NC2P-1
35708       IGCOUN=0
35709 C     WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
35710       CVQ=1.D0
35711       IREJ=0
35712       IF(IPIP.EQ.2)THEN
35713 C     IF(NUMEV.EQ.-324)THEN
35714 C     WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
35715 C    *             'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
35716 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35717 C    *              IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
35718       ENDIF
35719 C
35720 C
35721 C
35722 C     determine x-values of NC1T diquark
35723       XDIQT=PHKK(4,NC1T)*2.D0/UMO
35724       XVQP=PHKK(4,NC1P)*2.D0/UMO
35725 C
35726 C     determine x-values of sea quark pair
35727 C
35728       IPCO=1
35729       ICOU=0
35730  2234 CONTINUE
35731       ICOU=ICOU+1
35732       IF(ICOU.GE.500)THEN
35733         IREJ=1
35734         IF(ISQ.EQ.3)IREJ=3
35735         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
35736         IPCO=0
35737         RETURN
35738       ENDIF
35739       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
35740      * UMO, XDIQT,XVQP
35741       XSQ=0.D0
35742       XSAQ=0.D0
35743 **NEW
35744 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
35745       IF (IPIP.EQ.1) THEN
35746          XQMAX  = XDIQT/2.0D0
35747          XAQMAX = 2.D0*XVQP/3.0D0
35748       ELSE
35749          XQMAX  = 2.D0*XVQP/3.0D0
35750          XAQMAX = XDIQT/2.0D0
35751       ENDIF
35752       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
35753       ISAQ = 6+ISQ
35754 C     write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
35755 **
35756         IF(IPCO.GE.3)
35757      &     WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35758       IF(IREJ.GE.1)THEN
35759         IF(IPCO.GE.3)
35760      &     WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35761         IPCO=0
35762         RETURN
35763       ENDIF
35764       IF(IPIP.EQ.1)THEN
35765         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35766       ELSEIF(IPIP.EQ.2)THEN
35767         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35768       ENDIF
35769       IF(IPCO.GE.3)THEN
35770         WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
35771      &  XDIQT,XVQP,XSQ,XSAQ
35772       ENDIF
35773 C
35774 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
35775 C
35776 C     XSQ=0.D0
35777       IF(IPIP.EQ.1)THEN
35778         XDIQT=XDIQT-XSQ
35779         XVQP =XVQP -XSAQ
35780       ELSEIF(IPIP.EQ.2)THEN
35781         XDIQT=XDIQT-XSAQ
35782         XVQP =XVQP -XSQ
35783       ENDIF
35784       IF(IPCO.GE.3)
35785      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
35786 C
35787 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35788 C
35789       XVTHRO=CVQ/UMO
35790       IVTHR=0
35791  3466 CONTINUE
35792       IF(IVTHR.EQ.10)THEN
35793         IREJ=1
35794         IF(ISQ.EQ.3)IREJ=3
35795         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
35796       IPCO=0
35797         RETURN
35798       ENDIF
35799       IVTHR=IVTHR+1
35800       XVTHR=XVTHRO/(201-IVTHR)
35801       UNOPRV=UNON
35802  380  CONTINUE
35803       IF(XVTHR.GT.0.66D0*XDIQT)THEN
35804         IREJ=1
35805         IF(ISQ.EQ.3)IREJ=3
35806         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR  large',
35807      *  XVTHR
35808       IPCO=0
35809         RETURN
35810       ENDIF
35811       IF(DT_RNDM(V).LT.0.5D0)THEN
35812         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35813         XVTQII=XDIQT-XVTQI
35814       ELSE
35815         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35816         XVTQI=XDIQT-XVTQII
35817       ENDIF
35818       IF(IPCO.GE.3)THEN
35819         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
35820       ENDIF
35821 C
35822 C     Prepare 4 momenta of new chains and chain ends
35823 C
35824 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35825 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35826 C    +(4,NTMHKK)
35827 C
35828 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35829 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35830 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35831 C
35832 C     SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35833 C    *              IP1,IP21,IP22,IPP1,IPP2)
35834 C
35835       IF(IPIP.EQ.1)THEN
35836         XSQ1=XSQ
35837         XSAQ1=XSAQ
35838         ISQ1=ISQ
35839         ISAQ1=ISAQ
35840       ELSEIF(IPIP.EQ.2)THEN
35841         XSQ1=XSAQ
35842         XSAQ1=XSQ
35843         ISQ1=ISAQ
35844         ISAQ1=ISQ
35845       ENDIF
35846       IDHKT(1)   =IPP1
35847       ISTHKT(1)  =951
35848       JMOHKT(1,1)=NC2P
35849       JMOHKT(2,1)=0
35850       JDAHKT(1,1)=3+IIGLU1
35851       JDAHKT(2,1)=0
35852 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35853       PHKT(1,1)  =PHKK(1,NC2P)
35854       PHKT(2,1)  =PHKK(2,NC2P)
35855       PHKT(3,1)  =PHKK(3,NC2P)
35856       PHKT(4,1)  =PHKK(4,NC2P)
35857 C     PHKT(5,1)  =PHKK(5,NC2P)
35858       XMIST  =(PHKT(4,1)**2-
35859      * PHKT(3,1)**2-PHKT(2,1)**2-
35860      *PHKT(1,1)**2)
35861       IF(XMIST.GT.0.D0)THEN
35862       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35863      *PHKT(1,1)**2)
35864       ELSE
35865 C     WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
35866       PHKT(5,1)=0.D0
35867       ENDIF
35868       VHKT(1,1)  =VHKK(1,NC2P)
35869       VHKT(2,1)  =VHKK(2,NC2P)
35870       VHKT(3,1)  =VHKK(3,NC2P)
35871       VHKT(4,1)  =VHKK(4,NC2P)
35872       WHKT(1,1)  =WHKK(1,NC2P)
35873       WHKT(2,1)  =WHKK(2,NC2P)
35874       WHKT(3,1)  =WHKK(3,NC2P)
35875       WHKT(4,1)  =WHKK(4,NC2P)
35876 C     Add here IIGLU1 gluons to this chaina
35877       PG1=0.D0
35878       PG2=0.D0
35879       PG3=0.D0
35880       PG4=0.D0
35881       IF(IIGLU1.GE.1)THEN
35882       JJG=NC1P
35883       DO 61 IIG=2,2+IIGLU1-1
35884         KKG=JJG+IIG-1
35885         IDHKT(IIG)   =IDHKK(KKG)
35886         ISTHKT(IIG)  =921
35887         JMOHKT(1,IIG)=KKG
35888         JMOHKT(2,IIG)=0
35889         JDAHKT(1,IIG)=3+IIGLU1
35890         JDAHKT(2,IIG)=0
35891         PHKT(1,IIG)=PHKK(1,KKG)
35892         PG1=PG1+ PHKT(1,IIG)
35893         PHKT(2,IIG)=PHKK(2,KKG)
35894         PG2=PG2+ PHKT(2,IIG)
35895         PHKT(3,IIG)=PHKK(3,KKG)
35896         PG3=PG3+ PHKT(3,IIG)
35897         PHKT(4,IIG)=PHKK(4,KKG)
35898         PG4=PG4+ PHKT(4,IIG)
35899         PHKT(5,IIG)=PHKK(5,KKG)
35900         VHKT(1,IIG)  =VHKK(1,KKG)
35901         VHKT(2,IIG)  =VHKK(2,KKG)
35902         VHKT(3,IIG)  =VHKK(3,KKG)
35903         VHKT(4,IIG)  =VHKK(4,KKG)
35904         WHKT(1,IIG) =WHKK(1,KKG)
35905         WHKT(2,IIG) =WHKK(2,KKG)
35906         WHKT(3,IIG) =WHKK(3,KKG)
35907         WHKT(4,IIG) =WHKK(4,KKG)
35908    61 CONTINUE
35909       ENDIF
35910       IDHKT(2+IIGLU1)   =IP21
35911       ISTHKT(2+IIGLU1)  =952
35912       JMOHKT(1,2+IIGLU1)=NC1T
35913       JMOHKT(2,2+IIGLU1)=0
35914       JDAHKT(1,2+IIGLU1)=3+IIGLU1
35915       JDAHKT(2,2+IIGLU1)=0
35916       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
35917       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
35918       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
35919       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
35920 C     PHKT(5,2)  =PHKK(5,NC1T)
35921       XMIST  =(PHKT(4,2+IIGLU1)**2-
35922      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35923      *PHKT(1,2+IIGLU1)**2)
35924       IF(XMIST.GT.0.D0)THEN
35925       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
35926      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35927      *PHKT(1,2+IIGLU1)**2)
35928       ELSE
35929 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35930         PHKT(5,5+IIGLU1)=0.D0
35931       ENDIF
35932       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
35933       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
35934       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
35935       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
35936       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
35937       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
35938       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
35939       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
35940       IDHKT(3+IIGLU1)   =88888
35941       ISTHKT(3+IIGLU1)  =95
35942       JMOHKT(1,3+IIGLU1)=1
35943       JMOHKT(2,3+IIGLU1)=2+IIGLU1
35944       JDAHKT(1,3+IIGLU1)=0
35945       JDAHKT(2,3+IIGLU1)=0
35946       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
35947       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
35948       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
35949       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
35950       XMIST
35951      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35952      *            -PHKT(3,3+IIGLU1)**2)
35953       IF(XMIST.GT.0.D0)THEN
35954       PHKT(5,3+IIGLU1)
35955      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35956      *            -PHKT(3,3+IIGLU1)**2)
35957       ELSE
35958 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35959         PHKT(5,5+IIGLU1)=0.D0
35960       ENDIF
35961       IF(IPIP.GE.2)THEN
35962 C     IF(NUMEV.EQ.-324)THEN
35963 C     WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
35964 C    * JDAHKT(1,1),
35965 C    *JDAHKT(2,1),(PHKT(III,1),III=1,5)
35966       DO 71 IIG=2,2+IIGLU1-1
35967 C     WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35968 C    &             JMOHKT(1,IIG),JMOHKT(2,IIG),
35969 C    * JDAHKT(1,IIG),
35970 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35971    71 CONTINUE
35972 C     WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
35973 C    * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
35974 C    *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
35975 C     WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
35976 C    * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
35977 C    *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
35978       ENDIF
35979       CHAMAL=CHAM1
35980       IF(IPIP.EQ.1)THEN
35981         IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
35982       ELSEIF(IPIP.EQ.2)THEN
35983         IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
35984       ENDIF
35985       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
35986 C       IREJ=1
35987         IPCO=0
35988 C       RETURN
35989 C       WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
35990         GO TO 3466
35991       ENDIF
35992       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
35993       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
35994       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
35995       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
35996       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
35997       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
35998       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
35999       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
36000       IF(IPIP.EQ.1)THEN
36001         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
36002       ELSEIF(IPIP.EQ.2)THEN
36003         IDHKT(4+IIGLU1)   =ISAQ1
36004       ENDIF
36005       ISTHKT(4+IIGLU1)  =951
36006       JMOHKT(1,4+IIGLU1)=NC1P
36007       JMOHKT(2,4+IIGLU1)=0
36008       JDAHKT(1,4+IIGLU1)=6+IIGLU1
36009       JDAHKT(2,4+IIGLU1)=0
36010 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36011       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
36012       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
36013       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
36014       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
36015 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
36016       XMIST  =(PHKT(4,4+IIGLU1)**2-
36017      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36018      *PHKT(1,4+IIGLU1)**2)
36019       IF(XMIST.GT.0.D0)THEN
36020       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
36021      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36022      *PHKT(1,4+IIGLU1)**2)
36023       ELSE
36024 C     WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
36025       PHKT(5,4+IIGLU1)=0.D0
36026       ENDIF
36027       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
36028       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
36029       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
36030       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
36031       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
36032       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
36033       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
36034       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
36035       IDHKT(5+IIGLU1)   =IP22
36036       ISTHKT(5+IIGLU1)  =952
36037       JMOHKT(1,5+IIGLU1)=NC1T
36038       JMOHKT(2,5+IIGLU1)=0
36039       JDAHKT(1,5+IIGLU1)=6+IIGLU1
36040       JDAHKT(2,5+IIGLU1)=0
36041       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36042       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36043       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36044       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36045 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
36046       XMIST  =(PHKT(4,5+IIGLU1)**2-
36047      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36048      *PHKT(1,5+IIGLU1)**2)
36049       IF(XMIST.GT.0.D0)THEN
36050       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
36051      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36052      *PHKT(1,5+IIGLU1)**2)
36053       ELSE
36054 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36055         PHKT(5,5+IIGLU1)=0.D0
36056       ENDIF
36057       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
36058       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
36059       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
36060       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
36061       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
36062       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
36063       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
36064       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
36065       IDHKT(6+IIGLU1)   =88888
36066       ISTHKT(6+IIGLU1)  =95
36067       JMOHKT(1,6+IIGLU1)=4+IIGLU1
36068       JMOHKT(2,6+IIGLU1)=5+IIGLU1
36069       JDAHKT(1,6+IIGLU1)=0
36070       JDAHKT(2,6+IIGLU1)=0
36071       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36072       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36073       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36074       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36075       XMIST
36076      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36077      *            -PHKT(3,6+IIGLU1)**2)
36078       IF(XMIST.GT.0.D0)THEN
36079       PHKT(5,6+IIGLU1)
36080      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36081      *            -PHKT(3,6+IIGLU1)**2)
36082       ELSE
36083 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36084         PHKT(5,5+IIGLU1)=0.D0
36085       ENDIF
36086 C     IF(IPIP.GE.2)THEN
36087 C     IF(NUMEV.EQ.-324)THEN
36088 C     WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36089 C    * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36090 C    *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36091 C     WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36092 C    * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36093 C    *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36094 C     WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36095 C    * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36096 C    *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36097 C     ENDIF
36098       CHAMAL=CHAM1
36099       IF(IPIP.EQ.1)THEN
36100         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36101       ELSEIF(IPIP.EQ.2)THEN
36102         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36103       ENDIF
36104       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36105 C       IREJ=1
36106         IPCO=0
36107 C       RETURN
36108 C       WRITE(6,*)' MUSQBS1 jump back from chain 6',
36109 C    *  CHAMAL,PHKT(5,6+IIGLU1)
36110         GO TO 3466
36111       ENDIF
36112       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
36113       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
36114       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
36115       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
36116       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
36117       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
36118       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
36119       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
36120 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
36121       IDHKT(7+IIGLU1)   =IP1
36122       ISTHKT(7+IIGLU1)  =951
36123       JMOHKT(1,7+IIGLU1)=NC1P
36124       JMOHKT(2,7+IIGLU1)=0
36125 **NEW
36126 C     JDAHKT(1,7+IIGLU1)=9+IIGLU1
36127       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36128 **
36129       JDAHKT(2,7+IIGLU1)=0
36130       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36131       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36132       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36133       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36134 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
36135       XMIST  =(PHKT(4,7+IIGLU1)**2-
36136      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36137      *PHKT(1,7+IIGLU1)**2)
36138       IF(XMIST.GT.0.D0)THEN
36139       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
36140      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36141      *PHKT(1,7+IIGLU1)**2)
36142       ELSE
36143 C     WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
36144       PHKT(5,7+IIGLU1)=0.D0
36145       ENDIF
36146       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
36147       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
36148       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
36149       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
36150       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
36151       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
36152       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
36153       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
36154 C     Insert here the IIGLU2 gluons
36155       PG1=0.D0
36156       PG2=0.D0
36157       PG3=0.D0
36158       PG4=0.D0
36159       IF(IIGLU2.GE.1)THEN
36160       JJG=NC2P
36161       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36162         KKG=JJG+IIG-7-IIGLU1
36163         IDHKT(IIG)   =IDHKK(KKG)
36164         ISTHKT(IIG)  =921
36165         JMOHKT(1,IIG)=KKG
36166         JMOHKT(2,IIG)=0
36167         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36168         JDAHKT(2,IIG)=0
36169         PHKT(1,IIG)=PHKK(1,KKG)
36170         PG1=PG1+ PHKT(1,IIG)
36171         PHKT(2,IIG)=PHKK(2,KKG)
36172         PG2=PG2+ PHKT(2,IIG)
36173         PHKT(3,IIG)=PHKK(3,KKG)
36174         PG3=PG3+ PHKT(3,IIG)
36175         PHKT(4,IIG)=PHKK(4,KKG)
36176         PG4=PG4+ PHKT(4,IIG)
36177         PHKT(5,IIG)=PHKK(5,KKG)
36178         VHKT(1,IIG)  =VHKK(1,KKG)
36179         VHKT(2,IIG)  =VHKK(2,KKG)
36180         VHKT(3,IIG)  =VHKK(3,KKG)
36181         VHKT(4,IIG)  =VHKK(4,KKG)
36182         WHKT(1,IIG)  =WHKK(1,KKG)
36183         WHKT(2,IIG) =WHKK(2,KKG)
36184         WHKT(3,IIG) =WHKK(3,KKG)
36185         WHKT(4,IIG) =WHKK(4,KKG)
36186    81 CONTINUE
36187       ENDIF
36188       IF(IPIP.EQ.1)THEN
36189         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
36190         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
36191         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
36192         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
36193       ELSEIF(IPIP.EQ.2)THEN
36194         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
36195         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
36196         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
36197         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
36198       ENDIF
36199       ISTHKT(8+IIGLU1+IIGLU2)  =952
36200       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36201       JMOHKT(2,8+IIGLU1+IIGLU2)=0
36202       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36203       JDAHKT(2,8+IIGLU1+IIGLU2)=0
36204       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC2T)+
36205      * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36206       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC2T)+
36207      * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36208       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC2T)+
36209      * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36210       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC2T)+
36211      * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36212 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36213 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36214       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36215 C       IREJ=1
36216 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36217 C    *  ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
36218         IPCO=0
36219 C       RETURN
36220         GO TO 3466
36221       ENDIF
36222 C     PHKT(5,8)  =PHKK(5,NC2T)
36223       XMIST  =(PHKT(4,8+IIGLU1+IIGLU2)**2-
36224      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36225      *PHKT(1,8+IIGLU1+IIGLU2)**2)
36226       IF(XMIST.GT.0.D0)THEN
36227       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36228      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36229      *PHKT(1,8+IIGLU1+IIGLU2)**2)
36230       ELSE
36231 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36232         PHKT(5,5+IIGLU1)=0.D0
36233       ENDIF
36234       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
36235       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
36236       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
36237       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
36238       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
36239       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
36240       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
36241       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
36242       IDHKT(9+IIGLU1+IIGLU2)   =88888
36243       ISTHKT(9+IIGLU1+IIGLU2)  =95
36244       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36245       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36246       JDAHKT(1,9+IIGLU1+IIGLU2)=0
36247       JDAHKT(2,9+IIGLU1+IIGLU2)=0
36248 **NEW
36249 C     PHKT(1,9+IIGLU1+IIGLU2)
36250 C    * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36251 C     PHKT(2,9+IIGLU1+IIGLU2)
36252 C    * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36253 C     PHKT(3,9+IIGLU1+IIGLU2)
36254 C    * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36255 C     PHKT(4,9+IIGLU1+IIGLU2)
36256 C    * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36257       PHKT(1,9+IIGLU1+IIGLU2)
36258      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36259       PHKT(2,9+IIGLU1+IIGLU2)
36260      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36261       PHKT(3,9+IIGLU1+IIGLU2)
36262      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36263       PHKT(4,9+IIGLU1+IIGLU2)
36264      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36265 **
36266       XMIST
36267      * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
36268      * -PHKT(2,9+IIGLU1+IIGLU2)**2
36269      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
36270       IF(XMIST.GT.0.D0)THEN
36271       PHKT(5,9+IIGLU1+IIGLU2)
36272      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
36273      * -PHKT(2,9+IIGLU1+IIGLU2)**2
36274      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
36275       ELSE
36276 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36277         PHKT(5,5+IIGLU1)=0.D0
36278       ENDIF
36279       IF(IPIP.GE.2)THEN
36280 C     IF(NUMEV.EQ.-324)THEN
36281 C     WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36282 C    * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36283 C    *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36284 C     DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36285 C     WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
36286 C    * JDAHKT(1,IIG),
36287 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36288 C  91 CONTINUE
36289 C     WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36290 C    * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36291 C    *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36292 C    *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36293 C     WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36294 C    * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36295 C    *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
36296 C    *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36297       ENDIF
36298       CHAMAL=CHAB1
36299       IF(IPIP.EQ.1)THEN
36300         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
36301       ELSEIF(IPIP.EQ.2)THEN
36302         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
36303       ENDIF
36304       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
36305 C       IREJ=1
36306         IPCO=0
36307 C       RETURN
36308 C       WRITE(6,*)' MUSQBS1 jump back from chain 9',
36309 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
36310         GO TO 3466
36311       ENDIF
36312       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
36313       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
36314       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
36315       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
36316       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
36317       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
36318       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
36319       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
36320 C
36321       IPCO=0
36322       IGCOUN=9+IIGLU1+IIGLU2
36323        RETURN
36324        END
36325
36326 *$ CREATE MGSQBS2.FOR
36327 *COPY MGSQBS2
36328 C
36329 C
36330 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36331       SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36332      *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
36333 C
36334 C                  GSQBS-2 diagram (split target diquark)
36335 C
36336       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36337       SAVE
36338
36339       PARAMETER ( LINP = 10 ,
36340      &            LOUT = 6 ,
36341      &            LDAT = 9 )
36342
36343 * event history
36344
36345       PARAMETER (NMXHKK=200000)
36346
36347       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36348      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36349      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36350
36351 * extended event history
36352       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36353      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36354      &                IHIST(2,NMXHKK)
36355
36356 * Lorentz-parameters of the current interaction
36357       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
36358      &                UMO,PPCM,EPROJ,PPROJ
36359
36360 * diquark-breaking mechanism
36361       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36362
36363 C
36364       PARAMETER (NTMHKK= 300)
36365       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36366      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36367      +(4,NTMHKK)
36368
36369 *KEEP,XSEADI.
36370       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
36371      +SSMIMQ,VVMTHR
36372 *KEEP,DPRIN.
36373       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
36374 C
36375 C                  GSQBS-2 diagram (split target diquark)
36376 C
36377 C
36378 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
36379 C     Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
36380 C
36381 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
36382 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36383 C
36384 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36385 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36386 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36387 C
36388 C
36389 C
36390 C       Put new chains into COMMON /HKKTMP/
36391 C
36392       IIGLU1=NC1T-NC1P-1
36393       IIGLU2=NC2T-NC2P-1
36394       IGCOUN=0
36395 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
36396       CVQ=1.D0
36397       IREJ=0
36398 C     IF(IPIP.EQ.2)THEN
36399 C     WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
36400 C    *             'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
36401 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36402 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
36403 C     ENDIF
36404 C
36405 C
36406 C
36407 C     determine x-values of NC1T diquark
36408       XDIQT=PHKK(4,NC1T)*2.D0/UMO
36409       XVQP=PHKK(4,NC1P)*2.D0/UMO
36410 C
36411 C     determine x-values of sea quark pair
36412 C
36413       IPCO=1
36414       ICOU=0
36415  2234 CONTINUE
36416       ICOU=ICOU+1
36417       IF(ICOU.GE.500)THEN
36418         IREJ=1
36419         IF(ISQ.EQ.3)IREJ=3
36420         IF(IPCO.GE.3)
36421      &     WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
36422         IPCO=0
36423         RETURN
36424       ENDIF
36425       IF(IPCO.GE.3)
36426      &     WRITE(LOUT,*)'MGSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
36427      * UMO, XDIQT,XVQP
36428       XSQ=0.D0
36429       XSAQ=0.D0
36430 **NEW
36431 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
36432       IF (IPIP.EQ.1) THEN
36433          XQMAX  = XDIQT/2.0D0
36434          XAQMAX = 2.D0*XVQP/3.0D0
36435       ELSE
36436          XQMAX  = 2.D0*XVQP/3.0D0
36437          XAQMAX = XDIQT/2.0D0
36438       ENDIF
36439       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
36440       ISAQ = 6+ISQ
36441 C     write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
36442 **
36443         IF(IPCO.GE.3)
36444      &     WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36445       IF(IREJ.GE.1)THEN
36446         IF(IPCO.GE.3)
36447      &     WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36448         IPCO=0
36449         RETURN
36450       ENDIF
36451       IF(IPIP.EQ.1)THEN
36452         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36453       ELSEIF(IPIP.EQ.2)THEN
36454         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36455       ENDIF
36456       IF(IPCO.GE.3)THEN
36457         WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
36458      &  XDIQT,XVQP,XSQ,XSAQ
36459       ENDIF
36460 C
36461 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
36462 C
36463 C     XSQ=0.D0
36464       IF(IPIP.EQ.1)THEN
36465         XDIQT=XDIQT-XSQ
36466         XVQP =XVQP -XSAQ
36467       ELSEIF(IPIP.EQ.2)THEN
36468         XDIQT=XDIQT-XSAQ
36469         XVQP =XVQP -XSQ
36470       ENDIF
36471       IF(IPCO.GE.3)
36472      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
36473 C
36474 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36475 C
36476       XVTHRO=CVQ/UMO
36477       IVTHR=0
36478  3466 CONTINUE
36479       IF(IVTHR.EQ.10)THEN
36480         IREJ=1
36481         IF(ISQ.EQ.3)IREJ=3
36482         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
36483         IPCO=0
36484         RETURN
36485       ENDIF
36486       IVTHR=IVTHR+1
36487       XVTHR=XVTHRO/(201-IVTHR)
36488       UNOPRV=UNON
36489  380  CONTINUE
36490       IF(XVTHR.GT.0.66D0*XDIQT)THEN
36491         IREJ=1
36492         IF(ISQ.EQ.3)IREJ=3
36493         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR  large',
36494      *  XVTHR
36495         IPCO=0
36496         RETURN
36497       ENDIF
36498       IF(DT_RNDM(V).LT.0.5D0)THEN
36499         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36500         XVTQII=XDIQT-XVTQI
36501       ELSE
36502         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36503         XVTQI=XDIQT-XVTQII
36504       ENDIF
36505       IF(IPCO.GE.3)THEN
36506         WRITE(LOUT,'(A,2E12.4)')'  MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
36507       ENDIF
36508 C
36509 C     Prepare 4 momenta of new chains and chain ends
36510 C
36511 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36512 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36513 C    +(4,NTMHKK)
36514 C
36515 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36516 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36517 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36518 C
36519 C     SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36520 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
36521 C
36522       IF(IPIP.EQ.1)THEN
36523         XSQ1=XSQ
36524         XSAQ1=XSAQ
36525         ISQ1=ISQ
36526         ISAQ1=ISAQ
36527       ELSEIF(IPIP.EQ.2)THEN
36528         XSQ1=XSAQ
36529         XSAQ1=XSQ
36530         ISQ1=ISAQ
36531         ISAQ1=ISQ
36532       ENDIF
36533       KK11=IP21
36534 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
36535       KK21=IPP11
36536       KK22=IPP12
36537       XGIVE=0.D0
36538       IF(IPIP.EQ.1)THEN
36539         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
36540       ELSEIF(IPIP.EQ.2)THEN
36541         IDHKT(4+IIGLU1)   =ISAQ1
36542       ENDIF
36543       ISTHKT(4+IIGLU1)  =961
36544       JMOHKT(1,4+IIGLU1)=NC1P
36545       JMOHKT(2,4+IIGLU1)=0
36546       JDAHKT(1,4+IIGLU1)=6+IIGLU1
36547       JDAHKT(2,4+IIGLU1)=0
36548 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36549       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
36550       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
36551       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
36552       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
36553 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
36554       XXMIST=(PHKT(4,4+IIGLU1)**2-
36555      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36556      *PHKT(1,4+IIGLU1)**2)
36557       IF(XXMIST.GT.0.D0)THEN
36558         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
36559       ELSE
36560         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36561         XXMIST=ABS(XXMIST)
36562         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
36563       ENDIF
36564       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
36565       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
36566       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
36567       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
36568       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
36569       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
36570       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
36571       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
36572       IDHKT(5+IIGLU1)   =IP22
36573       ISTHKT(5+IIGLU1)  =962
36574       JMOHKT(1,5+IIGLU1)=NC1T
36575       JMOHKT(2,5+IIGLU1)=0
36576       JDAHKT(1,5+IIGLU1)=6+IIGLU1
36577       JDAHKT(2,5+IIGLU1)=0
36578       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36579       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36580       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36581       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36582 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
36583       XXMIST=(PHKT(4,5+IIGLU1)**2-
36584      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36585      *PHKT(1,5+IIGLU1)**2)
36586       IF(XXMIST.GT.0.D0)THEN
36587         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
36588       ELSE
36589         WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
36590         XXMIST=ABS(XXMIST)
36591         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
36592       ENDIF
36593       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
36594       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
36595       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
36596       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
36597       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
36598       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
36599       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
36600       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
36601       IDHKT(6+IIGLU1)   =88888
36602       ISTHKT(6+IIGLU1)  =96
36603       JMOHKT(1,6+IIGLU1)=4+IIGLU1
36604       JMOHKT(2,6+IIGLU1)=5+IIGLU1
36605       JDAHKT(1,6+IIGLU1)=0
36606       JDAHKT(2,6+IIGLU1)=0
36607       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36608       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36609       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36610       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36611       PHKT(5,6+IIGLU1)
36612      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36613      *            -PHKT(3,6+IIGLU1)**2)
36614       CHAMAL=CHAM1
36615       IF(IPIP.EQ.1)THEN
36616         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36617       ELSEIF(IPIP.EQ.2)THEN
36618         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36619       ENDIF
36620 C---------------------------------------------------
36621       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36622         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
36623 C                    we drop chain 6 and give the energy to chain 3
36624           IDHKT(6+IIGLU1)=22888
36625           XGIVE=1.D0
36626 C         WRITE(6,*)' drop chain 6 xgive=1'
36627           GO TO 7788
36628         ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
36629 C                    we drop chain 6 and give the energy to chain 3
36630 C                    and change KK11 to IDHKT(5)
36631           IDHKT(6+IIGLU1)=22888
36632           XGIVE=1.D0
36633 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
36634           KK11=IDHKT(5+IIGLU1)
36635           GO TO 7788
36636         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
36637 C                    we drop chain 6 and give the energy to chain 3
36638 C                    and change KK21 to IDHKT(5+IIGLU1)
36639 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
36640           IDHKT(6+IIGLU1)=22888
36641           XGIVE=1.D0
36642 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
36643           KK21=IDHKT(5+IIGLU1)
36644           GO TO 7788
36645         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
36646 C                    we drop chain 6 and give the energy to chain 3
36647 C                    and change KK22 to IDHKT(5)
36648 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
36649           IDHKT(6+IIGLU1)=22888
36650           XGIVE=1.D0
36651 C          WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
36652           KK22=IDHKT(5+IIGLU1)
36653           GO TO 7788
36654         ENDIF
36655 C       IREJ=1
36656         IPCO=0
36657 C       RETURN
36658         GO TO 3466
36659       ENDIF
36660  7788 CONTINUE
36661 C---------------------------------------------------
36662       IF(IPIP.GE.3)THEN
36663       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36664      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36665      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36666       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36667      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36668      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36669       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36670      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36671      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36672       ENDIF
36673       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
36674       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
36675       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
36676       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
36677       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
36678       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
36679       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
36680       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
36681 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
36682       IF(IPIP.EQ.1)THEN
36683         IDHKT(1)   =1000*KK21+100*KK22+3
36684         IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
36685         IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
36686         IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
36687       ELSEIF(IPIP.EQ.2)THEN
36688         IDHKT(1)   =1000*KK21+100*KK22-3
36689         IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
36690         IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
36691         IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
36692       ENDIF
36693       ISTHKT(1)  =961
36694       JMOHKT(1,1)=NC2P
36695       JMOHKT(2,1)=0
36696       JDAHKT(1,1)=3+IIGLU1
36697       JDAHKT(2,1)=0
36698 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36699       PHKT(1,1)  =PHKK(1,NC2P)
36700      *+XGIVE*PHKT(1,4+IIGLU1)
36701       PHKT(2,1)  =PHKK(2,NC2P)
36702      *+XGIVE*PHKT(2,4+IIGLU1)
36703       PHKT(3,1)  =PHKK(3,NC2P)
36704      *+XGIVE*PHKT(3,4+IIGLU1)
36705       PHKT(4,1)  =PHKK(4,NC2P)
36706      *+XGIVE*PHKT(4,4+IIGLU1)
36707 C     PHKT(5,1)  =PHKK(5,NC2P)
36708       XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
36709      *PHKT(1,1)**2
36710       IF(XXMIST.GT.0.D0)THEN
36711         PHKT(5,1)  =SQRT(XXMIST)
36712       ELSE
36713         WRITE(LOUT,*)'MGSQBS2',XXMIST
36714         XXMIST=ABS(XXMIST)
36715         PHKT(5,1)  =SQRT(XXMIST)
36716       ENDIF
36717       VHKT(1,1)  =VHKK(1,NC2P)
36718       VHKT(2,1)  =VHKK(2,NC2P)
36719       VHKT(3,1)  =VHKK(3,NC2P)
36720       VHKT(4,1)  =VHKK(4,NC2P)
36721       WHKT(1,1)  =WHKK(1,NC2P)
36722       WHKT(2,1)  =WHKK(2,NC2P)
36723       WHKT(3,1)  =WHKK(3,NC2P)
36724       WHKT(4,1)  =WHKK(4,NC2P)
36725 C     Add here IIGLU1 gluons to this chaina
36726       PG1=0.D0
36727       PG2=0.D0
36728       PG3=0.D0
36729       PG4=0.D0
36730       IF(IIGLU1.GE.1)THEN
36731       JJG=NC1P
36732       DO 61 IIG=2,2+IIGLU1-1
36733         KKG=JJG+IIG-1
36734         IDHKT(IIG)   =IDHKK(KKG)
36735         ISTHKT(IIG)  =921
36736         JMOHKT(1,IIG)=KKG
36737         JMOHKT(2,IIG)=0
36738         JDAHKT(1,IIG)=3+IIGLU1
36739         JDAHKT(2,IIG)=0
36740         PHKT(1,IIG)=PHKK(1,KKG)
36741         PG1=PG1+ PHKT(1,IIG)
36742         PHKT(2,IIG)=PHKK(2,KKG)
36743         PG2=PG2+ PHKT(2,IIG)
36744         PHKT(3,IIG)=PHKK(3,KKG)
36745         PG3=PG3+ PHKT(3,IIG)
36746         PHKT(4,IIG)=PHKK(4,KKG)
36747         PG4=PG4+ PHKT(4,IIG)
36748         PHKT(5,IIG)=PHKK(5,KKG)
36749         VHKT(1,IIG)  =VHKK(1,KKG)
36750         VHKT(2,IIG)  =VHKK(2,KKG)
36751         VHKT(3,IIG)  =VHKK(3,KKG)
36752         VHKT(4,IIG)  =VHKK(4,KKG)
36753         WHKT(1,IIG)  =WHKK(1,KKG)
36754         WHKT(2,IIG)  =WHKK(2,KKG)
36755         WHKT(3,IIG)  =WHKK(3,KKG)
36756         WHKT(4,IIG)  =WHKK(4,KKG)
36757    61 CONTINUE
36758       ENDIF
36759 C     IDHKT(2)   =IP21
36760       IDHKT(2+IIGLU1)   =KK11
36761       ISTHKT(2+IIGLU1)  =962
36762       JMOHKT(1,2+IIGLU1)=NC1T
36763       JMOHKT(2,2+IIGLU1)=0
36764       JDAHKT(1,2+IIGLU1)=3+IIGLU1
36765       JDAHKT(2,2+IIGLU1)=0
36766       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
36767 C    * +0.5D0*PHKK(1,NC2T)
36768      *+XGIVE*PHKT(1,5+IIGLU1)
36769       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
36770 C    *+0.5D0*PHKK(2,NC2T)
36771      *+XGIVE*PHKT(2,5+IIGLU1)
36772       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
36773 C    *+0.5D0*PHKK(3,NC2T)
36774      *+XGIVE*PHKT(3,5+IIGLU1)
36775       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
36776 C    *+0.5D0*PHKK(4,NC2T)
36777      *+XGIVE*PHKT(4,5+IIGLU1)
36778 C     PHKT(5,2)  =PHKK(5,NC1T)
36779       XXMIST=(PHKT(4,2+IIGLU1)**2-
36780      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
36781      *PHKT(1,2+IIGLU1)**2)
36782       IF(XXMIST.GT.0.D0)THEN
36783         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
36784       ELSE
36785         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36786         XXMIST=ABS(XXMIST)
36787         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
36788       ENDIF
36789       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
36790       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
36791       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
36792       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
36793       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
36794       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
36795       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
36796       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
36797       IDHKT(3+IIGLU1)   =88888
36798       ISTHKT(3+IIGLU1)  =96
36799       JMOHKT(1,3+IIGLU1)=1
36800       JMOHKT(2,3+IIGLU1)=2+IIGLU1
36801       JDAHKT(1,3+IIGLU1)=0
36802       JDAHKT(2,3+IIGLU1)=0
36803       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
36804       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
36805       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
36806       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
36807       PHKT(5,3+IIGLU1)
36808      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
36809      *            -PHKT(3,3+IIGLU1)**2)
36810       IF(IPIP.EQ.3)THEN
36811       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
36812      * JDAHKT(1,1),
36813      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
36814       DO 71 IIG=2,2+IIGLU1-1
36815       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36816      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
36817      * JDAHKT(1,IIG),
36818      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36819    71 CONTINUE
36820       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
36821      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
36822      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
36823       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
36824      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
36825      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
36826       ENDIF
36827       CHAMAL=CHAB1
36828       IF(IPIP.EQ.1)THEN
36829         IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
36830       ELSEIF(IPIP.EQ.2)THEN
36831         IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
36832       ENDIF
36833       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
36834 C       IREJ=1
36835         IPCO=0
36836 C       RETURN
36837         GO TO 3466
36838       ENDIF
36839       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
36840       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
36841       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
36842       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
36843       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
36844       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
36845       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
36846       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
36847 C     IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+1
36848       IDHKT(7+IIGLU1)   =IP1
36849       ISTHKT(7+IIGLU1)  =961
36850       JMOHKT(1,7+IIGLU1)=NC1P
36851       JMOHKT(2,7+IIGLU1)=0
36852       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36853       JDAHKT(2,7+IIGLU1)=0
36854       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36855       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36856       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36857       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36858 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
36859       XXMIST=(PHKT(4,7+IIGLU1)**2-
36860      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36861      *PHKT(1,7+IIGLU1)**2)
36862       IF(XXMIST.GT.0.D0)THEN
36863         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
36864       ELSE
36865         WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
36866         XXMIST=ABS(XXMIST)
36867         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
36868       ENDIF
36869       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
36870       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
36871       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
36872       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
36873       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
36874       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
36875       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
36876       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
36877 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
36878 C     Insert here the IIGLU2 gluons
36879       PG1=0.D0
36880       PG2=0.D0
36881       PG3=0.D0
36882       PG4=0.D0
36883       IF(IIGLU2.GE.1)THEN
36884       JJG=NC2P
36885       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36886         KKG=JJG+IIG-7-IIGLU1
36887         IDHKT(IIG)   =IDHKK(KKG)
36888         ISTHKT(IIG)  =921
36889         JMOHKT(1,IIG)=KKG
36890         JMOHKT(2,IIG)=0
36891         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36892         JDAHKT(2,IIG)=0
36893         PHKT(1,IIG)=PHKK(1,KKG)
36894         PG1=PG1+ PHKT(1,IIG)
36895         PHKT(2,IIG)=PHKK(2,KKG)
36896         PG2=PG2+ PHKT(2,IIG)
36897         PHKT(3,IIG)=PHKK(3,KKG)
36898         PG3=PG3+ PHKT(3,IIG)
36899         PHKT(4,IIG)=PHKK(4,KKG)
36900         PG4=PG4+ PHKT(4,IIG)
36901         PHKT(5,IIG)=PHKK(5,KKG)
36902         VHKT(1,IIG)  =VHKK(1,KKG)
36903         VHKT(2,IIG)  =VHKK(2,KKG)
36904         VHKT(3,IIG)  =VHKK(3,KKG)
36905         VHKT(4,IIG)  =VHKK(4,KKG)
36906         WHKT(1,IIG)  =WHKK(1,KKG)
36907         WHKT(2,IIG)  =WHKK(2,KKG)
36908         WHKT(3,IIG)  =WHKK(3,KKG)
36909         WHKT(4,IIG)  =WHKK(4,KKG)
36910    81 CONTINUE
36911       ENDIF
36912       IF(IPIP.EQ.1)THEN
36913         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
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       ELSEIF(IPIP.EQ.2)THEN
36918 **NEW
36919 C       IDHKT(8)   =1000*IPP2+100*(-ISQ1+6)-3
36920         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
36921 **
36922         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
36923         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
36924         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
36925       ENDIF
36926       ISTHKT(8+IIGLU1+IIGLU2)  =962
36927       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36928       JMOHKT(2,8+IIGLU1+IIGLU2)=0
36929       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36930       JDAHKT(2,8+IIGLU1+IIGLU2)=0
36931 C     PHKT(1,8)  =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
36932 C     PHKT(2,8)  =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
36933 C     PHKT(3,8)  =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
36934 C     PHKT(4,8)  =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
36935       PHKT(1,8+IIGLU1+IIGLU2)  =
36936      * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36937       PHKT(2,8+IIGLU1+IIGLU2)  =
36938      * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36939       PHKT(3,8+IIGLU1+IIGLU2)  =
36940      * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36941       PHKT(4,8+IIGLU1+IIGLU2)  =
36942      * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36943 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36944 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36945       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36946 C       IREJ=1
36947 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36948         IPCO=0
36949 C       RETURN
36950         GO TO 3466
36951       ENDIF
36952 C     PHKT(5,8)  =PHKK(5,NC2T)
36953       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36954      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36955      *PHKT(1,8+IIGLU1+IIGLU2)**2)
36956       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
36957       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
36958       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
36959       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
36960       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
36961       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
36962       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
36963       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
36964       IDHKT(9+IIGLU1+IIGLU2)   =88888
36965       ISTHKT(9+IIGLU1+IIGLU2)  =96
36966       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36967       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36968       JDAHKT(1,9+IIGLU1+IIGLU2)=0
36969       JDAHKT(2,9+IIGLU1+IIGLU2)=0
36970       PHKT(1,9+IIGLU1+IIGLU2)
36971      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36972       PHKT(2,9+IIGLU1+IIGLU2)
36973      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36974       PHKT(3,9+IIGLU1+IIGLU2)
36975      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36976       PHKT(4,9+IIGLU1+IIGLU2)
36977      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36978       PHKT(5,9+IIGLU1+IIGLU2)
36979      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
36980      * PHKT(2,9+IIGLU1+IIGLU2)**2
36981      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
36982       IF(IPIP.GE.3)THEN
36983       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36984      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36985      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36986       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36987       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36988      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
36989      * JDAHKT(1,IIG),
36990      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36991    91 CONTINUE
36992       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36993      * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36994      *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36995      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36996       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36997      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36998      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
36999      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37000       ENDIF
37001       CHAMAL=CHAB1
37002       IF(IPIP.EQ.1)THEN
37003         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37004       ELSEIF(IPIP.EQ.2)THEN
37005         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37006       ENDIF
37007       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37008 C       IREJ=1
37009         IPCO=0
37010 C       RETURN
37011         GO TO 3466
37012       ENDIF
37013       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
37014       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
37015       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
37016       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
37017       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
37018       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
37019       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
37020       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
37021 C
37022       IPCO=0
37023       IGCOUN=9+IIGLU1+IIGLU2
37024        RETURN
37025        END
37026
37027 *$ CREATE MUSQBS1.FOR
37028 *COPY MUSQBS1
37029 C
37030 C
37031 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37032       SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37033      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
37034 C
37035 C                  USQBS-1 diagram (split projectile diquark)
37036 C
37037       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37038       SAVE
37039
37040       PARAMETER ( LINP = 10 ,
37041      &            LOUT = 6 ,
37042      &            LDAT = 9 )
37043
37044 * event history
37045
37046       PARAMETER (NMXHKK=200000)
37047
37048       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37049      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37050      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37051
37052 * extended event history
37053       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37054      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37055      &                IHIST(2,NMXHKK)
37056
37057 * Lorentz-parameters of the current interaction
37058       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37059      &                UMO,PPCM,EPROJ,PPROJ
37060
37061 * diquark-breaking mechanism
37062       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37063
37064 C
37065       PARAMETER (NTMHKK= 300)
37066       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37067      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37068      +(4,NTMHKK)
37069 *KEEP,XSEADI.
37070       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37071      +SSMIMQ,VVMTHR
37072 *KEEP,DPRIN.
37073       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37074       COMMON /EVFLAG/ NUMEV
37075 C
37076 C                  USQBS-1 diagram (split projectile diquark)
37077 C
37078 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37079 C     Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
37080 C
37081 C     Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
37082 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37083 C
37084 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37085 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37086 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37087 C
37088 C       Put new chains into COMMON /HKKTMP/
37089 C
37090       IIGLU1=NC1T-NC1P-1
37091       IIGLU2=NC2T-NC2P-1
37092       IGCOUN=0
37093 C     WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
37094       CVQ=1.D0
37095       IREJ=0
37096       IF(IPIP.EQ.3)THEN
37097 C     IF(NUMEV.EQ.-324)THEN
37098       WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37099      *             ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
37100      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37101      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
37102       ENDIF
37103 C
37104 C
37105 C
37106 C     determine x-values of NC1P diquark
37107       XDIQP=PHKK(4,NC1P)*2.D0/UMO
37108       XVQT=PHKK(4,NC1T)*2.D0/UMO
37109 C
37110 C     determine x-values of sea quark pair
37111 C
37112       IPCO=1
37113       ICOU=0
37114  2234 CONTINUE
37115       ICOU=ICOU+1
37116       IF(ICOU.GE.500)THEN
37117         IREJ=1
37118         IF(ISQ.EQ.3)IREJ=3
37119         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
37120         IPCO=0
37121         RETURN
37122       ENDIF
37123       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
37124      * UMO, XDIQP,XVQT
37125       XSQ=0.D0
37126       XSAQ=0.D0
37127 **NEW
37128 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37129       IF (IPIP.EQ.1) THEN
37130          XQMAX  = XDIQP/2.0D0
37131          XAQMAX = 2.D0*XVQT/3.0D0
37132       ELSE
37133          XQMAX  = 2.D0*XVQT/3.0D0
37134          XAQMAX = XDIQP/2.0D0
37135       ENDIF
37136       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37137       ISAQ = 6+ISQ
37138 C     write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37139 **
37140       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37141       IF(IREJ.GE.1)THEN
37142         IF(IPCO.GE.3)
37143      &     WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37144         IPCO=0
37145         RETURN
37146       ENDIF
37147       IF(IPIP.EQ.1)THEN
37148         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37149       ELSEIF(IPIP.EQ.2)THEN
37150         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37151       ENDIF
37152       IF(IPCO.GE.3)THEN
37153         WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37154      &  XDIQP,XVQT,XSQ,XSAQ
37155       ENDIF
37156 C
37157 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
37158 C
37159 C     XSQ=0.D0
37160       IF(IPIP.EQ.1)THEN
37161         XDIQP=XDIQP-XSQ
37162         XVQT =XVQT -XSAQ
37163       ELSEIF(IPIP.EQ.2)THEN
37164         XDIQP=XDIQP-XSAQ
37165         XVQT =XVQT -XSQ
37166       ENDIF
37167       IF(IPCO.GE.3)
37168      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37169 C
37170 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37171 C
37172       XVTHRO=CVQ/UMO
37173       IVTHR=0
37174  3466 CONTINUE
37175       IF(IVTHR.EQ.10)THEN
37176         IREJ=1
37177         IF(ISQ.EQ.3)IREJ=3
37178         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
37179         IPCO=0
37180         RETURN
37181       ENDIF
37182       IVTHR=IVTHR+1
37183       XVTHR=XVTHRO/(201-IVTHR)
37184       UNOPRV=UNON
37185  380  CONTINUE
37186       IF(XVTHR.GT.0.66D0*XDIQP)THEN
37187         IREJ=1
37188         IF(ISQ.EQ.3)IREJ=3
37189         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR  large',
37190      *  XVTHR
37191         IPCO=0
37192         RETURN
37193       ENDIF
37194       IF(DT_RNDM(V).LT.0.5D0)THEN
37195         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37196         XVPQII=XDIQP-XVPQI
37197       ELSE
37198         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37199         XVPQI=XDIQP-XVPQII
37200       ENDIF
37201       IF(IPCO.GE.3)THEN
37202         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
37203       ENDIF
37204 C
37205 C     Prepare 4 momenta of new chains and chain ends
37206 C
37207 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37208 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37209 C    +(4,NTMHKK)
37210 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37211 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37212 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37213       IF(IPIP.EQ.1)THEN
37214         XSQ1=XSQ
37215         XSAQ1=XSAQ
37216         ISQ1=ISQ
37217         ISAQ1=ISAQ
37218       ELSEIF(IPIP.EQ.2)THEN
37219         XSQ1=XSAQ
37220         XSAQ1=XSQ
37221         ISQ1=ISAQ
37222         ISAQ1=ISQ
37223       ENDIF
37224       IDHKT(1)   =IP11
37225       ISTHKT(1)  =931
37226       JMOHKT(1,1)=NC1P
37227       JMOHKT(2,1)=0
37228       JDAHKT(1,1)=3+IIGLU1
37229       JDAHKT(2,1)=0
37230 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37231       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
37232       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
37233       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
37234       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
37235 C     PHKT(5,1)  =PHKK(5,NC1P)
37236       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37237      *PHKT(1,1)**2)
37238       IF(XMIST.GE.0.D0)THEN
37239       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37240      *PHKT(1,1)**2)
37241       ELSE
37242 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37243        PHKT(5,1)=0.D0
37244       ENDIF
37245       VHKT(1,1)  =VHKK(1,NC1P)
37246       VHKT(2,1)  =VHKK(2,NC1P)
37247       VHKT(3,1)  =VHKK(3,NC1P)
37248       VHKT(4,1)  =VHKK(4,NC1P)
37249       WHKT(1,1)  =WHKK(1,NC1P)
37250       WHKT(2,1)  =WHKK(2,NC1P)
37251       WHKT(3,1)  =WHKK(3,NC1P)
37252       WHKT(4,1)  =WHKK(4,NC1P)
37253 C     Add here IIGLU1 gluons to this chaina
37254       PG1=0.D0
37255       PG2=0.D0
37256       PG3=0.D0
37257       PG4=0.D0
37258       IF(IIGLU1.GE.1)THEN
37259       JJG=NC1P
37260       DO 61 IIG=2,2+IIGLU1-1
37261         KKG=JJG+IIG-1
37262         IDHKT(IIG)   =IDHKK(KKG)
37263         ISTHKT(IIG)  =921
37264         JMOHKT(1,IIG)=KKG
37265         JMOHKT(2,IIG)=0
37266         JDAHKT(1,IIG)=3+IIGLU1
37267         JDAHKT(2,IIG)=0
37268         PHKT(1,IIG)=PHKK(1,KKG)
37269         PG1=PG1+ PHKT(1,IIG)
37270         PHKT(2,IIG)=PHKK(2,KKG)
37271         PG2=PG2+ PHKT(2,IIG)
37272         PHKT(3,IIG)=PHKK(3,KKG)
37273         PG3=PG3+ PHKT(3,IIG)
37274         PHKT(4,IIG)=PHKK(4,KKG)
37275         PG4=PG4+ PHKT(4,IIG)
37276         PHKT(5,IIG)=PHKK(5,KKG)
37277         VHKT(1,IIG)  =VHKK(1,KKG)
37278         VHKT(2,IIG)  =VHKK(2,KKG)
37279         VHKT(3,IIG)  =VHKK(3,KKG)
37280         VHKT(4,IIG)  =VHKK(4,KKG)
37281         WHKT(1,IIG) =WHKK(1,KKG)
37282         WHKT(2,IIG) =WHKK(2,KKG)
37283         WHKT(3,IIG) =WHKK(3,KKG)
37284         WHKT(4,IIG) =WHKK(4,KKG)
37285    61 CONTINUE
37286       ENDIF
37287       IDHKT(2+IIGLU1)   =IPP2
37288       ISTHKT(2+IIGLU1)  =932
37289       JMOHKT(1,2+IIGLU1)=NC2T
37290       JMOHKT(2,2+IIGLU1)=0
37291       JDAHKT(1,2+IIGLU1)=3+IIGLU1
37292       JDAHKT(2,2+IIGLU1)=0
37293       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
37294       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
37295       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
37296       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
37297 C     PHKT(5,2+IIGLU1)  =PHKK(5,NC2T)
37298       XMIST=(PHKT(4,2+IIGLU1)**2-
37299      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37300      *PHKT(1,2+IIGLU1)**2)
37301       IF(XMIST.GT.0.D0)THEN
37302       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
37303      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37304      *PHKT(1,2+IIGLU1)**2)
37305       ELSE
37306 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37307         PHKT(5,2+IIGLU1)=0.D0
37308       ENDIF
37309       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
37310       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
37311       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
37312       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
37313       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
37314       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
37315       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
37316       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
37317       IDHKT(3+IIGLU1)   =88888
37318       ISTHKT(3+IIGLU1)  =94
37319       JMOHKT(1,3+IIGLU1)=1
37320       JMOHKT(2,3+IIGLU1)=2+IIGLU1
37321       JDAHKT(1,3+IIGLU1)=0
37322       JDAHKT(2,3+IIGLU1)=0
37323       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37324       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37325       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37326       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37327       XMIST
37328      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37329      *            -PHKT(3,3+IIGLU1)**2)
37330       IF(XMIST.GE.0.D0)THEN
37331       PHKT(5,3+IIGLU1)
37332      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37333      *            -PHKT(3,3+IIGLU1)**2)
37334       ELSE
37335 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37336        PHKT(5,1)=0.D0
37337       ENDIF
37338       IF(IPIP.GE.3)THEN
37339 C     IF(NUMEV.EQ.-324)THEN
37340       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
37341      * JMOHKT(2,1),JDAHKT(1,1),
37342      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37343       DO 71 IIG=2,2+IIGLU1-1
37344       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37345      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
37346      * JDAHKT(1,IIG),
37347      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37348    71 CONTINUE
37349       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37350      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37351      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37352       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37353      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37354      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37355       ENDIF
37356       CHAMAL=CHAM1
37357       IF(IPIP.EQ.1)THEN
37358         IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
37359       ELSEIF(IPIP.EQ.2)THEN
37360         IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
37361       ENDIF
37362       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37363 C       IREJ=1
37364         IPCO=0
37365 C       RETURN
37366 C       WRITE(6,*)' MUSQBS1 jump back from chain 3'
37367         GO TO 3466
37368       ENDIF
37369       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
37370       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
37371       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
37372       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
37373       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
37374       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
37375       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
37376       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
37377       IDHKT(4+IIGLU1)   =IP12
37378       ISTHKT(4+IIGLU1)  =931
37379       JMOHKT(1,4+IIGLU1)=NC1P
37380       JMOHKT(2,4+IIGLU1)=0
37381       JDAHKT(1,4+IIGLU1)=6+IIGLU1
37382       JDAHKT(2,4+IIGLU1)=0
37383 C   create  chain   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37384       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37385       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37386       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37387       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37388 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
37389       XMIST  =(PHKT(4,4+IIGLU1)**2-
37390      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37391      *PHKT(1,4+IIGLU1)**2)
37392       IF(XMIST.GT.0.D0)THEN
37393       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
37394      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37395      *PHKT(1,4+IIGLU1)**2)
37396       ELSE
37397 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37398         PHKT(5,4+IIGLU1)=0.D0
37399       ENDIF
37400       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
37401       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
37402       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
37403       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
37404       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
37405       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
37406       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
37407       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
37408       IF(IPIP.EQ.1)THEN
37409         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
37410       ELSEIF(IPIP.EQ.2)THEN
37411         IDHKT(5+IIGLU1)   =ISAQ1
37412       ENDIF
37413       ISTHKT(5+IIGLU1)  =932
37414       JMOHKT(1,5+IIGLU1)=NC1T
37415       JMOHKT(2,5+IIGLU1)=0
37416       JDAHKT(1,5+IIGLU1)=6+IIGLU1
37417       JDAHKT(2,5+IIGLU1)=0
37418       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37419       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37420       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37421       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37422 C     IF( PHKT(4,5).EQ.0.D0)THEN
37423 C       IREJ=1
37424 CIPCO=0
37425 CRETURN
37426 C     ENDIF
37427 C     PHKT(5,5)  =PHKK(5,NC1T)
37428       XMIST=(PHKT(4,5+IIGLU1)**2-
37429      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37430      *PHKT(1,5+IIGLU1)**2)
37431       IF(XMIST.GT.0.D0)THEN
37432       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
37433      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37434      *PHKT(1,5+IIGLU1)**2)
37435       ELSE
37436 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37437         PHKT(5,5+IIGLU1)=0.D0
37438       ENDIF
37439       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
37440       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
37441       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
37442       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
37443       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
37444       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
37445       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
37446       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
37447       IDHKT(6+IIGLU1)   =88888
37448       ISTHKT(6+IIGLU1)  =94
37449       JMOHKT(1,6+IIGLU1)=4+IIGLU1
37450       JMOHKT(2,6+IIGLU1)=5+IIGLU1
37451       JDAHKT(1,6+IIGLU1)=0
37452       JDAHKT(2,6+IIGLU1)=0
37453       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37454       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37455       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37456       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37457       XMIST
37458      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37459      *            -PHKT(3,6+IIGLU1)**2)
37460       IF(XMIST.GE.0.D0)THEN
37461       PHKT(5,6+IIGLU1)
37462      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37463      *            -PHKT(3,6+IIGLU1)**2)
37464       ELSE
37465 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37466        PHKT(5,1)=0.D0
37467       ENDIF
37468 C     IF(IPIP.EQ.3)THEN
37469       CHAMAL=CHAM1
37470       IF(IPIP.EQ.1)THEN
37471         IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37472       ELSEIF(IPIP.EQ.2)THEN
37473         IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37474       ENDIF
37475       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37476 C       IREJ=1
37477         IPCO=0
37478 C       RETURN
37479 C       WRITE(6,*)' MGSQBS1 jump back from chain 6',
37480 C    &  CHAMAL,PHKT(5,6+IIGLU1)
37481         GO TO 3466
37482       ENDIF
37483       IF(IPIP.GE.3)THEN
37484 C     IF(NUMEV.EQ.-324)THEN
37485       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37486      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37487      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37488       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37489      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37490      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37491       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37492      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37493      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37494       ENDIF
37495       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
37496       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
37497       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
37498       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
37499       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
37500       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
37501       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
37502       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
37503       IF(IPIP.EQ.1)THEN
37504         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+3
37505         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
37506         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
37507         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
37508       ELSEIF(IPIP.EQ.2)THEN
37509         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
37510         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
37511         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
37512         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
37513 C       WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
37514       ENDIF
37515       ISTHKT(7+IIGLU1)  =931
37516       JMOHKT(1,7+IIGLU1)=NC2P
37517       JMOHKT(2,7+IIGLU1)=0
37518       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37519       JDAHKT(2,7+IIGLU1)=0
37520 C    create chain     9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37521       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
37522       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
37523       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
37524       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
37525 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
37526 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
37527       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
37528 C       IREJ=1
37529 C       WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
37530         IPCO=0
37531 C       RETURN
37532         GO TO 3466
37533       ENDIF
37534 C     PHKT(5,7)  =PHKK(5,NC2P)
37535       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
37536      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37537      *PHKT(1,7+IIGLU1)**2)
37538       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
37539       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
37540       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
37541       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
37542       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
37543       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
37544       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
37545       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
37546 C     Insert here the IIGLU2 gluons
37547       PG1=0.D0
37548       PG2=0.D0
37549       PG3=0.D0
37550       PG4=0.D0
37551       IF(IIGLU2.GE.1)THEN
37552       JJG=NC2P
37553       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37554         KKG=JJG+IIG-7-IIGLU1
37555         IDHKT(IIG)   =IDHKK(KKG)
37556         ISTHKT(IIG)  =921
37557         JMOHKT(1,IIG)=KKG
37558         JMOHKT(2,IIG)=0
37559         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37560         JDAHKT(2,IIG)=0
37561         PHKT(1,IIG)=PHKK(1,KKG)
37562         PG1=PG1+ PHKT(1,IIG)
37563         PHKT(2,IIG)=PHKK(2,KKG)
37564         PG2=PG2+ PHKT(2,IIG)
37565         PHKT(3,IIG)=PHKK(3,KKG)
37566         PG3=PG3+ PHKT(3,IIG)
37567         PHKT(4,IIG)=PHKK(4,KKG)
37568         PG4=PG4+ PHKT(4,IIG)
37569         PHKT(5,IIG)=PHKK(5,KKG)
37570         VHKT(1,IIG)  =VHKK(1,KKG)
37571         VHKT(2,IIG)  =VHKK(2,KKG)
37572         VHKT(3,IIG)  =VHKK(3,KKG)
37573         VHKT(4,IIG)  =VHKK(4,KKG)
37574         WHKT(1,IIG)  =WHKK(1,KKG)
37575         WHKT(2,IIG) =WHKK(2,KKG)
37576         WHKT(3,IIG) =WHKK(3,KKG)
37577         WHKT(4,IIG) =WHKK(4,KKG)
37578    81 CONTINUE
37579       ENDIF
37580       IDHKT(8+IIGLU1+IIGLU2)   =IP2
37581       ISTHKT(8+IIGLU1+IIGLU2)  =932
37582       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
37583       JMOHKT(2,8+IIGLU1+IIGLU2)=0
37584       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37585       JDAHKT(2,8+IIGLU1+IIGLU2)=0
37586       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
37587       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
37588       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
37589       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
37590 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
37591       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
37592      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37593      *PHKT(1,8+IIGLU1+IIGLU2)**2)
37594       IF(XMIST.GT.0.D0)THEN
37595       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37596      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37597      *PHKT(1,8+IIGLU1+IIGLU2)**2)
37598       ELSE
37599 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37600         PHKT(5,8+IIGLU1+IIGLU2)=0.D0
37601       ENDIF
37602       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
37603       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
37604       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
37605       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
37606       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
37607       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
37608       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
37609       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
37610       IDHKT(9+IIGLU1+IIGLU2)   =88888
37611       ISTHKT(9+IIGLU1+IIGLU2)  =94
37612       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37613       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37614       JDAHKT(1,9+IIGLU1+IIGLU2)=0
37615       JDAHKT(2,9+IIGLU1+IIGLU2)=0
37616       PHKT(1,9+IIGLU1+IIGLU2)
37617      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37618       PHKT(2,9+IIGLU1+IIGLU2)
37619      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37620       PHKT(3,9+IIGLU1+IIGLU2)
37621      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37622       PHKT(4,9+IIGLU1+IIGLU2)
37623      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37624       XMIST
37625      *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37626      * -PHKT(2,9+IIGLU1+IIGLU2)**2
37627      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
37628       IF(XMIST.GE.0.D0)THEN
37629       PHKT(5,9+IIGLU1+IIGLU2)
37630      *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37631      * -PHKT(2,9+IIGLU1+IIGLU2)**2
37632      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
37633       ELSE
37634 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37635        PHKT(5,1)=0.D0
37636       ENDIF
37637       IF(IPIP.GE.3)THEN
37638 C     IF(NUMEV.EQ.-324)THEN
37639       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37640      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37641      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37642       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37643       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37644      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
37645      * JDAHKT(1,IIG),
37646      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37647    91 CONTINUE
37648       WRITE(LOUT,*)8+IIGLU1+IIGLU2,
37649      * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
37650      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
37651      *JDAHKT(1,8+IIGLU1+IIGLU2),
37652      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37653       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37654      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37655      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37656      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37657       ENDIF
37658       CHAMAL=CHAB1
37659       IF(IPIP.EQ.1)THEN
37660         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37661       ELSEIF(IPIP.EQ.2)THEN
37662         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37663       ENDIF
37664       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37665 C       IREJ=1
37666         IPCO=0
37667 C       RETURN
37668 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
37669 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37670         GO TO 3466
37671       ENDIF
37672       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
37673       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
37674       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
37675       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
37676       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
37677       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
37678       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
37679       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
37680 C
37681       IPCO=0
37682       IGCOUN=9+IIGLU1+IIGLU2
37683        RETURN
37684        END
37685
37686 *$ CREATE MGSQBS1.FOR
37687 *COPY MGSQBS1
37688 C
37689 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37690       SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37691      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
37692 C
37693 C                  GSQBS-1 diagram (split projectile diquark)
37694 C
37695       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37696       SAVE
37697
37698       PARAMETER ( LINP = 10 ,
37699      &            LOUT = 6 ,
37700      &            LDAT = 9 )
37701
37702 * event history
37703
37704       PARAMETER (NMXHKK=200000)
37705
37706       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37707      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37708      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37709
37710 * extended event history
37711       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37712      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37713      &                IHIST(2,NMXHKK)
37714
37715 * Lorentz-parameters of the current interaction
37716       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37717      &                UMO,PPCM,EPROJ,PPROJ
37718
37719 * diquark-breaking mechanism
37720       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37721
37722 C
37723       PARAMETER (NTMHKK= 300)
37724       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37725      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37726      +(4,NTMHKK)
37727 *KEEP,XSEADI.
37728       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37729      +SSMIMQ,VVMTHR
37730 *KEEP,DPRIN.
37731       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37732 C
37733 C                  GSQBS-1 diagram (split projectile diquark)
37734 C
37735 C
37736 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37737 C     Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
37738 C
37739 C     Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
37740 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37741 C
37742 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37743 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37744 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37745 C
37746 C       Put new chains into COMMON /HKKTMP/
37747 C
37748       IIGLU1=NC1T-NC1P-1
37749       IIGLU2=NC2T-NC2P-1
37750       IGCOUN=0
37751 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37752       CVQ=1.D0
37753       NNNC1=IDHKK(NC1)/1000
37754       MMMC1=IDHKK(NC1)-NNNC1*1000
37755       KKKC1=ISTHKK(NC1)
37756       NNNC2=IDHKK(NC2)/1000
37757       MMMC2=IDHKK(NC2)-NNNC2*1000
37758       KKKC2=ISTHKK(NC2)
37759       IREJ=0
37760       IF(IPIP.EQ.3)THEN
37761       WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37762      *             ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
37763      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37764      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
37765       ENDIF
37766 C
37767 C
37768 C
37769 C     determine x-values of NC1P diquark
37770       XDIQP=PHKK(4,NC1P)*2.D0/UMO
37771       XVQT=PHKK(4,NC1T)*2.D0/UMO
37772 C
37773 C     determine x-values of sea quark pair
37774 C
37775       IPCO=1
37776       ICOU=0
37777  2234 CONTINUE
37778       ICOU=ICOU+1
37779       IF(ICOU.GE.500)THEN
37780         IREJ=1
37781         IF(ISQ.EQ.3)IREJ=3
37782         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
37783       IPCO=0
37784         RETURN
37785       ENDIF
37786       IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
37787      * UMO, XDIQP,XVQT
37788       XSQ=0.D0
37789       XSAQ=0.D0
37790 **NEW
37791 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37792       IF (IPIP.EQ.1) THEN
37793          XQMAX  = XDIQP/2.0D0
37794          XAQMAX = 2.D0*XVQT/3.0D0
37795       ELSE
37796          XQMAX  = 2.D0*XVQT/3.0D0
37797          XAQMAX = XDIQP/2.0D0
37798       ENDIF
37799       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37800       ISAQ = 6+ISQ
37801 C     write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37802 **
37803         IF(IPCO.GE.3)
37804      &     WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37805       IF(IREJ.GE.1)THEN
37806         IF(IPCO.GE.3)
37807      &     WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37808       IPCO=0
37809         RETURN
37810       ENDIF
37811       IF(IPIP.EQ.1)THEN
37812         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37813       ELSEIF(IPIP.EQ.2)THEN
37814         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37815       ENDIF
37816       IF(IPCO.GE.3)THEN
37817         WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37818      &  XDIQP,XVQT,XSQ,XSAQ
37819       ENDIF
37820 C
37821 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
37822 C
37823 C     XSQ=0.D0
37824       IF(IPIP.EQ.1)THEN
37825         XDIQP=XDIQP-XSQ
37826 **NEW
37827 C       IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
37828 **
37829         XVQT =XVQT -XSAQ
37830       ELSEIF(IPIP.EQ.2)THEN
37831         XDIQP=XDIQP-XSAQ
37832         XVQT =XVQT -XSQ
37833       ENDIF
37834       IF(IPCO.GE.3)
37835      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37836 C
37837 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37838 C
37839       XVTHRO=CVQ/UMO
37840       IVTHR=0
37841  3466 CONTINUE
37842       IF(IVTHR.EQ.10)THEN
37843         IREJ=1
37844         IF(ISQ.EQ.3)IREJ=3
37845         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
37846       IPCO=0
37847         RETURN
37848       ENDIF
37849       IVTHR=IVTHR+1
37850       XVTHR=XVTHRO/(201-IVTHR)
37851       UNOPRV=UNON
37852  380  CONTINUE
37853       IF(XVTHR.GT.0.66D0*XDIQP)THEN
37854         IREJ=1
37855         IF(ISQ.EQ.3)IREJ=3
37856         IF(IPCO.GE.3)
37857      &     WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR  large',
37858      *  XVTHR
37859       IPCO=0
37860         RETURN
37861       ENDIF
37862       IF(DT_RNDM(V).LT.0.5D0)THEN
37863         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37864         XVPQII=XDIQP-XVPQI
37865       ELSE
37866         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37867         XVPQI=XDIQP-XVPQII
37868       ENDIF
37869       IF(IPCO.GE.3)THEN
37870         WRITE(LOUT,'(A,4E12.4)')'  MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
37871      &  XVTHR,XDIQP,XVPQI,XVPQII
37872       ENDIF
37873 C
37874 C     Prepare 4 momenta of new chains and chain ends
37875 C
37876 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37877 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37878 C    +(4,NTMHKK)
37879 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37880 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37881 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37882       IF(IPIP.EQ.1)THEN
37883         XSQ1=XSQ
37884         XSAQ1=XSAQ
37885         ISQ1=ISQ
37886         ISAQ1=ISAQ
37887       ELSEIF(IPIP.EQ.2)THEN
37888         XSQ1=XSAQ
37889         XSAQ1=XSQ
37890         ISQ1=ISAQ
37891         ISAQ1=ISQ
37892       ENDIF
37893       KK11=IP11
37894 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
37895       KK21= IPP21
37896       KK22= IPP22
37897       XGIVE=0.D0
37898       IDHKT(4+IIGLU1)   =IP12
37899       ISTHKT(4+IIGLU1)  =921
37900       JMOHKT(1,4+IIGLU1)=NC1P
37901       JMOHKT(2,4+IIGLU1)=0
37902       JDAHKT(1,4+IIGLU1)=6+IIGLU1
37903       JDAHKT(2,4+IIGLU1)=0
37904 **NEW
37905       IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
37906      &    (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
37907 **
37908       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37909       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37910       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37911       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37912 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
37913       XXMIST=(PHKT(4,4+IIGLU1)**2-
37914      *              PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37915      *              PHKT(1,4+IIGLU1)**2)
37916       IF(XXMIST.GT.0.D0)THEN
37917         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
37918       ELSE
37919         WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
37920         XXMIST=ABS(XXMIST)
37921         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
37922       ENDIF
37923       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
37924       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
37925       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
37926       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
37927       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
37928       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
37929       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
37930       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
37931       IF(IPIP.EQ.1)THEN
37932         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
37933       ELSEIF(IPIP.EQ.2)THEN
37934         IDHKT(5+IIGLU1)   =ISAQ1
37935       ENDIF
37936       ISTHKT(5+IIGLU1)  =922
37937       JMOHKT(1,5+IIGLU1)=NC1T
37938       JMOHKT(2,5+IIGLU1)=0
37939       JDAHKT(1,5+IIGLU1)=6+IIGLU1
37940       JDAHKT(2,5+IIGLU1)=0
37941 **NEW
37942       IF ((XSAQ1.LT.0.0D0).OR.(XVQT  .LT.0.0D0))
37943      &    WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
37944 **
37945       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37946       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37947       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37948       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37949 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
37950       XMIST=(PHKT(4,5+IIGLU1)**2-
37951      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37952      *PHKT(1,5+IIGLU1)**2)
37953       IF(XMIST.GT.0.D0)THEN
37954       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
37955      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37956      *PHKT(1,5+IIGLU1)**2)
37957       ELSE
37958 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37959         PHKT(5,5+IIGLU1)=0.D0
37960       ENDIF
37961       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
37962       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
37963       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
37964       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
37965       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
37966       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
37967       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
37968       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
37969       IDHKT(6+IIGLU1)   =88888
37970 C     IDHKT(6)   =1000*NNNC1+MMMC1
37971       ISTHKT(6+IIGLU1)  =93
37972 C     ISTHKT(6)  =KKKC1
37973       JMOHKT(1,6+IIGLU1)=4+IIGLU1
37974       JMOHKT(2,6+IIGLU1)=5+IIGLU1
37975       JDAHKT(1,6+IIGLU1)=0
37976       JDAHKT(2,6+IIGLU1)=0
37977       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37978       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37979       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37980       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37981       PHKT(5,6+IIGLU1)
37982      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37983      *            -PHKT(3,6+IIGLU1)**2)
37984       CHAMAL=CHAM1
37985       IF(IPIP.EQ.1)THEN
37986         IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
37987       ELSEIF(IPIP.EQ.2)THEN
37988         IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
37989       ENDIF
37990       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37991         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37992 C                    we drop chain 6 and give the energy to chain 3
37993           IDHKT(6+IIGLU1)=33888
37994           XGIVE=1.D0
37995 C         WRITE(6,*)' drop chain 6 xgive=1'
37996           GO TO 7788
37997         ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
37998 C                    we drop chain 6 and give the energy to chain 3
37999 C                    and change KK11 to IDHKT(4)
38000           IDHKT(6+IIGLU1)=33888
38001           XGIVE=1.D0
38002 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
38003           KK11=IDHKT(4+IIGLU1)
38004           GO TO 7788
38005         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
38006 C                    we drop chain 6 and give the energy to chain 3
38007 C                    and change KK21 to IDHKT(4)
38008 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
38009           IDHKT(6+IIGLU1)=33888
38010           XGIVE=1.D0
38011 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
38012           KK21=IDHKT(4+IIGLU1)
38013           GO TO 7788
38014         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
38015 C                    we drop chain 6 and give the energy to chain 3
38016 C                    and change KK22 to IDHKT(4)
38017 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
38018           IDHKT(6+IIGLU1)=33888
38019           XGIVE=1.D0
38020 C         WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
38021           KK22=IDHKT(4+IIGLU1)
38022           GO TO 7788
38023         ENDIF
38024 C       IREJ=1
38025         IPCO=0
38026 C       RETURN
38027 C       WRITE(6,*)' MGSQBS1 jump back from chain 6'
38028         GO TO 3466
38029       ENDIF
38030  7788 CONTINUE
38031       IF(IPIP.GE.3)THEN
38032       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38033      * JMOHKT(1,4+IIGLU1),
38034      * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38035      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38036       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38037      * JMOHKT(1,5+IIGLU1),
38038      * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38039      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38040       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38041      * JMOHKT(1,6+IIGLU1),
38042      * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38043      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38044       ENDIF
38045       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
38046       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
38047       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
38048       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
38049       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
38050       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
38051       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
38052       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
38053 C     IDHKT(1)   =IP11
38054       IDHKT(1)   =KK11
38055       ISTHKT(1)  =921
38056       JMOHKT(1,1)=NC1P
38057       JMOHKT(2,1)=0
38058       JDAHKT(1,1)=3+IIGLU1
38059       JDAHKT(2,1)=0
38060       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38061 C    * +0.5D0*PHKK(1,NC2P)
38062      *+XGIVE*PHKT(1,4+IIGLU1)
38063       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38064 C    * +0.5D0*PHKK(2,NC2P)
38065      *+XGIVE*PHKT(2,4+IIGLU1)
38066       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38067 C    * +0.5D0*PHKK(3,NC2P)
38068      *+XGIVE*PHKT(3,4+IIGLU1)
38069       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38070 C    * +0.5D0*PHKK(4,NC2P)
38071      *+XGIVE*PHKT(4,4+IIGLU1)
38072 C     PHKT(5,1)  =PHKK(5,NC1P)
38073       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38074      *PHKT(1,1)**2)
38075       IF(XMIST.GE.0.D0)THEN
38076       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38077      *PHKT(1,1)**2)
38078       ELSE
38079 C      WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
38080        PHKT(5,1)=0.D0
38081       ENDIF
38082       VHKT(1,1)  =VHKK(1,NC1P)
38083       VHKT(2,1)  =VHKK(2,NC1P)
38084       VHKT(3,1)  =VHKK(3,NC1P)
38085       VHKT(4,1)  =VHKK(4,NC1P)
38086       WHKT(1,1)  =WHKK(1,NC1P)
38087       WHKT(2,1)  =WHKK(2,NC1P)
38088       WHKT(3,1)  =WHKK(3,NC1P)
38089       WHKT(4,1)  =WHKK(4,NC1P)
38090 C     Add here IIGLU1 gluons to this chaina
38091       PG1=0.D0
38092       PG2=0.D0
38093       PG3=0.D0
38094       PG4=0.D0
38095       IF(IIGLU1.GE.1)THEN
38096       JJG=NC1P
38097       DO 61 IIG=2,2+IIGLU1-1
38098         KKG=JJG+IIG-1
38099         IDHKT(IIG)   =IDHKK(KKG)
38100         ISTHKT(IIG)  =921
38101         JMOHKT(1,IIG)=KKG
38102         JMOHKT(2,IIG)=0
38103         JDAHKT(1,IIG)=3+IIGLU1
38104         JDAHKT(2,IIG)=0
38105         PHKT(1,IIG)=PHKK(1,KKG)
38106         PG1=PG1+ PHKT(1,IIG)
38107         PHKT(2,IIG)=PHKK(2,KKG)
38108         PG2=PG2+ PHKT(2,IIG)
38109         PHKT(3,IIG)=PHKK(3,KKG)
38110         PG3=PG3+ PHKT(3,IIG)
38111         PHKT(4,IIG)=PHKK(4,KKG)
38112         PG4=PG4+ PHKT(4,IIG)
38113         PHKT(5,IIG)=PHKK(5,KKG)
38114         VHKT(1,IIG)  =VHKK(1,KKG)
38115         VHKT(2,IIG)  =VHKK(2,KKG)
38116         VHKT(3,IIG)  =VHKK(3,KKG)
38117         VHKT(4,IIG)  =VHKK(4,KKG)
38118         WHKT(1,IIG)  =WHKK(1,KKG)
38119         WHKT(2,IIG)  =WHKK(2,KKG)
38120         WHKT(3,IIG)  =WHKK(3,KKG)
38121         WHKT(4,IIG)  =WHKK(4,KKG)
38122    61 CONTINUE
38123       ENDIF
38124 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
38125       IF(IPIP.EQ.1)THEN
38126         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22+3
38127         IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
38128         IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
38129         IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
38130       ELSEIF(IPIP.EQ.2)THEN
38131         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22-3
38132         IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
38133         IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
38134         IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
38135       ENDIF
38136       ISTHKT(2+IIGLU1)  =922
38137       JMOHKT(1,2+IIGLU1)=NC2T
38138       JMOHKT(2,2+IIGLU1)=0
38139       JDAHKT(1,2+IIGLU1)=3+IIGLU1
38140       JDAHKT(2,2+IIGLU1)=0
38141       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
38142      *+XGIVE*PHKT(1,5+IIGLU1)
38143       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
38144      *+XGIVE*PHKT(2,5+IIGLU1)
38145       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
38146      *+XGIVE*PHKT(3,5+IIGLU1)
38147       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
38148      *+XGIVE*PHKT(4,5+IIGLU1)
38149 C     PHKT(5,2)  =PHKK(5,NC2T)
38150       XMIST=(PHKT(4,2+IIGLU1)**2-
38151      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38152      *PHKT(1,2+IIGLU1)**2)
38153       IF(XMIST.GT.0.D0)THEN
38154       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
38155      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38156      *PHKT(1,2+IIGLU1)**2)
38157       ELSE
38158 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38159       PHKT(5,2+IIGLU1)=0.D0
38160       ENDIF
38161       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
38162       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
38163       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
38164       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
38165       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
38166       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
38167       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
38168       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
38169       IDHKT(3+IIGLU1)   =88888
38170 C     IDHKT(3)   =1000*NNNC1+MMMC1+10
38171       ISTHKT(3+IIGLU1)  =93
38172 C     ISTHKT(3)  =KKKC1
38173       JMOHKT(1,3+IIGLU1)=1
38174       JMOHKT(2,3+IIGLU1)=2+IIGLU1
38175       JDAHKT(1,3+IIGLU1)=0
38176       JDAHKT(2,3+IIGLU1)=0
38177       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38178       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38179       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38180       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38181       PHKT(5,3+IIGLU1)
38182      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38183      *            -PHKT(3,3+IIGLU1)**2)
38184       IF(IPIP.GE.3)THEN
38185       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38186      * JDAHKT(1,1),
38187      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38188       DO 71 IIG=2,2+IIGLU1-1
38189       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38190      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38191      * JDAHKT(1,IIG),
38192      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38193    71 CONTINUE
38194       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
38195      &             IDHKT(2),JMOHKT(1,2+IIGLU1),
38196      * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38197      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38198       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38199      * JMOHKT(1,3+IIGLU1),
38200      * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38201      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38202       ENDIF
38203       CHAMAL=CHAB1
38204 **NEW
38205 C     IF(IPIP.EQ.1)THEN
38206 C       IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
38207 C     ELSEIF(IPIP.EQ.2)THEN
38208 C       IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
38209 C     ENDIF
38210       IF(IPIP.EQ.1)THEN
38211         IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
38212       ELSEIF(IPIP.EQ.2)THEN
38213         IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
38214       ENDIF
38215 **
38216       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38217 C       IREJ=1
38218         IPCO=0
38219 C       RETURN
38220 C       WRITE(6,*)' MGSQBS1 jump back from chain 3'
38221         GO TO 3466
38222       ENDIF
38223       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
38224       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
38225       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
38226       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
38227       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
38228       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
38229       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
38230       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
38231       IF(IPIP.EQ.1)THEN
38232         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ1+3
38233         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
38234         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
38235         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
38236       ELSEIF(IPIP.EQ.2)THEN
38237         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
38238         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38239         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38240         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38241 C       WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
38242       ENDIF
38243       ISTHKT(7+IIGLU1)  =921
38244       JMOHKT(1,7+IIGLU1)=NC2P
38245       JMOHKT(2,7+IIGLU1)=0
38246       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38247       JDAHKT(2,7+IIGLU1)=0
38248 C     PHKT(1,7)  =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
38249 C     PHKT(2,7)  =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
38250 C     PHKT(3,7)  =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
38251 C     PHKT(4,7+IIGLU1)  =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
38252 **NEW
38253       IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
38254      &    WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
38255 **
38256       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38257       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38258       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38259       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38260 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38261 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38262       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38263 C       IREJ=1
38264 C       WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
38265         IPCO=0
38266 C       RETURN
38267         GO TO 3466
38268       ENDIF
38269 C     PHKT(5,7)  =PHKK(5,NC2P)
38270       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
38271      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38272      *PHKT(1,7+IIGLU1)**2)
38273       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
38274       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
38275       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
38276       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
38277       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
38278       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
38279       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
38280       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
38281 C     Insert here the IIGLU2 gluons
38282       PG1=0.D0
38283       PG2=0.D0
38284       PG3=0.D0
38285       PG4=0.D0
38286       IF(IIGLU2.GE.1)THEN
38287       JJG=NC2P
38288       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38289         KKG=JJG+IIG-7-IIGLU1
38290         IDHKT(IIG)   =IDHKK(KKG)
38291         ISTHKT(IIG)  =921
38292         JMOHKT(1,IIG)=KKG
38293         JMOHKT(2,IIG)=0
38294         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38295         JDAHKT(2,IIG)=0
38296         PHKT(1,IIG)=PHKK(1,KKG)
38297         PG1=PG1+ PHKT(1,IIG)
38298         PHKT(2,IIG)=PHKK(2,KKG)
38299         PG2=PG2+ PHKT(2,IIG)
38300         PHKT(3,IIG)=PHKK(3,KKG)
38301         PG3=PG3+ PHKT(3,IIG)
38302         PHKT(4,IIG)=PHKK(4,KKG)
38303         PG4=PG4+ PHKT(4,IIG)
38304         PHKT(5,IIG)=PHKK(5,KKG)
38305         VHKT(1,IIG)  =VHKK(1,KKG)
38306         VHKT(2,IIG)  =VHKK(2,KKG)
38307         VHKT(3,IIG)  =VHKK(3,KKG)
38308         VHKT(4,IIG)  =VHKK(4,KKG)
38309         WHKT(1,IIG)  =WHKK(1,KKG)
38310         WHKT(2,IIG)  =WHKK(2,KKG)
38311         WHKT(3,IIG)  =WHKK(3,KKG)
38312         WHKT(4,IIG)  =WHKK(4,KKG)
38313    81 CONTINUE
38314       ENDIF
38315       IDHKT(8+IIGLU1+IIGLU2)   =IP2
38316       ISTHKT(8+IIGLU1+IIGLU2)  =922
38317       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38318       JMOHKT(2,8+IIGLU1+IIGLU2)=0
38319       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38320       JDAHKT(2,8+IIGLU1+IIGLU2)=0
38321 **NEW
38322       IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
38323      &    WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
38324 **
38325       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38326       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38327       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38328       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38329 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
38330       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38331      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38332      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38333       IF(XMIST.GT.0.D0)THEN
38334       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38335      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38336      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38337       ELSE
38338 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38339       PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38340       ENDIF
38341       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
38342       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
38343       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
38344       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
38345       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
38346       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
38347       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
38348       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
38349       IDHKT(9+IIGLU1+IIGLU2)   =88888
38350 C     IDHKT(9)   =1000*NNNC2+MMMC2+10
38351       ISTHKT(9+IIGLU1+IIGLU2)  =93
38352 C     ISTHKT(9)  =KKKC2
38353       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38354       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38355       JDAHKT(1,9+IIGLU1+IIGLU2)=0
38356       JDAHKT(2,9+IIGLU1+IIGLU2)=0
38357       PHKT(1,9+IIGLU1+IIGLU2)  =PHKT(1,7+IIGLU1)
38358      * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
38359       PHKT(2,9+IIGLU1+IIGLU2)  =PHKT(2,7+IIGLU1)
38360      * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
38361       PHKT(3,9+IIGLU1+IIGLU2)  =PHKT(3,7+IIGLU1)
38362      * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
38363       PHKT(4,9+IIGLU1+IIGLU2)  =PHKT(4,7+IIGLU1)
38364      * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
38365       PHKT(5,9+IIGLU1+IIGLU2)
38366      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38367      * PHKT(2,9+IIGLU1+IIGLU2)**2
38368      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38369       IF(IPIP.GE.3)THEN
38370       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38371      * JMOHKT(1,7+IIGLU1),
38372      * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38373      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38374       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38375       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38376      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38377      * JDAHKT(1,IIG),
38378      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38379    91 CONTINUE
38380       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38381      * IDHKT(8+IIGLU1+IIGLU2),
38382      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38383      * JDAHKT(1,8+IIGLU1+IIGLU2),
38384      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38385       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38386      * IDHKT(9+IIGLU1+IIGLU2),
38387      * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
38388      * JDAHKT(1,9+IIGLU1+IIGLU2),
38389      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38390       ENDIF
38391       CHAMAL=CHAB1
38392       IF(IPIP.EQ.1)THEN
38393         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38394       ELSEIF(IPIP.EQ.2)THEN
38395         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38396       ENDIF
38397       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38398 C       IREJ=1
38399         IPCO=0
38400 C       RETURN
38401 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
38402 C    &  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
38403         GO TO 3466
38404       ENDIF
38405       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
38406       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
38407       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
38408       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
38409       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
38410       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
38411       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
38412       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
38413 C
38414       IGCOUN=9+IIGLU1+IIGLU2
38415       IPCO=0
38416        RETURN
38417        END
38418
38419 *$ CREATE HKKHKT.FOR
38420 *COPY HKKHKT
38421 C
38422 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38423 C
38424       SUBROUTINE HKKHKT(I,J)
38425       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38426       SAVE
38427
38428 * event history
38429
38430       PARAMETER (NMXHKK=200000)
38431
38432       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38433      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38434      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38435
38436 * extended event history
38437       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38438      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38439      &                IHIST(2,NMXHKK)
38440
38441       PARAMETER (NTMHKK= 300)
38442       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38443      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38444      +(4,NTMHKK)
38445 C
38446       ISTHKK(I)  =ISTHKT(J)
38447       IDHKK(I)   =IDHKT(J)
38448 C     IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
38449       IF(IDHKK(I).EQ.88888)THEN
38450 C       JMOHKK(1,I)=I-2
38451 C       JMOHKK(2,I)=I-1
38452         JMOHKK(1,I)=I-(J-JMOHKT(1,J))
38453         JMOHKK(2,I)=I-(J-JMOHKT(2,J))
38454       ELSE
38455         JMOHKK(1,I)=JMOHKT(1,J)
38456         JMOHKK(2,I)=JMOHKT(2,J)
38457       ENDIF
38458       JDAHKK(1,I)=JDAHKT(1,J)
38459       JDAHKK(2,I)=JDAHKT(2,J)
38460 C       IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
38461 C       JDAHKK(1,I)=I+2
38462 C     ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
38463 C       JDAHKK(1,I)=I+1
38464 C     ENDIF
38465       IF(JDAHKT(1,J).GT.0)THEN
38466         JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
38467       ENDIF
38468       PHKK(1,I)  =PHKT(1,J)
38469       PHKK(2,I)  =PHKT(2,J)
38470       PHKK(3,I)  =PHKT(3,J)
38471       PHKK(4,I)  =PHKT(4,J)
38472       PHKK(5,I)  =PHKT(5,J)
38473       VHKK(1,I)  =VHKT(1,J)
38474       VHKK(2,I)  =VHKT(2,J)
38475       VHKK(3,I)  =VHKT(3,J)
38476       VHKK(4,I)  =VHKT(4,J)
38477       WHKK(1,I)  =WHKT(1,J)
38478       WHKK(2,I)  =WHKT(2,J)
38479       WHKK(3,I)  =WHKT(3,J)
38480       WHKK(4,I)  =WHKT(4,J)
38481       RETURN
38482       END
38483
38484 *$ CREATE DT_DBREAK.FOR
38485 *COPY DT_DBREAK
38486 *
38487 *===dbreak=============================================================*
38488 *
38489       SUBROUTINE DT_DBREAK(MODE)
38490
38491 ************************************************************************
38492 * This is the steering subroutine for the different diquark breaking   *
38493 * mechanisms.                                                          *
38494 *                                                                      *
38495 * MODE = 1  breaking of projectile diquark in qq-q chain using         *
38496 *           a sea quark (q-qq chain) of the same projectile            *
38497 *      = 2  breaking of target     diquark in q-qq chain using         *
38498 *           a sea quark (qq-q chain) of the same target                *
38499 *      = 3  breaking of projectile diquark in qq-q chain using         *
38500 *           a sea quark (q-aq chain) of the same projectile            *
38501 *      = 4  breaking of target     diquark in q-qq chain using         *
38502 *           a sea quark (aq-q chain) of the same target                *
38503 *      = 5  breaking of projectile anti-diquark in aqaq-aq chain using *
38504 *           a sea anti-quark (aq-aqaq chain) of the same projectile    *
38505 *      = 6  breaking of target     anti-diquark in aq-aqaq chain using *
38506 *           a sea anti-quark (aqaq-aq chain) of the same target        *
38507 *      = 7  breaking of projectile anti-diquark in aqaq-aq chain using *
38508 *           a sea anti-quark (aq-q chain) of the same projectile       *
38509 *      = 8  breaking of target     anti-diquark in aq-aqaq chain using *
38510 *           a sea anti-quark (q-aq chain) of the same target           *
38511 *                                                                      *
38512 * Original version by J. Ranft.                                        *
38513 * This version dated 17.5.00  is written by S. Roesler.                *
38514 ************************************************************************
38515
38516       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38517       SAVE
38518
38519       PARAMETER ( LINP = 10 ,
38520      &            LOUT = 6 ,
38521      &            LDAT = 9 )
38522
38523 * event history
38524
38525       PARAMETER (NMXHKK=200000)
38526
38527       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38528      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38529      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38530
38531 * extended event history
38532       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38533      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38534      &                IHIST(2,NMXHKK)
38535
38536 * flags for input different options
38537       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
38538       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
38539      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
38540
38541 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
38542       PARAMETER (MAXCHN=10000)
38543       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
38544
38545 * diquark-breaking mechanism
38546       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38547
38548 * flags for particle decays
38549       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
38550      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
38551      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
38552
38553 *
38554 * chain identifiers
38555 * ( 1 = q-aq,   2 = aq-q,   3 = q-qq,   4 = qq-q,
38556 *   5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
38557       DIMENSION IDCHN1(8),IDCHN2(8)
38558       DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
38559       DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
38560 *
38561 * parton identifiers
38562 * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
38563 *   +-51/52 = unitarity-sea, +-61/62 = gluons )
38564       DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
38565       DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
38566      &             31, 31, 31, 31, 31, 31, 31, 31,
38567      &             41, 41, 41, 41, 51, 51, 51, 51/
38568       DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
38569      &             32, 32, 32, 32, 32, 32, 32, 32,
38570      &             42, 42, 42, 42, 52, 52, 52, 52/
38571       DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
38572      &             51, 31, 41, 41, 31, 31, 31, 31,
38573      &              0, 41, 51, 51, 51, 51, 51, 51/
38574       DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
38575      &             32, 52, 42, 42, 32, 32, 32, 32,
38576      &             42,  0, 52, 52, 52, 52, 52, 52/
38577
38578       IF (NCHAIN.LE.0) RETURN
38579       DO 1 I=1,NCHAIN
38580          IDX1 = IDXCHN(1,I)
38581          IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
38582          IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
38583          IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
38584      &       .AND.
38585      &        ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
38586      &                                    (IS1P.EQ.ISP1P(MODE,3)))
38587      &       .AND.
38588      &        ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
38589      &                                    (IS1T.EQ.ISP1T(MODE,3)))
38590      &      ) THEN
38591             DO 2 J=1,NCHAIN
38592                IDX2 = IDXCHN(1,J)
38593                IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
38594                IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
38595                IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
38596      &             .AND.
38597      &              ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
38598      &                                      .OR.(IS2P.EQ.ISP2P(MODE,3)))
38599      &             .AND.
38600      &              ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
38601      &                                      .OR.(IS2T.EQ.ISP2T(MODE,3)))
38602      &            ) THEN
38603 *   find mother nucleons of the diquark to be splitted and of the
38604 *   sea-quark and reject this combination if it is not the same
38605                   IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
38606      &                (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
38607                      IANCES = 1
38608                   ELSE
38609                      IANCES = 2
38610                   ENDIF
38611                   IDXMO1 = JMOHKK(IANCES,IDX1)
38612     4             CONTINUE
38613                   IF ((JMOHKK(1,IDXMO1).NE.0).AND.
38614      &                (JMOHKK(2,IDXMO1).NE.0)) THEN
38615                      IANC = IANCES
38616                   ELSE
38617                      IANC = 1
38618                   ENDIF
38619                   IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
38620                      IDXMO1 = JMOHKK(IANC,IDXMO1)
38621                      GOTO 4
38622                   ENDIF
38623                   IDXMO2 = JMOHKK(IANCES,IDX2)
38624     5             CONTINUE
38625                   IF ((JMOHKK(1,IDXMO2).NE.0).AND.
38626      &                (JMOHKK(2,IDXMO2).NE.0)) THEN
38627                      IANC = IANCES
38628                   ELSE
38629                      IANC = 1
38630                   ENDIF
38631                   IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
38632                      IDXMO2 = JMOHKK(IANC,IDXMO2)
38633                      GOTO 5
38634                   ENDIF
38635                   IF (IDXMO1.NE.IDXMO2) GOTO 2
38636 *   quark content of projectile parton
38637                   IP1   = IDHKK(JMOHKK(1,IDX1))
38638                   IP11  = IP1/1000
38639                   IP12  = (IP1-1000*IP11)/100
38640                   IP2   = IDHKK(JMOHKK(2,IDX1))
38641                   IP21  = IP2/1000
38642                   IP22  = (IP2-1000*IP21)/100
38643 *   quark content of target parton
38644                   IT1  = IDHKK(JMOHKK(1,IDX2))
38645                   IT11 = IT1/1000
38646                   IT12 = (IT1-1000*IT11)/100
38647                   IT2  = IDHKK(JMOHKK(2,IDX2))
38648                   IT21 = IT2/1000
38649                   IT22 = (IT2-1000*IT21)/100
38650 *   split diquark and form new chains
38651                   IF (MODE.EQ.1) THEN
38652                      IF (IT1.EQ.4) GOTO 2
38653                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38654      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38655      &                         IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
38656                   ELSEIF (MODE.EQ.2) THEN
38657                      IF (IT2.EQ.4) GOTO 2
38658                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38659      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38660      &                         IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
38661                   ELSEIF (MODE.EQ.3) THEN
38662                      IF (IT1.EQ.4) GOTO 2
38663                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38664      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38665      &                         IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
38666                   ELSEIF (MODE.EQ.4) THEN
38667                      IF (IT2.EQ.4) GOTO 2
38668                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38669      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38670      &                         IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
38671                   ELSEIF (MODE.EQ.5) THEN
38672                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38673      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38674      &                         IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
38675                   ELSEIF (MODE.EQ.6) THEN
38676                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38677      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38678      &                         IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
38679                   ELSEIF (MODE.EQ.7) THEN
38680                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38681      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38682      &                         IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
38683                   ELSEIF (MODE.EQ.8) THEN
38684                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38685      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38686      &                         IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
38687                   ENDIF
38688                   IF (IREJ.GE.1) THEN
38689                      if ((ipq.lt.0).or.(ipq.ge.4))
38690      &                  write(LOUT,*) 'ipq !!!',ipq,mode
38691                      DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38692 *   accept or reject new chains corresponding to PDBSEA
38693                   ELSE
38694                      IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
38695                         ACC   = DBRKA(1,MODE)+DBRKA(2,MODE)
38696                         REJ   = DBRKR(1,MODE)+DBRKR(2,MODE)
38697                      ELSEIF (IPQ.EQ.3) THEN
38698                         ACC   = DBRKA(3,MODE)
38699                         REJ   = DBRKR(3,MODE)
38700                      ELSE
38701                         WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
38702                         STOP
38703                      ENDIF
38704                      IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
38705                         DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
38706                         IACC = 1
38707                      ELSE
38708                         DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38709                         IACC = 0
38710                      ENDIF
38711 *   new chains have been accepted and are now copied into HKKEVT
38712                      IF (IACC.EQ.1) THEN
38713                         IF (LEMCCK) THEN
38714                            CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
38715      &                                    PHKK(3,IDX1),PHKK(4,IDX1),
38716      &                                    1,IDUM1,IDUM2)
38717                            CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
38718      &                                    PHKK(3,IDX2),PHKK(4,IDX2),
38719      &                                    2,IDUM1,IDUM2)
38720                         ENDIF
38721                         IDHKK(IDX1) = 99888
38722                         IDHKK(IDX2) = 99888
38723                         IDXCHN(2,I) = -1
38724                         IDXCHN(2,J) = -1
38725                         DO 3 K=1,IGCOUN
38726                            NHKK = NHKK+1
38727                            CALL HKKHKT(NHKK,K)
38728                            IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
38729                               PX = -PHKK(1,NHKK)
38730                               PY = -PHKK(2,NHKK)
38731                               PZ = -PHKK(3,NHKK)
38732                               PE = -PHKK(4,NHKK)
38733                               CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
38734                            ENDIF
38735     3                   CONTINUE
38736                         IF (LEMCCK) THEN
38737                            CHKLEV = 0.1D0
38738                            CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
38739      &                                                             IREJ)
38740                            IF (IREJ.NE.0) CALL DT_EVTOUT(4)
38741                         ENDIF
38742                         GOTO 1
38743                      ENDIF
38744                   ENDIF
38745                ENDIF
38746     2       CONTINUE
38747          ENDIF
38748     1 CONTINUE
38749       RETURN
38750       END
38751
38752 *$ CREATE DT_CQPAIR.FOR
38753 *COPY DT_CQPAIR
38754 *
38755 *===cqpair=============================================================*
38756 *
38757       SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
38758
38759 ************************************************************************
38760 * This subroutine Creates a Quark-antiquark PAIR from the sea.         *
38761 *                                                                      *
38762 *   XQMAX   maxium energy fraction of quark (input)                    *
38763 *   XAQMAX  maxium energy fraction of antiquark (input)                *
38764 *   XQ      energy fraction of quark (output)                          *
38765 *   XAQ     energy fraction of antiquark (output)                      *
38766 *   IFLV    quark flavour (- antiquark flavor) (output)                *
38767 *                                                                      *
38768 * This version dated 14.5.00  is written by S. Roesler.                *
38769 ************************************************************************
38770
38771       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38772       SAVE
38773
38774       PARAMETER ( LINP = 10 ,
38775      &            LOUT = 6 ,
38776      &            LDAT = 9 )
38777
38778 * Lorentz-parameters of the current interaction
38779       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38780      &                UMO,PPCM,EPROJ,PPROJ
38781
38782 *
38783       IREJ = 0
38784       XQ   = 0.0D0
38785       XAQ  = 0.0D0
38786 *
38787 * sample quark flavour
38788 *
38789 *  set seasq here (the one from DTCHAI should be used in the future)
38790       SEASQ = 0.5D0
38791       IFLV  = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
38792 *
38793 * sample energy fractions of sea pair
38794 * we first sample the energy fraction of a gluon and then split the gluon
38795 *
38796 *  maximum energy fraction of the gluon forced via input
38797       XGMAXI = XQMAX+XAQMAX
38798 *  minimum energy fraction of the gluon
38799       XTHR1 = 4.0D0 /UMO**2
38800       XTHR2 = 0.54D0/UMO**1.5D0
38801       XGMIN = MAX(XTHR1,XTHR2)
38802 *  maximum energy fraction of the gluon
38803       XGMAX = 0.3D0
38804       XGMAX = MIN(XGMAXI,XGMAX)
38805       IF (XGMIN.GE.XGMAX) THEN
38806          IREJ = 1
38807          RETURN
38808       ENDIF
38809 *
38810 *  sample energy fraction of the gluon
38811       NLOOP = 0
38812     1 CONTINUE
38813       NLOOP = NLOOP+1
38814       IF (NLOOP.GE.50) THEN
38815          IREJ = 1
38816          RETURN
38817       ENDIF
38818       XGLUON = DT_SAMSQX(XGMIN,XGMAX)
38819       EGLUON = XGLUON*UMO/2.0D0
38820 *
38821 *  split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
38822       ZMIN = MIN(0.1D0,0.5D0/EGLUON)
38823       ZMAX = 1.0D0-ZMIN
38824       RZ   = DT_RNDM(ZMAX)
38825       XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
38826       RQ   = DT_RNDM(ZMAX)
38827       IF (RQ.LT.0.5D0) THEN
38828          XQ  = XGLUON*XHLP
38829          XAQ = XGLUON-XQ
38830       ELSE
38831          XAQ = XGLUON*XHLP
38832          XQ  = XGLUON-XAQ
38833       ENDIF
38834       IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1
38835
38836       RETURN
38837       END