DPMJET/dpmjet3.0-4.f

   1 *
   2 *    +-------------------------------------------------------------+
   3 *    |                                                             |
   4 *    |                                                             |
   5 *    |                        DPMJET 3.0                           |
   6 *    |                                                             |
   7 *    |                                                             |
   8 *    |         S. Roesler+), R. Engel#), J. Ranft*)                |
   9 *    |                                                             |
  10 *    |         +) CERN, TIS-RP                                     |
  11 *    |            CH-1211 Geneva 23, Switzerland                   |
  12 *    |            Email: Stefan.Roesler@cern.ch                    |
  13 *    |                                                             |
  14 *    |         #) University of Delaware, BRI                      |
  15 *    |            Newark, DE 19716, USA                            |
  16 *    |                                                             |
  17 *    |         *) University of Siegen, Dept. of Physics           |
  18 *    |            D-57068 Siegen, Germany                          |
  19 *    |                                                             |
  20 *    |                                                             |
  21 *    |       http://home.cern.ch/sroesler/dpmjet3.html             |
  22 *    |                                                             |
  23 *    |                                                             |
  24 *    |       Monte Carlo models used for event generation:         |
  25 *    |          PHOJET 1.12, JETSET 7.4 and LEPTO 6.5.1            |
  26 *    |                                                             |
  27 *    +-------------------------------------------------------------+
  28 *
  29 *
  30 *===init===============================================================*
  31 *
  32 CDECK  ID>, DT_INIT
  33       SUBROUTINE DT_INIT(NCASES,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
  34      &                                             IDP,IGLAU)
  35
  36 ************************************************************************
  37 * Initialization of event generation                                   *
  38 * This version dated  7.4.98  is written by S. Roesler.                *
  39 ************************************************************************
  40
  41       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  42       SAVE
  43
  44       PARAMETER ( LINP = 5 ,
  45      &            LOUT = 6 ,
  46      &            LDAT = 9 )
  47
  48       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
  49
  50 * particle properties (BAMJET index convention)
  51       CHARACTER*8  ANAME
  52       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
  53      &                IICH(210),IIBAR(210),K1(210),K2(210)
  54 * names of hadrons used in input-cards
  55       CHARACTER*8 BTYPE
  56       COMMON /DTPAIN/ BTYPE(30)
  57
  58       INCLUDE './flukapro/(DIMPAR)'
  59       INCLUDE './flukapro/(PAREVT)'
  60       INCLUDE './flukapro/(EVAPAR)'
  61       INCLUDE './flukapro/(FRBKCM)'
  62
  63       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
  64
  65 * emulsion treatment
  66       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
  67      &                NCOMPO,IEMUL
  68 * Glauber formalism: parameters
  69       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
  70      &                BMAX(NCOMPX),BSTEP(NCOMPX),
  71      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
  72      &                NSITEB,NSTATB
  73 * Glauber formalism: cross sections
  74       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
  75      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
  76      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
  77      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
  78      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
  79      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
  80      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
  81      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
  82      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
  83      &                BSLOPE,NEBINI,NQBINI
  84 * interface HADRIN-DPM
  85       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
  86 * central particle production, impact parameter biasing
  87       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
  88 * parameter for intranuclear cascade
  89       LOGICAL LPAULI
  90       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
  91 * various options for treatment of partons (DTUNUC 1.x)
  92 * (chain recombination, Cronin,..)
  93       LOGICAL LCO2CR,LINTPT
  94       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
  95      &                LCO2CR,LINTPT
  96 * threshold values for x-sampling (DTUNUC 1.x)
  97       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
  98      &                SSMIMQ,VVMTHR
  99 * flags for input different options
 100       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
 101       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
 102      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
 103 * nuclear potential
 104       LOGICAL LFERMI
 105       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
 106      &                EBINDP(2),EBINDN(2),EPOT(2,210),
 107      &                ETACOU(2),ICOUL,LFERMI
 108 * n-n cross section fluctuations
 109       PARAMETER (NBINS = 1000)
 110       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
 111 * flags for particle decays
 112       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
 113      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
 114      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
 115 * diquark-breaking mechanism
 116       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
 117 * nucleon-nucleon event-generator
 118       CHARACTER*8 CMODEL
 119       LOGICAL LPHOIN
 120       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
 121 * properties of interacting particles
 122       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
 123 * properties of photon/lepton projectiles
 124       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
 125 * flags for diffractive interactions (DTUNUC 1.x)
 126       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
 127 * parameters for hA-diffraction
 128       COMMON /DTDIHA/ DIBETA,DIALPH
 129 * Lorentz-parameters of the current interaction
 130       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
 131      &                UMO,PPCM,EPROJ,PPROJ
 132 * kinematical cuts for lepton-nucleus interactions
 133       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
 134      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
 135 * VDM parameter for photon-nucleus interactions
 136       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
 137 * Glauber formalism: flags and parameters for statistics
 138       LOGICAL LPROD
 139       CHARACTER*8 CGLB
 140       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
 141 * cuts for variable energy runs
 142       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
 143 * flags for activated histograms
 144       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
 145
 146       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
 147
 148       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
 149
 150 * LEPTO
 151 **LUND single / double precision
 152       REAL CUT,PARL,TMPX,TMPY,TMPW2,TMPQ2,TMPU
 153       COMMON /LEPTOU/ CUT(14),LST(40),PARL(30),
 154      &                TMPX,TMPY,TMPW2,TMPQ2,TMPU
 155 * LEPTO
 156       REAL RPPN
 157       COMMON /LEPTOI/ RPPN,LEPIN,INTER
 158 * steering flags for qel neutrino scattering modules
 159       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
 160 * event flag
 161       COMMON /DTEVNO/ NEVENT,ICASCA
 162
 163       INTEGER PYCOMP
 164
 165 C     DIMENSION XPARA(5)
 166       DIMENSION XDUMB(40),IPRANG(5)
 167
 168       PARAMETER (MXCARD=58)
 169       CHARACTER*78 CLINE,CTITLE
 170       CHARACTER*60 CWHAT
 171       CHARACTER*8  BLANK,SDUM
 172       CHARACTER*10 CODE,CODEWD
 173       CHARACTER*72 HEADER
 174       LOGICAL LSTART,LEINP,LXSTAB
 175       DIMENSION WHAT(6),CODE(MXCARD)
 176       DATA CODE/
 177      &   'TITLE     ','PROJPAR   ','TARPAR    ','ENERGY    ',
 178      &   'MOMENTUM  ','CMENERGY  ','EMULSION  ','FERMI     ',
 179      &   'TAUFOR    ','PAULI     ','COULOMB   ','HADRIN    ',
 180      &   'EVAP      ','EMCCHECK  ','MODEL     ','PHOINPUT  ',
 181      &   'GLAUBERI  ','FLUCTUAT  ','CENTRAL   ','RECOMBIN  ',
 182      &   'COMBIJET  ','XCUTS     ','INTPT     ','CRONINPT  ',
 183      &   'SEADISTR  ','SEASU3    ','DIQUARKS  ','RESONANC  ',
 184      &   'DIFFRACT  ','SINGLECH  ','NOFRAGME  ','HADRONIZE ',
 185      &   'POPCORN   ','PARDECAY  ','BEAM      ','LUND-MSTU ',
 186      &   'LUND-MSTJ ','LUND-MDCY ','LUND-PARJ ','LUND-PARU ',
 187      &   'OUTLEVEL  ','FRAME     ','L-TAG     ','L-ETAG    ',
 188      &   'ECMS-CUT  ','VDM-PAR1  ','HISTOGRAM ','XS-TABLE  ',
 189      &   'GLAUB-PAR ','GLAUB-INI ','VDM-PAR2  ','XS-QELPRO ',
 190      &   'RNDMINIT  ','LEPTO-CUT ','LEPTO-LST ','LEPTO-PARL',
 191      &   'START     ','STOP      '/
 192       DATA BLANK /'        '/
 193
 194       DATA LSTART,LXSTAB,IFIRST /.TRUE.,.FALSE.,1/
 195       DATA CMEOLD /0.0D0/
 196
 197 * --- Added by Chiara
 198
 199       CHARACTER*100  ALIROOT
 200       CHARACTER*100 FILNAM
 201       INTEGER*4 LNROOT
 202       LOGICAL EXISTS
 203       ALIROOT=' '
 204
 205 *---------------------------------------------------------------------
 206 * at the first call of INIT: initialize event generation
 207       EPNSAV = EPN
 208       IF (LSTART) THEN
 209          CALL DT_TITLE
 210 *   initialization and test of the random number generator
 211          IF (ITRSPT.NE.1) THEN
 212
 213             CALL FL48UT (ISRM48,ISEED1,ISEED2)
 214             CALL FL48IN (54217137,ISEED1,ISEED2)
 215
 216          ENDIF
 217 *   initialization of BAMJET, DECAY and HADRIN
 218          CALL DT_DDATAR
 219          CALL DT_DHADDE
 220          CALL DT_DCHANT
 221          CALL DT_DCHANH
 222 *   set default values for input variables
 223          CALL DT_DEFAUL(EPN,PPN)
 224          IGLAU  = 0
 225          IXSQEL = 0
 226 *   flag for collision energy input
 227          LEINP  = .FALSE.
 228          LSTART = .FALSE.
 229       ENDIF
 230
 231 *---------------------------------------------------------------------
 232    10 CONTINUE
 233
 234 * bypass reading input cards (e.g. for use with Fluka)
 235 *  in this case Epn is expected to carry the beam momentum
 236       IF (NCASES.EQ.-1) THEN
 237          IP      = NPMASS
 238          IPZ     = NPCHAR
 239          PPN     = EPNSAV
 240          EPN     = ZERO
 241          CMENER  = ZERO
 242          LEINP   = .TRUE.
 243          MKCRON  = 0
 244          WHAT(1) = 1
 245          WHAT(2) = 0
 246          CODEWD  = 'START     '
 247          GOTO 900
 248       ENDIF
 249
 250 * read control card from input-unit LINP
 251 C      READ(LINP,'(A78)',END=9999) CLINE
 252 * ###   Read control card from specified file
 253 * ### Changed by Chiara (original version LINP=5)
 254 *      OPEN(UNIT=7,
 255 *     + FILE='/home/oppedisa/AliRoot/new/DPMJET/inp/PbPbLHC.inp',
 256 *     + STATUS='OLD')
 257
 258       CALL GETENVF('ALICE_ROOT',ALIROOT)
 259       LNROOT = LNBLNK(ALIROOT)
 260
 261       FILNAM=ALIROOT(1:LNROOT)//'/DPMJET/inp/PbPbLHC.inp'
 262       OPEN(UNIT=7,FILE=FILNAM,STATUS='OLD')
 263
 264
 265       READ(7,'(A78)',END=9999) CLINE
 266
 267       IF (CLINE(1:1).EQ.'*') THEN
 268 * comment-line
 269 C         WRITE(LOUT,'(A78)') CLINE
 270          GOTO 10
 271       ENDIF
 272 C     READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM
 273 C1000 FORMAT(A10,6E10.0,A8)
 274       DO 1008 I=1,6
 275          WHAT(I) = ZERO
 276  1008 CONTINUE
 277       READ(CLINE,1006,END=9999) CODEWD,CWHAT,SDUM
 278  1006 FORMAT(A10,A60,A8)
 279       READ(CWHAT,*,END=1007) (WHAT(I),I=1,6)
 280  1007 CONTINUE
 281       WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM
 282  1001 FORMAT(A10,6G10.3,A8)
 283
 284   900 CONTINUE
 285
 286 * check for valid control card and get card index
 287       ICW = 0
 288       DO 11 I=1,MXCARD
 289          IF (CODEWD.EQ.CODE(I)) ICW = I
 290    11 CONTINUE
 291       IF (ICW.EQ.0) THEN
 292          WRITE(LOUT,1002) CODEWD
 293  1002    FORMAT(/,1X,'---> ',A10,': invalid control-card !',/)
 294          GOTO 10
 295       ENDIF
 296
 297       GOTO(
 298 *------------------------------------------------------------
 299 *       TITLE   ,  PROJPAR ,  TARPAR  ,  ENERGY  ,  MOMENTUM,
 300      &  100     ,  110     ,  120     ,  130     ,  140     ,
 301 *
 302 *------------------------------------------------------------
 303 *       CMENERGY,  EMULSION,  FERMI   ,  TAUFOR  ,  PAULI   ,
 304      &  150     ,  160     ,  170     ,  180     ,  190     ,
 305 *
 306 *------------------------------------------------------------
 307 *       COULOMB ,  HADRIN  ,  EVAP    ,  EMCCHECK,  MODEL   ,
 308      &  200     ,  210     ,  220     ,  230     ,  240     ,
 309 *
 310 *------------------------------------------------------------
 311 *       PHOINPUT,  GLAUBERI,  FLUCTUAT,  CENTRAL ,  RECOMBIN,
 312      &  250     ,  260     ,  270     ,  280     ,  290     ,
 313 *
 314 *------------------------------------------------------------
 315 *       COMBIJET,  XCUTS   ,  INTPT   ,  CRONINPT,  SEADISTR,
 316      &  300     ,  310     ,  320     ,  330     ,  340     ,
 317 *
 318 *------------------------------------------------------------
 319 *       SEASU3  ,  DIQUARKS,  RESONANC,  DIFFRACT,  SINGLECH,
 320      &  350     ,  360     ,  370     ,  380     ,  390     ,
 321 *
 322 *------------------------------------------------------------
 323 *       NOFRAGME, HADRONIZE,  POPCORN ,  PARDECAY,  BEAM    ,
 324      &  400     ,  410     ,  420     ,  430     ,  440     ,
 325 *
 326 *------------------------------------------------------------
 327 *      LUND-MSTU, LUND-MSTJ, LUND-MDCY, LUND-PARJ, LUND-PARU,
 328      &  450     ,  451     ,  452     ,  460     ,  470     ,
 329 *
 330 *------------------------------------------------------------
 331 *       OUTLEVEL,  FRAME   , L-TAG    ,  L-ETAG  ,  ECMS-CUT,
 332      &  480     ,  490     ,  500     ,  510     ,  520     ,
 333 *
 334 *------------------------------------------------------------
 335 *       VDM-PAR1, HISTOGRAM, XS-TABLE , GLAUB-PAR, GLAUB-INI,
 336      &  530     ,  540     ,  550     ,  560     ,  565     ,
 337 *
 338 *------------------------------------------------------------
 339 *               ,          ,  VDM-PAR2, XS-QELPRO, RNDMINIT ,
 340      &                        570     ,  580     ,  590     ,
 341 *
 342 *------------------------------------------------------------
 343 *      LEPTO-CUT, LEPTO-LST,LEPTO-PARL,  START   ,  STOP    )
 344      &  600     ,  610     ,  620     ,  630     ,  640     ) , ICW
 345 *
 346 *------------------------------------------------------------
 347
 348       GOTO 10
 349
 350 *********************************************************************
 351 *                                                                   *
 352 *               control card:  codewd = TITLE                       *
 353 *                                                                   *
 354 *       what (1..6), sdum   no meaning                              *
 355 *                                                                   *
 356 *       Note:  The control-card following this must consist of      *
 357 *              a string of characters usually giving the title of   *
 358 *              the run.                                             *
 359 *                                                                   *
 360 *********************************************************************
 361
 362   100 CONTINUE
 363 C      READ(LINP,'(A78)') CTITLE
 364 * ###   Read control card from specified file
 365 * ### Changed by Chiara (original version LINP=5)
 366       READ(7,'(A78)') CTITLE
 367
 368       WRITE(LOUT,'(//,5X,A78,//)') CTITLE
 369       GOTO 10
 370
 371 *********************************************************************
 372 *                                                                   *
 373 *               control card:  codewd = PROJPAR                     *
 374 *                                                                   *
 375 *       what (1) =  mass number of projectile nucleus  default: 1   *
 376 *       what (2) =  charge of projectile nucleus       default: 1   *
 377 *       what (3..6)   no meaning                                    *
 378 *       sdum        projectile particle code word                   *
 379 *                                                                   *
 380 *       Note: If sdum is defined what (1..2) have no meaning.       *
 381 *                                                                   *
 382 *********************************************************************
 383
 384   110 CONTINUE
 385       IF (SDUM.EQ.BLANK) THEN
 386          IP     = INT(WHAT(1))
 387          IPZ    = INT(WHAT(2))
 388          IJPROJ = 1
 389          IBPROJ = 1
 390       ELSE
 391          IJPROJ = 0
 392          DO 111 II=1,30
 393             IF (SDUM.EQ.BTYPE(II)) THEN
 394                IP     = 1
 395                IPZ    = 1
 396                IF (II.EQ.26) THEN
 397                   IJPROJ = 135
 398                ELSEIF (II.EQ.27) THEN
 399                   IJPROJ = 136
 400                ELSEIF (II.EQ.28) THEN
 401                   IJPROJ = 133
 402                ELSEIF (II.EQ.29) THEN
 403                   IJPROJ = 134
 404                ELSE
 405                   IJPROJ = II
 406                ENDIF
 407                IBPROJ = IIBAR(IJPROJ)
 408 * photon
 409                IF ((IJPROJ.EQ.7).AND.(WHAT(1).GT.ZERO)) VIRT = WHAT(1)
 410 * lepton
 411                IF (((IJPROJ.EQ. 3).OR.(IJPROJ.EQ. 4).OR.
 412      &              (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11)).AND.
 413      &                              (WHAT(1).GT.ZERO)) Q2HI = WHAT(1)
 414             ENDIF
 415   111    CONTINUE
 416          IF (IJPROJ.EQ.0) THEN
 417             WRITE(LOUT,1110)
 418  1110       FORMAT(/,1X,'invalid PROJPAR card !',/)
 419             GOTO 9999
 420          ENDIF
 421       ENDIF
 422       GOTO 10
 423
 424 *********************************************************************
 425 *                                                                   *
 426 *               control card:  codewd = TARPAR                      *
 427 *                                                                   *
 428 *       what (1) =  mass number of target nucleus      default: 1   *
 429 *       what (2) =  charge of target nucleus           default: 1   *
 430 *       what (3..6)   no meaning                                    *
 431 *       sdum        target particle code word                       *
 432 *                                                                   *
 433 *       Note: If sdum is defined what (1..2) have no meaning.       *
 434 *                                                                   *
 435 *********************************************************************
 436
 437   120 CONTINUE
 438       IF (SDUM.EQ.BLANK) THEN
 439          IT     = INT(WHAT(1))
 440          ITZ    = INT(WHAT(2))
 441          IJTARG = 1
 442          IBTARG = 1
 443       ELSE
 444          IJTARG = 0
 445          DO 121 II=1,30
 446             IF (SDUM.EQ.BTYPE(II)) THEN
 447                IT     = 1
 448                ITZ    = 1
 449                IJTARG = II
 450                IBTARG = IIBAR(IJTARG)
 451             ENDIF
 452   121    CONTINUE
 453          IF (IJTARG.EQ.0) THEN
 454             WRITE(LOUT,1120)
 455  1120       FORMAT(/,1X,'invalid TARPAR card !',/)
 456             GOTO 9999
 457          ENDIF
 458       ENDIF
 459       GOTO 10
 460
 461 *********************************************************************
 462 *                                                                   *
 463 *               control card:  codewd = ENERGY                      *
 464 *                                                                   *
 465 *       what (1) =  energy (GeV) of projectile in Lab.              *
 466 *                   if what(1) < 0:  |what(1)| = kinetic energy     *
 467 *                                                default: 200 GeV   *
 468 *                   if |what(2)| > 0: min. energy for variable      *
 469 *                                     energy runs                   *
 470 *       what (2) =  max. energy for variable energy runs            *
 471 *                   if what(2) < 0:  |what(2)| = kinetic energy     *
 472 *                                                                   *
 473 *********************************************************************
 474
 475   130 CONTINUE
 476       EPN    = WHAT(1)
 477       PPN    = ZERO
 478       CMENER = ZERO
 479       IF ((ABS(WHAT(2)).GT.ZERO).AND.
 480      &    (ABS(WHAT(2)).GT.ABS(WHAT(1)))) THEN
 481          VARELO = WHAT(1)
 482          VAREHI = WHAT(2)
 483          EPN    = VAREHI
 484       ENDIF
 485       LEINP  = .TRUE.
 486       GOTO 10
 487
 488 *********************************************************************
 489 *                                                                   *
 490 *               control card:  codewd = MOMENTUM                    *
 491 *                                                                   *
 492 *       what (1) =  momentum (GeV/c) of projectile in Lab.          *
 493 *                                                default: 200 GeV/c *
 494 *       what (2..6), sdum   no meaning                              *
 495 *                                                                   *
 496 *********************************************************************
 497
 498   140 CONTINUE
 499       EPN    = ZERO
 500       PPN    = WHAT(1)
 501       CMENER = ZERO
 502       LEINP  = .TRUE.
 503       GOTO 10
 504
 505 *********************************************************************
 506 *                                                                   *
 507 *               control card:  codewd = CMENERGY                    *
 508 *                                                                   *
 509 *       what (1) =  energy in nucleon-nucleon cms.                  *
 510 *                                                default: none      *
 511 *       what (2..6), sdum   no meaning                              *
 512 *                                                                   *
 513 *********************************************************************
 514
 515   150 CONTINUE
 516       EPN    = ZERO
 517       PPN    = ZERO
 518       CMENER = WHAT(1)
 519       LEINP  = .TRUE.
 520       GOTO 10
 521
 522 *********************************************************************
 523 *                                                                   *
 524 *               control card:  codewd = EMULSION                    *
 525 *                                                                   *
 526 *               definition of nuclear emulsions                     *
 527 *                                                                   *
 528 *     what(1)      mass number of emulsion component                *
 529 *     what(2)      charge of emulsion component                     *
 530 *     what(3)      fraction of events in which a scattering on a    *
 531 *                  nucleus of this properties is performed          *
 532 *     what(4,5,6)  as what(1,2,3) but for another component         *
 533 *                                             default: no emulsion  *
 534 *     sdum         no meaning                                       *
 535 *                                                                   *
 536 *     Note: If this input-card is once used with valid parameters   *
 537 *           TARPAR is obsolete.                                     *
 538 *           Not the absolute values of the fractions are important  *
 539 *           but only the ratios of fractions of different comp.     *
 540 *           This control card can be repeatedly used to define      *
 541 *           emulsions consisting of up to 10 elements.              *
 542 *                                                                   *
 543 *********************************************************************
 544
 545   160 CONTINUE
 546       IF ((WHAT(1).GT.ZERO).AND.(WHAT(2).GT.ZERO)
 547      &                     .AND.(ABS(WHAT(3)).GT.ZERO)) THEN
 548          NCOMPO = NCOMPO+1
 549          IF (NCOMPO.GT.NCOMPX) THEN
 550             WRITE(LOUT,1600)
 551             STOP
 552          ENDIF
 553          IEMUMA(NCOMPO) = INT(WHAT(1))
 554          IEMUCH(NCOMPO) = INT(WHAT(2))
 555          EMUFRA(NCOMPO) = WHAT(3)
 556          IEMUL = 1
 557 C        CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
 558       ENDIF
 559       IF ((WHAT(4).GT.ZERO).AND.(WHAT(5).GT.ZERO)
 560      &                     .AND.(ABS(WHAT(6)).GT.ZERO)) THEN
 561          NCOMPO = NCOMPO+1
 562          IF (NCOMPO.GT.NCOMPX) THEN
 563             WRITE(LOUT,1001)
 564             STOP
 565          ENDIF
 566          IEMUMA(NCOMPO) = INT(WHAT(4))
 567          IEMUCH(NCOMPO) = INT(WHAT(5))
 568          EMUFRA(NCOMPO) = WHAT(6)
 569 C        CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
 570       ENDIF
 571  1600 FORMAT(1X,'too many emulsion components - program stopped')
 572       GOTO 10
 573
 574 *********************************************************************
 575 *                                                                   *
 576 *               control card:  codewd = FERMI                       *
 577 *                                                                   *
 578 *       what (1) = -1 Fermi-motion of nucleons not treated          *
 579 *                                                 default: 1        *
 580 *       what (2) =    scale factor for Fermi-momentum               *
 581 *                                                 default: 0.75     *
 582 *       what (3..6), sdum   no meaning                              *
 583 *                                                                   *
 584 *********************************************************************
 585
 586   170 CONTINUE
 587       IF (WHAT(1).EQ.-1.0D0) THEN
 588          LFERMI = .FALSE.
 589       ELSE
 590          LFERMI = .TRUE.
 591       ENDIF
 592       XMOD = WHAT(2)
 593       IF (XMOD.GE.ZERO) FERMOD = XMOD
 594       GOTO 10
 595
 596 *********************************************************************
 597 *                                                                   *
 598 *               control card:  codewd = TAUFOR                      *
 599 *                                                                   *
 600 *          formation time supressed intranuclear cascade            *
 601 *                                                                   *
 602 *    what (1)      formation time (in fm/c)                         *
 603 *                  note: what(1)=10. corresponds roughly to an      *
 604 *                        average formation time of 1 fm/c           *
 605 *                                                 default: 5. fm/c  *
 606 *    what (2)      number of generations followed                   *
 607 *                                                 default: 25       *
 608 *    what (3) = 1. p_t-dependent formation zone                     *
 609 *             = 2. constant formation zone                          *
 610 *                                                 default: 1        *
 611 *    what (4)      modus of selection of nucleus where the          *
 612 *                  cascade if followed first                        *
 613 *             = 1.  proj./target-nucleus with probab. 1/2           *
 614 *             = 2.  nucleus with highest mass                       *
 615 *             = 3.  proj. nucleus if particle is moving in pos. z   *
 616 *                   targ. nucleus if particle is moving in neg. z   *
 617 *                                                 default: 1        *
 618 *    what (5..6), sdum   no meaning                                 *
 619 *                                                                   *
 620 *********************************************************************
 621
 622   180 CONTINUE
 623       TAUFOR = WHAT(1)
 624       KTAUGE = INT(WHAT(2))
 625       INCMOD = 1
 626       IF ((WHAT(3).GE.1.0D0).AND.(WHAT(3).LE.2.0D0))
 627      &                                    ITAUVE = INT(WHAT(3))
 628       IF ((WHAT(4).GE.1.0D0).AND.(WHAT(4).LE.3.0D0))
 629      &                                    INCMOD = INT(WHAT(4))
 630       GOTO 10
 631
 632 *********************************************************************
 633 *                                                                   *
 634 *               control card:  codewd = PAULI                       *
 635 *                                                                   *
 636 *       what (1) =  -1  Pauli's principle for secondary             *
 637 *                       interactions not treated                    *
 638 *                                                    default: 1     *
 639 *       what (2..6), sdum   no meaning                              *
 640 *                                                                   *
 641 *********************************************************************
 642
 643   190 CONTINUE
 644       IF (WHAT(1).EQ.-1.0D0) THEN
 645          LPAULI = .FALSE.
 646       ELSE
 647          LPAULI = .TRUE.
 648       ENDIF
 649       GOTO 10
 650
 651 *********************************************************************
 652 *                                                                   *
 653 *               control card:  codewd = COULOMB                     *
 654 *                                                                   *
 655 *       what (1) = -1. Coulomb-energy treatment switched off        *
 656 *                                                    default: 1     *
 657 *       what (2..6), sdum   no meaning                              *
 658 *                                                                   *
 659 *********************************************************************
 660
 661   200 CONTINUE
 662       ICOUL = 1
 663       IF (WHAT(1).EQ.-1.0D0) THEN
 664          ICOUL = 0
 665       ELSE
 666          ICOUL = 1
 667       ENDIF
 668       GOTO 10
 669
 670 *********************************************************************
 671 *                                                                   *
 672 *               control card:  codewd = HADRIN                      *
 673 *                                                                   *
 674 *                       HADRIN module                               *
 675 *                                                                   *
 676 *    what (1) = 0. elastic/inelastic interactions with probab.      *
 677 *                  as defined by cross-sections                     *
 678 *             = 1. inelastic interactions forced                    *
 679 *             = 2. elastic interactions forced                      *
 680 *                                                 default: 1        *
 681 *    what (2)      upper threshold in total energy (GeV) below      *
 682 *                  which interactions are sampled by HADRIN         *
 683 *                                                 default: 5. GeV   *
 684 *    what (3..6), sdum   no meaning                                 *
 685 *                                                                   *
 686 *********************************************************************
 687
 688   210 CONTINUE
 689       IWHAT = INT(WHAT(1))
 690       IF ((IWHAT.GE.0).AND.(IWHAT.LE.2)) INTHAD = IWHAT
 691       IF ((WHAT(2).GT.ZERO).AND.(WHAT(2).LT.15.0D0)) EHADTH = WHAT(2)
 692       GOTO 10
 693
 694 *********************************************************************
 695 *                                                                   *
 696 *               control card:  codewd = EVAP                        *
 697 *                                                                   *
 698 *                    evaporation module                             *
 699 *                                                                   *
 700 *  what (1) =< -1 ==> evaporation is switched off                   *
 701 *           >=  1 ==> evaporation is performed                      *
 702 *                                                                   *
 703 *         what (1) = i1 + i2*10 + i3*100 + i4*10000                 *
 704 *                    (i1, i2, i3, i4 >= 0 )                         *
 705 *                                                                   *
 706 *   i1 is the flag for selecting the T=0 level density option used  *
 707 *      =  1: standard EVAP level densities with Cook pairing        *
 708 *            energies                                               *
 709 *      =  2: Z,N-dependent Gilbert & Cameron level densities        *
 710 *                                                        (default)  *
 711 *      =  3: Julich A-dependent level densities                     *
 712 *      =  4: Z,N-dependent Brancazio & Cameron level densities      *
 713 *                                                                   *
 714 *   i2 >= 1: high energy fission activated                          *
 715 *            (default high energy fission activated)                *
 716 *                                                                   *
 717 *   i3 =  0: No energy dependence for level densities               *
 718 *      =  1: Standard Ignyatuk (1975, 1st) energy dependence        *
 719 *            for level densities (default)                          *
 720 *      =  2: Standard Ignyatuk (1975, 1st) energy dependence        *
 721 *            for level densities with NOT used set of parameters    *
 722 *      =  3: Standard Ignyatuk (1975, 1st) energy dependence        *
 723 *            for level densities with NOT used set of parameters    *
 724 *      =  4: Second   Ignyatuk (1975, 2nd) energy dependence        *
 725 *            for level densities                                    *
 726 *      =  5: Second   Ignyatuk (1975, 2nd) energy dependence        *
 727 *            for level densities with fit 1 Iljinov & Mebel set of  *
 728 *            parameters                                             *
 729 *      =  6: Second   Ignyatuk (1975, 2nd) energy dependence        *
 730 *            for level densities with fit 2 Iljinov & Mebel set of  *
 731 *            parameters                                             *
 732 *      =  7: Second   Ignyatuk (1975, 2nd) energy dependence        *
 733 *            for level densities with fit 3 Iljinov & Mebel set of  *
 734 *            parameters                                             *
 735 *      =  8: Second   Ignyatuk (1975, 2nd) energy dependence        *
 736 *            for level densities with fit 4 Iljinov & Mebel set of  *
 737 *            parameters                                             *
 738 *                                                                   *
 739 *   i4 >= 1: Original Gilbert and Cameron pairing energies used     *
 740 *            (default Cook's modified pairing energies)             *
 741 *                                                                   *
 742 *  what (2) = ig + 10 * if   (ig and if must have the same sign)    *
 743 *                                                                   *
 744 *   ig =< -1 ==> deexcitation gammas are not produced               *
 745 *                (if the evaporation step is not performed          *
 746 *                 they are never produced)                          *
 747 *   if =< -1 ==> Fermi Break Up is not invoked                      *
 748 *                (if the evaporation step is not performed          *
 749 *                 it is never invoked)                              *
 750 *   The default is: deexcitation gamma produced and Fermi break up  *
 751 *                   activated for the new  preequilibrium, not      *
 752 *                   activated otherwise.                            *
 753 *  what (3..6), sdum   no meaning                                   *
 754 *                                                                   *
 755 *********************************************************************
 756
 757  220  CONTINUE
 758
 759       IF (WHAT(1).LE.-1.0D0) THEN
 760          LEVPRT = .FALSE.
 761          LDEEXG = .FALSE.
 762          LHEAVY = .FALSE.
 763          GOTO 10
 764       ENDIF
 765       WHTSAV = WHAT (1)
 766       IF ( NINT (WHAT (1)) .GE. 10000 ) THEN
 767          LLVMOD   = .FALSE.
 768          JLVHLP   = NINT (WHAT (1)) / 10000
 769          WHAT (1) = WHAT (1) - 10000.D+00 * JLVHLP
 770       END IF
 771       IF ( NINT (WHAT (1)) .GE. 100 ) THEN
 772          JLVMOD   = NINT (WHAT (1)) / 100
 773          WHAT (1) = WHAT (1) - 100.D+00 * JLVMOD
 774       END IF
 775       IF ( NINT (WHAT (1)) .GE. 10  ) THEN
 776          IFISS    = 1
 777          JLVHLP   = NINT (WHAT (1)) / 10
 778          WHAT (1) = WHAT (1) - 10.D+00 * JLVHLP
 779       ELSE IF ( NINT (WHTSAV) .NE. 0 ) THEN
 780          IFISS    = 0
 781       END IF
 782       IF ( NINT (WHAT (1)) .GE. 0 ) THEN
 783          LEVPRT = .TRUE.
 784          ILVMOD = NINT (WHAT(1))
 785          IF ( ABS (NINT (WHAT (2))) .GE. 10  ) THEN
 786             LFRMBK   = .TRUE.
 787             JLVHLP   = NINT (WHAT (2)) / 10
 788             WHAT (2) = WHAT (2) - 10.D+00 * JLVHLP
 789          ELSE IF ( NINT (WHAT (2)) .NE. 0 ) THEN
 790             LFRMBK   = .FALSE.
 791          END IF
 792          IF ( NINT (WHAT (2)) .GE. 0 ) THEN
 793             LDEEXG = .TRUE.
 794          ELSE
 795             LDEEXG = .FALSE.
 796          END IF
 797 **sr heavies are always put to /FKFHVY/
 798 C        IF ( NINT (WHAT(3)) .GE. 1 ) THEN
 799 C           LHEAVY = .TRUE.
 800 C        ELSE
 801 C           LHEAVY = .FALSE.
 802 C        END IF
 803          LHEAVY = .TRUE.
 804       ELSE
 805          LEVPRT = .FALSE.
 806          LDEEXG = .FALSE.
 807          LHEAVY = .FALSE.
 808       END IF
 809
 810       LOLDEV = .FALSE.
 811
 812       GOTO 10
 813
 814 *********************************************************************
 815 *                                                                   *
 816 *               control card:  codewd = EMCCHECK                    *
 817 *                                                                   *
 818 *    extended energy-momentum / quantum-number conservation check   *
 819 *                                                                   *
 820 *       what (1) = -1   extended check not performed                *
 821 *                                                    default: 1.    *
 822 *       what (2..6), sdum   no meaning                              *
 823 *                                                                   *
 824 *********************************************************************
 825
 826   230 CONTINUE
 827       IF (WHAT(1).EQ.-1) THEN
 828          LEMCCK = .FALSE.
 829       ELSE
 830          LEMCCK = .TRUE.
 831       ENDIF
 832       GOTO 10
 833
 834 *********************************************************************
 835 *                                                                   *
 836 *               control card:  codewd = MODEL                       *
 837 *                                                                   *
 838 *     Model to be used to treat nucleon-nucleon interactions        *
 839 *                                                                   *
 840 *       sdum = DTUNUC    two-chain model                            *
 841 *            = PHOJET    multiple chains including minijets         *
 842 *            = LEPTO     DIS                                        *
 843 *            = QNEUTRIN  quasi-elastic neutrino scattering          *
 844 *                                                  default: PHOJET  *
 845 *                                                                   *
 846 *       if sdum = LEPTO:                                            *
 847 *       what (1)         (variable INTER)                           *
 848 *                        = 1  gamma exchange                        *
 849 *                        = 2  W+-   exchange                        *
 850 *                        = 3  Z0    exchange                        *
 851 *                        = 4  gamma/Z0 exchange                     *
 852 *                                                                   *
 853 *       if sdum = QNEUTRIN:                                         *
 854 *       what (1)         = 0  elastic scattering on nucleon and     *
 855 *                             tau does not decay (default)          *
 856 *                        = 1  decay of tau into mu..                *
 857 *                        = 2  decay of tau into e..                 *
 858 *                        = 10 CC events on p and n                  *
 859 *                        = 11 NC events on p and n                  *
 860 *                                                                   *
 861 *       what (2..6)      no meaning                                 *
 862 *                                                                   *
 863 *********************************************************************
 864
 865   240 CONTINUE
 866       IF (SDUM.EQ.CMODEL(1)) THEN
 867          MCGENE = 1
 868       ELSEIF (SDUM.EQ.CMODEL(2)) THEN
 869          MCGENE = 2
 870       ELSEIF (SDUM.EQ.CMODEL(3)) THEN
 871          MCGENE = 3
 872          IF ((WHAT(1).GE.1.0D0).AND.(WHAT(1).LE.4.0D0))
 873      &      INTER = INT(WHAT(1))
 874       ELSEIF (SDUM.EQ.CMODEL(4)) THEN
 875          MCGENE = 4
 876          IWHAT  = INT(WHAT(1))
 877          IF ((IWHAT.EQ.1 ).OR.(IWHAT.EQ.2 ).OR.
 878      &       (IWHAT.EQ.10).OR.(IWHAT.EQ.11))
 879      &      NEUDEC = IWHAT
 880       ELSE
 881          STOP ' Unknown model !'
 882       ENDIF
 883       GOTO 10
 884
 885 *********************************************************************
 886 *                                                                   *
 887 *               control card:  codewd = PHOINPUT                    *
 888 *                                                                   *
 889 *       Start of input-section for PHOJET-specific input-cards      *
 890 *       Note:  This section will not be finished before giving      *
 891 *              ENDINPUT-card                                        *
 892 *       what (1..6), sdum   no meaning                              *
 893 *                                                                   *
 894 *********************************************************************
 895
 896   250 CONTINUE
 897       IF (LPHOIN) THEN
 898
 899 C         CALL PHO_INIT(LINP,IREJ1)
 900 * ###   Read control card from specified file
 901 * ### Changed by Chiara (original version LINP=5)
 902          CALL PHO_INIT(7,IREJ1)
 903
 904          IF (IREJ1.NE.0) THEN
 905             WRITE(LOUT,'(1X,A)')'INIT:   reading PHOJET-input failed'
 906             STOP
 907          ENDIF
 908          LPHOIN = .FALSE.
 909       ENDIF
 910       GOTO 10
 911
 912 *********************************************************************
 913 *                                                                   *
 914 *               control card:  codewd = GLAUBERI                    *
 915 *                                                                   *
 916 *        Pre-initialization of impact parameter selection           *
 917 *                                                                   *
 918 *        what (1..6), sdum   no meaning                             *
 919 *                                                                   *
 920 *********************************************************************
 921
 922   260 CONTINUE
 923       IF (IFIRST.NE.99) THEN
 924          CALL DT_RNDMST(12,34,56,78)
 925          CALL DT_RNDMTE(1)
 926          OPEN(40,FILE='shm.out',STATUS='UNKNOWN')
 927 C        OPEN(11,FILE='shm.dbg',STATUS='UNKNOWN')
 928          IFIRST = 99
 929       ENDIF
 930
 931       IPPN = 8
 932       PLOW = 10.0D0
 933 C     IPPN = 1
 934 C     PLOW = 100.0D0
 935       PHI  = 1.0D5
 936       APLOW = LOG10(PLOW)
 937       APHI  = LOG10(PHI)
 938       ADP   = (APHI-APLOW)/DBLE(IPPN)
 939
 940       IPLOW = 1
 941       IDIP  = 1
 942       IIP   = 5
 943 C     IPLOW = 1
 944 C     IDIP  = 1
 945 C     IIP   = 1
 946       IPRANG(1) = 1
 947       IPRANG(2) = 2
 948       IPRANG(3) = 5
 949       IPRANG(4) = 10
 950       IPRANG(5) = 20
 951
 952       ITLOW = 30
 953       IDIT  = 3
 954       IIT   = 60
 955 C     IDIT  = 10
 956 C     IIT   = 21
 957
 958       DO 473 NCIT=1,IIT
 959          IT   = ITLOW+(NCIT-1)*IDIT
 960 C        IPHI = IT
 961 C        IDIP = 10
 962 C        IIP  = (IPHI-IPLOW)/IDIP
 963 C        IF (IIP.EQ.0) IIP = 1
 964 C        IF (IT.EQ.IPLOW) IIP = 0
 965
 966          DO 472 NCIP=1,IIP
 967             IP = IPRANG(NCIP)
 968 CC           IF (NCIP.LE.IIP) THEN
 969 C               IP = IPLOW+(NCIP-1)*IDIP
 970 CC           ELSE
 971 CC              IP = IT
 972 CC           ENDIF
 973             IF (IP.GT.IT) GOTO 472
 974
 975             DO 471 NCP=1,IPPN+1
 976                APPN = APLOW+DBLE(NCP-1)*ADP
 977                PPN  = 10**APPN
 978
 979                OPEN(12,FILE='shm.sta',STATUS='UNKNOWN')
 980                WRITE(12,'(1X,2I5,E15.3)') IP,IT,PPN
 981                CLOSE(12)
 982
 983                XLIM1 = 0.0D0
 984                XLIM2 = 50.0D0
 985                XLIM3 = ZERO
 986                IBIN  = 50
 987                CALL DT_NEWHGR(XDUM,XDUM,XDUM,XDUMB,-1,IHDUM)
 988                CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHSHMA)
 989
 990                NEVFIT = 5
 991 C              IF ((IP.GT.10).OR.(IT.GT.10)) THEN
 992 C                 NEVFIT = 5
 993 C              ELSE
 994 C                 NEVFIT = 10
 995 C              ENDIF
 996                SIGAV  = 0.0D0
 997
 998                DO 478 I=1,NEVFIT
 999                   CALL DT_SHMAKI(IP,IDUM1,IT,IDUM1,IJPROJ,PPN,99)
1000                   SIGAV = SIGAV+XSPRO(1,1,1)
1001                   DO 479 J=1,50
1002                      XC = DBLE(J)
1003                      CALL DT_FILHGR(XC,BSITE(1,1,1,J),IHSHMA,I)
1004   479             CONTINUE
1005   478          CONTINUE
1006
1007                CALL DT_EVTHIS(IDUM)
1008                HEADER = ' BSITE'
1009 C              CALL OUTGEN(IHSHMA,0,0,0,0,0,HEADER,0,NEVFIT,ONE,0,1,-1)
1010
1011 C              CALL GENFIT(XPARA)
1012 C              WRITE(40,'(2I4,E11.3,F6.0,5E11.3)')
1013 C    &              IP,IT,PPN,SIGAV/DBLE(NEVFIT),XPARA
1014
1015   471       CONTINUE
1016
1017   472    CONTINUE
1018
1019   473 CONTINUE
1020
1021       STOP
1022
1023 *********************************************************************
1024 *                                                                   *
1025 *               control card:  codewd = FLUCTUAT                    *
1026 *                                                                   *
1027 *           Treatment of cross section fluctuations                 *
1028 *                                                                   *
1029 *       what (1) = 1  treat cross section fluctuations              *
1030 *                                                    default: 0.    *
1031 *       what (1..6), sdum   no meaning                              *
1032 *                                                                   *
1033 *********************************************************************
1034
1035  270  CONTINUE
1036       IFLUCT = 0
1037       IF (WHAT(1).EQ.ONE) THEN
1038          IFLUCT = 1
1039          CALL DT_FLUINI
1040       ENDIF
1041       GOTO 10
1042
1043 *********************************************************************
1044 *                                                                   *
1045 *               control card:  codewd = CENTRAL                     *
1046 *                                                                   *
1047 *       what (1) = 1.  central production forced     default: 0     *
1048 *  if what (1) < 0 and > -100                                       *
1049 *       what (2) = min. impact parameter             default: 0     *
1050 *       what (3) = max. impact parameter             default: b_max *
1051 *  if what (1) < -99                                                *
1052 *       what (2) = fraction of cross section         default: 1     *
1053 *  if what (1) = -1 : evaporation/fzc suppressed                    *
1054 *  if what (1) < -1 : evaporation/fzc allowed                       *
1055 *                                                                   *
1056 *       what (4..6), sdum   no meaning                              *
1057 *                                                                   *
1058 *********************************************************************
1059
1060   280 CONTINUE
1061       ICENTR = INT(WHAT(1))
1062       IF (ICENTR.LT.0) THEN
1063          IF (ICENTR.GT.-100) THEN
1064             BIMIN = WHAT(2)
1065             BIMAX = WHAT(3)
1066          ELSE
1067             XSFRAC = WHAT(2)
1068          ENDIF
1069       ENDIF
1070       GOTO 10
1071
1072 *********************************************************************
1073 *                                                                   *
1074 *               control card:  codewd = RECOMBIN                    *
1075 *                                                                   *
1076 *                     Chain recombination                           *
1077 *        (recombine S-S and V-V chains to V-S chains)               *
1078 *                                                                   *
1079 *       what (1) = -1. recombination switched off    default: 1     *
1080 *       what (2..6), sdum   no meaning                              *
1081 *                                                                   *
1082 *********************************************************************
1083
1084   290 CONTINUE
1085       IRECOM = 1
1086       IF (WHAT(1).EQ.-1.0D0) IRECOM = 0
1087       GOTO 10
1088
1089 *********************************************************************
1090 *                                                                   *
1091 *               control card:  codewd = COMBIJET                    *
1092 *                                                                   *
1093 *               chain fusion (2 q-aq --> qq-aqaq)                   *
1094 *                                                                   *
1095 *       what (1) = 1   fusion treated                               *
1096 *                                                    default: 0.    *
1097 *       what (2)       minimum number of uncombined chains from     *
1098 *                      single projectile or target nucleons         *
1099 *                                                    default: 0.    *
1100 *       what (3..6), sdum   no meaning                              *
1101 *                                                                   *
1102 *********************************************************************
1103
1104   300 CONTINUE
1105       LCO2CR = .FALSE.
1106       IF (INT(WHAT(1)).EQ.1) LCO2CR = .TRUE.
1107       IF (WHAT(2).GE.ZERO) CUTOF = WHAT(2)
1108       GOTO 10
1109
1110 *********************************************************************
1111 *                                                                   *
1112 *               control card:  codewd = XCUTS                       *
1113 *                                                                   *
1114 *                 thresholds for x-sampling                         *
1115 *                                                                   *
1116 *    what (1)    defines lower threshold for val.-q x-value (CVQ)   *
1117 *                                                 default: 1.       *
1118 *    what (2)    defines lower threshold for val.-qq x-value (CDQ)  *
1119 *                                                 default: 2.       *
1120 *    what (3)    defines lower threshold for sea-q x-value (CSEA)   *
1121 *                                                 default: 0.2      *
1122 *    what (4)    sea-q x-values in S-S chains (SSMIMA)              *
1123 *                                                 default: 0.14     *
1124 *    what (5)    not used                                           *
1125 *                                                 default: 2.       *
1126 *    what (6), sdum   no meaning                                    *
1127 *                                                                   *
1128 *    Note: Lower thresholds (what(1..3)) are def. as x_thr=CXXX/ECM *
1129 *                                                                   *
1130 *********************************************************************
1131
1132   310 CONTINUE
1133       IF (WHAT(1).GE.0.5D0) CVQ    = WHAT(1)
1134       IF (WHAT(2).GE.ONE)   CDQ    = WHAT(2)
1135       IF (WHAT(3).GE.0.1D0) CSEA   = WHAT(3)
1136       IF (WHAT(4).GE.ZERO) THEN
1137          SSMIMA = WHAT(4)
1138          SSMIMQ = SSMIMA**2
1139       ENDIF
1140       IF (WHAT(5).GT.2.0D0) VVMTHR = WHAT(5)
1141       GOTO 10
1142
1143 *********************************************************************
1144 *                                                                   *
1145 *               control card:  codewd = INTPT                       *
1146 *                                                                   *
1147 *     what (1) = -1   intrinsic transverse momenta of partons       *
1148 *                     not treated                default: 1         *
1149 *     what (2..6), sdum   no meaning                                *
1150 *                                                                   *
1151 *********************************************************************
1152
1153   320 CONTINUE
1154       IF (WHAT(1).EQ.-1.0D0) THEN
1155          LINTPT = .FALSE.
1156       ELSE
1157          LINTPT = .TRUE.
1158       ENDIF
1159       GOTO 10
1160
1161 *********************************************************************
1162 *                                                                   *
1163 *               control card:  codewd = CRONINPT                    *
1164 *                                                                   *
1165 *    Cronin effect (multiple scattering of partons at chain ends)   *
1166 *                                                                   *
1167 *       what (1) = -1  Cronin effect not treated     default: 1     *
1168 *       what (2) = 0   scattering parameter          default: 0.64  *
1169 *       what (3..6), sdum   no meaning                              *
1170 *                                                                   *
1171 *********************************************************************
1172
1173   330 CONTINUE
1174       IF (WHAT(1).EQ.-1.0D0) THEN
1175          MKCRON = 0
1176       ELSE
1177          MKCRON = 1
1178       ENDIF
1179       CRONCO = WHAT(2)
1180       GOTO 10
1181
1182 *********************************************************************
1183 *                                                                   *
1184 *               control card:  codewd = SEADISTR                    *
1185 *                                                                   *
1186 *     what (1)  (XSEACO)  sea(x) prop. 1/x**what (1)   default: 1.  *
1187 *     what (2)  (UNON)                                 default: 2.  *
1188 *     what (3)  (UNOM)                                 default: 1.5 *
1189 *     what (4)  (UNOSEA)                               default: 5.  *
1190 *                        qdis(x) prop. (1-x)**what (1)  etc.        *
1191 *     what (5..6), sdum   no meaning                                *
1192 *                                                                   *
1193 *********************************************************************
1194
1195   340 CONTINUE
1196       XSEACO = WHAT(1)
1197       XSEACU = 1.05D0-XSEACO
1198       UNON   = WHAT(2)
1199       IF (UNON.LT.0.1D0) UNON = 2.0D0
1200       UNOM   = WHAT(3)
1201       IF (UNOM.LT.0.1D0) UNOM = 1.5D0
1202       UNOSEA = WHAT(4)
1203       IF (UNOSEA.LT.0.1D0) UNOSEA = 5.0D0
1204       GOTO 10
1205
1206 *********************************************************************
1207 *                                                                   *
1208 *               control card:  codewd = SEASU3                      *
1209 *                                                                   *
1210 *          Treatment of strange-quarks at chain ends                *
1211 *                                                                   *
1212 *       what (1)   (SEASQ)  strange-quark supression factor         *
1213 *                  iflav = 1.+rndm*(2.+SEASQ)                       *
1214 *                                                    default: 1.    *
1215 *       what (2..6), sdum   no meaning                              *
1216 *                                                                   *
1217 *********************************************************************
1218
1219   350 CONTINUE
1220       SEASQ = WHAT(1)
1221       GOTO 10
1222
1223 *********************************************************************
1224 *                                                                   *
1225 *               control card:  codewd = DIQUARKS                    *
1226 *                                                                   *
1227 *     what (1) = -1.  sea-diquark/antidiquark-pairs not treated     *
1228 *                                                    default: 1.    *
1229 *     what (2..6), sdum   no meaning                                *
1230 *                                                                   *
1231 *********************************************************************
1232
1233  360  CONTINUE
1234       IF (WHAT(1).EQ.-1.0D0) THEN
1235          LSEADI = .FALSE.
1236       ELSE
1237          LSEADI = .TRUE.
1238       ENDIF
1239       GOTO 10
1240
1241 *********************************************************************
1242 *                                                                   *
1243 *               control card:  codewd = RESONANC                    *
1244 *                                                                   *
1245 *                 treatment of low mass chains                      *
1246 *                                                                   *
1247 *    what (1) = -1 low chain masses are not corrected for resonance *
1248 *                  masses (obsolete for BAMJET-fragmentation)       *
1249 *                                       default: 1.                 *
1250 *    what (2) = -1 massless partons     default: 1. (massive)       *
1251 *                                       default: 1. (massive)       *
1252 *    what (3) = -1 chain-system containing chain of too small       *
1253 *                  mass is rejected (note: this does not fully      *
1254 *                  apply to S-S chains) default: 0.                 *
1255 *    what (4..6), sdum   no meaning                                 *
1256 *                                                                   *
1257 *********************************************************************
1258
1259   370 CONTINUE
1260       IRESCO = 1
1261       IMSHL  = 1
1262       IRESRJ = 0
1263       IF (WHAT(1).EQ.-ONE) IRESCO = 0
1264       IF (WHAT(2).EQ.-ONE) IMSHL  = 0
1265       IF (WHAT(3).EQ.-ONE) IRESRJ = 1
1266       GOTO 10
1267
1268 *********************************************************************
1269 *                                                                   *
1270 *               control card:  codewd = DIFFRACT                    *
1271 *                                                                   *
1272 *                Treatment of diffractive events                    *
1273 *                                                                   *
1274 *     what (1) = (ISINGD) 0  no single diffraction                  *
1275 *                         1  single diffraction included            *
1276 *                       +-2  single diffractive events only         *
1277 *                       +-3  projectile single diffraction only     *
1278 *                       +-4  target single diffraction only         *
1279 *                        -5  double pomeron exchange only           *
1280 *                      (neg. sign applies to PHOJET events)         *
1281 *                                                     default: 0.   *
1282 *                                                                   *
1283 *     what (2) = (IDOUBD) 0  no double diffraction                  *
1284 *                         1  double diffraction included            *
1285 *                         2  double diffractive events only         *
1286 *                                                     default: 0.   *
1287 *     what (3) = 1 projectile diffraction treated (2-channel form.) *
1288 *                                                     default: 0.   *
1289 *     what (4) = alpha-parameter in projectile diffraction          *
1290 *                                                     default: 0.   *
1291 *     what (5..6), sdum   no meaning                                *
1292 *                                                                   *
1293 *********************************************************************
1294
1295   380 CONTINUE
1296       IF (ABS(WHAT(1)).GT.ZERO) ISINGD = INT(WHAT(1))
1297       IF (ABS(WHAT(2)).GT.ZERO) IDOUBD = INT(WHAT(2))
1298       IF ((ISINGD.GT.1).AND.(IDOUBD.GT.1)) THEN
1299          WRITE(LOUT,1380)
1300  1380    FORMAT(1X,'INIT:   inconsistent DIFFRACT - input !',/,
1301      &          11X,'IDOUBD is reset to zero')
1302          IDOUBD = 0
1303       ENDIF
1304       IF (WHAT(3).GT.ZERO) DIBETA = WHAT(3)
1305       IF (WHAT(4).GT.ZERO) DIALPH = WHAT(4)
1306       GOTO 10
1307
1308 *********************************************************************
1309 *                                                                   *
1310 *               control card:  codewd = SINGLECH                    *
1311 *                                                                   *
1312 *       what (1) = 1.  Regge contribution (one chain) included      *
1313 *                                                   default: 0.     *
1314 *       what (2..6), sdum   no meaning                              *
1315 *                                                                   *
1316 *********************************************************************
1317
1318  390  CONTINUE
1319       ISICHA = 0
1320       IF (WHAT(1).EQ.ONE) ISICHA = 1
1321       GOTO 10
1322
1323 *********************************************************************
1324 *                                                                   *
1325 *               control card:  codewd = NOFRAGME                    *
1326 *                                                                   *
1327 *                 biased chain hadronization                        *
1328 *                                                                   *
1329 *       what (1..6) = -1  no of hadronizsation of S-S chains        *
1330 *                   = -2  no of hadronizsation of D-S chains        *
1331 *                   = -3  no of hadronizsation of S-D chains        *
1332 *                   = -4  no of hadronizsation of S-V chains        *
1333 *                   = -5  no of hadronizsation of D-V chains        *
1334 *                   = -6  no of hadronizsation of V-S chains        *
1335 *                   = -7  no of hadronizsation of V-D chains        *
1336 *                   = -8  no of hadronizsation of V-V chains        *
1337 *                   = -9  no of hadronizsation of comb. chains      *
1338 *                                  default:  complete hadronization *
1339 *       sdum   no meaning                                           *
1340 *                                                                   *
1341 *********************************************************************
1342
1343   400 CONTINUE
1344       DO 401 I=1,6
1345          ICHAIN = INT(WHAT(I))
1346          IF ((ICHAIN.LE.-1).AND.(ICHAIN.GE.-9))
1347      &      LHADRO(ABS(ICHAIN)) = .FALSE.
1348   401 CONTINUE
1349       GOTO 10
1350
1351 *********************************************************************
1352 *                                                                   *
1353 *               control card:  codewd = HADRONIZE                   *
1354 *                                                                   *
1355 *           hadronization model and parameter switch                *
1356 *                                                                   *
1357 *       what (1) = 1    hadronization via BAMJET                    *
1358 *                = 2    hadronization via JETSET                    *
1359 *                                                    default: 2     *
1360 *       what (2) = 1..3 parameter set to be used                    *
1361 *                       JETSET: 3 sets available                    *
1362 *                               ( = 3 default JETSET-parameters)    *
1363 *                       BAMJET: 1 set available                     *
1364 *                                                    default: 1     *
1365 *       what (3..6), sdum   no meaning                              *
1366 *                                                                   *
1367 *********************************************************************
1368
1369   410 CONTINUE
1370       IWHAT1 = INT(WHAT(1))
1371       IWHAT2 = INT(WHAT(2))
1372       IF ((IWHAT1.EQ.1).OR.(IWHAT1.EQ.2)) IFRAG(1) = IWHAT1
1373       IF ((IWHAT1.EQ.2).AND.(IWHAT2.GE.1).AND.(IWHAT2.LE.3))
1374      &                                    IFRAG(2) = IWHAT2
1375       GOTO 10
1376
1377 *********************************************************************
1378 *                                                                   *
1379 *               control card:  codewd = POPCORN                     *
1380 *                                                                   *
1381 *  "Popcorn-effect" in fragmentation and diquark breaking diagrams  *
1382 *                                                                   *
1383 *   what (1) = (PDB) frac. of diquark fragmenting directly into     *
1384 *                    baryons (PYTHIA/JETSET fragmentation)          *
1385 *                    (JETSET: = 0. Popcorn mechanism switched off)  *
1386 *                                                    default: 0.5   *
1387 *   what (2) = probability for accepting a diquark breaking         *
1388 *              diagram involving the generation of a u/d quark-     *
1389 *              antiquark pair                        default: 0.0   *
1390 *   what (3) = same a what (2), here for s quark-antiquark pair     *
1391 *                                                    default: 0.0   *
1392 *   what (4..6), sdum   no meaning                                  *
1393 *                                                                   *
1394 *********************************************************************
1395
1396   420 CONTINUE
1397       IF (WHAT(1).GE.0.0D0) PDB = WHAT(1)
1398       IF (WHAT(2).GE.0.0D0) THEN
1399          PDBSEA(1) = WHAT(2)
1400          PDBSEA(2) = WHAT(2)
1401       ENDIF
1402       IF (WHAT(3).GE.0.0D0) PDBSEA(3) = WHAT(3)
1403       DO 421 I=1,8
1404          DBRKA(1,I) = DBRKR(1,I)*PDBSEA(1)/(1.D0-PDBSEA(1))
1405          DBRKA(2,I) = DBRKR(2,I)*PDBSEA(2)/(1.D0-PDBSEA(2))
1406          DBRKA(3,I) = DBRKR(3,I)*PDBSEA(3)/(1.D0-PDBSEA(3))
1407   421 CONTINUE
1408       GOTO 10
1409
1410 *********************************************************************
1411 *                                                                   *
1412 *               control card:  codewd = PARDECAY                    *
1413 *                                                                   *
1414 *      what (1) = 1.  Sigma0/Asigma0 are decaying within JETSET     *
1415 *               = 2.  pion^0 decay after intranucl. cascade         *
1416 *                                                default: no decay  *
1417 *      what (2..6), sdum   no meaning                               *
1418 *                                                                   *
1419 *********************************************************************
1420
1421  430  CONTINUE
1422       IF (WHAT(1).EQ.ONE)  ISIG0 = 1
1423       IF (WHAT(1).EQ.2.0D0) IPI0 = 1
1424       GOTO 10
1425
1426 *********************************************************************
1427 *                                                                   *
1428 *               control card:  codewd = BEAM                        *
1429 *                                                                   *
1430 *              definition of beam parameters                        *
1431 *                                                                   *
1432 *      what (1/2)  > 0 : energy of beam 1/2 (GeV)                   *
1433 *                  < 0 : abs(what(1/2)) energy per charge of        *
1434 *                        beam 1/2 (GeV)                             *
1435 *                  (beam 1 is directed into positive z-direction)   *
1436 *      what (3)    beam crossing angle, defined as 2x angle between *
1437 *                  one beam and the z-axis (micro rad)              *
1438 *      what (4)    angle with x-axis defining the collision plane   *
1439 *      what (5..6), sdum   no meaning                               *
1440 *                                                                   *
1441 *      Note: this card requires previously defined projectile and   *
1442 *            target identities (PROJPAR, TARPAR)                    *
1443 *                                                                   *
1444 *********************************************************************
1445
1446   440 CONTINUE
1447       CALL DT_BEAMPR(WHAT,PPN,1)
1448       EPN    = ZERO
1449       CMENER = ZERO
1450       LEINP  = .TRUE.
1451       GOTO 10
1452
1453 *********************************************************************
1454 *                                                                   *
1455 *               control card:  codewd = LUND-MSTU                   *
1456 *                                                                   *
1457 *          set parameter MSTU in JETSET-common /LUDAT1/             *
1458 *                                                                   *
1459 *       what (1) =  index according to LUND-common block            *
1460 *       what (2) =  new value of MSTU( int(what(1)) )               *
1461 *       what (3), what(4) and what (5), what(6) further             *
1462 *                   parameter in the same way as what (1) and       *
1463 *                   what (2)                                        *
1464 *                        default: default-Lund or corresponding to  *
1465 *                                 the set given in HADRONIZE        *
1466 *                                                                   *
1467 *********************************************************************
1468
1469   450 CONTINUE
1470       IF (WHAT(1).GT.ZERO) THEN
1471          NMSTU = NMSTU+1
1472          IMSTU(NMSTU) = INT(WHAT(1))
1473          MSTUX(NMSTU) = INT(WHAT(2))
1474       ENDIF
1475       IF (WHAT(3).GT.ZERO) THEN
1476          NMSTU = NMSTU+1
1477          IMSTU(NMSTU) = INT(WHAT(3))
1478          MSTUX(NMSTU) = INT(WHAT(4))
1479       ENDIF
1480       IF (WHAT(5).GT.ZERO) THEN
1481          NMSTU = NMSTU+1
1482          IMSTU(NMSTU) = INT(WHAT(5))
1483          MSTUX(NMSTU) = INT(WHAT(6))
1484       ENDIF
1485       GOTO 10
1486
1487 *********************************************************************
1488 *                                                                   *
1489 *               control card:  codewd = LUND-MSTJ                   *
1490 *                                                                   *
1491 *          set parameter MSTJ in JETSET-common /LUDAT1/             *
1492 *                                                                   *
1493 *       what (1) =  index according to LUND-common block            *
1494 *       what (2) =  new value of MSTJ( int(what(1)) )               *
1495 *       what (3), what(4) and what (5), what(6) further             *
1496 *                   parameter in the same way as what (1) and       *
1497 *                   what (2)                                        *
1498 *                        default: default-Lund or corresponding to  *
1499 *                                 the set given in HADRONIZE        *
1500 *                                                                   *
1501 *********************************************************************
1502
1503   451 CONTINUE
1504       IF (WHAT(1).GT.ZERO) THEN
1505          NMSTJ = NMSTJ+1
1506          IMSTJ(NMSTJ) = INT(WHAT(1))
1507          MSTJX(NMSTJ) = INT(WHAT(2))
1508       ENDIF
1509       IF (WHAT(3).GT.ZERO) THEN
1510          NMSTJ = NMSTJ+1
1511          IMSTJ(NMSTJ) = INT(WHAT(3))
1512          MSTJX(NMSTJ) = INT(WHAT(4))
1513       ENDIF
1514       IF (WHAT(5).GT.ZERO) THEN
1515          NMSTJ = NMSTJ+1
1516          IMSTJ(NMSTJ) = INT(WHAT(5))
1517          MSTJX(NMSTJ) = INT(WHAT(6))
1518       ENDIF
1519       GOTO 10
1520
1521 *********************************************************************
1522 *                                                                   *
1523 *               control card:  codewd = LUND-MDCY                   *
1524 *                                                                   *
1525 *  set parameter MDCY(I,1) for particle decays in JETSET-common     *
1526 *                                                      /LUDAT3/     *
1527 *                                                                   *
1528 *       what (1-6) = PDG particle index of particle which should    *
1529 *                    not decay                                      *
1530 *                        default: default-Lund or forced in         *
1531 *                                 DT_INITJS                         *
1532 *                                                                   *
1533 *********************************************************************
1534
1535   452 CONTINUE
1536       DO 4521 I=1,6
1537          IF (WHAT(I).NE.ZERO) THEN
1538
1539             KC = PYCOMP(INT(WHAT(I)))
1540
1541             MDCY(KC,1) = 0
1542          ENDIF
1543  4521 CONTINUE
1544       GOTO 10
1545
1546 *********************************************************************
1547 *                                                                   *
1548 *               control card:  codewd = LUND-PARJ                   *
1549 *                                                                   *
1550 *          set parameter PARJ in JETSET-common /LUDAT1/             *
1551 *                                                                   *
1552 *       what (1) =  index according to LUND-common block            *
1553 *       what (2) =  new value of PARJ( int(what(1)) )               *
1554 *       what (3), what(4) and what (5), what(6) further             *
1555 *                   parameter in the same way as what (1) and       *
1556 *                   what (2)                                        *
1557 *                        default: default-Lund or corresponding to  *
1558 *                                 the set given in HADRONIZE        *
1559 *                                                                   *
1560 *********************************************************************
1561
1562   460 CONTINUE
1563       IF (WHAT(1).NE.ZERO) THEN
1564          NPARJ = NPARJ+1
1565          IPARJ(NPARJ) = INT(WHAT(1))
1566          PARJX(NPARJ) = WHAT(2)
1567       ENDIF
1568       IF (WHAT(3).NE.ZERO) THEN
1569          NPARJ = NPARJ+1
1570          IPARJ(NPARJ) = INT(WHAT(3))
1571          PARJX(NPARJ) = WHAT(4)
1572       ENDIF
1573       IF (WHAT(5).NE.ZERO) THEN
1574          NPARJ = NPARJ+1
1575          IPARJ(NPARJ) = INT(WHAT(5))
1576          PARJX(NPARJ) = WHAT(6)
1577       ENDIF
1578       GOTO 10
1579
1580 *********************************************************************
1581 *                                                                   *
1582 *               control card:  codewd = LUND-PARU                   *
1583 *                                                                   *
1584 *          set parameter PARJ in JETSET-common /LUDAT1/             *
1585 *                                                                   *
1586 *       what (1) =  index according to LUND-common block            *
1587 *       what (2) =  new value of PARU( int(what(1)) )               *
1588 *       what (3), what(4) and what (5), what(6) further             *
1589 *                   parameter in the same way as what (1) and       *
1590 *                   what (2)                                        *
1591 *                        default: default-Lund or corresponding to  *
1592 *                                 the set given in HADRONIZE        *
1593 *                                                                   *
1594 *********************************************************************
1595
1596   470 CONTINUE
1597       IF (WHAT(1).GT.ZERO) THEN
1598          NPARU = NPARU+1
1599          IPARU(NPARU) = INT(WHAT(1))
1600          PARUX(NPARU) = WHAT(2)
1601       ENDIF
1602       IF (WHAT(3).GT.ZERO) THEN
1603          NPARU = NPARU+1
1604          IPARU(NPARU) = INT(WHAT(3))
1605          PARUX(NPARU) = WHAT(4)
1606       ENDIF
1607       IF (WHAT(5).GT.ZERO) THEN
1608          NPARU = NPARU+1
1609          IPARU(NPARU) = INT(WHAT(5))
1610          PARUX(NPARU) = WHAT(6)
1611       ENDIF
1612       GOTO 10
1613
1614 *********************************************************************
1615 *                                                                   *
1616 *               control card:  codewd = OUTLEVEL                    *
1617 *                                                                   *
1618 *                    output control switches                        *
1619 *                                                                   *
1620 *       what (1) =  internal rejection informations  default: 0     *
1621 *       what (2) =  energy-momentum conservation check output       *
1622 *                                                    default: 0     *
1623 *       what (3) =  internal warning messages        default: 0     *
1624 *       what (4..6), sdum    not yet used                           *
1625 *                                                                   *
1626 *********************************************************************
1627
1628   480 CONTINUE
1629       DO 481 K=1,6
1630          IOULEV(K) = INT(WHAT(K))
1631   481 CONTINUE
1632       GOTO 10
1633
1634 *********************************************************************
1635 *                                                                   *
1636 *               control card:  codewd = FRAME                       *
1637 *                                                                   *
1638 *          frame in which final state is given in DTEVT1            *
1639 *                                                                   *
1640 *       what (1) = 1  target rest frame (laboratory)                *
1641 *                = 2  nucleon-nucleon cms                           *
1642 *                                                    default: 1     *
1643 *                                                                   *
1644 *********************************************************************
1645
1646   490 CONTINUE
1647       KFRAME = INT(WHAT(1))
1648       IF ((KFRAME.GE.1).AND.(KFRAME.LE.2)) IFRAME = KFRAME
1649       GOTO 10
1650
1651 *********************************************************************
1652 *                                                                   *
1653 *               control card:  codewd = L-TAG                       *
1654 *                                                                   *
1655 *                        lepton tagger:                             *
1656 *   definition of kinematical cuts for radiated photon and          *
1657 *   outgoing lepton detection in lepton-nucleus interactions        *
1658 *                                                                   *
1659 *       what (1) = y_min                                            *
1660 *       what (2) = y_max                                            *
1661 *       what (3) = Q^2_min                                          *
1662 *       what (4) = Q^2_max                                          *
1663 *       what (5) = theta_min  (Lab)                                 *
1664 *       what (6) = theta_max  (Lab)                                 *
1665 *                                       default: no cuts            *
1666 *       sdum    no meaning                                          *
1667 *                                                                   *
1668 *********************************************************************
1669
1670   500 CONTINUE
1671       YMIN  = WHAT(1)
1672       YMAX  = WHAT(2)
1673       Q2MIN = WHAT(3)
1674       Q2MAX = WHAT(4)
1675       THMIN = WHAT(5)
1676       THMAX = WHAT(6)
1677       GOTO 10
1678
1679 *********************************************************************
1680 *                                                                   *
1681 *               control card:  codewd = L-ETAG                      *
1682 *                                                                   *
1683 *                        lepton tagger:                             *
1684 *       what (1) = min. outgoing lepton energy  (in Lab)            *
1685 *       what (2) = min. photon energy           (in Lab)            *
1686 *       what (3) = max. photon energy           (in Lab)            *
1687 *                                       default: no cuts            *
1688 *       what (2..6), sdum    no meaning                             *
1689 *                                                                   *
1690 *********************************************************************
1691
1692   510 CONTINUE
1693       ELMIN = MAX(WHAT(1),ZERO)
1694       EGMIN = MAX(WHAT(2),ZERO)
1695       EGMAX = MAX(WHAT(3),ZERO)
1696       GOTO 10
1697
1698 *********************************************************************
1699 *                                                                   *
1700 *               control card:  codewd = ECMS-CUT                    *
1701 *                                                                   *
1702 *     what (1) = min. c.m. energy to be sampled                     *
1703 *     what (2) = max. c.m. energy to be sampled                     *
1704 *     what (3) = min x_Bj         to be sampled                     *
1705 *                                       default: no cuts            *
1706 *     what (3..6), sdum    no meaning                               *
1707 *                                                                   *
1708 *********************************************************************
1709
1710   520 CONTINUE
1711       ECMIN  = WHAT(1)
1712       ECMAX  = WHAT(2)
1713       IF (ECMIN.GT.ECMAX) ECMIN = ECMAX
1714       XBJMIN = MAX(WHAT(3),ZERO)
1715       GOTO 10
1716
1717 *********************************************************************
1718 *                                                                   *
1719 *               control card:  codewd = VDM-PAR1                    *
1720 *                                                                   *
1721 *      parameters in gamma-nucleus cross section calculation        *
1722 *                                                                   *
1723 *       what (1) =  Lambda^2                       default: 2.      *
1724 *       what (2)    lower limit in M^2 integration                  *
1725 *                =  1  (3m_pi)^2                                    *
1726 *                =  2  (m_rho0)^2                                   *
1727 *                =  3  (m_phi)^2                   default: 1       *
1728 *       what (3)    upper limit in M^2 integration                  *
1729 *                =  1   s/2                                         *
1730 *                =  2   s/4                                         *
1731 *                =  3   s                          default: 3       *
1732 *       what (4)    CKMT F_2 structure function                     *
1733 *                =  2212  proton                                    *
1734 *                =  100   deuteron                 default: 2212    *
1735 *       what (5)    calculation of gamma-nucleon xsections          *
1736 *                =  1  according to CKMT-parametrization of F_2     *
1737 *                =  2  integrating SIGVP over M^2                   *
1738 *                =  3  using SIGGA                                  *
1739 *                =  4  PHOJET cross sections       default:  4      *
1740 *                                                                   *
1741 *       what (6), sdum    no meaning                                *
1742 *                                                                   *
1743 *********************************************************************
1744
1745   530 CONTINUE
1746       IF (WHAT(1).GE.ZERO) RL2 = WHAT(1)
1747       IF ((WHAT(2).GE.1).AND.(WHAT(2).LE.3)) INTRGE(1) = INT(WHAT(2))
1748       IF ((WHAT(3).GE.1).AND.(WHAT(3).LE.3)) INTRGE(2) = INT(WHAT(3))
1749       IF ((WHAT(4).EQ.2212).OR.(WHAT(4).EQ.100)) IDPDF = INT(WHAT(4))
1750       IF ((WHAT(5).GE.1).AND.(WHAT(5).LE.4)) MODEGA = INT(WHAT(5))
1751       GOTO 10
1752
1753 *********************************************************************
1754 *                                                                   *
1755 *               control card:  codewd = HISTOGRAM                   *
1756 *                                                                   *
1757 *           activate different classes of histograms                *
1758 *                                                                   *
1759 *                                default: no histograms             *
1760 *                                                                   *
1761 *********************************************************************
1762
1763   540 CONTINUE
1764       DO 541 J=1,6
1765          IF ((WHAT(J).GE.100).AND.(WHAT(J).LE.150)) THEN
1766             IHISPP(INT(WHAT(J))-100) = 1
1767          ELSEIF ((ABS(WHAT(J)).GE.200).AND.(ABS(WHAT(J)).LE.250)) THEN
1768             IHISXS(INT(ABS(WHAT(J)))-200) = 1
1769             IF (WHAT(J).LT.ZERO) IXSTBL = 1
1770          ENDIF
1771   541 CONTINUE
1772       GOTO 10
1773
1774 *********************************************************************
1775 *                                                                   *
1776 *               control card:  codewd = XS-TABLE                    *
1777 *                                                                   *
1778 *    output of cross section table for requested interaction        *
1779 *              - particle production deactivated ! -                *
1780 *                                                                   *
1781 *       what (1)      lower energy limit for tabulation             *
1782 *                > 0  Lab. frame                                    *
1783 *                < 0  nucleon-nucleon cms                           *
1784 *       what (2)      upper energy limit for tabulation             *
1785 *                > 0  Lab. frame                                    *
1786 *                < 0  nucleon-nucleon cms                           *
1787 *       what (3) > 0  # of equidistant lin. bins in E               *
1788 *                < 0  # of equidistant log. bins in E               *
1789 *       what (4)      lower limit of particle virtuality (photons)  *
1790 *       what (5)      upper limit of particle virtuality (photons)  *
1791 *       what (6) > 0  # of equidistant lin. bins in Q^2             *
1792 *                < 0  # of equidistant log. bins in Q^2             *
1793 *                                                                   *
1794 *********************************************************************
1795
1796   550 CONTINUE
1797       IF (WHAT(1).EQ.99999.0D0) THEN
1798          IRATIO = INT(WHAT(2))
1799          GOTO 10
1800       ENDIF
1801       CMENER = ABS(WHAT(2))
1802       IF (.NOT.LXSTAB) THEN
1803
1804          CALL BERTTP
1805          CALL INCINI
1806
1807       ENDIF
1808       IF ((.NOT.LXSTAB).OR.(CMENER.NE.CMEOLD)) THEN
1809          CMEOLD = CMENER
1810          IF (WHAT(2).GT.ZERO)
1811      &      CMENER = SQRT(2.0D0*AAM(1)**2+2.0D0*WHAT(2)*AAM(1))
1812          EPN = ZERO
1813          PPN = ZERO
1814 C        WRITE(LOUT,*) 'CMENER = ',CMENER
1815          CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,CMENER,1)
1816          CALL DT_PHOINI
1817       ENDIF
1818       CALL DT_XSTABL(WHAT,IXSQEL,IRATIO)
1819       IXSQEL = 0
1820       LXSTAB = .TRUE.
1821       GOTO 10
1822
1823 *********************************************************************
1824 *                                                                   *
1825 *               control card:  codewd = GLAUB-PAR                   *
1826 *                                                                   *
1827 *                parameters in Glauber-formalism                    *
1828 *                                                                   *
1829 *    what (1)  # of nucleon configurations sampled in integration   *
1830 *              over nuclear desity                default: 1000     *
1831 *    what (2)  # of bins for integration over impact-parameter and  *
1832 *              for profile-function calculation   default: 49       *
1833 *    what (3)  = 1 calculation of tot., el. and qel. cross sections *
1834 *                                                 default: 0        *
1835 *    what (4)  = 1   read pre-calculated impact-parameter distrib.  *
1836 *                    from "sdum".glb                                *
1837 *              =-1   dump pre-calculated impact-parameter distrib.  *
1838 *                    into "sdum".glb                                *
1839 *              = 100 read pre-calculated impact-parameter distrib.  *
1840 *                    for variable projectile/target/energy runs     *
1841 *                    from "sdum".glb                                *
1842 *                                                 default: 0        *
1843 *    what (5..6)   no meaning                                       *
1844 *    sdum      if |what (4)| = 1 name of in/output-file (sdum.glb)  *
1845 *                                                                   *
1846 *********************************************************************
1847
1848   560 CONTINUE
1849       IF (WHAT(1).GT.ZERO) JSTATB = INT(WHAT(1))
1850       IF (WHAT(2).GT.ZERO) JBINSB = INT(WHAT(2))
1851       IF (WHAT(3).EQ.ONE) LPROD = .FALSE.
1852       IF ((ABS(WHAT(4)).EQ.ONE).OR.(WHAT(4).EQ.100)) THEN
1853          IOGLB = INT(WHAT(4))
1854          CGLB  = SDUM
1855       ENDIF
1856       GOTO 10
1857
1858 *********************************************************************
1859 *                                                                   *
1860 *               control card:  codewd = GLAUB-INI                   *
1861 *                                                                   *
1862 *             pre-initialization of profile function                *
1863 *                                                                   *
1864 *       what (1)      lower energy limit for initialization         *
1865 *                > 0  Lab. frame                                    *
1866 *                < 0  nucleon-nucleon cms                           *
1867 *       what (2)      upper energy limit for initialization         *
1868 *                > 0  Lab. frame                                    *
1869 *                < 0  nucleon-nucleon cms                           *
1870 *       what (3) > 0  # of equidistant lin. bins in E               *
1871 *                < 0  # of equidistant log. bins in E               *
1872 *       what (4)      maximum projectile mass number for which the  *
1873 *                     Glauber data are initialized for each         *
1874 *                     projectile mass number                        *
1875 *                     (if <= mass given with the PROJPAR-card)      *
1876 *                                              default: 18          *
1877 *       what (5)      steps in mass number starting from what (4)   *
1878 *                     up to mass number defined with PROJPAR-card   *
1879 *                     for which Glauber data are initialized        *
1880 *                                              default: 5           *
1881 *       what (6)      no meaning                                    *
1882 *       sdum          no meaning                                    *
1883 *                                                                   *
1884 *********************************************************************
1885
1886   565 CONTINUE
1887       IOGLB = -100
1888       CALL DT_GLBINI(WHAT)
1889       GOTO 10
1890
1891 *********************************************************************
1892 *                                                                   *
1893 *               control card:  codewd = VDM-PAR2                    *
1894 *                                                                   *
1895 *      parameters in gamma-nucleus cross section calculation        *
1896 *                                                                   *
1897 *      what (1) = 0 no suppression of shadowing by direct photon    *
1898 *                   processes                                       *
1899 *               = 1 suppression ..                   default: 1     *
1900 *      what (2) = 0 no suppression of shadowing by anomalous        *
1901 *                   component if photon-F_2                         *
1902 *               = 1 suppression ..                   default: 1     *
1903 *      what (3) = 0 no suppression of shadowing by coherence        *
1904 *                   length of the photon                            *
1905 *               = 1 suppression ..                   default: 1     *
1906 *      what (4) = 1 longitudinal polarized photons are taken into   *
1907 *                   account                                         *
1908 *                   eps*R*Q^2/M^2 = what(4)*Q^2/M^2  default: 0     *
1909 *      what (5..6), sdum    no meaning                              *
1910 *                                                                   *
1911 *********************************************************************
1912
1913   570 CONTINUE
1914       IF ((WHAT(1).EQ.ZERO).OR.(WHAT(1).EQ.ONE)) ISHAD(1) = INT(WHAT(1))
1915       IF ((WHAT(2).EQ.ZERO).OR.(WHAT(2).EQ.ONE)) ISHAD(2) = INT(WHAT(2))
1916       IF ((WHAT(3).EQ.ZERO).OR.(WHAT(3).EQ.ONE)) ISHAD(3) = INT(WHAT(3))
1917       EPSPOL  = WHAT(4)
1918       GOTO 10
1919
1920 *********************************************************************
1921 *                                                                   *
1922 *               control card:  XS-QELPRO                            *
1923 *                                                                   *
1924 *     what (1..6), sdum    no meaning                               *
1925 *                                                                   *
1926 *********************************************************************
1927
1928   580 CONTINUE
1929       IXSQEL = ABS(WHAT(1))
1930       GOTO 10
1931
1932 *********************************************************************
1933 *                                                                   *
1934 *               control card:  RNDMINIT                             *
1935 *                                                                   *
1936 *           initialization of random number generator               *
1937 *                                                                   *
1938 *     what (1..4)    values for initialization (= 1..168)           *
1939 *     what (5..6), sdum    no meaning                               *
1940 *                                                                   *
1941 *********************************************************************
1942
1943   590 CONTINUE
1944       IF ((WHAT(1).LT.1.0D0).OR.(WHAT(1).GT.168.0D0)) THEN
1945          NA1 = 22
1946       ELSE
1947          NA1 = WHAT(1)
1948       ENDIF
1949       IF ((WHAT(2).LT.1.0D0).OR.(WHAT(2).GT.168.0D0)) THEN
1950          NA2 = 54
1951       ELSE
1952          NA2 = WHAT(2)
1953       ENDIF
1954       IF ((WHAT(3).LT.1.0D0).OR.(WHAT(3).GT.168.0D0)) THEN
1955          NA3 = 76
1956       ELSE
1957          NA3 = WHAT(3)
1958       ENDIF
1959       IF ((WHAT(4).LT.1.0D0).OR.(WHAT(4).GT.168.0D0)) THEN
1960          NA4 = 92
1961       ELSE
1962          NA4 = WHAT(4)
1963       ENDIF
1964       CALL DT_RNDMST(NA1,NA2,NA3,NA4)
1965       GOTO 10
1966
1967 *********************************************************************
1968 *                                                                   *
1969 *               control card:  codewd = LEPTO-CUT                   *
1970 *                                                                   *
1971 *          set parameter CUT in LEPTO-common /LEPTOU/               *
1972 *                                                                   *
1973 *       what (1) =  index in CUT-array                              *
1974 *       what (2) =  new value of CUT( int(what(1)) )                *
1975 *       what (3), what(4) and what (5), what(6) further             *
1976 *                   parameter in the same way as what (1) and       *
1977 *                   what (2)                                        *
1978 *                        default: default-LEPTO parameters          *
1979 *                                                                   *
1980 *********************************************************************
1981
1982   600 CONTINUE
1983       IF (WHAT(1).GT.ZERO) CUT(INT(WHAT(1))) = WHAT(2)
1984       IF (WHAT(3).GT.ZERO) CUT(INT(WHAT(3))) = WHAT(4)
1985       IF (WHAT(5).GT.ZERO) CUT(INT(WHAT(5))) = WHAT(6)
1986       GOTO 10
1987
1988 *********************************************************************
1989 *                                                                   *
1990 *               control card:  codewd = LEPTO-LST                   *
1991 *                                                                   *
1992 *          set parameter LST in LEPTO-common /LEPTOU/               *
1993 *                                                                   *
1994 *       what (1) =  index in LST-array                              *
1995 *       what (2) =  new value of LST( int(what(1)) )                *
1996 *       what (3), what(4) and what (5), what(6) further             *
1997 *                   parameter in the same way as what (1) and       *
1998 *                   what (2)                                        *
1999 *                        default: default-LEPTO parameters          *
2000 *                                                                   *
2001 *********************************************************************
2002
2003   610 CONTINUE
2004       IF (WHAT(1).GT.ZERO) LST(INT(WHAT(1))) = INT(WHAT(2))
2005       IF (WHAT(3).GT.ZERO) LST(INT(WHAT(3))) = INT(WHAT(4))
2006       IF (WHAT(5).GT.ZERO) LST(INT(WHAT(5))) = INT(WHAT(6))
2007       GOTO 10
2008
2009 *********************************************************************
2010 *                                                                   *
2011 *               control card:  codewd = LEPTO-PARL                  *
2012 *                                                                   *
2013 *          set parameter PARL in LEPTO-common /LEPTOU/              *
2014 *                                                                   *
2015 *       what (1) =  index in PARL-array                             *
2016 *       what (2) =  new value of PARL( int(what(1)) )               *
2017 *       what (3), what(4) and what (5), what(6) further             *
2018 *                   parameter in the same way as what (1) and       *
2019 *                   what (2)                                        *
2020 *                        default: default-LEPTO parameters          *
2021 *                                                                   *
2022 *********************************************************************
2023
2024   620 CONTINUE
2025       IF (WHAT(1).GT.ZERO) PARL(INT(WHAT(1))) = WHAT(2)
2026       IF (WHAT(3).GT.ZERO) PARL(INT(WHAT(3))) = WHAT(4)
2027       IF (WHAT(5).GT.ZERO) PARL(INT(WHAT(5))) = WHAT(6)
2028       GOTO 10
2029
2030 *********************************************************************
2031 *                                                                   *
2032 *               control card:  codewd = START                       *
2033 *                                                                   *
2034 *       what (1) =   number of events                default: 100.  *
2035 *       what (2) = 0 Glauber initialization follows                 *
2036 *                = 1 Glauber initialization supressed, fitted       *
2037 *                    results are used instead                       *
2038 *                    (this does not apply if emulsion-treatment     *
2039 *                     is requested)                                 *
2040 *                = 2 Glauber initialization is written to           *
2041 *                    output-file shmakov.out                        *
2042 *                = 3 Glauber initialization is read from input-file *
2043 *                    shmakov.out                     default: 0     *
2044 *       what (3..6)  no meaning                                     *
2045 *       what (3..6)  no meaning                                     *
2046 *                                                                   *
2047 *********************************************************************
2048
2049   630 CONTINUE
2050
2051 * check for cross-section table output only
2052       IF (LXSTAB) STOP
2053
2054       NCASES = INT(WHAT(1))
2055       IF (NCASES.LE.0) NCASES = 100
2056       IGLAU = INT(WHAT(2))
2057       IF ((IGLAU.NE.1).AND.(IGLAU.NE.2).AND.(IGLAU.NE.3))
2058      &                                            IGLAU = 0
2059
2060       NPMASS = IP
2061       NPCHAR = IPZ
2062       NTMASS = IT
2063       NTCHAR = ITZ
2064       IDP    = IJPROJ
2065       IDT    = IJTARG
2066       IF (IDP.LE.0) IDP = 1
2067 * muon neutrinos: temporary (missing index)
2068 * (new patch in projpar: therefore the following this is probably not
2069 *  necessary anymore..)
2070 C     IF (IDP.EQ.26) IDP = 5
2071 C     IF (IDP.EQ.27) IDP = 6
2072
2073 * redefine collision energy
2074       IF (LEINP) THEN
2075          IF (ABS(VAREHI).GT.ZERO) THEN
2076             PDUM = ZERO
2077             IF (VARELO.LT.EHADLO) VARELO = EHADLO
2078             CALL DT_LTINI(IDP,IDT,VARELO,PDUM,VARCLO,1)
2079             PDUM = ZERO
2080             CALL DT_LTINI(IDP,IDT,VAREHI,PDUM,VARCHI,1)
2081          ENDIF
2082          CALL DT_LTINI(IDP,IDT,EPN,PPN,CMENER,1)
2083       ELSE
2084          WRITE(LOUT,1003)
2085  1003    FORMAT(1X,'INIT:   collision energy not defined!',/,
2086      &          1X,'              -program stopped-      ')
2087          STOP
2088       ENDIF
2089
2090 * switch off evaporation (even if requested) if central coll. requ.
2091       IF ((ICENTR.EQ.-1).OR.(ICENTR.GT.0).OR.(XSFRAC.LT.0.5D0)) THEN
2092          IF (LEVPRT) THEN
2093             WRITE(LOUT,1004)
2094  1004       FORMAT(1X,/,'Warning!  Evaporation request rejected since',
2095      &             ' central collisions forced.')
2096             LEVPRT = .FALSE.
2097             LDEEXG = .FALSE.
2098             LHEAVY = .FALSE.
2099          ENDIF
2100       ENDIF
2101
2102 * initialization of evaporation-module
2103
2104 *  initialize evaporation if the code is not used as Fluka event generator
2105       IF (ITRSPT.NE.1) THEN
2106          CALL BERTTP
2107          CALL INCINI
2108       ENDIF
2109       IF (LEVPRT) LHEAVY = .TRUE.
2110
2111
2112 * save the default JETSET-parameter
2113       CALL DT_JSPARA(0)
2114
2115 * force use of phojet for g-A
2116       IF ((IDP.EQ.7).AND.(MCGENE.NE.3)) MCGENE = 2
2117 * initialization of nucleon-nucleon event generator
2118       IF (MCGENE.EQ.2) CALL DT_PHOINI
2119 * initialization of LEPTO event generator
2120       IF (MCGENE.EQ.3) THEN
2121
2122          STOP ' This version does not contain LEPTO !'
2123
2124       ENDIF
2125
2126 * initialization of quasi-elastic neutrino scattering
2127       IF (MCGENE.EQ.4) THEN
2128          IF (IJPROJ.EQ.5) THEN
2129             NEUTYP = 1
2130          ELSEIF (IJPROJ.EQ.6) THEN
2131             NEUTYP = 2
2132          ELSEIF (IJPROJ.EQ.135) THEN
2133             NEUTYP = 3
2134          ELSEIF (IJPROJ.EQ.136) THEN
2135             NEUTYP = 4
2136          ELSEIF (IJPROJ.EQ.133) THEN
2137             NEUTYP = 5
2138          ELSEIF (IJPROJ.EQ.134) THEN
2139             NEUTYP = 6
2140          ENDIF
2141       ENDIF
2142
2143 * normalize fractions of emulsion components
2144       IF (NCOMPO.GT.0) THEN
2145          SUMFRA = ZERO
2146          DO 491 I=1,NCOMPO
2147             SUMFRA = SUMFRA+EMUFRA(I)
2148   491    CONTINUE
2149          IF (SUMFRA.GT.ZERO) THEN
2150             DO 492 I=1,NCOMPO
2151                EMUFRA(I) = EMUFRA(I)/SUMFRA
2152   492       CONTINUE
2153          ENDIF
2154       ENDIF
2155
2156 * disallow Cronin's multiple scattering for nucleus-nucleus interactions
2157       IF ((IP.GT.1).AND.(MKCRON.GT.0)) THEN
2158          WRITE(LOUT,1005)
2159  1005    FORMAT(/,1X,'INIT:  multiple scattering disallowed',/)
2160          MKCRON = 0
2161       ENDIF
2162
2163 * initialization of Glauber-formalism (moved to xAEVT, sr 26.3.96)
2164 C     IF (NCOMPO.LE.0) THEN
2165 C        CALL DT_SHMAKI(IP,IPZ,IT,ITZ,IDP,PPN,IGLAU)
2166 C     ELSE
2167 C        DO 493 I=1,NCOMPO
2168 C           CALL DT_SHMAKI(IP,IPZ,IEMUMA(I),IEMUCH(I),IDP,PPN,0)
2169 C 493    CONTINUE
2170 C     ENDIF
2171
2172 * pre-tabulation of elastic cross-sections
2173       CALL DT_SIGTBL(JDUM,JDUM,DUM,DUM,-1)
2174
2175       CALL DT_XTIME
2176
2177       RETURN
2178
2179 *********************************************************************
2180 *                                                                   *
2181 *               control card:  codewd = STOP                        *
2182 *                                                                   *
2183 *               stop of the event generation                        *
2184 *                                                                   *
2185 *       what (1..6)  no meaning                                     *
2186 *                                                                   *
2187 *********************************************************************
2188
2189  9999 CONTINUE
2190       WRITE(LOUT,9000)
2191  9000 FORMAT(1X,'---> unexpected end of input !')
2192
2193   640 CONTINUE
2194       STOP
2195
2196       END
2197 *
2198 *===kkinc==============================================================*
2199 *
2200 CDECK  ID>, DT_KKINC
2201       SUBROUTINE DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,
2202      &                                                         IREJ)
2203
2204 ************************************************************************
2205 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering   *
2206 * This subroutine is an update of the previous version written         *
2207 * by J. Ranft/ H.-J. Moehring.                                         *
2208 * This version dated 19.11.95 is written by S. Roesler                 *
2209 ************************************************************************
2210
2211       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2212       SAVE
2213
2214       PARAMETER ( LINP = 5 ,
2215      &            LOUT = 6 ,
2216      &            LDAT = 9 )
2217
2218       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY5=1.0D-5,
2219      &           TINY2=1.0D-2,TINY3=1.0D-3)
2220
2221       LOGICAL LFZC
2222
2223 * event history
2224
2225       PARAMETER (NMXHKK=200000)
2226
2227       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2228      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2229      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2230 * extended event history
2231       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2232      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2233      &                IHIST(2,NMXHKK)
2234 * particle properties (BAMJET index convention)
2235       CHARACTER*8  ANAME
2236       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2237      &                IICH(210),IIBAR(210),K1(210),K2(210)
2238 * properties of interacting particles
2239       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2240 * Lorentz-parameters of the current interaction
2241       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
2242      &                UMO,PPCM,EPROJ,PPROJ
2243 * flags for input different options
2244       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2245       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2246      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2247 * flags for particle decays
2248       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2249      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2250      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2251 * cuts for variable energy runs
2252       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2253 * Glauber formalism: flags and parameters for statistics
2254       LOGICAL LPROD
2255       CHARACTER*8 CGLB
2256       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2257
2258       DIMENSION WHAT(6)
2259
2260       IREJ  = 0
2261       ILOOP = 0
2262   100 CONTINUE
2263       IF (ILOOP.EQ.4) THEN
2264          WRITE(LOUT,1000) NEVHKK
2265  1000    FORMAT(1X,'KKINC: event ',I8,' rejected!')
2266          GOTO 9999
2267       ENDIF
2268       ILOOP = ILOOP+1
2269
2270 * variable energy-runs, recalculate parameters for LT's
2271       IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN
2272          PDUM = ZERO
2273          CDUM = ZERO
2274          CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1)
2275       ENDIF
2276       IF (EPN.GT.EPROJ) THEN
2277          WRITE(LOUT,'(A,E9.3,2A,E9.3,A)')
2278      &      ' Requested energy (',EPN,'GeV) exceeds',
2279      &      ' initialization energy (',EPROJ,'GeV) !'
2280          STOP
2281       ENDIF
2282
2283 * re-initialize /DTPRTA/
2284       IP  = NPMASS
2285       IPZ = NPCHAR
2286       IT  = NTMASS
2287       ITZ = NTCHAR
2288       IJPROJ = IDP
2289       IBPROJ = IIBAR(IJPROJ)
2290
2291 * calculate nuclear potentials (common /DTNPOT/)
2292       CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
2293
2294 * initialize treatment for residual nuclei
2295       CALL DT_RESNCL(EPN,NLOOP,1)
2296
2297 * sample hadron/nucleus-nucleus interaction
2298       CALL DT_KKEVNT(KKMAT,IREJ1)
2299       IF (IREJ1.GT.0) THEN
2300          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC'
2301          GOTO 9999
2302       ENDIF
2303
2304       IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN
2305
2306 * intranuclear cascade of final state particles for KTAUGE generations
2307 * of secondaries
2308          CALL DT_FOZOCA(LFZC,IREJ1)
2309          IF (IREJ1.GT.0) THEN
2310             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC'
2311             GOTO 9999
2312          ENDIF
2313
2314 * baryons unable to escape the nuclear potential are treated as
2315 * excited nucleons (ISTHKK=15,16)
2316          CALL DT_SCN4BA
2317
2318 * decay of resonances produced in intranuclear cascade processes
2319 **sr 15-11-95 should be obsolete
2320 C        IF (LFZC) CALL DT_DECAY1
2321
2322   101    CONTINUE
2323 * treatment of residual nuclei
2324          CALL DT_RESNCL(EPN,NLOOP,2)
2325
2326 * evaporation / fission / fragmentation
2327 * (if intranuclear cascade was sampled only)
2328          IF (LFZC) THEN
2329             CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1)
2330             IF (IREJ1.GT.1) GOTO 101
2331             IF (IREJ1.EQ.1) GOTO 100
2332          ENDIF
2333
2334       ENDIF
2335
2336 * transform finale state into Lab.
2337       IFLAG = 2
2338       CALL DT_BEAMPR(WHAT,DUM,IFLAG)
2339       IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB
2340
2341       IF (IPI0.EQ.1) CALL DT_DECPI0
2342
2343 C     IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4)
2344
2345       RETURN
2346  9999 CONTINUE
2347       IREJ = 1
2348       RETURN
2349       END
2350 *
2351 *===defaul=============================================================*
2352 *
2353 CDECK  ID>, DT_DEFAUL
2354       SUBROUTINE DT_DEFAUL(EPN,PPN)
2355
2356 ************************************************************************
2357 * Variables are set to default values.                                 *
2358 * This version dated 8.5.95 is written by S. Roesler.                  *
2359 ************************************************************************
2360
2361       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2362       SAVE
2363       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
2364       PARAMETER (TWOPI  = 6.283185307179586454D+00)
2365
2366 * particle properties (BAMJET index convention)
2367       CHARACTER*8  ANAME
2368       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2369      &                IICH(210),IIBAR(210),K1(210),K2(210)
2370 * nuclear potential
2371       LOGICAL LFERMI
2372       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
2373      &                EBINDP(2),EBINDN(2),EPOT(2,210),
2374      &                ETACOU(2),ICOUL,LFERMI
2375 * interface HADRIN-DPM
2376       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
2377 * central particle production, impact parameter biasing
2378       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
2379 * properties of interacting particles
2380       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2381 * properties of photon/lepton projectiles
2382       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2383
2384       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2385
2386 * emulsion treatment
2387       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2388      &                NCOMPO,IEMUL
2389 * parameter for intranuclear cascade
2390       LOGICAL LPAULI
2391       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
2392 * various options for treatment of partons (DTUNUC 1.x)
2393 * (chain recombination, Cronin,..)
2394       LOGICAL LCO2CR,LINTPT
2395       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
2396      &                LCO2CR,LINTPT
2397 * threshold values for x-sampling (DTUNUC 1.x)
2398       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
2399      &                SSMIMQ,VVMTHR
2400 * flags for input different options
2401       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2402       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2403      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2404 * n-n cross section fluctuations
2405       PARAMETER (NBINS = 1000)
2406       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
2407 * flags for particle decays
2408       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2409      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2410      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2411 * diquark-breaking mechanism
2412       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
2413 * nucleon-nucleon event-generator
2414       CHARACTER*8 CMODEL
2415       LOGICAL LPHOIN
2416       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2417 * flags for diffractive interactions (DTUNUC 1.x)
2418       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
2419 * VDM parameter for photon-nucleus interactions
2420       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
2421 * Glauber formalism: flags and parameters for statistics
2422       LOGICAL LPROD
2423       CHARACTER*8 CGLB
2424       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2425 * kinematical cuts for lepton-nucleus interactions
2426       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2427      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2428 * flags for activated histograms
2429       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2430 * cuts for variable energy runs
2431       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2432 * parameters for hA-diffraction
2433       COMMON /DTDIHA/ DIBETA,DIALPH
2434 * LEPTO
2435       REAL RPPN
2436       COMMON /LEPTOI/ RPPN,LEPIN,INTER
2437 * steering flags for qel neutrino scattering modules
2438       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
2439 * event flag
2440       COMMON /DTEVNO/ NEVENT,ICASCA
2441
2442       DATA POTMES /0.002D0/
2443
2444 * common /DTNPOT/
2445       DO 10 I=1,2
2446          PFERMP(I) = ZERO
2447          PFERMN(I) = ZERO
2448          EBINDP(I) = ZERO
2449          EBINDN(I) = ZERO
2450          DO 11 J=1,210
2451             EPOT(I,J) = ZERO
2452    11    CONTINUE
2453 * nucleus independent meson potential
2454          EPOT(I,13) = POTMES
2455          EPOT(I,14) = POTMES
2456          EPOT(I,15) = POTMES
2457          EPOT(I,16) = POTMES
2458          EPOT(I,23) = POTMES
2459          EPOT(I,24) = POTMES
2460          EPOT(I,25) = POTMES
2461    10 CONTINUE
2462 **sr 7.4.98: changed after corrected B-sampling
2463 C     FERMOD    = 0.55D0
2464       FERMOD    = 0.68D0
2465       ETACOU(1) = ZERO
2466       ETACOU(2) = ZERO
2467       ICOUL     = 1
2468       LFERMI    = .TRUE.
2469
2470 * common /HNTHRE/
2471       EHADTH = -99.0D0
2472       EHADLO = 4.06D0
2473       EHADHI = 6.0D0
2474       INTHAD = 1
2475       IDXTA  = 2
2476
2477 * common /DTIMPA/
2478       ICENTR = 0
2479       BIMIN  = ZERO
2480       BIMAX  = 1.0D10
2481       XSFRAC = 1.0D0
2482
2483 * common /DTPRTA/
2484       IP  = 1
2485       IPZ = 1
2486       IT  = 1
2487       ITZ = 1
2488       IJPROJ = 1
2489       IBPROJ = 1
2490       IJTARG = 1
2491       IBTARG = 1
2492 * common /DTGPRO/
2493       VIRT = ZERO
2494       DO 14 I=1,4
2495          PGAMM(I)  = ZERO
2496          PLEPT0(I) = ZERO
2497          PLEPT1(I) = ZERO
2498          PNUCL(I)  = ZERO
2499    14 CONTINUE
2500       IDIREC   = 0
2501
2502 * common /DTFOTI/
2503 **sr 7.4.98: changed after corrected B-sampling
2504 C     TAUFOR = 4.4D0
2505       TAUFOR = 3.1D0
2506       KTAUGE = 25
2507       ITAUVE = 1
2508       INCMOD = 1
2509       LPAULI = .TRUE.
2510
2511 * common /DTCHAI/
2512       SEASQ  = ONE
2513       MKCRON = 1
2514       CRONCO = 0.64D0
2515       ISICHA = 0
2516       CUTOF  = 100.0D0
2517       LCO2CR = .FALSE.
2518       IRECOM = 1
2519       LINTPT = .TRUE.
2520
2521 * common /DTXCUT/
2522 *  definition of soft quark distributions
2523       XSEACU = 0.05D0
2524       UNON   = 2.0D0
2525       UNOM   = 1.5D0
2526       UNOSEA = 5.0D0
2527 *  cutoff parameters for x-sampling
2528       CVQ    = 1.0D0
2529       CDQ    = 2.0D0
2530 C     CSEA   = 0.3D0
2531       CSEA   = 0.1D0
2532       SSMIMA = 1.2D0
2533       SSMIMQ = SSMIMA**2
2534       VVMTHR = 2.0D0
2535
2536 * common /DTXSFL/
2537       IFLUCT = 0
2538
2539 * common /DTFRPA/
2540       PDB = 0.15D0
2541       PDBSEA(1) = 0.0D0
2542       PDBSEA(2) = 0.0D0
2543       PDBSEA(3) = 0.0D0
2544       ISIG0 = 0
2545       IPI0  = 0
2546       NMSTU = 0
2547       NPARU = 0
2548       NMSTJ = 0
2549       NPARJ = 0
2550
2551 * common /DTDIQB/
2552       DO 15 I=1,8
2553          DBRKR(1,I) = 5.0D0
2554          DBRKR(2,I) = 5.0D0
2555          DBRKR(3,I) = 10.0D0
2556          DBRKA(1,I) = ZERO
2557          DBRKA(2,I) = ZERO
2558          DBRKA(3,I) = ZERO
2559    15 CONTINUE
2560       CHAM1 = 0.2D0
2561       CHAM3 = 0.5D0
2562       CHAB1 = 0.7D0
2563       CHAB3 = 1.0D0
2564
2565 * common /DTFLG3/
2566       ISINGD = 0
2567       IDOUBD = 0
2568       IFLAGD = 0
2569       IDIFF  = 0
2570
2571 * common /DTMODL/
2572       MCGENE    = 2
2573       CMODEL(1) = 'DTUNUC  '
2574       CMODEL(2) = 'PHOJET  '
2575       CMODEL(3) = 'LEPTO   '
2576       CMODEL(4) = 'QNEUTRIN'
2577       LPHOIN    = .TRUE.
2578       ELOJET    = 5.0D0
2579
2580 * common /DTLCUT/
2581       ECMIN  = 3.5D0
2582       ECMAX  = 1.0D10
2583       XBJMIN = ZERO
2584       ELMIN = ZERO
2585       EGMIN = ZERO
2586       EGMAX = 1.0D10
2587       YMIN  = TINY10
2588       YMAX  = 0.999D0
2589       Q2MIN = TINY10
2590       Q2MAX = 10.0D0
2591       THMIN = ZERO
2592       THMAX = TWOPI
2593       Q2LI  = ZERO
2594       Q2HI  = 1.0D10
2595       ECMLI = ZERO
2596       ECMHI = 1.0D10
2597
2598 * common /DTVDMP/
2599       RL2       = 2.0D0
2600       INTRGE(1) = 1
2601       INTRGE(2) = 3
2602       IDPDF     = 2212
2603       MODEGA    = 4
2604       ISHAD(1)  = 1
2605       ISHAD(2)  = 1
2606       ISHAD(3)  = 1
2607       EPSPOL    = ZERO
2608
2609 * common /DTGLGP/
2610       JSTATB = 1000
2611       JBINSB = 49
2612       CGLB   = '        '
2613       IF (ITRSPT.EQ.1) THEN
2614          IOGLB  = 100
2615       ELSE
2616          IOGLB  = 0
2617       ENDIF
2618       LPROD  = .TRUE.
2619
2620 * common /DTHIS3/
2621       DO 16 I=1,50
2622          IHISPP(I) = 0
2623          IHISXS(I) = 0
2624    16 CONTINUE
2625       IXSTBL = 0
2626
2627 * common /DTVARE/
2628       VARELO = ZERO
2629       VAREHI = ZERO
2630       VARCLO = ZERO
2631       VARCHI = ZERO
2632
2633 * common /DTDIHA/
2634       DIBETA = -1.0D0
2635       DIALPH = ZERO
2636
2637 * common /LEPTOI/
2638       RPPN  = 0.0
2639       LEPIN = 0
2640       INTER = 0
2641
2642 * common /QNEUTO/
2643       NEUTYP = 1
2644       NEUDEC = 0
2645
2646 * common /DTEVNO/
2647       NEVENT = 1
2648       IF (ITRSPT.EQ.1) THEN
2649          ICASCA = 1
2650       ELSE
2651          ICASCA = 0
2652       ENDIF
2653
2654 * default Lab.-energy
2655       EPN = 200.0D0
2656       PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ)))
2657
2658       RETURN
2659       END
2660 *
2661 *===aaevt==============================================================*
2662 *
2663 CDECK  ID>, DT_AAEVT
2664       SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2665      &                                             IDP,IGLAU)
2666
2667 ************************************************************************
2668 * This version dated 22.03.96 is written by S. Roesler.                *
2669 ************************************************************************
2670
2671       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2672       SAVE
2673
2674       PARAMETER ( LINP = 5 ,
2675      &            LOUT = 6 ,
2676      &            LDAT = 9 )
2677
2678       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2679
2680 * emulsion treatment
2681       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2682      &                NCOMPO,IEMUL
2683 * event flag
2684       COMMON /DTEVNO/ NEVENT,ICASCA
2685
2686       CHARACTER*8 DATE,HHMMSS
2687       DIMENSION IDMNYR(3)
2688
2689       KKMAT  = 1
2690       NMSG   = MAX(NEVTS/100,1)
2691
2692 * initialization of run-statistics and histograms
2693       CALL DT_STATIS(1)
2694
2695       CALL PHO_PHIST(1000,DUM)
2696
2697 * initialization of Glauber-formalism
2698       IF (NCOMPO.LE.0) THEN
2699          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2700       ELSE
2701          DO 1 I=1,NCOMPO
2702             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2703     1    CONTINUE
2704       ENDIF
2705       CALL DT_SIGEMU
2706
2707       CALL IDATE(IDMNYR)
2708       WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2709      &   IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2710       CALL ITIME(IDMNYR)
2711       WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2712      &   IDMNYR(1),IDMNYR(2),IDMNYR(3)
2713       WRITE(LOUT,1001) DATE,HHMMSS
2714  1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8,
2715      &       '   Time: ',A8,' )')
2716
2717 * generate NEVTS events
2718       DO 2 IEVT=1,NEVTS
2719
2720 *  print run-status message
2721          IF (MOD(IEVT,NMSG).EQ.0) THEN
2722             CALL IDATE(IDMNYR)
2723             WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2724      &         IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2725             CALL ITIME(IDMNYR)
2726             WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2727      &         IDMNYR(1),IDMNYR(2),IDMNYR(3)
2728             WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS
2729  1000       FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A,
2730      &             '   Time: ',A,' )',/)
2731 C           WRITE(LOUT,1000) IEVT-1
2732 C1000       FORMAT(1X,I8,' events sampled')
2733          ENDIF
2734          NEVENT = IEVT
2735 *  treat nuclear emulsions
2736          IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
2737 *  composite targets only
2738          KKMAT = -KKMAT
2739 *  sample this event
2740          CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ)
2741
2742          CALL PHO_PHIST(2000,DUM)
2743
2744     2 CONTINUE
2745
2746 * print run-statistics and histograms to output-unit 6
2747
2748       CALL PHO_PHIST(3000,DUM)
2749
2750       CALL DT_STATIS(2)
2751
2752       RETURN
2753       END
2754 *
2755 *===laevt==============================================================*
2756 *
2757 CDECK  ID>, DT_LAEVT
2758       SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2759      &                                             IDP,IGLAU)
2760
2761 ************************************************************************
2762 * Interface to run DPMJET for lepton-nucleus interactions.             *
2763 * Kinematics is sampled using the equivalent photon approximation      *
2764 * Based on GPHERA-routine by R. Engel.                                 *
2765 * This version dated 23.03.96 is written by S. Roesler.                *
2766 ************************************************************************
2767
2768       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2769       SAVE
2770
2771       PARAMETER ( LINP = 5 ,
2772      &            LOUT = 6 ,
2773      &            LDAT = 9 )
2774
2775       PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,
2776      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
2777       PARAMETER (TWOPI  = 6.283185307179586454D+00,
2778      &           PI     = TWOPI/TWO,
2779      &           ALPHEM = ONE/137.0D0)
2780
2781 C     CHARACTER*72 HEADER
2782
2783 * particle properties (BAMJET index convention)
2784       CHARACTER*8  ANAME
2785       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2786      &                IICH(210),IIBAR(210),K1(210),K2(210)
2787 * event history
2788
2789       PARAMETER (NMXHKK=200000)
2790
2791       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2792      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2793      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2794 * extended event history
2795       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2796      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2797      &                IHIST(2,NMXHKK)
2798 * kinematical cuts for lepton-nucleus interactions
2799       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2800      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2801 * properties of interacting particles
2802       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2803 * properties of photon/lepton projectiles
2804       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2805 * kinematics at lepton-gamma vertex
2806       COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4)
2807 * flags for activated histograms
2808       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2809
2810       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2811
2812 * emulsion treatment
2813       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2814      &                NCOMPO,IEMUL
2815 * Glauber formalism: cross sections
2816       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
2817      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
2818      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
2819      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
2820      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
2821      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
2822      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
2823      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
2824      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
2825      &                BSLOPE,NEBINI,NQBINI
2826 * nucleon-nucleon event-generator
2827       CHARACTER*8 CMODEL
2828       LOGICAL LPHOIN
2829       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2830 * flags for input different options
2831       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2832       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2833      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2834 * event flag
2835       COMMON /DTEVNO/ NEVENT,ICASCA
2836
2837       DIMENSION XDUMB(40),BGTA(4)
2838
2839 * LEPTO
2840       IF (MCGENE.EQ.3) THEN
2841
2842          STOP ' This version does not contain LEPTO !'
2843
2844       ENDIF
2845
2846       KKMAT  = 1
2847       NMSG   = MAX(NEVTS/10,1)
2848
2849 * mass of incident lepton
2850       AMLPT  = AAM(IDP)
2851       AMLPT2 = AMLPT**2
2852       IDPPDG = IDT_IPDGHA(IDP)
2853
2854 * consistency of kinematical limits
2855       Q2MIN  = MAX(Q2MIN,TINY10)
2856       Q2MAX  = MAX(Q2MAX,TINY10)
2857       YMIN   = MIN(MAX(YMIN,TINY10),0.999D0)
2858       YMAX   = MIN(MAX(YMAX,TINY10),0.999D0)
2859
2860 * total energy of the lepton-nucleon system
2861       PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2
2862      &                                      +(PLEPT0(3)+PNUCL(3))**2 )
2863       ETOTLN = PLEPT0(4)+PNUCL(4)
2864       ECMLN  = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN))
2865       ECMAX  = MIN(ECMAX,ECMLN)
2866       WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN,
2867      &                 THMIN,THMAX,ELMIN
2868  1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X,
2869      &       '------------------',/,9X,'W (min)   =',
2870      &       F7.1,' GeV    (max) =',F7.1,' GeV',/,9X,'y (min)   =',
2871      &       F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1,
2872      &       ' GeV^2  (max) =',F7.1,' GeV^2',/,' (Lab)   E_g (min) ='
2873      &       ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =',
2874      &       F7.4,'   for E_lpt >',F7.1,' GeV',/)
2875
2876 * Lorentz-parameter for transf. into Lab
2877       BGTA(1) = PNUCL(1)/AAM(1)
2878       BGTA(2) = PNUCL(2)/AAM(1)
2879       BGTA(3) = PNUCL(3)/AAM(1)
2880       BGTA(4) = PNUCL(4)/AAM(1)
2881 * LT of incident lepton into Lab and dump it in DTEVT1
2882       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2883      &            PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4),
2884      &            PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4))
2885       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2886      &            PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4),
2887      &            PLTOT,PPA(1),PPA(2),PPA(3),PPA(4))
2888 * maximum energy of photon nucleon system
2889       PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2
2890      &                                      +(YMAX*PPL0(3)+PPA(3))**2)
2891       ETOTGN = YMAX*PPL0(4)+PPA(4)
2892       EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2893       EGNMAX = MIN(EGNMAX,ECMAX)
2894 * minimum energy of photon nucleon system
2895       PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2
2896      &                                      +(YMIN*PPL0(3)+PPA(3))**2)
2897       ETOTGN = YMIN*PPL0(4)+PPA(4)
2898       EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2899       EGNMIN = MAX(EGNMIN,ECMIN)
2900
2901 * limits for Glauber-initialization
2902       Q2LI  = Q2MIN
2903       Q2HI  = MAX(Q2LI,MIN(Q2HI,Q2MAX))
2904       ECMLI = MAX(EGNMIN,THREE)
2905       ECMHI = EGNMAX
2906       WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI
2907  1004 FORMAT(1X,'resulting limits:',/,9X,'W (min)   =',F7.1,
2908      &       ' GeV    (max) =',F7.1,' GeV',/,/,' limits for ',
2909      &       'Glauber-initialization:',/,9X,'W (min)   =',F7.1,
2910      &       ' GeV    (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1,
2911      &       ' GeV^2  (max) =',F7.1,' GeV^2',/)
2912 * initialization of Glauber-formalism
2913       IF (NCOMPO.LE.0) THEN
2914          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2915       ELSE
2916          DO 9 I=1,NCOMPO
2917             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2918     9    CONTINUE
2919       ENDIF
2920       CALL DT_SIGEMU
2921
2922 * initialization of run-statistics and histograms
2923       CALL DT_STATIS(1)
2924
2925       CALL PHO_PHIST(1000,DUM)
2926
2927 * maximum photon-nucleus cross section
2928       I1  = 1
2929       I2  = 1
2930       RAT = ONE
2931       IF (EGNMAX.GE.ECMNN(NEBINI)) THEN
2932          I1  = NEBINI
2933          I2  = NEBINI
2934          RAT = ONE
2935       ELSEIF (EGNMAX.GT.ECMNN(1)) THEN
2936          DO 5 I=2,NEBINI
2937             IF (EGNMAX.LT.ECMNN(I)) THEN
2938                I1  = I-1
2939                I2  = I
2940                RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2941                GOTO 6
2942             ENDIF
2943     5    CONTINUE
2944     6    CONTINUE
2945       ENDIF
2946       SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2947       EGNXX  = EGNMAX
2948       I1  = 1
2949       I2  = 1
2950       RAT = ONE
2951       IF (EGNMIN.GE.ECMNN(NEBINI)) THEN
2952          I1  = NEBINI
2953          I2  = NEBINI
2954          RAT = ONE
2955       ELSEIF (EGNMIN.GT.ECMNN(1)) THEN
2956          DO 7 I=2,NEBINI
2957             IF (EGNMIN.LT.ECMNN(I)) THEN
2958                I1  = I-1
2959                I2  = I
2960                RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2961                GOTO 8
2962             ENDIF
2963     7    CONTINUE
2964     8    CONTINUE
2965       ENDIF
2966       SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2967       IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN
2968       SIGMAX = MAX(SIGMAX,SIGXX)
2969       WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb'
2970
2971 * plot photon flux table
2972       AYMIN = LOG(YMIN)
2973       AYMAX = LOG(YMAX)
2974       AYRGE = AYMAX-AYMIN
2975       MAXTAB = 50
2976       ADY    = LOG(YMAX/YMIN)/DBLE(MAXTAB-1)
2977 C     WRITE(LOUT,'(/,1X,A)') 'LAEVT:   photon flux '
2978       DO 1 I=1,MAXTAB
2979          Y     = EXP(AYMIN+ADY*DBLE(I-1))
2980          Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y))
2981          FF1   = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2982      &                           -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX))
2983          FF2   = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2984      &                           -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX))
2985 C        WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2
2986     1 CONTINUE
2987
2988 * maximum residual weight for flux sampling (dy/y)
2989       YY     = YMIN
2990       Q2LOW  = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2991       WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW)
2992      &         -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2993
2994       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0)
2995       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1)
2996       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2)
2997       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0)
2998       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1)
2999       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2)
3000       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0)
3001       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1)
3002       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2)
3003       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0)
3004       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1)
3005       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2)
3006       XBLOW = 0.001D0
3007       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0)
3008       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1)
3009       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2)
3010
3011       ITRY = 0
3012       ITRW = 0
3013       NC0  = 0
3014       NC1  = 0
3015
3016 * generate events
3017       DO 2 IEVT=1,NEVTS
3018          IF (MOD(IEVT,NMSG).EQ.0) THEN
3019 C           OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out',
3020 C    &                                         STATUS='UNKNOWN')
3021             WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled'
3022 C           CLOSE(LDAT)
3023          ENDIF
3024          NEVENT = IEVT
3025
3026   100    CONTINUE
3027          ITRY = ITRY+1
3028
3029 *  sample y
3030   101    CONTINUE
3031          ITRW  = ITRW+1
3032          YY    = EXP(AYRGE*DT_RNDM(RAT)+AYMIN)
3033          Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
3034          Q2LOG = LOG(Q2MAX/Q2LOW)
3035          WGH   = (ONE+(ONE-YY)**2)*Q2LOG
3036      &           -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
3037          IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH
3038  1000    FORMAT(1X,'LAEVT:   weight error!',3E12.5)
3039          IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101
3040
3041 *  sample Q2
3042          YEFF = ONE+(ONE-YY)**2
3043   102    CONTINUE
3044          Q2  = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
3045          WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF
3046          IF (WGH.LT.DT_RNDM(Q2)) GOTO 102
3047
3048 c        NC0 = NC0+1
3049 c        CALL DT_FILHGR(YY,ONE,IHFLY0,NC0)
3050 c        CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0)
3051
3052 *  kinematics at lepton-photon vertex
3053 *   scattered electron
3054          YQ2 = SQRT((ONE-YY)*Q2)
3055          Q2E = Q2/(4.0D0*PLEPT0(4))
3056          E1Y = (ONE-YY)*PLEPT0(4)
3057          CALL DT_DSFECF(SIF,COF)
3058          PLEPT1(1) = YQ2*COF
3059          PLEPT1(2) = YQ2*SIF
3060          PLEPT1(3) = E1Y-Q2E
3061          PLEPT1(4) = E1Y+Q2E
3062 C        THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) )
3063 *   radiated photon
3064          PGAMM(1) = -PLEPT1(1)
3065          PGAMM(2) = -PLEPT1(2)
3066          PGAMM(3) = PLEPT0(3)-PLEPT1(3)
3067          PGAMM(4) = PLEPT0(4)-PLEPT1(4)
3068 *   E_cm cut
3069          PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2
3070      &                                        +(PGAMM(3)+PNUCL(3))**2 )
3071          ETOTGN = PGAMM(4)+PNUCL(4)
3072          ECMGN  = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)
3073          IF (ECMGN.LT.0.1D0) GOTO 101
3074          ECMGN  = SQRT(ECMGN)
3075          IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101
3076
3077 *  Lorentz-transformation into nucleon-rest system
3078          CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3079      &               PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4),
3080      &               PGTOT,PPG(1),PPG(2),PPG(3),PPG(4))
3081          CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3082      &               PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4),
3083      &               PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4))
3084 *  temporary checks..
3085          Q2TMP = ABS(PPG(4)**2-PGTOT**2)
3086          IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP
3087  1001    FORMAT(1X,'LAEVT:    inconsistent kinematics (Q2,Q2TMP) ',
3088      &          2F10.4)
3089          ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT))
3090          IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP
3091  1002    FORMAT(1X,'LAEVT:    inconsistent kinematics (ECMGN,ECMTMP) ',
3092      &          2F10.2)
3093          YYTMP = PPG(4)/PPL0(4)
3094          IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP
3095  1005    FORMAT(1X,'LAEVT:    inconsistent kinematics (YY,YYTMP) ',
3096      &          2F10.4)
3097
3098 *  lepton tagger (Lab)
3099          THETA = ACOS( PPL1(3)/PLTOT )
3100          IF (PPL1(4).GT.ELMIN) THEN
3101             IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101
3102          ENDIF
3103 *  photon energy-cut (Lab)
3104          IF (PPG(4).LT.EGMIN) GOTO 101
3105          IF (PPG(4).GT.EGMAX) GOTO 101
3106 *   x_Bj cut
3107          XBJ = ABS(Q2/(1.876D0*PPG(4)))
3108          IF (XBJ.LT.XBJMIN) GOTO 101
3109
3110          NC0 = NC0+1
3111          CALL DT_FILHGR(    Q2,ONE,IHFLQ0,NC0)
3112          CALL DT_FILHGR(    YY,ONE,IHFLY0,NC0)
3113          CALL DT_FILHGR(   XBJ,ONE,IHFLX0,NC0)
3114          CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0)
3115          CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0)
3116
3117 *  rotation angles against z-axis
3118          COD = PPG(3)/PGTOT
3119 C        SID = SQRT((ONE-COD)*(ONE+COD))
3120          PPT = SQRT(PPG(1)**2+PPG(2)**2)
3121          SID = PPT/PGTOT
3122          COF = ONE
3123          SIF = ZERO
3124          IF (PGTOT*SID.GT.TINY10) THEN
3125             COF   = PPG(1)/(SID*PGTOT)
3126             SIF   = PPG(2)/(SID*PGTOT)
3127             ANORF = SQRT(COF*COF+SIF*SIF)
3128             COF   = COF/ANORF
3129             SIF   = SIF/ANORF
3130          ENDIF
3131
3132          IF (IXSTBL.EQ.0) THEN
3133 *  change to photon projectile
3134             IJPROJ = 7
3135 *  set virtuality
3136             VIRT = Q2
3137 *  re-initialize LTs with new kinematics
3138 *  !!PGAMM ist set in cms (ECMGN) along z
3139             EPN = ZERO
3140             PPN = ZERO
3141             CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0)
3142 *  Introduced by Chiara -> force CMS-system
3143 *            IFRAME = 2
3144 *  to force Lab-system
3145             IFRAME = 1
3146 *  get emulsion component if requested
3147             IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
3148 *  convolute with cross section
3149             CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT)
3150             CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT)
3151             IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)')
3152      &         'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX,
3153      &                                        Q2,ECMGN,STOT
3154             IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100
3155             NC1 = NC1+1
3156             CALL DT_FILHGR(    Q2,ONE,IHFLQ1,NC1)
3157             CALL DT_FILHGR(    YY,ONE,IHFLY1,NC1)
3158             CALL DT_FILHGR(   XBJ,ONE,IHFLX1,NC1)
3159             CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1)
3160             CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1)
3161 *  composite targets only
3162             KKMAT = -KKMAT
3163 *  sample this event
3164             CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT,
3165      &                                                            IREJ)
3166 *  rotate momenta of final state particles back in photon-nucleon syst.
3167             DO 4 I=NPOINT(4),NHKK
3168                IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3169      &                                      (ISTHKK(I).EQ.1001)) THEN
3170                   PX = PHKK(1,I)
3171                   PY = PHKK(2,I)
3172                   PZ = PHKK(3,I)
3173                   CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF,
3174      &                        PHKK(1,I),PHKK(2,I),PHKK(3,I))
3175                ENDIF
3176     4       CONTINUE
3177          ENDIF
3178
3179          CALL DT_FILHGR(    Q2,ONE,IHFLQ2,NC1)
3180          CALL DT_FILHGR(    YY,ONE,IHFLY2,NC1)
3181          CALL DT_FILHGR(   XBJ,ONE,IHFLX2,NC1)
3182          CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1)
3183          CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1)
3184
3185 *  dump this event to histograms
3186
3187          CALL PHO_PHIST(2000,DUM)
3188
3189     2 CONTINUE
3190
3191       WGY    = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW)
3192       WGY    = WGY*LOG(YMAX/YMIN)
3193       WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY)
3194
3195 C     HEADER = ' LAEVT:  Q^2 distribution 0'
3196 C     CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3197 C     HEADER = ' LAEVT:  Q^2 distribution 1'
3198 C     CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3199 C     HEADER = ' LAEVT:  Q^2 distribution 2'
3200 C     CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3201 C     HEADER = ' LAEVT:  y   distribution 0'
3202 C     CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3203 C     HEADER = ' LAEVT:  y   distribution 1'
3204 C     CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3205 C     HEADER = ' LAEVT:  y   distribution 2'
3206 C     CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3207 C     HEADER = ' LAEVT:  x   distribution 0'
3208 C     CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3209 C     HEADER = ' LAEVT:  x   distribution 1'
3210 C     CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3211 C     HEADER = ' LAEVT:  x   distribution 2'
3212 C     CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3213 C     HEADER = ' LAEVT:  E_g distribution 0'
3214 C     CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3215 C     HEADER = ' LAEVT:  E_g distribution 1'
3216 C     CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3217 C     HEADER = ' LAEVT:  E_g distribution 2'
3218 C     CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3219 C     HEADER = ' LAEVT:  E_c distribution 0'
3220 C     CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3221 C     HEADER = ' LAEVT:  E_c distribution 1'
3222 C     CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3223 C     HEADER = ' LAEVT:  E_c distribution 2'
3224 C     CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3225
3226 * print run-statistics and histograms to output-unit 6
3227
3228       CALL PHO_PHIST(3000,DUM)
3229
3230       IF (IXSTBL.EQ.0) CALL DT_STATIS(2)
3231
3232       RETURN
3233       END
3234 *
3235 *===dtuini=============================================================*
3236 *
3237 CDECK  ID>, DT_DTUINI
3238       SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
3239      &                                               IDP,IEMU)
3240
3241       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3242       SAVE
3243
3244       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
3245
3246 * emulsion treatment
3247       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
3248      &                NCOMPO,IEMUL
3249 * Glauber formalism: flags and parameters for statistics
3250       LOGICAL LPROD
3251       CHARACTER*8 CGLB
3252       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
3253
3254       CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU)
3255       CALL DT_STATIS(1)
3256
3257       CALL PHO_PHIST(1000,DUM)
3258
3259       IF (NCOMPO.LE.0) THEN
3260          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
3261       ELSE
3262          DO 1 I=1,NCOMPO
3263             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
3264     1    CONTINUE
3265       ENDIF
3266       IF (IOGLB.NE.100) CALL DT_SIGEMU
3267       IEMU = IEMUL
3268
3269       RETURN
3270       END
3271 *
3272 *===dtuout=============================================================*
3273 *
3274 CDECK  ID>, DT_DTUOUT
3275       SUBROUTINE DT_DTUOUT
3276
3277       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3278       SAVE
3279
3280       CALL PHO_PHIST(3000,DUM)
3281
3282       CALL DT_STATIS(2)
3283
3284       RETURN
3285       END
3286 *
3287 *===beam===============================================================*
3288 *
3289 CDECK  ID>, DT_BEAMPR
3290       SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE)
3291
3292 ************************************************************************
3293 * Initialization of event generation                                   *
3294 * This version dated  7.4.98  is written by S. Roesler.                *
3295 ************************************************************************
3296
3297       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3298       SAVE
3299
3300       PARAMETER ( LINP = 5 ,
3301      &            LOUT = 6 ,
3302      &            LDAT = 9 )
3303
3304       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3305       PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3306
3307       LOGICAL LBEAM
3308
3309 * event history
3310
3311       PARAMETER (NMXHKK=200000)
3312
3313       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3314      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3315      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3316 * extended event history
3317       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3318      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3319      &                IHIST(2,NMXHKK)
3320 * properties of interacting particles
3321       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3322 * particle properties (BAMJET index convention)
3323       CHARACTER*8  ANAME
3324       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3325      &                IICH(210),IIBAR(210),K1(210),K2(210)
3326 * beam momenta
3327       COMMON /DTBEAM/ P1(4),P2(4)
3328
3329 C     DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4)
3330       DIMENSION WHAT(6),P1CMS(4),P2CMS(4)
3331
3332       DATA LBEAM /.FALSE./
3333
3334       GOTO (1,2) MODE
3335
3336     1 CONTINUE
3337
3338       E1  = WHAT(1)
3339       IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1))
3340       E2  = WHAT(2)
3341       IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2))
3342       PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) )
3343       PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) )
3344       TH  = 1.D-6*WHAT(3)/2.D0
3345       PH  = WHAT(4)*BOG
3346       P1(1) = PP1*SIN(TH)*COS(PH)
3347       P1(2) = PP1*SIN(TH)*SIN(PH)
3348       P1(3) = PP1*COS(TH)
3349       P1(4) = E1
3350       P2(1) = PP2*SIN(TH)*COS(PH)
3351       P2(2) = PP2*SIN(TH)*SIN(PH)
3352       P2(3) = -PP2*COS(TH)
3353       P2(4) = E2
3354       ECM  = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
3355      &                                              -(P1(3)+P2(3))**2 )
3356       ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG))
3357       PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) )
3358       BGX  = (P1(1)+P2(1))/ECM
3359       BGY  = (P1(2)+P2(2))/ECM
3360       BGZ  = (P1(3)+P2(3))/ECM
3361       BGE  = (P1(4)+P2(4))/ECM
3362       CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4),
3363      &            P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4))
3364       CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4),
3365      &            P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4))
3366       COD = P1CMS(3)/P1TOT
3367 C     SID = SQRT((ONE-COD)*(ONE+COD))
3368       PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2)
3369       SID = PPT/P1TOT
3370       COF = ONE
3371       SIF = ZERO
3372       IF (P1TOT*SID.GT.TINY10) THEN
3373          COF   = P1CMS(1)/(SID*P1TOT)
3374          SIF   = P1CMS(2)/(SID*P1TOT)
3375          ANORF = SQRT(COF*COF+SIF*SIF)
3376          COF   = COF/ANORF
3377          SIF   = SIF/ANORF
3378       ENDIF
3379 **check
3380 C     WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3381 C     WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3382 C     WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT
3383 C     WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT
3384 C     PAX = ZERO
3385 C     PAY = ZERO
3386 C     PAZ = P1TOT
3387 C     PAE = SQRT(AAM(IJPROJ)**2+PAZ**2)
3388 C     PBX = ZERO
3389 C     PBY = ZERO
3390 C     PBZ = -P2TOT
3391 C     PBE = SQRT(AAM(IJTARG)**2+PBZ**2)
3392 C     WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE
3393 C     WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE
3394 C     CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF,
3395 C    &            P1CMS(1),P1CMS(2),P1CMS(3))
3396 C     CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF,
3397 C    &            P2CMS(1),P2CMS(2),P2CMS(3))
3398 C     WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)
3399 C     WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)
3400 C     CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),
3401 C    &            P1TOT,P1(1),P1(2),P1(3),P1(4))
3402 C     CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),
3403 C    &            P2TOT,P2(1),P2(2),P2(3),P2(4))
3404 C     WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3405 C     WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3406 C     STOP
3407 **
3408
3409       LBEAM = .TRUE.
3410
3411       RETURN
3412
3413     2 CONTINUE
3414
3415       IF (LBEAM) THEN
3416          IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3417          DO 20 I=NPOINT(4),NHKK
3418             IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3419      &                                   (ISTHKK(I).EQ.1001)) THEN
3420                CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
3421      &                     COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
3422                PECMS = PHKK(4,I)
3423                CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
3424      &                     PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
3425             ENDIF
3426    20    CONTINUE
3427       ELSE
3428          MODE = -1
3429       ENDIF
3430
3431       RETURN
3432       END
3433 *
3434 *===eventb=============================================================*
3435 *
3436 CDECK  ID>, DT_EVENTB
3437       SUBROUTINE DT_EVENTB(NCSY,IREJ)
3438
3439 ************************************************************************
3440 * Treatment of nucleon-nucleon interactions with full two-component    *
3441 * Dual Parton Model.                                                   *
3442 *          NCSY     number of nucleon-nucleon interactions             *
3443 *          IREJ     rejection flag                                     *
3444 * This version dated 14.01.2000 is written by S. Roesler               *
3445 ************************************************************************
3446
3447       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3448       SAVE
3449
3450       PARAMETER ( LINP = 5 ,
3451      &            LOUT = 6 ,
3452      &            LDAT = 9 )
3453
3454       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
3455
3456 * event history
3457
3458       PARAMETER (NMXHKK=200000)
3459
3460       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3461      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3462      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3463 * extended event history
3464       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3465      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3466      &                IHIST(2,NMXHKK)
3467 *! uncomment this line for internal phojet-fragmentation
3468 C #include "dtu_dtevtp.inc"
3469 * particle properties (BAMJET index convention)
3470       CHARACTER*8  ANAME
3471       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3472      &                IICH(210),IIBAR(210),K1(210),K2(210)
3473 * flags for input different options
3474       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
3475       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3476      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3477 * rejection counter
3478       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
3479      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
3480      &                IREXCI(3),IRDIFF(2),IRINC
3481 * properties of interacting particles
3482       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3483 * properties of photon/lepton projectiles
3484       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
3485 * various options for treatment of partons (DTUNUC 1.x)
3486 * (chain recombination, Cronin,..)
3487       LOGICAL LCO2CR,LINTPT
3488       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
3489      &                LCO2CR,LINTPT
3490 * statistics
3491       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
3492      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
3493      &                ICEVTG(8,0:30)
3494 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
3495       COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
3496 * Glauber formalism: collision properties
3497       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
3498      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
3499 * flags for diffractive interactions (DTUNUC 1.x)
3500       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
3501 * statistics: double-Pomeron exchange
3502       COMMON /DTFLG2/ INTFLG,IPOPO
3503 * flags for particle decays
3504       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
3505      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
3506      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
3507 * nucleon-nucleon event-generator
3508       CHARACTER*8 CMODEL
3509       LOGICAL LPHOIN
3510       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
3511 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
3512       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3513       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3514       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3515      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3516 C  model switches and parameters
3517       CHARACTER*8 MDLNA
3518       INTEGER ISWMDL,IPAMDL
3519       DOUBLE PRECISION PARMDL
3520       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3521 C  initial state parton radiation (internal part)
3522       INTEGER MXISR3,MXISR4
3523       PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
3524       INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
3525       DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
3526       COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
3527      &                ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
3528      &                IFL1(2,MXISR3),IFL2(2,MXISR3),
3529      &                IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
3530 C  event debugging information
3531       INTEGER NMAXD
3532       PARAMETER (NMAXD=100)
3533       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3534      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3535       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3536      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3537 C  general process information
3538       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3539       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3540
3541       DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
3542      &          PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
3543      &          PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
3544      &          KPRON(15),ISINGL(2000)
3545
3546 * initial values for max. number of phojet scatterings and dtunuc chains
3547 * to be fragmented with one pyexec call
3548       DATA MXPHFR,MXDTFR /10,100/
3549
3550       IREJ      = 0
3551 * pointer to first parton of the first chain in dtevt common
3552       NPOINT(3) = NHKK+1
3553 * special flag for double-Pomeron statistics
3554       IPOPO = 1
3555 * counter for low-mass (DTUNUC) interactions
3556       NDTUSC = 0
3557 * counter for interactions treated by PHOJET
3558       NPHOSC = 0
3559
3560 * scan interactions for single nucleon-nucleon interactions
3561 * (this has to be checked here because Cronin modifies parton momenta)
3562       NC = NPOINT(2)
3563       IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
3564       DO 8 I=1,NCSY
3565          ISINGL(I) = 0
3566          MOP = JMOHKK(1,NC)
3567          MOT = JMOHKK(1,NC+1)
3568          DIFF1 = ABS(PHKK(4,MOP)-PHKK(4,  NC)-PHKK(4,NC+2))
3569          DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
3570          IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
3571          NC = NC+4
3572     8 CONTINUE
3573
3574 * multiple scattering of chain ends
3575       IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
3576       IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
3577
3578 * switch to PHOJET-settings for JETSET parameter
3579       CALL DT_INITJS(1)
3580
3581 * loop over nucleon-nucleon interaction
3582       NC = NPOINT(2)
3583       DO 2 I=1,NCSY
3584 *
3585 *   pick up one nucleon-nucleon interaction from DTEVT1
3586 *     ppnn  / ptnn   - momenta of the interacting nucleons (cms)
3587 *     ptotnn         - total momentum of the interacting nucleons (cms)
3588 *     pp1,2 / pt1,2  - momenta of the four partons
3589 *     pp    / pt     - total momenta of the proj / targ partons
3590 *     ptot           - total momentum of the four partons
3591          MOP = JMOHKK(1,NC)
3592          MOT = JMOHKK(1,NC+1)
3593          DO 3 K=1,4
3594             PPNN(K)   = PHKK(K,MOP)
3595             PTNN(K)   = PHKK(K,MOT)
3596             PTOTNN(K) = PPNN(K)+PTNN(K)
3597             PP1(K)    = PHKK(K,NC)
3598             PT1(K)    = PHKK(K,NC+1)
3599             PP2(K)    = PHKK(K,NC+2)
3600             PT2(K)    = PHKK(K,NC+3)
3601             PP(K)     = PP1(K)+PP2(K)
3602             PT(K)     = PT1(K)+PT2(K)
3603             PTOT(K)   = PP(K)+PT(K)
3604     3    CONTINUE
3605 *
3606 *-----------------------------------------------------------------------
3607 *   this is a complete nucleon-nucleon interaction
3608 *
3609          IF (ISINGL(I).EQ.1) THEN
3610 *
3611 *     initialize PHOJET-variables for remnant/valence-partons
3612             IHFLD(1,1) = 0
3613             IHFLD(1,2) = 0
3614             IHFLD(2,1) = 0
3615             IHFLD(2,2) = 0
3616             IHFLS(1) = 1
3617             IHFLS(2) = 1
3618 *     save current settings of PHOJET process and min. bias flags
3619             DO 9 K=1,11
3620                KPRON(K) = IPRON(K,1)
3621     9       CONTINUE
3622             ISWSAV   = ISWMDL(2)
3623 *
3624 *     check if forced sampling of diffractive interaction requested
3625             IF (ISINGD.LT.-1) THEN
3626                DO 90 K=1,11
3627                   IPRON(K,1) = 0
3628    90          CONTINUE
3629                IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
3630                IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
3631                IF (ISINGD.EQ.-5) IPRON(4,1) = 1
3632             ENDIF
3633 *
3634 *     for photons: a direct/anomalous interaction is not sampled
3635 *     in PHOJET but already in Glauber-formalism. Here we check if such
3636 *     an interaction is requested
3637             IF (IJPROJ.EQ.7) THEN
3638 *       first switch off direct interactions
3639                IPRON(8,1) = 0
3640 *       this is a direct interactions
3641                IF (IDIREC.EQ.1) THEN
3642                   DO 12 K=1,11
3643                      IPRON(K,1) = 0
3644    12             CONTINUE
3645                   IPRON(8,1) = 1
3646 *       this is an anomalous interactions
3647 *         (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
3648                ELSEIF (IDIREC.EQ.2) THEN
3649                   ISWMDL(2) = 0
3650                ENDIF
3651             ELSE
3652                IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
3653             ENDIF
3654 *
3655 *     make sure that total momenta of partons, pp and pt, are on mass
3656 *     shell (Cronin may have srewed this up..)
3657             CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
3658             IF (IR1.NE.0) THEN
3659                IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
3660      &              'EVENTB:  mass shell correction rejected'
3661                GOTO 9999
3662             ENDIF
3663 *
3664 *     initialize the incoming particles in PHOJET
3665             IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3666
3667                CALL PHO_SETPAR(1,22,0,VIRT)
3668
3669             ELSE
3670
3671                CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
3672
3673             ENDIF
3674
3675             CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
3676
3677 *
3678 *     initialize rejection loop counter for anomalous processes
3679             IRJANO = 0
3680   800       CONTINUE
3681             IRJANO = IRJANO+1
3682 *
3683 *     temporary fix for ifano problem
3684             IFANO(1) = 0
3685             IFANO(2) = 0
3686 *
3687 *     generate complete hadron/nucleon/photon-nucleon event with PHOJET
3688
3689             CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
3690
3691 *
3692 *     for photons: special consistency check for anomalous interactions
3693             IF (IJPROJ.EQ.7) THEN
3694                IF (IRJANO.LT.30) THEN
3695                   IF (IFANO(1).NE.0) THEN
3696 *       here, an anomalous interaction was generated. Check if it
3697 *       was also requested. Otherwise reject this event.
3698                      IF (IDIREC.EQ.0) GOTO 800
3699                   ELSE
3700 *       here, an anomalous interaction was not generated. Check if it
3701 *       was requested in which case we need to reject this event.
3702                      IF (IDIREC.EQ.2) GOTO 800
3703                   ENDIF
3704                ELSE
3705                   WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
3706      &                          IRJANO,IDIREC,NEVHKK
3707                ENDIF
3708             ENDIF
3709 *
3710 *     copy back original settings of PHOJET process and min. bias flags
3711             DO 10 K=1,11
3712                IPRON(K,1) = KPRON(K)
3713    10       CONTINUE
3714             ISWMDL(2) = ISWSAV
3715 *
3716 *     check if PHOJET has rejected this event
3717             IF (IREJ1.NE.0) THEN
3718 C              IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3719                WRITE(LOUT,'(1X,A,I4)')
3720      &            'EVENTB:  chain system rejected',IDIREC
3721
3722                CALL PHO_PREVNT(0)
3723
3724                GOTO 9999
3725             ENDIF
3726 *
3727 *     copy partons and strings from PHOJET common back into DTEVT for
3728 *     external fragmentation
3729             MO1 = NC
3730             MO2 = NC+3
3731 *!      uncomment this line for internal phojet-fragmentation
3732 C           CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
3733             NPHOSC = NPHOSC+1
3734             CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
3735             IF (IREJ1.NE.0) THEN
3736                IF (IOULEV(1).GT.0)
3737      &         WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
3738                GOTO 9999
3739             ENDIF
3740 *
3741 *     update statistics counter
3742             ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
3743 *
3744 *-----------------------------------------------------------------------
3745 *   this interaction involves "remnants"
3746 *
3747          ELSE
3748 *
3749 *     total mass of this system
3750             PPTOT  = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
3751             AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
3752             IF (AMTOT2.LT.ZERO) THEN
3753                AMTOT = ZERO
3754             ELSE
3755                AMTOT = SQRT(AMTOT2)
3756             ENDIF
3757 *
3758 *     systems with masses larger than elojet are treated with PHOJET
3759             IF (AMTOT.GT.ELOJET) THEN
3760 *
3761 *     initialize PHOJET-variables for remnant/valence-partons
3762 *       projectile parton flavors and valence flag
3763                IHFLD(1,1) = IDHKK(NC)
3764                IHFLD(1,2) = IDHKK(NC+2)
3765                IHFLS(1)   = 0
3766                IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
3767      &                            .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
3768 *       target parton flavors and valence flag
3769                IHFLD(2,1) = IDHKK(NC+1)
3770                IHFLD(2,2) = IDHKK(NC+3)
3771                IHFLS(2)   = 0
3772                IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
3773      &                            .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
3774 *       flag signalizing PHOJET how to treat the remnant:
3775 *         iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
3776 *         iremn > -1 valence remnant: PHOJET assumes flavors according
3777 *                    to mother particle
3778                IREMN1 = IHFLS(1)-1
3779                IREMN2 = IHFLS(2)-1
3780 *
3781 *     initialize the incoming particles in PHOJET
3782                IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3783
3784                   CALL PHO_SETPAR(1,22,IREMN1,VIRT)
3785
3786                ELSE
3787
3788                   CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
3789
3790                ENDIF
3791
3792                CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
3793
3794 *
3795 *     calculate Lorentz parameter of the nucleon-nucleon cm-system
3796                PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
3797                AMNN   = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
3798                BGX    = PTOTNN(1)/AMNN
3799                BGY    = PTOTNN(2)/AMNN
3800                BGZ    = PTOTNN(3)/AMNN
3801                GAM    = PTOTNN(4)/AMNN
3802 *     transform interacting nucleons into nucleon-nucleon cm-system
3803                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3804      &                     PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
3805      &                     PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
3806                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3807      &                     PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
3808      &                     PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
3809 *     transform (total) momenta of the proj and targ partons into
3810 *     nucleon-nucleon cm-system
3811                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3812      &                     PP(1),PP(2),PP(3),PP(4),
3813      &                     PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
3814                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3815      &                     PT(1),PT(2),PT(3),PT(4),
3816      &                     PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
3817 *     energy fractions of the proj and targ partons
3818                XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
3819                XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
3820 ***
3821 * testprint
3822 c              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3823 c    &                        (PPTCMS(2)+PTTCMS(2))**2 +
3824 c    &                        (PPTCMS(3)+PTTCMS(3))**2 )
3825 c              EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3826 c    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3827 c              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3828 c    &                        (PPSUB(2)+PTSUB(2))**2 +
3829 c    &                        (PPSUB(3)+PTSUB(3))**2 )
3830 c              EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3831 c    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
3832 ***
3833 *
3834 *     save current settings of PHOJET process and min. bias flags
3835                DO 7 K=1,11
3836                   KPRON(K) = IPRON(K,1)
3837     7          CONTINUE
3838 *     disallow direct photon int. (does not make sense here anyway)
3839                IPRON(8,1) = 0
3840 *     disallow double pomeron processes (due to technical problems
3841 *     in PHOJET, needs to be solved sometime)
3842                IPRON(4,1) = 0
3843 *     disallow diffraction for sea-diquarks
3844                IF ((IABS(IHFLD(1,1)).GT.1100).AND.
3845      &             (IABS(IHFLD(1,2)).GT.1100)) THEN
3846                   IPRON(3,1) = 0
3847                   IPRON(6,1) = 0
3848                ENDIF
3849                IF ((IABS(IHFLD(2,1)).GT.1100).AND.
3850      &             (IABS(IHFLD(2,2)).GT.1100)) THEN
3851                   IPRON(3,1) = 0
3852                   IPRON(5,1) = 0
3853                ENDIF
3854 *
3855 *     we need massless partons: transform them on mass shell
3856                XMP = ZERO
3857                XMT = ZERO
3858                DO 6 K=1,4
3859                   PPTMP(K) = PPSUB(K)
3860                   PTTMP(K) = PTSUB(K)
3861     6          CONTINUE
3862                CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
3863                PPSUTO  = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
3864                PTSUTO  = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
3865                PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
3866      &                  (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
3867 *     total energy of the subsysten after mass transformation
3868 *      (should be the same as before..)
3869                SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
3870      &                      (PPSUB(4)+PTSUB(4)+PSUTOT) )
3871 *
3872 *     after mass shell transformation the x_sub - relation has to be
3873 *     corrected. We therefore create "pseudo-momenta" of mother-nucleons.
3874 *
3875 *     The old version was to scale based on the original x_sub and the
3876 *     4-momenta of the subsystem. At very high energy this could lead to
3877 *     "pseudo-cm energies" of the parent system considerably exceeding
3878 *     the true cm energy. Now we keep the true cm energy and calculate
3879 *     new x_sub instead.
3880 C old version  PPTCMS(4) = PPSUB(4)/XPSUB
3881                PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
3882                XPSUB = PPSUB(4)/PPTCMS(4)
3883                IF (IJPROJ.EQ.7) THEN
3884                   AMP2  = PHKK(5,MOT)**2
3885                   PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
3886                ELSE
3887 *???????
3888                   PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
3889      &                        *(PPTCMS(4)+PHKK(5,MOP)))
3890 C                 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
3891 C    &                        *(PPTCMS(4)+PHKK(5,MOT)))
3892                ENDIF
3893 C old version  PTTCMS(4) = PTSUB(4)/XTSUB
3894                PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
3895                XTSUB = PTSUB(4)/PTTCMS(4)
3896                PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
3897      &                     *(PTTCMS(4)+PHKK(5,MOT)))
3898                DO 4 K=1,3
3899                   PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
3900                   PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
3901     4          CONTINUE
3902 ***
3903 * testprint
3904 *
3905 *     ppnn  / ptnn   - momenta of the int. nucleons (cms, negl. Fermi)
3906 *     ptotnn         - total momentum of the int. nucleons (cms, negl. Fermi)
3907 *     pptcms/ pttcms - momenta of the interacting nucleons (cms)
3908 *     pp1,2 / pt1,2  - momenta of the four partons
3909 *
3910 *     pp    / pt     - total momenta of the pr/ta partons (cms, negl. Fermi)
3911 *     ptot           - total momentum of the four partons (cms, negl. Fermi)
3912 *     ppsub / ptsub  - total momenta of the proj / targ partons (cms)
3913 *
3914 c              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3915 c    &                        (PPTCMS(2)+PTTCMS(2))**2 +
3916 c    &                        (PPTCMS(3)+PTTCMS(3))**2 )
3917 c              ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3918 c    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3919 c              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3920 c    &                        (PPSUB(2)+PTSUB(2))**2 +
3921 c    &                        (PPSUB(3)+PTSUB(3))**2 )
3922 c              ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3923 c    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
3924 c              IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
3925 c                 WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
3926 c                 WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
3927 c                 WRITE(*,*) ' XPSUB,  XTSUB  : ',XPSUB,XTSUB
3928 c              ENDIF
3929 c              BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
3930 c              BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
3931 c              BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
3932 c              BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
3933 *     transform interacting nucleons into nucleon-nucleon cm-system
3934 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3935 c    &                    PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
3936 c    &                     PPNEW1,PPNEW2,PPNEW3,PPNEW4)
3937 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3938 c    &                    PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
3939 c    &                     PTNEW1,PTNEW2,PTNEW3,PTNEW4)
3940 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3941 c    &                     PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
3942 c    &                     PPSUB1,PPSUB2,PPSUB3,PPSUB4)
3943 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3944 c    &                     PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
3945 c    &                     PTSUB1,PTSUB2,PTSUB3,PTSUB4)
3946 c              PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
3947 c    &                        (PPNEW2+PTNEW2)**2 +
3948 c    &                        (PPNEW3+PTNEW3)**2 )
3949 c              ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
3950 c    &                        (PPNEW4+PTNEW4+PTSTCM) )
3951 c              PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
3952 c    &                        (PPSUB2+PTSUB2)**2 +
3953 c    &                        (PPSUB3+PTSUB3)**2 )
3954 c              ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
3955 c    &                        (PPSUB4+PTSUB4+PTSTSU) )
3956 C              WRITE(*,*) ' mother cmE :'
3957 C              WRITE(*,*) ETSTCM,ENEWCM
3958 C              WRITE(*,*) ' subsystem cmE :'
3959 C              WRITE(*,*) ETSTSU,ENEWSU
3960 C              WRITE(*,*) ' projectile mother :'
3961 C              WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
3962 C              WRITE(*,*) ' target mother :'
3963 C              WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
3964 C              WRITE(*,*) ' projectile subsystem:'
3965 C              WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
3966 C              WRITE(*,*) ' target subsystem:'
3967 C              WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
3968 C              WRITE(*,*) ' projectile subsystem should be:'
3969 C              WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
3970 C    &                    XPSUB*ETSTCM/2.0D0
3971 C              WRITE(*,*) ' target subsystem should be:'
3972 C              WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
3973 C    &                    XTSUB*ETSTCM/2.0D0
3974 C              WRITE(*,*) ' subsystem cmE should be: '
3975 C              WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
3976 ***
3977 *
3978 *     generate complete remnant - nucleon/remnant event with PHOJET
3979
3980                CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
3981
3982 *
3983 *     copy back original settings of PHOJET process flags
3984                DO 11 K=1,11
3985                   IPRON(K,1) = KPRON(K)
3986    11          CONTINUE
3987 *
3988 *     check if PHOJET has rejected this event
3989                IF (IREJ1.NE.0) THEN
3990                   IF (IOULEV(1).GT.0)
3991      &            WRITE(LOUT,'(1X,A)') 'EVENTB:  chain system rejected'
3992                   WRITE(LOUT,*)
3993      &                 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
3994
3995                   CALL PHO_PREVNT(0)
3996
3997                   GOTO 9999
3998                ENDIF
3999 *
4000 *     copy partons and strings from PHOJET common back into DTEVT for
4001 *     external fragmentation
4002                MO1 = NC
4003                MO2 = NC+3
4004 *!      uncomment this line for internal phojet-fragmentation
4005 C              CALL DT_GETFSP(MO1,MO2,PP,PT,1)
4006                NPHOSC = NPHOSC+1
4007                CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
4008                IF (IREJ1.NE.0) THEN
4009                   IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
4010      &               'EVENTB: chain system rejected 2'
4011                   GOTO 9999
4012                ENDIF
4013 *
4014 *     update statistics counter
4015                ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
4016 *
4017 *-----------------------------------------------------------------------
4018 * two-chain approx. for smaller systems
4019 *
4020             ELSE
4021 *
4022                NDTUSC = NDTUSC+1
4023 *   special flag for double-Pomeron statistics
4024                IPOPO = 0
4025 *
4026 *   pick up flavors at the ends of the two chains
4027                IFP1 = IDHKK(NC)
4028                IFT1 = IDHKK(NC+1)
4029                IFP2 = IDHKK(NC+2)
4030                IFT2 = IDHKK(NC+3)
4031 *   ..and the indices of the mothers
4032                MOP1 = NC
4033                MOT1 = NC+1
4034                MOP2 = NC+2
4035                MOT2 = NC+3
4036                CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
4037      &                     IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
4038 *
4039 *   check if this chain system was rejected
4040                IF (IREJ1.GT.0) THEN
4041                   IF (IOULEV(1).GT.0) THEN
4042                      WRITE(LOUT,*) 'rejected 1 in EVENTB'
4043                      WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
4044      &                  IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
4045                   ENDIF
4046                   IRHHA = IRHHA+1
4047                   GOTO 9999
4048                ENDIF
4049 *   the following lines are for sea-sea chains rejected in GETCSY
4050                IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
4051                ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
4052             ENDIF
4053 *
4054          ENDIF
4055 *
4056 *     update statistics counter
4057          ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
4058 *
4059          NC = NC+4
4060 *
4061     2 CONTINUE
4062 *
4063 *-----------------------------------------------------------------------
4064 * treatment of low-mass chains (if there are any)
4065 *
4066       IF (NDTUSC.GT.0) THEN
4067 *
4068 *   correct chains of very low masses for possible resonances
4069          IF (IRESCO.EQ.1) THEN
4070             CALL DT_EVTRES(IREJ1)
4071             IF (IREJ1.GT.0) THEN
4072                IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
4073                IRRES(1) = IRRES(1)+1
4074                GOTO 9999
4075             ENDIF
4076          ENDIF
4077 *   fragmentation of low-mass chains
4078 *!  uncomment this line for internal phojet-fragmentation
4079 *   (of course it will still be fragmented by DPMJET-routines but it
4080 *    has to be done here instead of further below)
4081 C        CALL DT_EVTFRA(IREJ1)
4082 C        IF (IREJ1.GT.0) THEN
4083 C           IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
4084 C           IRFRAG = IRFRAG+1
4085 C           GOTO 9999
4086 C        ENDIF
4087       ELSE
4088 *! uncomment this line for internal phojet-fragmentation
4089 C        NPOINT(4) = NHKK+1
4090          IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
4091       ENDIF
4092 *
4093 *-----------------------------------------------------------------------
4094 * new di-quark breaking mechanisms
4095 *
4096       MXLEFT = 2
4097       CALL DT_CHASTA(0)
4098       IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
4099      &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
4100          CALL DT_DIQBRK
4101          MXLEFT = 4
4102       ENDIF
4103 *
4104 *-----------------------------------------------------------------------
4105 * hadronize this event
4106 *
4107 *   hadronize PHOJET chain systems
4108       NPYMAX = 0
4109       NPJE   = NPHOSC/MXPHFR
4110       IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
4111       IF (NPJE.GT.1) THEN
4112          NLEFT = NPHOSC-NPJE*MXPHFR
4113          DO 20 JFRG=1,NPJE
4114             NFRG = JFRG*MXPHFR
4115             IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
4116                CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4117                IF (IREJ1.GT.0) GOTO 22
4118                NLEFT = 0
4119             ELSE
4120                CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
4121                IF (IREJ1.GT.0) GOTO 22
4122             ENDIF
4123             IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4124    20    CONTINUE
4125          IF (NLEFT.GT.0) THEN
4126             CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4127             IF (IREJ1.GT.0) GOTO 22
4128             IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4129          ENDIF
4130       ELSE
4131          CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4132          IF (IREJ1.GT.0) GOTO 22
4133          IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4134       ENDIF
4135 *
4136 *   check max. filling level of jetset common and
4137 *   reduce mxphfr if necessary
4138       IF (NPYMAX.GT.3000) THEN
4139          IF (NPYMAX.GT.3500) THEN
4140             MXPHFR = MAX(1,MXPHFR-2)
4141          ELSE
4142             MXPHFR = MAX(1,MXPHFR-1)
4143          ENDIF
4144 C        WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
4145       ENDIF
4146 *
4147 *   hadronize DTUNUC chain systems
4148    23 CONTINUE
4149       IBACK = MXDTFR
4150       CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
4151       IF (IREJ2.GT.0) GOTO 22
4152 *
4153 *   check max. filling level of jetset common and
4154 *   reduce mxdtfr if necessary
4155       IF (NPYMEM.GT.3000) THEN
4156          IF (NPYMEM.GT.3500) THEN
4157             MXDTFR = MAX(1,MXDTFR-20)
4158          ELSE
4159             MXDTFR = MAX(1,MXDTFR-10)
4160          ENDIF
4161 C        WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
4162       ENDIF
4163 *
4164       IF (IBACK.EQ.-1) GOTO 23
4165 *
4166    22 CONTINUE
4167 C     CALL DT_EVTFRG(1,IREJ1)
4168 C     CALL DT_EVTFRG(2,IREJ2)
4169       IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
4170          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
4171          IRFRAG = IRFRAG+1
4172          GOTO 9999
4173       ENDIF
4174 *
4175 * get final state particles from /DTEVTP/
4176 *! uncomment this line for internal phojet-fragmentation
4177 C     CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
4178
4179       IF (IJPROJ.NE.7)
4180      &   CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
4181 C     IF (IREJ3.NE.0) GOTO 9999
4182
4183       RETURN
4184
4185  9999 CONTINUE
4186       IREVT = IREVT+1
4187       IREJ  = 1
4188       RETURN
4189       END
4190 *
4191 *===getpje=============================================================*
4192 *
4193 CDECK  ID>, DT_GETPJE
4194       SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
4195
4196 ************************************************************************
4197 * This subroutine copies PHOJET partons and strings from POEVT1 into   *
4198 * DTEVT1.                                                              *
4199 *      MO1,MO2   indices of first and last mother-parton in DTEVT1     *
4200 *      PP,PT     4-momenta of projectile/target being handled by       *
4201 *                PHOJET                                                *
4202 * This version dated 11.12.99 is written by S. Roesler                 *
4203 ************************************************************************
4204
4205       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4206       SAVE
4207
4208       PARAMETER ( LINP = 5 ,
4209      &            LOUT = 6 ,
4210      &            LDAT = 9 )
4211
4212       PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
4213      &           ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
4214
4215       LOGICAL LFLIP
4216
4217 * event history
4218
4219       PARAMETER (NMXHKK=200000)
4220
4221       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4222      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4223      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4224 * extended event history
4225       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4226      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4227      &                IHIST(2,NMXHKK)
4228 * Lorentz-parameters of the current interaction
4229       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4230      &                UMO,PPCM,EPROJ,PPROJ
4231 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
4232       COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
4233 * flags for input different options
4234       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4235       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4236      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4237 * statistics: double-Pomeron exchange
4238       COMMON /DTFLG2/ INTFLG,IPOPO
4239 * statistics
4240       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
4241      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
4242      &                ICEVTG(8,0:30)
4243 * rejection counter
4244       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
4245      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
4246      &                IREXCI(3),IRDIFF(2),IRINC
4247
4248 C  standard particle data interface
4249       INTEGER NMXHEP
4250
4251       PARAMETER (NMXHEP=4000)
4252
4253       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
4254       DOUBLE PRECISION PHEP,VHEP
4255       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
4256      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
4257      &                VHEP(4,NMXHEP)
4258 C  extension to standard particle data interface (PHOJET specific)
4259       INTEGER IMPART,IPHIST,ICOLOR
4260       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
4261
4262 C  color string configurations including collapsed strings and hadrons
4263       INTEGER MSTR
4264       PARAMETER (MSTR=500)
4265       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
4266       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
4267      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
4268      &                NNCH(MSTR),IBHAD(MSTR),ISTR
4269 C  general process information
4270       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4271       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4272 C  model switches and parameters
4273       CHARACTER*8 MDLNA
4274       INTEGER ISWMDL,IPAMDL
4275       DOUBLE PRECISION PARMDL
4276       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4277 C  event debugging information
4278       INTEGER NMAXD
4279       PARAMETER (NMAXD=100)
4280       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4281      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4282       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4283      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4284
4285       DIMENSION PP(4),PT(4)
4286       DATA MAXLOP /10000/
4287
4288       INHKK = NHKK
4289       LFLIP = .TRUE.
4290     1 CONTINUE
4291       NPVAL = 0
4292       NTVAL = 0
4293       IREJ  = 0
4294
4295 *   store initial momenta for energy-momentum conservation check
4296       IF (LEMCCK) THEN
4297          CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
4298          CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
4299       ENDIF
4300 * copy partons and strings from POEVT1 into DTEVT1
4301       DO 11 I=1,ISTR
4302 C        IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
4303          IF (NCODE(I).EQ.-99) THEN
4304             IDXSTG = NPOS(1,I)
4305             IDSTG  = IDHEP(IDXSTG)
4306             PX = PHEP(1,IDXSTG)
4307             PY = PHEP(2,IDXSTG)
4308             PZ = PHEP(3,IDXSTG)
4309             PE = PHEP(4,IDXSTG)
4310             IF (MODE.LT.0) THEN
4311                ISTAT = 70000+IPJE
4312                CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
4313      &                        11,IDSTG,0)
4314                IF (LEMCCK) THEN
4315                   PX = -PX
4316                   PY = -PY
4317                   PZ = -PZ
4318                   PE = -PE
4319                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4320                ENDIF
4321             ELSE
4322                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4323      &                        PPX,PPY,PPZ,PPE)
4324                ISTAT = 70000+IPJE
4325                CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
4326      &                        11,IDSTG,0)
4327                IF (LEMCCK) THEN
4328                   PX = -PPX
4329                   PY = -PPY
4330                   PZ = -PPZ
4331                   PE = -PPE
4332                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4333                ENDIF
4334             ENDIF
4335             NOBAM(NHKK)   = 0
4336             IHIST(1,NHKK) = IPHIST(1,IDXSTG)
4337             IHIST(2,NHKK) = 0
4338          ELSEIF (NCODE(I).GE.0) THEN
4339 *   indices of partons and string in POEVT1
4340             IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
4341             IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
4342             IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
4343                WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
4344      &         ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
4345                STOP ' GETPJE 1'
4346             ENDIF
4347             IDXSTG = NPOS(1,I)
4348 *   find "mother" string of the string
4349             IDXMS1 = ABS(JMOHEP(1,IDX1))
4350             IDXMS2 = ABS(JMOHEP(1,IDX2))
4351             IF (IDXMS1.NE.IDXMS2) THEN
4352                IDXMS1 = IDXSTG
4353                IDXMS2 = IDXSTG
4354 C              STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
4355             ENDIF
4356 *   search POEVT1 for the original hadron of the parton
4357             ILOOP = 0
4358             IPOM1 = 0
4359    14       CONTINUE
4360             ILOOP = ILOOP+1
4361
4362             IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
4363
4364             IDXMS1 = ABS(JMOHEP(1,IDXMS1))
4365             IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
4366      &          (ILOOP.LT.MAXLOP)) GOTO 14
4367             IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
4368             IPOM2 = 0
4369             ILOOP = 0
4370    15       CONTINUE
4371             ILOOP = ILOOP+1
4372
4373             IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
4374
4375             IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
4376                IDXMS2 = ABS(JMOHEP(2,IDXMS2))
4377             ELSE
4378                IDXMS2 = ABS(JMOHEP(1,IDXMS2))
4379             ENDIF
4380             IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
4381      &          (ILOOP.LT.MAXLOP)) GOTO 15
4382             IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
4383 *   parton 1
4384             IF (IDXMS1.EQ.1) THEN
4385                ISPTN1 = ISTHKK(MO1)
4386                M1PTN1 = MO1
4387                M2PTN1 = MO1+2
4388             ELSE
4389                ISPTN1 = ISTHKK(MO2)
4390                M1PTN1 = MO2-2
4391                M2PTN1 = MO2
4392             ENDIF
4393 *   parton 2
4394             IF (IDXMS2.EQ.1) THEN
4395                ISPTN2 = ISTHKK(MO1)
4396                M1PTN2 = MO1
4397                M2PTN2 = MO1+2
4398             ELSE
4399                ISPTN2 = ISTHKK(MO2)
4400                M1PTN2 = MO2-2
4401                M2PTN2 = MO2
4402             ENDIF
4403 *   check for mis-identified mothers and switch mother indices if necessary
4404             IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
4405      &          .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
4406      &          (LFLIP)) THEN
4407                IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
4408                   ISPTN1 = ISTHKK(MO1)
4409                   M1PTN1 = MO1
4410                   M2PTN1 = MO1+2
4411                   ISPTN2 = ISTHKK(MO2)
4412                   M1PTN2 = MO2-2
4413                   M2PTN2 = MO2
4414                ELSE
4415                   ISPTN1 = ISTHKK(MO2)
4416                   M1PTN1 = MO2-2
4417                   M2PTN1 = MO2
4418                   ISPTN2 = ISTHKK(MO1)
4419                   M1PTN2 = MO1
4420                   M2PTN2 = MO1+2
4421                ENDIF
4422             ENDIF
4423 *   register partons in temporary common
4424 *     parton at chain end
4425             PX = PHEP(1,IDX1)
4426             PY = PHEP(2,IDX1)
4427             PZ = PHEP(3,IDX1)
4428             PE = PHEP(4,IDX1)
4429 * flag only partons coming from Pomeron with 41/42
4430 C           IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4431             IF (IPOM1.NE.0) THEN
4432                ISTX = ABS(ISPTN1)/10
4433                IMO  = ABS(ISPTN1)-10*ISTX
4434                ISPTN1 = -(40+IMO)
4435             ELSE
4436                IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
4437                   ISTX = ABS(ISPTN1)/10
4438                   IMO  = ABS(ISPTN1)-10*ISTX
4439                   IF ((IDHEP(IDX1).EQ.21).OR.
4440      &                (ABS(IPHIST(1,IDX1)).GE.100)) THEN
4441                      ISPTN1 = -(60+IMO)
4442                   ELSE
4443                      ISPTN1 = -(50+IMO)
4444                   ENDIF
4445                ENDIF
4446             ENDIF
4447             IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
4448             IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
4449             IF (MODE.LT.0) THEN
4450                CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
4451      &                        PZ,PE,0,0,0)
4452             ELSE
4453                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4454      &                        PPX,PPY,PPZ,PPE)
4455                CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
4456      &                        PPZ,PPE,0,0,0)
4457             ENDIF
4458             IHIST(1,NHKK) = IPHIST(1,IDX1)
4459             IHIST(2,NHKK) = 0
4460             DO 19 KK=1,4
4461                VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
4462                WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
4463    19       CONTINUE
4464             VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
4465             WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
4466             M1STRG = NHKK
4467 *     gluon kinks
4468             NGLUON = IDX2-IDX1-1
4469             IF (NGLUON.GT.0) THEN
4470                DO 17 IGLUON=1,NGLUON
4471                   IDX   = IDX1+IGLUON
4472                   IDXMS = ABS(JMOHEP(1,IDX))
4473                   IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
4474                      ILOOP = 0
4475    16                CONTINUE
4476                      ILOOP = ILOOP+1
4477                      IDXMS = ABS(JMOHEP(1,IDXMS))
4478                      IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
4479      &                   (ILOOP.LT.MAXLOP)) GOTO 16
4480                      IF (ILOOP.EQ.MAXLOP)
4481      &                  WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
4482                   ENDIF
4483                   IF (IDXMS.EQ.1) THEN
4484                      ISPTN = ISTHKK(MO1)
4485                      M1PTN = MO1
4486                      M2PTN = MO1+2
4487                   ELSE
4488                      ISPTN = ISTHKK(MO2)
4489                      M1PTN = MO2-2
4490                      M2PTN = MO2
4491                   ENDIF
4492                   PX = PHEP(1,IDX)
4493                   PY = PHEP(2,IDX)
4494                   PZ = PHEP(3,IDX)
4495                   PE = PHEP(4,IDX)
4496                   IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
4497                      ISTX = ABS(ISPTN)/10
4498                      IMO  = ABS(ISPTN)-10*ISTX
4499                      IF ((IDHEP(IDX).EQ.21).OR.
4500      &                   (ABS(IPHIST(1,IDX)).GE.100)) THEN
4501                         ISPTN = -(60+IMO)
4502                      ELSE
4503                         ISPTN = -(50+IMO)
4504                      ENDIF
4505                   ENDIF
4506                   IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
4507                   IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
4508                   IF (MODE.LT.0) THEN
4509                      CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4510      &                              PX,PY,PZ,PE,0,0,0)
4511                   ELSE
4512                      CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4513      &                              PPX,PPY,PPZ,PPE)
4514                      CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4515      &                              PPX,PPY,PPZ,PPE,0,0,0)
4516                   ENDIF
4517                   IHIST(1,NHKK) = IPHIST(1,IDX)
4518                   IHIST(2,NHKK) = 0
4519                   DO 20 KK=1,4
4520                      VHKK(KK,NHKK) = VHKK(KK,M2PTN)
4521                      WHKK(KK,NHKK) = WHKK(KK,M1PTN)
4522    20             CONTINUE
4523                   VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
4524                   WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
4525    17          CONTINUE
4526             ENDIF
4527 *     parton at chain end
4528             PX = PHEP(1,IDX2)
4529             PY = PHEP(2,IDX2)
4530             PZ = PHEP(3,IDX2)
4531             PE = PHEP(4,IDX2)
4532 * flag only partons coming from Pomeron with 41/42
4533 C           IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4534             IF (IPOM2.NE.0) THEN
4535                ISTX = ABS(ISPTN2)/10
4536                IMO  = ABS(ISPTN2)-10*ISTX
4537                ISPTN2 = -(40+IMO)
4538             ELSE
4539                IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
4540                   ISTX = ABS(ISPTN2)/10
4541                   IMO  = ABS(ISPTN2)-10*ISTX
4542                   IF ((IDHEP(IDX2).EQ.21).OR.
4543      &                (ABS(IPHIST(1,IDX2)).GE.100)) THEN
4544                      ISPTN2 = -(60+IMO)
4545                   ELSE
4546                      ISPTN2 = -(50+IMO)
4547                   ENDIF
4548                ENDIF
4549             ENDIF
4550             IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
4551             IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
4552             IF (MODE.LT.0) THEN
4553                CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4554      &                        PX,PY,PZ,PE,0,0,0)
4555             ELSE
4556                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4557      &                        PPX,PPY,PPZ,PPE)
4558                CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4559      &                        PPX,PPY,PPZ,PPE,0,0,0)
4560             ENDIF
4561             IHIST(1,NHKK) = IPHIST(1,IDX2)
4562             IHIST(2,NHKK) = 0
4563             DO 21 KK=1,4
4564                VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
4565                WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
4566    21       CONTINUE
4567             VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
4568             WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
4569             M2STRG = NHKK
4570 *   register string
4571             JSTRG = 100*IPROCE+NCODE(I)
4572             PX = PHEP(1,IDXSTG)
4573             PY = PHEP(2,IDXSTG)
4574             PZ = PHEP(3,IDXSTG)
4575             PE = PHEP(4,IDXSTG)
4576             IF (MODE.LT.0) THEN
4577                ISTAT = 70000+IPJE
4578                CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4579      &                        PX,PY,PZ,PE,0,0,0)
4580                IF (LEMCCK) THEN
4581                   PX = -PX
4582                   PY = -PY
4583                   PZ = -PZ
4584                   PE = -PE
4585                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4586                ENDIF
4587             ELSE
4588                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4589      &                        PPX,PPY,PPZ,PPE)
4590                ISTAT = 70000+IPJE
4591                CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4592      &                        PPX,PPY,PPZ,PPE,0,0,0)
4593                IF (LEMCCK) THEN
4594                   PX = -PPX
4595                   PY = -PPY
4596                   PZ = -PPZ
4597                   PE = -PPE
4598                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4599                ENDIF
4600             ENDIF
4601             NOBAM(NHKK)   = 0
4602             IHIST(1,NHKK) = 0
4603             IHIST(2,NHKK) = 0
4604             DO 18 KK=1,4
4605                VHKK(KK,NHKK) = VHKK(KK,MO2)
4606                WHKK(KK,NHKK) = WHKK(KK,MO1)
4607    18       CONTINUE
4608             VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
4609             WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
4610          ENDIF
4611    11 CONTINUE
4612
4613       IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
4614          NHKK  = INHKK
4615          LFLIP = .FALSE.
4616          GOTO 1
4617       ENDIF
4618
4619       IF (LEMCCK) THEN
4620          IF (UMO.GT.1.0D5) THEN
4621             CHKLEV = 1.0D0
4622          ELSE
4623             CHKLEV = TINY1
4624          ENDIF
4625          CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
4626
4627          IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
4628
4629       ENDIF
4630
4631 * internal statistics
4632 *   dble-Po statistics.
4633       IF (IPROCE.NE.4) IPOPO = 0
4634
4635       INTFLG = IPROCE
4636       IDCHSY = IDCH(MO1)
4637       IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
4638          ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
4639       ELSE
4640          WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
4641  1000    FORMAT(1X,'GETFSP:   warning! incons. process id. (',I2,
4642      &          ') at evt(chain) ',I6,'(',I2,')')
4643       ENDIF
4644       IF (IPROCE.EQ.5) THEN
4645          IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
4646             ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
4647          ELSE
4648 C           WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4649  1001       FORMAT(1X,'GETFSP:   warning! incons. diffrac. id. ',
4650      &             '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
4651          ENDIF
4652       ELSEIF (IPROCE.EQ.6) THEN
4653          IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4654             ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
4655          ELSE
4656 C           WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4657          ENDIF
4658       ELSEIF (IPROCE.EQ.7) THEN
4659          IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
4660      &       (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4661             IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
4662      &         ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
4663             IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
4664      &         ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
4665             IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
4666      &         ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
4667             IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
4668      &         ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
4669          ELSE
4670             WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4671          ENDIF
4672       ENDIF
4673       IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
4674      &                                                       THEN
4675          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4676          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4677          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4678       ENDIF
4679       ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
4680       ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
4681       ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
4682       ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
4683       ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
4684
4685       RETURN
4686
4687  9999 CONTINUE
4688       IREJ = 1
4689       RETURN
4690       END
4691 *
4692 *===phoini=============================================================*
4693 *
4694 CDECK  ID>, DT_PHOINI
4695       SUBROUTINE DT_PHOINI
4696
4697 ************************************************************************
4698 * Initialization PHOJET-event generator for nucleon-nucleon interact.  *
4699 * This version dated 16.11.95 is written by S. Roesler                 *
4700 * Last change: s.r. 21.01.01                                           *
4701 ************************************************************************
4702
4703       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4704       SAVE
4705
4706       PARAMETER ( LINP = 5 ,
4707      &            LOUT = 6 ,
4708      &            LDAT = 9 )
4709
4710       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
4711
4712 * nucleon-nucleon event-generator
4713       CHARACTER*8 CMODEL
4714       LOGICAL LPHOIN
4715       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
4716 * particle properties (BAMJET index convention)
4717       CHARACTER*8  ANAME
4718       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
4719      &                IICH(210),IIBAR(210),K1(210),K2(210)
4720 * Lorentz-parameters of the current interaction
4721       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4722      &                UMO,PPCM,EPROJ,PPROJ
4723 * properties of interacting particles
4724       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4725 * properties of photon/lepton projectiles
4726       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
4727
4728       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
4729
4730 * emulsion treatment
4731       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
4732      &                NCOMPO,IEMUL
4733 * VDM parameter for photon-nucleus interactions
4734       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
4735 * nuclear potential
4736       LOGICAL LFERMI
4737       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4738      &                EBINDP(2),EBINDN(2),EPOT(2,210),
4739      &                ETACOU(2),ICOUL,LFERMI
4740 * Glauber formalism: flags and parameters for statistics
4741       LOGICAL LPROD
4742       CHARACTER*8 CGLB
4743       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
4744 *
4745 * parameters for cascade calculations:
4746 * maximum mumber of PDF's which can be defined in phojet (limited
4747 * by the dimension of ipdfs in pho_setpdf)
4748       PARAMETER (MAXPDF = 20)
4749 * PDF parametrization and number of set for the first 30 hadrons in
4750 * the bamjet-code list
4751 *   negative numbers mean that the PDF is set in phojet,
4752 *   zero stands for "not a hadron"
4753       DIMENSION IPARPD(30),ISETPD(30)
4754 * PDF parametrization
4755       DATA IPARPD /
4756      &  -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
4757      &   5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
4758 * number of set
4759       DATA ISETPD /
4760      &  -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
4761      &   6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
4762
4763 **PHOJET105a
4764 C     COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4765 C     PARAMETER ( MAXPRO = 16 )
4766 C     PARAMETER ( MAXTAB = 20 )
4767 C     COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
4768 C    &                MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
4769 C     CHARACTER*8 MDLNA
4770 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
4771 C     COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
4772 **PHOJET110
4773 C  global event kinematics and particle IDs
4774       INTEGER IFPAP,IFPAB
4775       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
4776       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4777 C  hard cross sections and MC selection weights
4778       INTEGER Max_pro_2
4779       PARAMETER ( Max_pro_2 = 16 )
4780       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
4781      &  MH_acc_1,MH_acc_2
4782       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
4783       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
4784      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
4785      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
4786      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
4787      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
4788 C  model switches and parameters
4789       CHARACTER*8 MDLNA
4790       INTEGER ISWMDL,IPAMDL
4791       DOUBLE PRECISION PARMDL
4792       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4793 C  general process information
4794       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4795       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4796 **
4797       DIMENSION PP(4),PT(4)
4798
4799       LOGICAL LSTART
4800       DATA LSTART /.TRUE./
4801
4802       IJP = IJPROJ
4803       IJT = IJTARG
4804       Q2  = VIRT
4805 * lepton-projectiles: initialize real photon instead
4806       IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
4807          IJP = 7
4808          Q2  = ZERO
4809       ENDIF
4810
4811       IF (LPHOIN) CALL PHO_INIT(-1,IDUM)
4812
4813 * switch Reggeon off
4814 C     IPAMDL(3)= 0
4815       IF (IP.EQ.1) THEN
4816          IFPAP(1) = IDT_IPDGHA(IJP)
4817          IFPAB(1) = IJP
4818       ELSE
4819          IFPAP(1) = 2212
4820          IFPAB(1) = IDT_ICIHAD(IFPAP(1))
4821       ENDIF
4822       PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
4823       PVIRT(1) = PMASS(1)**2
4824       IF (IT.EQ.1) THEN
4825          IFPAP(2) = IDT_IPDGHA(IJT)
4826          IFPAB(2) = IJT
4827       ELSE
4828          IFPAP(2) = 2212
4829          IFPAB(2) = IDT_ICIHAD(IFPAP(2))
4830       ENDIF
4831       PMASS(2) = AAM(IFPAB(2))
4832       PVIRT(2) = ZERO
4833       DO 1 K=1,4
4834          PP(K) = ZERO
4835          PT(K) = ZERO
4836     1 CONTINUE
4837 * get max. possible momenta of incoming particles to be used for PHOJET ini.
4838       PPF = ZERO
4839       PTF = ZERO
4840       SCPF= 1.5D0
4841       IF (UMO.GE.1.E5) THEN
4842          SCPF= 5.0D0
4843       ENDIF
4844       IF (NCOMPO.GT.0) THEN
4845          DO 2 I=1,NCOMPO
4846             IF (IT.GT.1) THEN
4847                CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
4848             ELSE
4849                CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
4850             ENDIF
4851             PPFTMP = MAX(PFERMP(1),PFERMN(1))
4852             PTFTMP = MAX(PFERMP(2),PFERMN(2))
4853             IF (PPFTMP.GT.PPF) PPF = PPFTMP
4854             IF (PTFTMP.GT.PTF) PTF = PTFTMP
4855     2    CONTINUE
4856       ELSE
4857          CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
4858          PPF = MAX(PFERMP(1),PFERMN(1))
4859          PTF = MAX(PFERMP(2),PFERMN(2))
4860       ENDIF
4861       PTF = -PTF
4862       PPF = SCPF*PPF
4863       PTF = SCPF*PTF
4864       IF (IJP.EQ.7) THEN
4865          AMP2  = SIGN(PMASS(1)**2,PMASS(1))
4866          PP(3) = PPCM
4867          PP(4) = SQRT(AMP2+PP(3)**2)
4868       ELSE
4869          EPF = SQRT(PPF**2+PMASS(1)**2)
4870          CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
4871       ENDIF
4872       ETF = SQRT(PTF**2+PMASS(2)**2)
4873       CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
4874       ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
4875      &              (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
4876       IF (LSTART) THEN
4877 C *** Commented by Chiara
4878 C         WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
4879  1001    FORMAT(
4880      &      ' DT_PHOINI:    PHOJET initialized for projectile A,Z = ',
4881      &      I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
4882 C *** Commented by Chiara
4883 C         IF (NCOMPO.GT.0) THEN
4884 C            WRITE(LOUT,1002) SCPF,PTF,PT
4885 C         ELSE
4886 C            WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
4887 C         ENDIF
4888  1002    FORMAT(
4889      &      ' DT_PHOINI:    PHOJET initialized for target emulsion  ',
4890      &          /,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
4891  1003    FORMAT(
4892      &      ' DT_PHOINI:    PHOJET initialized for target     A,Z = ',
4893      &      I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
4894 C *** Commented by Chiara
4895 C         WRITE(LOUT,1004) ECMINI
4896  1004    FORMAT(' E_cm = ',E10.3)
4897          IF (IJP.EQ.8) WRITE(LOUT,1005)
4898  1005    FORMAT(
4899      &      ' DT_PHOINI: warning! proton parameters used for neutron',
4900      &          ' projectile')
4901          LSTART = .FALSE.
4902       ENDIF
4903 * switch off new diffractive cross sections at low energies for nuclei
4904 * (temporary solution)
4905       IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
4906          WRITE(LOUT,'(1X,A)')
4907      &      ' DT_PHOINI: model-switch 30 for nuclei re-set !'
4908          CALL PHO_SETMDL(30,0,1)
4909       ENDIF
4910 *
4911 C     IF (IJP.EQ.7) THEN
4912 C        AMP2  = SIGN(PMASS(1)**2,PMASS(1))
4913 C        PP(3) = PPCM
4914 C        PP(4) = SQRT(AMP2+PP(3)**2)
4915 C     ELSE
4916 C        PFERMX = ZERO
4917 C        IF (IP.GT.1) PFERMX = 0.5D0
4918 C        EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
4919 C        CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
4920 C     ENDIF
4921 C     PFERMX = ZERO
4922 C     IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
4923 C     EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
4924 C     CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
4925 **sr 26.10.96
4926       ISAV = IPAMDL(13)
4927       IF ((ISHAD(2).EQ.1).AND.
4928      &   ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
4929      &    (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
4930 **
4931
4932       CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
4933
4934 **sr 26.10.96
4935       IPAMDL(13) = ISAV
4936 **
4937 *
4938 * patch for cascade calculations:
4939 * define parton distribution functions for other hadrons, i.e. other
4940 * then defined already in phojet
4941       IF (IOGLB.EQ.100) THEN
4942          WRITE(LOUT,1006)
4943  1006    FORMAT(/,1X,'PHOINI: additional parton distribution functions',
4944      &          ' assiged (ID,IPAR,ISET)',/)
4945          NPDF = 0
4946          DO 3 I=1,30
4947             IF (IPARPD(I).NE.0) THEN
4948                NPDF = NPDF+1
4949                IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
4950                IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
4951                   IDPDG = IDT_IPDGHA(I)
4952                   IPAR  = IPARPD(I)
4953                   ISET  = ISETPD(I)
4954                   WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
4955                   CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
4956                ENDIF
4957             ENDIF
4958     3    CONTINUE
4959       ENDIF
4960
4961 C     CALL PHO_PHIST(-1,SIGMAX)
4962
4963       IF (IREJ1.NE.0) THEN
4964          WRITE(LOUT,1000)
4965  1000    FORMAT(1X,'PHOINI:   PHOJET event-initialization failed!')
4966          STOP
4967       ENDIF
4968
4969       RETURN
4970       END
4971
4972 *
4973 *===eventd=============================================================*
4974 *
4975 CDECK  ID>, DT_EVENTD
4976       SUBROUTINE DT_EVENTD(IREJ)
4977
4978 ************************************************************************
4979 * Quasi-elastic neutrino nucleus scattering.                           *
4980 * This version dated 29.04.00 is written by S. Roesler.                *
4981 ************************************************************************
4982
4983       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4984       SAVE
4985
4986       PARAMETER ( LINP = 5 ,
4987      &            LOUT = 6 ,
4988      &            LDAT = 9 )
4989
4990       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
4991       PARAMETER (SQTINF=1.0D+15)
4992
4993       LOGICAL LFIRST
4994
4995 * event history
4996
4997       PARAMETER (NMXHKK=200000)
4998
4999       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5000      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5001      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5002 * extended event history
5003       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5004      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5005      &                IHIST(2,NMXHKK)
5006 * flags for input different options
5007       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5008       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5009      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5010
5011       PARAMETER (MAXLND=4000)
5012       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
5013
5014 * properties of interacting particles
5015       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5016 * Lorentz-parameters of the current interaction
5017       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5018      &                UMO,PPCM,EPROJ,PPROJ
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 * steering flags for qel neutrino scattering modules
5025       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
5026       COMMON /QNPOL/ POLARX(4),PMODUL
5027
5028       INTEGER PYK
5029
5030       DATA LFIRST /.TRUE./
5031
5032       IREJ = 0
5033
5034       IF (LFIRST) THEN
5035          LFIRST = .FALSE.
5036          CALL DT_MASS_INI
5037       ENDIF
5038
5039 * JETSET parameter
5040       CALL DT_INITJS(0)
5041
5042 * interacting target nucleon
5043       LTYP = NEUTYP
5044       IF (NEUDEC.LE.9) THEN
5045          IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
5046             NUCTYP = 2112
5047             NUCTOP = 2
5048          ELSE
5049             NUCTYP = 2212
5050             NUCTOP = 1
5051          ENDIF
5052       ELSE
5053          RTYP  = DT_RNDM(RTYP)
5054          ZFRAC = DBLE(ITZ)/DBLE(IT)
5055          IF (RTYP.LE.ZFRAC) THEN
5056             NUCTYP = 2212
5057             NUCTOP = 1
5058          ELSE
5059             NUCTYP = 2112
5060             NUCTOP = 2
5061          ENDIF
5062       ENDIF
5063
5064 * select first nucleon in list with matching id and reset all other
5065 * nucleons which have been marked as "wounded" by ININUC
5066       IFOUND = 0
5067       DO 1 I=1,NHKK
5068          IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
5069             ISTHKK(I) = 12
5070             IFOUND    = 1
5071             IDX = I
5072          ELSE
5073             IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
5074          ENDIF
5075     1 CONTINUE
5076       IF (IFOUND.EQ.0)
5077      &   STOP ' EVENTD: interacting target nucleon not found! '
5078
5079 * correct position of proj. lepton: assume position of target nucleon
5080       DO 3 I=1,4
5081          VHKK(I,1) = VHKK(I,IDX)
5082          WHKK(I,1) = WHKK(I,IDX)
5083     3 CONTINUE
5084
5085 * load initial momenta for conservation check
5086       IF (LEMCCK) THEN
5087          CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
5088          CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
5089      &                                                      2,IDUM,IDUM)
5090       ENDIF
5091
5092 * quasi-elastic scattering
5093       IF (NEUDEC.LT.9) THEN
5094          CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
5095      &                                          PHKK(4,IDX),PHKK(5,IDX))
5096 *  CC event on p or n
5097       ELSEIF (NEUDEC.EQ.10) THEN
5098          CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
5099      &                     PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5100 *  NC event on p or n
5101       ELSEIF (NEUDEC.EQ.11) THEN
5102          CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
5103      &                     PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5104       ENDIF
5105
5106 * get final state particles from Lund-common and write them into HKKEVT
5107       NPOINT(1) = NHKK+1
5108       NPOINT(4) = NHKK+1
5109
5110       NLINES = PYK(0,1)
5111
5112       NHKK0  = NHKK+1
5113       DO 4 I=4,NLINES
5114          IF (K(I,1).EQ.1) THEN
5115             ID = K(I,2)
5116             PX = P(I,1)
5117             PY = P(I,2)
5118             PZ = P(I,3)
5119             PE = P(I,4)
5120             CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
5121             IDBJ = IDT_ICIHAD(ID)
5122             EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
5123             IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
5124                IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
5125             ENDIF
5126             VHKK(1,NHKK) = VHKK(1,IDX)
5127             VHKK(2,NHKK) = VHKK(2,IDX)
5128             VHKK(3,NHKK) = VHKK(3,IDX)
5129             VHKK(4,NHKK) = VHKK(4,IDX)
5130 C           IF (I.EQ.4) THEN
5131 C              WHKK(1,NHKK) = POLARX(1)
5132 C              WHKK(2,NHKK) = POLARX(2)
5133 C              WHKK(3,NHKK) = POLARX(3)
5134 C              WHKK(4,NHKK) = POLARX(4)
5135 C           ELSE
5136                WHKK(1,NHKK) = WHKK(1,IDX)
5137                WHKK(2,NHKK) = WHKK(2,IDX)
5138                WHKK(3,NHKK) = WHKK(3,IDX)
5139                WHKK(4,NHKK) = WHKK(4,IDX)
5140 C           ENDIF
5141             IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
5142          ENDIF
5143     4 CONTINUE
5144
5145       IF (LEMCCK) THEN
5146          CHKLEV = TINY5
5147          CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
5148          IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
5149       ENDIF
5150
5151 * transform momenta into cms (as required for inc etc.)
5152       DO 5 I=NHKK0,NHKK
5153          IF (ISTHKK(I).EQ.1) THEN
5154             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
5155             PHKK(3,I) = PZ
5156             PHKK(4,I) = PE
5157          ENDIF
5158     5 CONTINUE
5159
5160       RETURN
5161       END
5162 *
5163 *===kkevnt=============================================================*
5164 *
5165 CDECK  ID>, DT_KKEVNT
5166       SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
5167
5168 ************************************************************************
5169 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering   *
5170 * without nuclear effects (one event).                                 *
5171 * This subroutine is an update of the previous version (KKEVT) written *
5172 * by J. Ranft/ H.-J. Moehring.                                         *
5173 * This version dated 20.04.95 is written by S. Roesler                 *
5174 ************************************************************************
5175
5176       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5177       SAVE
5178
5179       PARAMETER ( LINP = 5 ,
5180      &            LOUT = 6 ,
5181      &            LDAT = 9 )
5182
5183       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
5184
5185       PARAMETER ( MAXNCL = 260,
5186
5187      &            MAXVQU = MAXNCL,
5188      &            MAXSQU = 20*MAXVQU,
5189      &            MAXINT = MAXVQU+MAXSQU)
5190 * event history
5191
5192       PARAMETER (NMXHKK=200000)
5193
5194       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5195      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5196      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5197 * extended event history
5198       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5199      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5200      &                IHIST(2,NMXHKK)
5201 * flags for input different options
5202       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5203       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5204      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5205 * rejection counter
5206       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
5207      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
5208      &                IREXCI(3),IRDIFF(2),IRINC
5209 * statistics
5210       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5211      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5212      &                ICEVTG(8,0:30)
5213 * properties of interacting particles
5214       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5215 * Lorentz-parameters of the current interaction
5216       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5217      &                UMO,PPCM,EPROJ,PPROJ
5218 * flags for diffractive interactions (DTUNUC 1.x)
5219       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5220 * interface HADRIN-DPM
5221       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5222 * nucleon-nucleon event-generator
5223       CHARACTER*8 CMODEL
5224       LOGICAL LPHOIN
5225       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
5226 * coordinates of nucleons
5227       COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
5228 * interface between Glauber formalism and DPM
5229       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
5230      &                INTER1(MAXINT),INTER2(MAXINT)
5231 * Glauber formalism: collision properties
5232       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5233      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5234 * central particle production, impact parameter biasing
5235       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5236 **temporary
5237 * statistics: Glauber-formalism
5238       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5239 **
5240
5241       DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5242
5243       IREJ   = 0
5244       ICREQU = ICREQU+1
5245       NC     = 0
5246
5247     1 CONTINUE
5248       ICSAMP = ICSAMP+1
5249       NC     = NC+1
5250       IF (MOD(NC,10).EQ.0) THEN
5251          WRITE(LOUT,1000) NEVHKK
5252  1000    FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5253          GOTO 9999
5254       ENDIF
5255
5256 * initialize DTEVT1/DTEVT2
5257       CALL DT_EVTINI
5258
5259 * We need the following only in order to sample nucleon coordinates.
5260 * However we don't have parameters (cross sections, slope etc.)
5261 * for neutrinos available. Therefore switch projectile to proton
5262 * in this case.
5263       IF (MCGENE.EQ.4) THEN
5264          JJPROJ = 1
5265       ELSE
5266          JJPROJ = IJPROJ
5267       ENDIF
5268
5269    10 CONTINUE
5270       IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5271 * make sure that Glauber-formalism is called each time the interaction
5272 * configuration changed
5273      &     (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5274      &     (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5275 * sample number of nucleon-nucleon coll. according to Glauber-form.
5276          CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5277 * --- Added by Chiara to monit impact parameter generation
5278 *        PRINT *,' Impact parameter generation : b = ', BIMPAC, 'fm'
5279          NWTSAM = NN
5280          NWASAM = NP
5281          NWBSAM = NT
5282          NEVOLD = NEVHKK
5283          IPOLD  = IP
5284          ITOLD  = IT
5285          JJPOLD = JJPROJ
5286          EPROLD = EPROJ
5287       ENDIF
5288
5289 * force diffractive particle production in h-K interactions
5290       IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5291      &    (IP.EQ.1).AND.(NN.NE.1)) THEN
5292          NEVOLD = 0
5293          GOTO 10
5294       ENDIF
5295
5296 * check number of involved proj. nucl. (NP) if central prod.is requested
5297       IF (ICENTR.GT.0) THEN
5298          CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5299          IF (IBACK.GT.0) GOTO 10
5300       ENDIF
5301
5302 * get initial nucleon-configuration in projectile and target
5303 * rest-system (including Fermi-momenta if requested)
5304       CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5305       MODE = 2
5306       IF (EPROJ.LE.EHADTH) MODE = 3
5307       CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5308
5309       IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5310
5311 * activate HADRIN at low energies (implemented for h-N scattering only)
5312          IF (EPROJ.LE.EHADHI) THEN
5313             IF (EHADTH.LT.ZERO) THEN
5314 *   smooth transition btwn. DPM and HADRIN
5315                FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5316                RR   = DT_RNDM(FRAC)
5317                IF (RR.GT.FRAC) THEN
5318                   IF (IP.EQ.1) THEN
5319                      CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5320                      IF (IREJ1.GT.0) GOTO 1
5321                      RETURN
5322                   ELSE
5323                      WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5324                   ENDIF
5325                ENDIF
5326             ELSE
5327 *   fixed threshold for onset of production via HADRIN
5328                IF (EPROJ.LE.EHADTH) THEN
5329                   IF (IP.EQ.1) THEN
5330                      CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5331                      IF (IREJ1.GT.0) GOTO 1
5332                      RETURN
5333                   ELSE
5334                      WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5335                   ENDIF
5336                ENDIF
5337             ENDIF
5338          ENDIF
5339  1001    FORMAT(1X,'KKEVNT:   warning! interaction of proj. (m=',
5340      &          I3,') with target (m=',I3,')',/,11X,
5341      &          'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5342      &          'GeV) cannot be handled')
5343
5344 * sampling of momentum-x fractions & flavors of chain ends
5345          CALL DT_SPLPTN(NN)
5346
5347 * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5348          CALL DT_NUC2CM
5349
5350 * collect momenta of chain ends and put them into DTEVT1
5351          CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5352          IF (IREJ1.NE.0) GOTO 1
5353
5354       ENDIF
5355
5356 * handle chains including fragmentation (two-chain approximation)
5357       IF (MCGENE.EQ.1) THEN
5358 *  two-chain approximation
5359          CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5360          IF (IREJ1.NE.0) THEN
5361             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5362             GOTO 1
5363          ENDIF
5364       ELSEIF (MCGENE.EQ.2) THEN
5365 *  multiple-Po exchange including minijets
5366          CALL DT_EVENTB(NCSY,IREJ1)
5367          IF (IREJ1.NE.0) THEN
5368             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5369             GOTO 1
5370          ENDIF
5371       ELSEIF (MCGENE.EQ.3) THEN
5372
5373          STOP ' This version does not contain LEPTO !'
5374
5375       ELSEIF (MCGENE.EQ.4) THEN
5376 *  quasi-elastic neutrino scattering
5377          CALL DT_EVENTD(IREJ1)
5378          IF (IREJ1.NE.0) THEN
5379             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5380             GOTO 1
5381          ENDIF
5382       ELSE
5383          WRITE(LOUT,1002) MCGENE
5384  1002    FORMAT(1X,'KKEVNT:   warning! event-generator',I4,
5385      &         ' not available - program stopped')
5386          STOP
5387       ENDIF
5388
5389       RETURN
5390
5391  9999 CONTINUE
5392       IREJ = 1
5393       RETURN
5394       END
5395 *
5396 *===chkcen=============================================================*
5397 *
5398 CDECK  ID>, DT_CHKCEN
5399       SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5400
5401 ************************************************************************
5402 * Check of number of involved projectile nucleons if central production*
5403 * is requested.                                                        *
5404 * Adopted from a part of the old KKEVT routine which was written by    *
5405 * J. Ranft/H.-J.Moehring.                                              *
5406 * This version dated 13.01.95 is written by S. Roesler                 *
5407 ************************************************************************
5408
5409       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5410       SAVE
5411
5412       PARAMETER ( LINP = 5 ,
5413      &            LOUT = 6 ,
5414      &            LDAT = 9 )
5415
5416 * statistics
5417       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5418      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5419      &                ICEVTG(8,0:30)
5420 * central particle production, impact parameter biasing
5421       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5422
5423       IBACK = 0
5424
5425 * old version
5426       IF (ICENTR.EQ.2) THEN
5427          IF (IP.LT.IT) THEN
5428             IF (IP.LE.8) THEN
5429                IF (NP.LT.IP-1) IBACK = 1
5430             ELSEIF (IP.LE.16) THEN
5431                IF (NP.LT.IP-2) IBACK = 1
5432             ELSEIF (IP.LE.32) THEN
5433                IF (NP.LT.IP-3) IBACK = 1
5434             ELSEIF (IP.GE.33) THEN
5435                IF (NP.LT.IP-5) IBACK = 1
5436             ENDIF
5437          ELSEIF (IP.EQ.IT) THEN
5438             IF (IP.EQ.32) THEN
5439                IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5440             ELSE
5441                IF (NP.LT.IP-IP/8) IBACK = 1
5442             ENDIF
5443          ELSEIF (ABS(IP-IT).LT.3) THEN
5444             IF (NP.LT.IP-IP/8) IBACK = 1
5445          ENDIF
5446       ELSE
5447 * new version (DPMJET, 5.6.99)
5448          IF (IP.LT.IT) THEN
5449             IF (IP.LE.8) THEN
5450                IF (NP.LT.IP-1) IBACK = 1
5451             ELSEIF (IP.LE.16) THEN
5452                IF (NP.LT.IP-2) IBACK = 1
5453             ELSEIF (IP.LT.32) THEN
5454                IF (NP.LT.IP-3) IBACK = 1
5455             ELSEIF (IP.GE.32) THEN
5456                IF (IT.LE.150) THEN
5457 *   Example: S-Ag
5458                   IF (NP.LT.IP-1) IBACK = 1
5459                ELSE
5460 *   Example: S-Au
5461                   IF (NP.LT.IP) IBACK = 1
5462                ENDIF
5463             ENDIF
5464          ELSEIF (IP.EQ.IT) THEN
5465 *   Example: S-S
5466            IF (IP.EQ.32) THEN
5467               IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5468 *   Example: Pb-Pb
5469            ELSE
5470               IF (NP.LT.IP-IP/4) IBACK = 1
5471            ENDIF
5472          ELSEIF (ABS(IP-IT).LT.3) THEN
5473             IF (NP.LT.IP-IP/8) IBACK = 1
5474          ENDIF
5475       ENDIF
5476
5477       ICCPRO = ICCPRO+1
5478
5479       RETURN
5480       END
5481 *
5482 *===ininuc=============================================================*
5483 *
5484 CDECK  ID>, DT_ININUC
5485       SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5486
5487 ************************************************************************
5488 * Samples initial configuration of nucleons in nucleus with mass NMASS *
5489 * including Fermi-momenta (if reqested).                               *
5490 *          ID             BAMJET-code for hadrons (instead of nuclei)  *
5491 *          NMASS          mass number of nucleus (number of nucleons)  *
5492 *          NCH            charge of nucleus                            *
5493 *          COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5494 *          JS(NMASS) > 0  nucleon undergoes nucleon-nucleon interact.  *
5495 *          IMODE = 1      projectile nucleus                           *
5496 *                = 2      target     nucleus                           *
5497 *                = 3      target     nucleus (E_lab<E_thr for HADRIN)  *
5498 * Adopted from a part of the old KKEVT routine which was written by    *
5499 * J. Ranft/H.-J.Moehring.                                              *
5500 * This version dated 13.01.95 is written by S. Roesler                 *
5501 ************************************************************************
5502
5503       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5504       SAVE
5505
5506       PARAMETER ( LINP = 5 ,
5507      &            LOUT = 6 ,
5508      &            LDAT = 9 )
5509
5510       PARAMETER (FM2MM=1.0D-12)
5511
5512       PARAMETER ( MAXNCL = 260,
5513
5514      &            MAXVQU = MAXNCL,
5515      &            MAXSQU = 20*MAXVQU,
5516      &            MAXINT = MAXVQU+MAXSQU)
5517 * event history
5518
5519       PARAMETER (NMXHKK=200000)
5520
5521       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5522      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5523      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5524 * extended event history
5525       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5526      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5527      &                IHIST(2,NMXHKK)
5528 * flags for input different options
5529       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5530       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5531      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5532 * auxiliary common for chain system storage (DTUNUC 1.x)
5533       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5534 * nuclear potential
5535       LOGICAL LFERMI
5536       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5537      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5538      &                ETACOU(2),ICOUL,LFERMI
5539 * properties of photon/lepton projectiles
5540       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5541 * particle properties (BAMJET index convention)
5542       CHARACTER*8  ANAME
5543       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5544      &                IICH(210),IIBAR(210),K1(210),K2(210)
5545 * Glauber formalism: collision properties
5546       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5547      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5548 * flavors of partons (DTUNUC 1.x)
5549       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5550      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5551      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5552      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5553      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5554      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5555      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5556 * interface HADRIN-DPM
5557       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5558
5559       DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5560
5561 * number of neutrons
5562       NNEU = NMASS-NCH
5563 * initializations
5564       NP = 0
5565       NN = 0
5566       DO 1 K=1,4
5567          PFTOT(K) = 0.0D0
5568     1 CONTINUE
5569       MODE   = IMODE
5570       IF (IMODE.GT.2) MODE = 2
5571 **sr 29.5. new NPOINT(1)-definition
5572 C     IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5573 **
5574       NHADRI = 0
5575       NC     = NHKK
5576
5577 * get initial configuration
5578       DO 2 I=1,NMASS
5579          NHKK = NHKK+1
5580          IF (JS(I).GT.0) THEN
5581             ISTHKK(NHKK) = 10+MODE
5582             IF (IMODE.EQ.3) THEN
5583 *   additional treatment if HADRIN-generator is requested
5584                NHADRI = NHADRI+1
5585                IF (NHADRI.EQ.1) IDXTA  = NHKK
5586                IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5587             ENDIF
5588          ELSE
5589             ISTHKK(NHKK) = 12+MODE
5590          ENDIF
5591          IF (NMASS.GE.2) THEN
5592 *   treatment for nuclei
5593             FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5594             RR   = DT_RNDM(FRAC)
5595             IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5596                IDX = 8
5597                NN  = NN+1
5598             ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5599                IDX = 1
5600                NP  = NP+1
5601             ELSEIF (NN.LT.NNEU) THEN
5602                IDX = 8
5603                NN  = NN+1
5604             ELSEIF (NP.LT.NCH)  THEN
5605                IDX = 1
5606                NP  = NP+1
5607             ENDIF
5608             IDHKK(NHKK) = IDT_IPDGHA(IDX)
5609             IDBAM(NHKK) = IDX
5610             IF (MODE.EQ.1) THEN
5611                IPOSP(I)  = NHKK
5612                KKPROJ(I) = IDX
5613             ELSE
5614                IPOST(I)  = NHKK
5615                KKTARG(I) = IDX
5616             ENDIF
5617             IF (IDX.EQ.1) THEN
5618                PFER = PFERMP(MODE)
5619                PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5620             ELSE
5621                PFER = PFERMN(MODE)
5622                PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5623             ENDIF
5624             CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5625             DO 3 K=1,4
5626                PFTOT(K) = PFTOT(K)+PF(K)
5627                PHKK(K,NHKK) = PF(K)
5628     3       CONTINUE
5629             PHKK(5,NHKK) = AAM(IDX)
5630          ELSE
5631 *   treatment for hadrons
5632             IDHKK(NHKK)  = IDT_IPDGHA(ID)
5633             IDBAM(NHKK)  = ID
5634             PHKK(4,NHKK) = AAM(ID)
5635             PHKK(5,NHKK) = AAM(ID)
5636 C* VDM assumption
5637 C            IF (IDHKK(NHKK).EQ.22) THEN
5638 C               PHKK(4,NHKK) = AAM(33)
5639 C               PHKK(5,NHKK) = AAM(33)
5640 C            ENDIF
5641             IF (MODE.EQ.1) THEN
5642                IPOSP(I)  = NHKK
5643                KKPROJ(I) = ID
5644                PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5645             ELSE
5646                IPOST(I)  = NHKK
5647                KKTARG(I) = ID
5648             ENDIF
5649          ENDIF
5650          DO 4 K=1,3
5651             VHKK(K,NHKK) = COORD(K,I)*FM2MM
5652             WHKK(K,NHKK) = COORD(K,I)*FM2MM
5653     4    CONTINUE
5654          IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5655          IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5656          VHKK(4,NHKK) = 0.0D0
5657          WHKK(4,NHKK) = 0.0D0
5658     2 CONTINUE
5659
5660 * balance Fermi-momenta
5661       IF (NMASS.GE.2) THEN
5662          DO 5 I=1,NMASS
5663             NC = NC+1
5664             DO 6 K=1,3
5665                PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5666     6       CONTINUE
5667             PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5668      &                        PHKK(2,NC)**2+PHKK(3,NC)**2)
5669     5    CONTINUE
5670       ENDIF
5671
5672       RETURN
5673       END
5674 *
5675 *===fer4m==============================================================*
5676 *
5677 CDECK  ID>, DT_FER4M
5678       SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
5679
5680 ************************************************************************
5681 * Sampling of nucleon Fermi-momenta from distributions at T=0.         *
5682 *                                   processed by S. Roesler, 17.10.95  *
5683 ************************************************************************
5684
5685       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5686       SAVE
5687
5688       PARAMETER ( LINP = 5 ,
5689      &            LOUT = 6 ,
5690      &            LDAT = 9 )
5691
5692       LOGICAL LSTART
5693
5694 * particle properties (BAMJET index convention)
5695       CHARACTER*8  ANAME
5696       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5697      &                IICH(210),IIBAR(210),K1(210),K2(210)
5698 * nuclear potential
5699       LOGICAL LFERMI
5700       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5701      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5702      &                ETACOU(2),ICOUL,LFERMI
5703
5704       DATA LSTART /.TRUE./
5705
5706       ILOOP = 0
5707       IF (LFERMI) THEN
5708          IF (LSTART) THEN
5709             WRITE(LOUT,1000)
5710  1000       FORMAT(/,1X,'FER4M:   sampling of Fermi-momenta activated')
5711             LSTART = .FALSE.
5712          ENDIF
5713     1    CONTINUE
5714          CALL DT_DFERMI(PABS)
5715          PABS = PFERM*PABS
5716 C        IF (PABS.GE.PBIND) THEN
5717 C           ILOOP = ILOOP+1
5718 C           IF (MOD(ILOOP,500).EQ.0) THEN
5719 C              WRITE(LOUT,1001) PABS,PBIND,ILOOP
5720 C1001          FORMAT(1X,'FER4M:    Fermi-mom. corr. for binding',
5721 C    &                ' energy ',2E12.3,I6)
5722 C           ENDIF
5723 C           GOTO 1
5724 C        ENDIF
5725          CALL DT_DPOLI(POLC,POLS)
5726          CALL DT_DSFECF(SFE,CFE)
5727          CXTA = POLS*CFE
5728          CYTA = POLS*SFE
5729          CZTA = POLC
5730          ET   = SQRT(PABS*PABS+AAM(KT)**2)
5731          PXT  = CXTA*PABS
5732          PYT  = CYTA*PABS
5733          PZT  = CZTA*PABS
5734       ELSE
5735          ET   = AAM(KT)
5736          PXT  = 0.0D0
5737          PYT  = 0.0D0
5738          PZT  = 0.0D0
5739       ENDIF
5740
5741       RETURN
5742       END
5743 *
5744 *===nuc2cm=============================================================*
5745 *
5746 CDECK  ID>, DT_NUC2CM
5747       SUBROUTINE DT_NUC2CM
5748
5749 ************************************************************************
5750 * Lorentz-transformation of all wounded nucleons from Lab. to nucl.-   *
5751 * nucl. cms. (This subroutine replaces NUCMOM.)                        *
5752 * This version dated 15.01.95 is written by S. Roesler                 *
5753 ************************************************************************
5754
5755       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5756       SAVE
5757
5758       PARAMETER ( LINP = 5 ,
5759      &            LOUT = 6 ,
5760      &            LDAT = 9 )
5761
5762       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
5763
5764 * event history
5765
5766       PARAMETER (NMXHKK=200000)
5767
5768       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5769      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5770      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5771 * extended event history
5772       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5773      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5774      &                IHIST(2,NMXHKK)
5775 * statistics
5776       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5777      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5778      &                ICEVTG(8,0:30)
5779 * properties of photon/lepton projectiles
5780       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5781 * particle properties (BAMJET index convention)
5782       CHARACTER*8  ANAME
5783       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5784      &                IICH(210),IIBAR(210),K1(210),K2(210)
5785 * Glauber formalism: collision properties
5786       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5787      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5788 **temporary
5789 * statistics: Glauber-formalism
5790       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5791 **
5792
5793       ICWP = 0
5794       ICWT = 0
5795       NWTACC = 0
5796       NWAACC = 0
5797       NWBACC = 0
5798
5799       NPOINT(1) = NHKK+1
5800       NEND      = NHKK
5801       DO 1 I=1,NEND
5802          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
5803             IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
5804             IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
5805             MODE = ISTHKK(I)-9
5806 C            IF (IDHKK(I).EQ.22) THEN
5807 C* VDM assumption
5808 C               PEIN = AAM(33)
5809 C               IDB  = 33
5810 C            ELSE
5811 C               PEIN = PHKK(4,I)
5812 C               IDB  = IDBAM(I)
5813 C            ENDIF
5814 C            CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
5815 C     &           PX,PY,PZ,PE,IDB,MODE)
5816             IF (PHKK(5,I).GT.ZERO) THEN
5817                CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
5818      &              PX,PY,PZ,PE,IDBAM(I),MODE)
5819             ELSE
5820                PX = PGAMM(1)
5821                PY = PGAMM(2)
5822                PZ = PGAMM(3)
5823                PE = PGAMM(4)
5824             ENDIF
5825             IST = ISTHKK(I)-2
5826             ID  = IDHKK(I)
5827 C* VDM assumption
5828 C            IF (ID.EQ.22) ID = 113
5829             CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
5830             IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
5831             IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
5832          ENDIF
5833     1 CONTINUE
5834
5835       NWTACC = MAX(NWAACC,NWBACC)
5836       ICDPR  = ICDPR+ICWP
5837       ICDTA  = ICDTA+ICWT
5838 **temporary
5839       IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
5840          CALL DT_EVTOUT(4)
5841          STOP
5842       ENDIF
5843
5844       RETURN
5845       END
5846 *
5847 *===splptn=============================================================*
5848 *
5849 CDECK  ID>, DT_SPLPTN
5850       SUBROUTINE DT_SPLPTN(NN)
5851
5852 ************************************************************************
5853 * SamPLing of ParToN momenta and flavors.                              *
5854 * This version dated 15.01.95 is written by S. Roesler                 *
5855 ************************************************************************
5856
5857       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5858       SAVE
5859
5860       PARAMETER ( LINP = 5 ,
5861      &            LOUT = 6 ,
5862      &            LDAT = 9 )
5863
5864 * Lorentz-parameters of the current interaction
5865       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5866      &                UMO,PPCM,EPROJ,PPROJ
5867
5868 * sample flavors of sea-quarks
5869       CALL DT_SPLFLA(NN,1)
5870
5871 * sample x-values of partons at chain ends
5872       ECM = UMO
5873       CALL DT_XKSAMP(NN,ECM)
5874
5875 * samle flavors
5876       CALL DT_SPLFLA(NN,2)
5877
5878       RETURN
5879       END
5880 *
5881 *===splfla=============================================================*
5882 *
5883 CDECK  ID>, DT_SPLFLA
5884       SUBROUTINE DT_SPLFLA(NN,MODE)
5885
5886 ************************************************************************
5887 * SamPLing of FLAvors of partons at chain ends.                        *
5888 * This subroutine replaces FLKSAA/FLKSAM.                              *
5889 *            NN            number of nucleon-nucleon interactions      *
5890 *            MODE = 1      sea-flavors                                 *
5891 *                 = 2      valence-flavors                             *
5892 * Based on the original version written by J. Ranft/H.-J. Moehring.    *
5893 * This version dated 16.01.95 is written by S. Roesler                 *
5894 ************************************************************************
5895
5896       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5897       SAVE
5898
5899       PARAMETER ( LINP = 5 ,
5900      &            LOUT = 6 ,
5901      &            LDAT = 9 )
5902
5903       PARAMETER ( MAXNCL = 260,
5904
5905      &            MAXVQU = MAXNCL,
5906      &            MAXSQU = 20*MAXVQU,
5907      &            MAXINT = MAXVQU+MAXSQU)
5908 * flavors of partons (DTUNUC 1.x)
5909       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5910      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5911      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5912      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5913      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5914      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5915      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5916 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5917       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5918      &                IXPV,IXPS,IXTV,IXTS,
5919      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
5920      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
5921      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
5922      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
5923      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
5924      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
5925      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
5926      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
5927 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5928       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5929      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5930 * particle properties (BAMJET index convention)
5931       CHARACTER*8  ANAME
5932       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5933      &                IICH(210),IIBAR(210),K1(210),K2(210)
5934 * various options for treatment of partons (DTUNUC 1.x)
5935 * (chain recombination, Cronin,..)
5936       LOGICAL LCO2CR,LINTPT
5937       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
5938      &                LCO2CR,LINTPT
5939
5940       IF (MODE.EQ.1) THEN
5941 * sea-flavors
5942          DO 1 I=1,NN
5943             IPSQ(I)  = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5944             IPSAQ(I) = -IPSQ(I)
5945     1    CONTINUE
5946          DO 2 I=1,NN
5947             ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5948             ITSAQ(I)= -ITSQ(I)
5949     2    CONTINUE
5950       ELSEIF (MODE.EQ.2) THEN
5951 * valence flavors
5952          DO 3 I=1,IXPV
5953             CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
5954     3    CONTINUE
5955          DO 4 I=1,IXTV
5956             CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
5957     4    CONTINUE
5958       ENDIF
5959
5960       RETURN
5961       END
5962 *
5963 *===getptn=============================================================*
5964 *
5965 CDECK  ID>, DT_GETPTN
5966       SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
5967
5968 ************************************************************************
5969 * This subroutine collects partons at chain ends from temporary        *
5970 * commons and puts them into DTEVT1.                                   *
5971 * This version dated 15.01.95 is written by S. Roesler                 *
5972 ************************************************************************
5973
5974       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5975       SAVE
5976
5977       PARAMETER ( LINP = 5 ,
5978      &            LOUT = 6 ,
5979      &            LDAT = 9 )
5980
5981       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
5982
5983       LOGICAL LCHK
5984
5985       PARAMETER ( MAXNCL = 260,
5986
5987      &            MAXVQU = MAXNCL,
5988      &            MAXSQU = 20*MAXVQU,
5989      &            MAXINT = MAXVQU+MAXSQU)
5990 * event history
5991
5992       PARAMETER (NMXHKK=200000)
5993
5994       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5995      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5996      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5997 * extended event history
5998       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5999      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6000      &                IHIST(2,NMXHKK)
6001 * flags for input different options
6002       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6003       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6004      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6005 * auxiliary common for chain system storage (DTUNUC 1.x)
6006       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
6007 * statistics
6008       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6009      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6010      &                ICEVTG(8,0:30)
6011 * flags for diffractive interactions (DTUNUC 1.x)
6012       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6013 * x-values of partons (DTUNUC 1.x)
6014       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
6015      &                XTVQ(MAXVQU),XTVD(MAXVQU),
6016      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
6017      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
6018 * flavors of partons (DTUNUC 1.x)
6019       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6020      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6021      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
6022      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6023      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
6024      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6025      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
6026 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6027       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6028      &                IXPV,IXPS,IXTV,IXTS,
6029      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
6030      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
6031      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
6032      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
6033      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
6034      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
6035      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
6036      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
6037 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6038       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6039      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6040
6041       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
6042
6043       DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
6044
6045       IREJ      = 0
6046       NCSY      = 0
6047       NPOINT(2) = NHKK+1
6048
6049 * sea-sea chains
6050       DO 10 I=1,NSS
6051          IF (ISKPCH(1,I).EQ.99) GOTO 10
6052          ICCHAI(1,1) = ICCHAI(1,1)+2
6053          IDXP = INTSS1(I)
6054          IDXT = INTSS2(I)
6055          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6056          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6057          DO 11 K=1,4
6058             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6059             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6060             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6061             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6062    11    CONTINUE
6063          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6064      &                                  +(PP1(3)+PT1(3))**2)
6065          ECH   = PP1(4)+PT1(4)
6066          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6067          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6068      &                                  +(PP2(3)+PT2(3))**2)
6069          ECH   = PP2(4)+PT2(4)
6070          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6071          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6072             AM1 = SQRT(AM1)
6073             AM2 = SQRT(AM2)
6074             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6075 C              WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6076  5000          FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6077             ENDIF
6078          ELSE
6079             WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6080          ENDIF
6081          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6082          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6083          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6084          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6085          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6086      &                                                    0,0,1)
6087          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6088      &                                                    0,0,1)
6089          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6090      &                                                    0,0,1)
6091          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6092      &                                                    0,0,1)
6093          NCSY = NCSY+1
6094    10 CONTINUE
6095
6096 * disea-sea chains
6097       DO 20 I=1,NDS
6098          IF (ISKPCH(2,I).EQ.99) GOTO 20
6099          ICCHAI(1,2) = ICCHAI(1,2)+2
6100          IDXP = INTDS1(I)
6101          IDXT = INTDS2(I)
6102          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6103          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6104          DO 21 K=1,4
6105             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6106             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6107             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6108             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6109    21    CONTINUE
6110          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6111      &                                  +(PP1(3)+PT1(3))**2)
6112          ECH   = PP1(4)+PT1(4)
6113          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6114          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6115      &                                  +(PP2(3)+PT2(3))**2)
6116          ECH   = PP2(4)+PT2(4)
6117          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6118          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6119             AM1 = SQRT(AM1)
6120             AM2 = SQRT(AM2)
6121             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6122 C              WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6123  5001          FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6124             ENDIF
6125          ELSE
6126             WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6127          ENDIF
6128          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6129          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6130          IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6131          IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6132          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6133      &                                                    0,0,2)
6134          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6135      &                                                    0,0,2)
6136          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6137      &                                                    0,0,2)
6138          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6139      &                                                    0,0,2)
6140          NCSY = NCSY+1
6141    20 CONTINUE
6142
6143 * sea-disea chains
6144       DO 30 I=1,NSD
6145          IF (ISKPCH(3,I).EQ.99) GOTO 30
6146          ICCHAI(1,3) = ICCHAI(1,3)+2
6147          IDXP = INTSD1(I)
6148          IDXT = INTSD2(I)
6149          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6150          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6151          DO 31 K=1,4
6152             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6153             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6154             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6155             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6156    31    CONTINUE
6157          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6158      &                                  +(PP1(3)+PT1(3))**2)
6159          ECH   = PP1(4)+PT1(4)
6160          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6161          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6162      &                                  +(PP2(3)+PT2(3))**2)
6163          ECH   = PP2(4)+PT2(4)
6164          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6165          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6166             AM1 = SQRT(AM1)
6167             AM2 = SQRT(AM2)
6168             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6169 C              WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6170  5002          FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6171             ENDIF
6172          ELSE
6173             WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6174          ENDIF
6175          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6176          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6177          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6178          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6179          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6180      &                                                    0,0,3)
6181          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6182      &                                                    0,0,3)
6183          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6184      &                                                    0,0,3)
6185          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6186      &                                                    0,0,3)
6187          NCSY = NCSY+1
6188    30 CONTINUE
6189
6190 * disea-valence chains
6191       DO 50 I=1,NDV
6192          IF (ISKPCH(5,I).EQ.99) GOTO 50
6193          ICCHAI(1,5) = ICCHAI(1,5)+2
6194          IDXP = INTDV1(I)
6195          IDXT = INTDV2(I)
6196          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6197          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6198          DO 51 K=1,4
6199             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6200             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6201             PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6202             PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6203    51    CONTINUE
6204          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6205      &                                  +(PP1(3)+PT1(3))**2)
6206          ECH   = PP1(4)+PT1(4)
6207          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6208          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6209      &                                  +(PP2(3)+PT2(3))**2)
6210          ECH   = PP2(4)+PT2(4)
6211          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6212          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6213             AM1 = SQRT(AM1)
6214             AM2 = SQRT(AM2)
6215             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6216 C              WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6217  5003          FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6218             ENDIF
6219          ELSE
6220             WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6221          ENDIF
6222          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6223          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6224          IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6225          IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6226          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6227      &                                                    0,0,5)
6228          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6229      &                                                    0,0,5)
6230          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6231      &                                                    0,0,5)
6232          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6233      &                                                    0,0,5)
6234          NCSY = NCSY+1
6235    50 CONTINUE
6236
6237 * valence-sea chains
6238       DO 60 I=1,NVS
6239          IF (ISKPCH(6,I).EQ.99) GOTO 60
6240          ICCHAI(1,6) = ICCHAI(1,6)+2
6241          IDXP = INTVS1(I)
6242          IDXT = INTVS2(I)
6243          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6244          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6245          DO 61 K=1,4
6246             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6247             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6248             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6249             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6250    61    CONTINUE
6251          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6252          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6253          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6254          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6255          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6256          IF (LCHK) THEN
6257             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6258      &                                                       0,0,6)
6259             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6260      &                                                       0,0,6)
6261             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6262      &                                                       0,0,6)
6263             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6264      &                                                       0,0,6)
6265             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6266      &                                     +(PP1(3)+PT1(3))**2)
6267             ECH   = PP1(4)+PT1(4)
6268             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6269             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6270      &                                     +(PP2(3)+PT2(3))**2)
6271             ECH   = PP2(4)+PT2(4)
6272             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6273          ELSE
6274             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6275      &                                                       0,0,6)
6276             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6277      &                                                       0,0,6)
6278             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6279      &                                                       0,0,6)
6280             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6281      &                                                       0,0,6)
6282             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6283      &                                     +(PP1(3)+PT2(3))**2)
6284             ECH   = PP1(4)+PT2(4)
6285             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6286             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6287      &                                     +(PP2(3)+PT1(3))**2)
6288             ECH   = PP2(4)+PT1(4)
6289             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6290          ENDIF
6291          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6292             AM1 = SQRT(AM1)
6293             AM2 = SQRT(AM2)
6294             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6295 C              WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6296  5004          FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6297             ENDIF
6298          ELSE
6299             WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6300          ENDIF
6301          NCSY = NCSY+1
6302    60 CONTINUE
6303
6304 * sea-valence chains
6305       DO 40 I=1,NSV
6306          IF (ISKPCH(4,I).EQ.99) GOTO 40
6307          ICCHAI(1,4) = ICCHAI(1,4)+2
6308          IDXP = INTSV1(I)
6309          IDXT = INTSV2(I)
6310          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6311          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6312          DO 41 K=1,4
6313             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6314             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6315             PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6316             PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6317    41    CONTINUE
6318          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6319      &                                  +(PP1(3)+PT1(3))**2)
6320          ECH   = PP1(4)+PT1(4)
6321          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6322          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6323      &                                  +(PP2(3)+PT2(3))**2)
6324          ECH   = PP2(4)+PT2(4)
6325          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6326          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6327             AM1 = SQRT(AM1)
6328             AM2 = SQRT(AM2)
6329             IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6330 C              WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6331  5005          FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6332             ENDIF
6333          ELSE
6334             WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6335          ENDIF
6336          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6337          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6338          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6339          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6340          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6341      &                                                    0,0,4)
6342          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6343      &                                                    0,0,4)
6344          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6345      &                                                    0,0,4)
6346          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6347      &                                                    0,0,4)
6348          NCSY = NCSY+1
6349    40 CONTINUE
6350
6351 * valence-disea chains
6352       DO 70 I=1,NVD
6353          IF (ISKPCH(7,I).EQ.99) GOTO 70
6354          ICCHAI(1,7) = ICCHAI(1,7)+2
6355          IDXP = INTVD1(I)
6356          IDXT = INTVD2(I)
6357          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6358          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6359          DO 71 K=1,4
6360             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6361             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6362             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6363             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6364    71    CONTINUE
6365          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6366          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6367          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6368          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6369          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6370          IF (LCHK) THEN
6371             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6372      &                                                       0,0,7)
6373             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6374      &                                                       0,0,7)
6375             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6376      &                                                       0,0,7)
6377             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6378      &                                                       0,0,7)
6379             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6380      &                                     +(PP1(3)+PT1(3))**2)
6381             ECH   = PP1(4)+PT1(4)
6382             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6383             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6384      &                                     +(PP2(3)+PT2(3))**2)
6385             ECH   = PP2(4)+PT2(4)
6386             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6387          ELSE
6388             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6389      &                                                       0,0,7)
6390             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6391      &                                                       0,0,7)
6392             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6393      &                                                       0,0,7)
6394             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6395      &                                                       0,0,7)
6396             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6397      &                                     +(PP1(3)+PT2(3))**2)
6398             ECH   = PP1(4)+PT2(4)
6399             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6400             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6401      &                                     +(PP2(3)+PT1(3))**2)
6402             ECH   = PP2(4)+PT1(4)
6403             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6404          ENDIF
6405          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6406             AM1 = SQRT(AM1)
6407             AM2 = SQRT(AM2)
6408             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6409 C              WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6410  5006          FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6411             ENDIF
6412          ELSE
6413             WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6414          ENDIF
6415          NCSY = NCSY+1
6416    70 CONTINUE
6417
6418 * valence-valence chains
6419       DO 80 I=1,NVV
6420          IF (ISKPCH(8,I).EQ.99) GOTO 80
6421          ICCHAI(1,8) = ICCHAI(1,8)+2
6422          IDXP = INTVV1(I)
6423          IDXT = INTVV2(I)
6424          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6425          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6426          DO 81 K=1,4
6427             PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6428             PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6429             PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6430             PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6431    81    CONTINUE
6432          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6433          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6434          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6435          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6436
6437 * check for diffractive event
6438          IDIFF = 0
6439          IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6440      &        (IP.EQ.1).AND.(NN.EQ.1)) THEN
6441             DO 800 K=1,4
6442                PP(K) = PP1(K)+PP2(K)
6443                PT(K) = PT1(K)+PT2(K)
6444   800       CONTINUE
6445             ISTCK = NHKK
6446             CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6447      &                  IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6448 C           IF (IREJ1.NE.0) GOTO 9999
6449             IF (IREJ1.NE.0) THEN
6450                IDIFF = 0
6451                NHKK  = ISTCK
6452             ENDIF
6453          ELSE
6454             IDIFF = 0
6455          ENDIF
6456
6457          IF (IDIFF.EQ.0) THEN
6458 *   valence-valence chain system
6459             CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6460             IF (LCHK) THEN
6461 *    baryon-baryon
6462                CALL DT_EVTPUT(-21,IFP1,MOP,0,
6463      &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6464                CALL DT_EVTPUT(-22,IFT1,MOT,0,
6465      &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6466                CALL DT_EVTPUT(-21,IFP2,MOP,0,
6467      &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6468                CALL DT_EVTPUT(-22,IFT2,MOT,0,
6469      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6470                PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6471      &                                        +(PP1(3)+PT1(3))**2)
6472                ECH   = PP1(4)+PT1(4)
6473                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6474                PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6475      &                                        +(PP2(3)+PT2(3))**2)
6476                ECH   = PP2(4)+PT2(4)
6477                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6478             ELSE
6479 *    antibaryon-baryon
6480                CALL DT_EVTPUT(-21,IFP1,MOP,0,
6481      &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6482                CALL DT_EVTPUT(-22,IFT2,MOT,0,
6483      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6484                CALL DT_EVTPUT(-21,IFP2,MOP,0,
6485      &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6486                CALL DT_EVTPUT(-22,IFT1,MOT,0,
6487      &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6488                PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6489      &                                        +(PP1(3)+PT2(3))**2)
6490                ECH   = PP1(4)+PT2(4)
6491                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6492                PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6493      &                                        +(PP2(3)+PT1(3))**2)
6494                ECH   = PP2(4)+PT1(4)
6495                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6496             ENDIF
6497             IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6498                AM1 = SQRT(AM1)
6499                AM2 = SQRT(AM2)
6500                IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6501 C                 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6502  5007             FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6503                ENDIF
6504             ELSE
6505                WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6506             ENDIF
6507             NCSY = NCSY+1
6508          ENDIF
6509    80 CONTINUE
6510       IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6511
6512 * energy-momentum & flavor conservation check
6513       IF (ABS(IDIFF).NE.1) THEN
6514          IF (IDIFF.NE.0) THEN
6515             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6516      &                                              1,3,10,IREJ)
6517          ELSE
6518             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6519      &                                              1,3,10,IREJ)
6520          ENDIF
6521          IF (IREJ.NE.0) THEN
6522             CALL DT_EVTOUT(4)
6523             STOP
6524          ENDIF
6525       ENDIF
6526
6527       RETURN
6528
6529  9999 CONTINUE
6530       IREJ  = 1
6531       RETURN
6532       END
6533 *
6534 *===chkcsy=============================================================*
6535 *
6536 CDECK  ID>, DT_CHKCSY
6537       SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6538
6539 ************************************************************************
6540 * CHeCk Chain SYstem for consistency of partons at chain ends.         *
6541 *            ID1,ID2        PDG-numbers of partons at chain ends       *
6542 *            LCHK = .true.  consistent chain                           *
6543 *                 = .false. inconsistent chain                         *
6544 * This version dated 18.01.95 is written by S. Roesler                 *
6545 ************************************************************************
6546
6547       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6548       SAVE
6549
6550       PARAMETER ( LINP = 5 ,
6551      &            LOUT = 6 ,
6552      &            LDAT = 9 )
6553
6554       LOGICAL LCHK
6555
6556       LCHK = .TRUE.
6557
6558 * q-aq chain
6559       IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6560          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6561 * q-qq, aq-aqaq chain
6562       ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6563      &        ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6564          IF (ID1*ID2.LT.0) LCHK = .FALSE.
6565 * qq-aqaq chain
6566       ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6567          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6568       ENDIF
6569
6570       RETURN
6571       END
6572 *
6573 *===eventa=============================================================*
6574 *
6575 CDECK  ID>, DT_EVENTA
6576       SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6577
6578 ************************************************************************
6579 * Treatment of nucleon-nucleon interactions in a two-chain             *
6580 * approximation.                                                       *
6581 *  (input) ID       BAMJET-index of projectile hadron (in case of      *
6582 *                   h-K scattering)                                    *
6583 *          IP/IT    mass number of projectile/target nucleus           *
6584 *          NCSY     number of two chain systems                        *
6585 *          IREJ     rejection flag                                     *
6586 * This version dated 15.01.95 is written by S. Roesler                 *
6587 ************************************************************************
6588
6589       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6590       SAVE
6591
6592       PARAMETER ( LINP = 5 ,
6593      &            LOUT = 6 ,
6594      &            LDAT = 9 )
6595
6596       PARAMETER (TINY10=1.0D-10)
6597
6598 * event history
6599
6600       PARAMETER (NMXHKK=200000)
6601
6602       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6603      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6604      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6605 * extended event history
6606       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6607      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6608      &                IHIST(2,NMXHKK)
6609 * rejection counter
6610       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6611      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6612      &                IREXCI(3),IRDIFF(2),IRINC
6613 * flags for diffractive interactions (DTUNUC 1.x)
6614       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6615 * particle properties (BAMJET index convention)
6616       CHARACTER*8  ANAME
6617       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6618      &                IICH(210),IIBAR(210),K1(210),K2(210)
6619 * flags for input different options
6620       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6621       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6622      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6623 * various options for treatment of partons (DTUNUC 1.x)
6624 * (chain recombination, Cronin,..)
6625       LOGICAL LCO2CR,LINTPT
6626       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6627      &                LCO2CR,LINTPT
6628
6629       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
6630
6631       IREJ      = 0
6632       NPOINT(3) = NHKK+1
6633
6634 * skip following treatment for low-mass diffraction
6635       IF (ABS(IFLAGD).EQ.1) THEN
6636          NPOINT(3) = NPOINT(2)
6637          GOTO 5
6638       ENDIF
6639
6640 * multiple scattering of chain ends
6641       IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
6642       IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
6643
6644       NC = NPOINT(2)
6645 * get a two-chain system from DTEVT1
6646       DO 3 I=1,NCSY
6647          IFP1 = IDHKK(NC)
6648          IFT1 = IDHKK(NC+1)
6649          IFP2 = IDHKK(NC+2)
6650          IFT2 = IDHKK(NC+3)
6651          DO 4 K=1,4
6652             PP1(K) = PHKK(K,NC)
6653             PT1(K) = PHKK(K,NC+1)
6654             PP2(K) = PHKK(K,NC+2)
6655             PT2(K) = PHKK(K,NC+3)
6656     4    CONTINUE
6657          MOP1 = NC
6658          MOT1 = NC+1
6659          MOP2 = NC+2
6660          MOT2 = NC+3
6661          CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
6662      &               IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
6663          IF (IREJ1.GT.0) THEN
6664             IRHHA = IRHHA+1
6665             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
6666             GOTO 9999
6667          ENDIF
6668          NC = NC+4
6669     3 CONTINUE
6670
6671 * meson/antibaryon projectile:
6672 * sample single-chain valence-valence systems (Reggeon contrib.)
6673       IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
6674          IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
6675       ENDIF
6676
6677       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6678 * check DTEVT1 for remaining resonance mass corrections
6679          CALL DT_EVTRES(IREJ1)
6680          IF (IREJ1.GT.0) THEN
6681             IRRES(1) = IRRES(1)+1
6682             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
6683             GOTO 9999
6684          ENDIF
6685       ENDIF
6686
6687 * assign p_t to two-"chain" systems consisting of two resonances only
6688 * since only entries for chains will be affected, this is obsolete
6689 * in case of JETSET-fragmetation
6690       CALL DT_RESPT
6691
6692 * combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
6693       IF (LCO2CR) CALL DT_COM2CR
6694
6695     5 CONTINUE
6696
6697 * fragmentation of the complete event
6698 **uncomment for internal phojet-fragmentation
6699 C     CALL DT_EVTFRA(IREJ1)
6700       CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
6701       IF (IREJ1.GT.0) THEN
6702          IRFRAG = IRFRAG+1
6703          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
6704          GOTO 9999
6705       ENDIF
6706
6707 * decay of possible resonances (should be obsolete)
6708       CALL DT_DECAY1
6709
6710       RETURN
6711
6712  9999 CONTINUE
6713       IREVT = IREVT+1
6714       IREJ  = 1
6715       RETURN
6716       END
6717 *
6718 *===getcsy=============================================================*
6719 *
6720 CDECK  ID>, DT_GETCSY
6721       SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
6722      &                  IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
6723
6724 ************************************************************************
6725 * This version dated 15.01.95 is written by S. Roesler                 *
6726 ************************************************************************
6727
6728       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6729       SAVE
6730
6731       PARAMETER ( LINP = 5 ,
6732      &            LOUT = 6 ,
6733      &            LDAT = 9 )
6734
6735       PARAMETER (TINY10=1.0D-10)
6736
6737 * event history
6738
6739       PARAMETER (NMXHKK=200000)
6740
6741       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6742      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6743      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6744 * extended event history
6745       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6746      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6747      &                IHIST(2,NMXHKK)
6748 * rejection counter
6749       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6750      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6751      &                IREXCI(3),IRDIFF(2),IRINC
6752 * flags for input different options
6753       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6754       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6755      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6756 * flags for diffractive interactions (DTUNUC 1.x)
6757       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6758
6759       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
6760      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
6761
6762       IREJ  = 0
6763
6764 * get quark content of partons
6765       DO 1 I=1,2
6766          IFP1(I) = 0
6767          IFP2(I) = 0
6768          IFT1(I) = 0
6769          IFT2(I) = 0
6770     1 CONTINUE
6771       IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
6772       IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
6773       IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
6774       IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
6775       IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
6776       IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
6777       IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
6778       IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
6779
6780 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
6781       IDCH1 = 2
6782       IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
6783       IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
6784       IDCH2 = 2
6785       IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
6786       IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
6787
6788 * store initial configuration for energy-momentum cons. check
6789       IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
6790
6791 * sample intrinsic p_t at chain-ends
6792       CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
6793      &            PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
6794      &            AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
6795       IF (IREJ1.NE.0) THEN
6796          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
6797          IRPT = IRPT+1
6798          GOTO 9999
6799       ENDIF
6800
6801 C      IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6802 C         IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
6803 C* check second chain for resonance
6804 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6805 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
6806 C            IF (IREJ1.NE.0) GOTO 9999
6807 C            IF (IDR2.NE.0) THEN
6808 C               CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6809 C     &                     AMCH2,AMCH2N,AMCH1,IREJ1)
6810 C               IF (IREJ1.NE.0) GOTO 9999
6811 C            ENDIF
6812 C* check first chain for resonance
6813 C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6814 C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
6815 C            IF (IREJ1.NE.0) GOTO 9999
6816 C            IF (IDR1.NE.0) IDR1 = 100*IDR1
6817 C         ELSE
6818 C* check first chain for resonance
6819 C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6820 C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
6821 C            IF (IREJ1.NE.0) GOTO 9999
6822 C            IF (IDR1.NE.0) THEN
6823 C               CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6824 C     &                     AMCH1,AMCH1N,AMCH2,IREJ1)
6825 C               IF (IREJ1.NE.0) GOTO 9999
6826 C            ENDIF
6827 C* check second chain for resonance
6828 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6829 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
6830 C            IF (IREJ1.NE.0) GOTO 9999
6831 C            IF (IDR2.NE.0) IDR2 = 100*IDR2
6832 C         ENDIF
6833 C      ENDIF
6834
6835       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6836 * check chains for resonances
6837          CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6838      &               AMCH1,AMCH1N,IDCH1,IREJ1)
6839          IF (IREJ1.NE.0) GOTO 9999
6840          CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6841      &               AMCH2,AMCH2N,IDCH2,IREJ1)
6842          IF (IREJ1.NE.0) GOTO 9999
6843 * change kinematics corresponding to resonance-masses
6844          IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
6845             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6846      &                                 AMCH1,AMCH1N,AMCH2,IREJ1)
6847             IF (IREJ1.GT.0) GOTO 9999
6848             IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6849             CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6850      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
6851             IF (IREJ1.NE.0) GOTO 9999
6852             IF (IDR2.NE.0) IDR2 = 100*IDR2
6853          ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
6854             CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6855      &                                 AMCH2,AMCH2N,AMCH1,IREJ1)
6856             IF (IREJ1.GT.0) GOTO 9999
6857             IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6858             CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6859      &                  AMCH1,AMCH1N,IDCH1,IREJ1)
6860             IF (IREJ1.NE.0) GOTO 9999
6861             IF (IDR1.NE.0) IDR1 = 100*IDR1
6862          ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
6863             AMDIF1 = ABS(AMCH1-AMCH1N)
6864             AMDIF2 = ABS(AMCH2-AMCH2N)
6865             IF (AMDIF2.LT.AMDIF1) THEN
6866                CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6867      &                                    AMCH2,AMCH2N,AMCH1,IREJ1)
6868                IF (IREJ1.GT.0) GOTO 9999
6869                IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6870                CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
6871      &                     IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
6872                IF (IREJ1.NE.0) GOTO 9999
6873                IF (IDR1.NE.0) IDR1 = 100*IDR1
6874             ELSE
6875                CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6876      &                                    AMCH1,AMCH1N,AMCH2,IREJ1)
6877                IF (IREJ1.GT.0) GOTO 9999
6878                IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6879                CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
6880      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
6881                IF (IREJ1.NE.0) GOTO 9999
6882                IF (IDR2.NE.0) IDR2 = 100*IDR2
6883             ENDIF
6884          ENDIF
6885       ENDIF
6886
6887 * store final configuration for energy-momentum cons. check
6888       IF (LEMCCK) THEN
6889          CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
6890          CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
6891          IF (IREJ1.NE.0) GOTO 9999
6892       ENDIF
6893
6894 * put partons and chains into DTEVT1
6895       DO 10 I=1,4
6896          PCH1(I) = PP1(I)+PT1(I)
6897          PCH2(I) = PP2(I)+PT2(I)
6898    10 CONTINUE
6899       CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
6900      &                                      PP1(3),PP1(4),0,0,0)
6901       CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
6902      &                                      PT1(3),PT1(4),0,0,0)
6903       KCH = 100+IDCH(MOP1)*10+1
6904       CALL DT_EVTPUT(KCH,88888,-2,-1,
6905      &           PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
6906       CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
6907      &                                      PP2(3),PP2(4),0,0,0)
6908       CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
6909      &                                      PT2(3),PT2(4),0,0,0)
6910       KCH = KCH+1
6911       CALL DT_EVTPUT(KCH,88888,-2,-1,
6912      &           PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
6913
6914       RETURN
6915
6916  9999 CONTINUE
6917       IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
6918 * "cancel" sea-sea chains
6919          CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
6920          IF (IREJ1.NE.0) GOTO 9998
6921 **sr 16.5. flag for EVENTB
6922          IREJ = -1
6923          RETURN
6924       ENDIF
6925  9998 CONTINUE
6926       IREJ = 1
6927       RETURN
6928       END
6929 *
6930 *===chkine=============================================================*
6931 *
6932 CDECK  ID>, DT_CHKINE
6933       SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
6934      &                  AMCH1,AMCH1N,AMCH2,IREJ)
6935
6936 ************************************************************************
6937 * This subroutine replaces CORMOM.                                     *
6938 * This version dated 05.01.95 is written by S. Roesler                 *
6939 ************************************************************************
6940
6941       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6942       SAVE
6943
6944       PARAMETER ( LINP = 5 ,
6945      &            LOUT = 6 ,
6946      &            LDAT = 9 )
6947
6948       PARAMETER (TINY10=1.0D-10)
6949
6950 * flags for input different options
6951       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6952       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6953      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6954 * rejection counter
6955       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6956      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6957      &                IREXCI(3),IRDIFF(2),IRINC
6958
6959       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
6960      &          PP1I(4),PP2I(4),PT1I(4),PT2I(4)
6961
6962       IREJ  = 0
6963       JMSHL = IMSHL
6964
6965       SCALE  = AMCH1N/MAX(AMCH1,TINY10)
6966       DO 10 I=1,4
6967          PP1(I) = PP1I(I)
6968          PP2(I) = PP2I(I)
6969          PT1(I) = PT1I(I)
6970          PT2(I) = PT2I(I)
6971          PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
6972          PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
6973          PP1(I) = SCALE*PP1(I)
6974          PT1(I) = SCALE*PT1(I)
6975    10 CONTINUE
6976       IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
6977      &    (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
6978
6979       ECH = PP2(4)+PT2(4)
6980       PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
6981      &                               (PP2(3)+PT2(3))**2 )
6982       AMCH22 = (ECH-PCH)*(ECH+PCH)
6983       IF (AMCH22.LT.0.0D0) THEN
6984          IF (IOULEV(1).GT.0)
6985      &      WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
6986          GOTO 9997
6987       ENDIF
6988
6989       AMCH1 = AMCH1N
6990       AMCH2 = SQRT(AMCH22)
6991
6992 * put partons again on mass shell
6993    13 CONTINUE
6994       XM1 = 0.0D0
6995       XM2 = 0.0D0
6996       IF (JMSHL.EQ.1) THEN
6997
6998          XM1 = PYMASS(IFP1)
6999          XM2 = PYMASS(IFT1)
7000
7001       ENDIF
7002       CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
7003       IF (IREJ1.NE.0) THEN
7004          IF (JMSHL.EQ.0) GOTO 9998
7005          JMSHL = 0
7006          GOTO 13
7007       ENDIF
7008       JMSHL = IMSHL
7009       DO 11 I=1,4
7010          PP1(I) = P1(I)
7011          PT1(I) = P2(I)
7012    11 CONTINUE
7013    14 CONTINUE
7014       XM1 = 0.0D0
7015       XM2 = 0.0D0
7016       IF (JMSHL.EQ.1) THEN
7017
7018          XM1 = PYMASS(IFP2)
7019          XM2 = PYMASS(IFT2)
7020
7021       ENDIF
7022       CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
7023       IF (IREJ1.NE.0) THEN
7024          IF (JMSHL.EQ.0) GOTO 9998
7025          JMSHL = 0
7026          GOTO 14
7027       ENDIF
7028       DO 12 I=1,4
7029          PP2(I) = P1(I)
7030          PT2(I) = P2(I)
7031    12 CONTINUE
7032       DO 15 I=1,4
7033          PP1I(I) = PP1(I)
7034          PP2I(I) = PP2(I)
7035          PT1I(I) = PT1(I)
7036          PT2I(I) = PT2(I)
7037    15 CONTINUE
7038       RETURN
7039
7040  9997 IRCHKI(1) = IRCHKI(1)+1
7041 **sr
7042 C     GOTO 9999
7043       IREJ = -1
7044       RETURN
7045 **
7046  9998 IRCHKI(2) = IRCHKI(2)+1
7047
7048  9999 CONTINUE
7049       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
7050       IREJ = 1
7051       RETURN
7052       END
7053 *
7054 *===ch2res=============================================================*
7055 *
7056 CDECK  ID>, DT_CH2RES
7057       SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7058      &                  AM,AMN,IMODE,IREJ)
7059
7060 ************************************************************************
7061 * Check chains for resonance production.                               *
7062 * This subroutine replaces COMCMA/COBCMA/COMCM2                        *
7063 *    input:                                                            *
7064 *          IF1,2,3,4    input flavors (q,aq in any order)              *
7065 *          AM           chain mass                                     *
7066 *          MODE = 1     check q-aq chain for meson-resonance           *
7067 *               = 2     check q-qq, aq-aqaq chain for baryon-resonance *
7068 *               = 3     check qq-aqaq chain for lower mass cut         *
7069 *    output:                                                           *
7070 *          IDR = 0      no resonances found                            *
7071 *              = -1     pseudoscalar meson/octet baryon                *
7072 *              = 1      vector-meson/decuplet baryon                   *
7073 *          IDXR         BAMJET-index of corresponding resonance        *
7074 *          AMN          mass of corresponding resonance                *
7075 *                                                                      *
7076 *          IREJ         rejection flag                                 *
7077 * This version dated 06.01.95 is written by S. Roesler                 *
7078 ************************************************************************
7079
7080       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7081       SAVE
7082
7083       PARAMETER ( LINP = 5 ,
7084      &            LOUT = 6 ,
7085      &            LDAT = 9 )
7086
7087 * particle properties (BAMJET index convention)
7088       CHARACTER*8  ANAME
7089       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7090      &                IICH(210),IIBAR(210),K1(210),K2(210)
7091 * quark-content to particle index conversion (DTUNUC 1.x)
7092       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7093      &                IA08(6,21),IA10(6,21)
7094 * rejection counter
7095       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7096      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7097      &                IREXCI(3),IRDIFF(2),IRINC
7098 * flags for input different options
7099       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7100       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7101      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7102
7103       DIMENSION IF(4),JF(4)
7104
7105 **sr 4.7. test
7106 C     DATA AMLOM,AMLOB /0.08D0,0.2D0/
7107       DATA AMLOM,AMLOB /0.1D0,0.7D0/
7108 **
7109 C     DATA AMLOM,AMLOB /0.001D0,0.001D0/
7110
7111       MODE = ABS(IMODE)
7112
7113       IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7114          WRITE(LOUT,1000) MODE
7115  1000    FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7116      &          1X,'        program stopped')
7117          STOP
7118       ENDIF
7119
7120       AMX  = AM
7121       IREJ = 0
7122       IDR  = 0
7123       IDXR = 0
7124       AMN  = AMX
7125       IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7126       IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7127
7128       IF(1) = IF1
7129       IF(2) = IF2
7130       IF(3) = IF3
7131       IF(4) = IF4
7132       NF = 0
7133       DO 100 I=1,4
7134          IF (IF(I).NE.0) THEN
7135             NF = NF+1
7136             JF(NF) = IF(I)
7137          ENDIF
7138   100 CONTINUE
7139       IF (NF.LE.MODE) THEN
7140          WRITE(LOUT,1001) MODE,IF
7141  1001    FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7142      &   I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7143          GOTO 9999
7144       ENDIF
7145
7146       GOTO (1,2,3) MODE
7147
7148 * check for meson resonance
7149     1 CONTINUE
7150       IFQ  = JF(1)
7151       IFAQ = ABS(JF(2))
7152       IF (JF(2).GT.0) THEN
7153          IFQ  = JF(2)
7154          IFAQ = ABS(JF(1))
7155       ENDIF
7156       IFPS = IMPS(IFAQ,IFQ)
7157       IFV  = IMVE(IFAQ,IFQ)
7158       AMPS = AAM(IFPS)
7159       AMV  = AAM(IFV)
7160       AMHI = AMV+0.3D0
7161       IF (AMX.LT.AMV) THEN
7162          IF (AMX.LT.AMPS) THEN
7163             IF (IMODE.GT.0) THEN
7164                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7165             ELSE
7166                IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7167             ENDIF
7168             LOMRES = LOMRES+1
7169          ENDIF
7170 *    replace chain by pseudoscalar meson
7171          IDR  = -1
7172          IDXR = IFPS
7173          AMN  = AMPS
7174       ELSEIF (AMX.LT.AMHI) THEN
7175 *    replace chain by vector-meson
7176          IDR  = 1
7177          IDXR = IFV
7178          AMN  = AMV
7179       ENDIF
7180       RETURN
7181
7182 * check for baryon resonance
7183     2 CONTINUE
7184       CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7185       AM8  = AAM(JB8)
7186       AM10 = AAM(JB10)
7187       AMHI = AM10+0.3D0
7188       IF (AMX.LT.AM10) THEN
7189          IF (AMX.LT.AM8) THEN
7190             IF (IMODE.GT.0) THEN
7191                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7192             ELSE
7193                IF (AMX.LT.0.8D0*AM8) GOTO 9999
7194             ENDIF
7195             LOBRES = LOBRES+1
7196          ENDIF
7197 *    replace chain by oktet baryon
7198          IDR  = -1
7199          IDXR = JB8
7200          AMN  = AM8
7201       ELSEIF (AMX.LT.AMHI) THEN
7202          IDR  = 1
7203          IDXR = JB10
7204          AMN  = AM10
7205       ENDIF
7206       RETURN
7207
7208 * check qq-aqaq for lower mass cut
7209     3 CONTINUE
7210 *   empirical definition of AMHI to allow for (b-antib)-pair prod.
7211       AMHI = 2.5D0
7212       IF (AMX.LT.AMHI) GOTO 9999
7213       RETURN
7214
7215  9999 CONTINUE
7216       IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7217      &    WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7218       IREJ = 1
7219       IRRES(2) = IRRES(2)+1
7220       RETURN
7221       END
7222 *
7223 *===rjseac=============================================================*
7224 *
7225 CDECK  ID>, DT_RJSEAC
7226       SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7227
7228 ************************************************************************
7229 * ReJection of SEA-sea Chains.                                         *
7230 *         MOP1/2       entries of projectile sea-partons in DTEVT1     *
7231 *         MOT1/2       entries of projectile sea-partons in DTEVT1     *
7232 * This version dated 16.01.95 is written by S. Roesler                 *
7233 ************************************************************************
7234
7235       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7236       SAVE
7237
7238       PARAMETER ( LINP = 5 ,
7239      &            LOUT = 6 ,
7240      &            LDAT = 9 )
7241
7242       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7243
7244 * event history
7245
7246       PARAMETER (NMXHKK=200000)
7247
7248       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7249      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7250      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7251 * extended event history
7252       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7253      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7254      &                IHIST(2,NMXHKK)
7255 * statistics
7256       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7257      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7258      &                ICEVTG(8,0:30)
7259
7260       DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7261
7262       IREJ = 0
7263
7264 * projectile sea q-aq-pair
7265 *    indices of sea-pair
7266       IDXSEA(1,1) = MOP1
7267       IDXSEA(1,2) = MOP2
7268 *    index of mother-nucleon
7269       IDXNUC(1)   = JMOHKK(1,MOP1)
7270 *    status of valence quarks to be corrected
7271       ISTVAL(1)   = -21
7272
7273 * target sea q-aq-pair
7274 *    indices of sea-pair
7275       IDXSEA(2,1) = MOT1
7276       IDXSEA(2,2) = MOT2
7277 *    index of mother-nucleon
7278       IDXNUC(2)   = JMOHKK(1,MOT1)
7279 *    status of valence quarks to be corrected
7280       ISTVAL(2)   = -22
7281
7282       DO 1 N=1,2
7283          IDONE = 0
7284          DO 2 I=NPOINT(2),NHKK
7285             IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7286      &          (JMOHKK(1,I).EQ.IDXNUC(N)))   THEN
7287 * valence parton found
7288 *    inrease 4-momentum by sea 4-momentum
7289                DO 3 K=1,4
7290                   PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7291      &                                  PHKK(K,IDXSEA(N,2))
7292     3          CONTINUE
7293                PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7294      &                              PHKK(2,I)**2-PHKK(3,I)**2))
7295 *    "cancel" sea-pair
7296                DO 4 J=1,2
7297                   ISTHKK(IDXSEA(N,J))   = 100
7298                   IDHKK(IDXSEA(N,J))    = 0
7299                   JMOHKK(1,IDXSEA(N,J)) = 0
7300                   JMOHKK(2,IDXSEA(N,J)) = 0
7301                   JDAHKK(1,IDXSEA(N,J)) = 0
7302                   JDAHKK(2,IDXSEA(N,J)) = 0
7303                   DO 5 K=1,4
7304                      PHKK(K,IDXSEA(N,J)) = ZERO
7305                      VHKK(K,IDXSEA(N,J)) = ZERO
7306                      WHKK(K,IDXSEA(N,J)) = ZERO
7307     5             CONTINUE
7308                   PHKK(5,IDXSEA(N,J)) = ZERO
7309     4          CONTINUE
7310                IDONE = 1
7311             ENDIF
7312     2    CONTINUE
7313          IF (IDONE.NE.1) THEN
7314             WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7315  1000       FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7316      &                '-record!',/,1X,'        sea-quark pairs   ',
7317      &                2I5,4X,2I5,'   could not be canceled!')
7318             GOTO 9999
7319          ENDIF
7320     1 CONTINUE
7321       ICRJSS = ICRJSS+1
7322       RETURN
7323
7324  9999 CONTINUE
7325       IREJ = 1
7326       RETURN
7327       END
7328 *
7329 *===vv2sch=============================================================*
7330 *
7331 CDECK  ID>, DT_VV2SCH
7332       SUBROUTINE DT_VV2SCH
7333
7334 ************************************************************************
7335 * Change Valence-Valence chain systems to Single CHain systems for     *
7336 * hadron-nucleus collisions with meson or antibaryon projectile.       *
7337 * (Reggeon contribution)                                               *
7338 * The single chain system is approximately treated as one chain and a  *
7339 * meson at rest.                                                       *
7340 * This version dated 18.01.95 is written by S. Roesler                 *
7341 ************************************************************************
7342
7343       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7344       SAVE
7345
7346       PARAMETER ( LINP = 5 ,
7347      &            LOUT = 6 ,
7348      &            LDAT = 9 )
7349
7350       PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7351
7352       LOGICAL LSTART
7353
7354 * event history
7355
7356       PARAMETER (NMXHKK=200000)
7357
7358       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7359      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7360      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7361 * extended event history
7362       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7363      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7364      &                IHIST(2,NMXHKK)
7365 * flags for input different options
7366       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7367       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7368      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7369 * statistics
7370       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7371      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7372      &                ICEVTG(8,0:30)
7373
7374       DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7375      &          PCH2(4)
7376
7377       DATA LSTART /.TRUE./
7378
7379       IFSC  = 0
7380       IF (LSTART) THEN
7381          WRITE(LOUT,1000)
7382  1000    FORMAT(/,1X,'VV2SCH:  Reggeon contribution to valance-',
7383      &          'valence chains treated')
7384          LSTART = .FALSE.
7385       ENDIF
7386
7387       NSTOP = NHKK
7388
7389 * get index of first chain
7390       DO 1 I=NPOINT(3),NHKK
7391          IF (IDHKK(I).EQ.88888) THEN
7392             NC = I
7393             GOTO 2
7394          ENDIF
7395     1 CONTINUE
7396
7397     2 CONTINUE
7398       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7399      &                        .AND.(NC.LT.NSTOP)) THEN
7400 * get valence-valence chains
7401          IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7402 *   get "mother"-hadron indices
7403             MO1   = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7404             MO2   = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7405             KPROJ = IDT_ICIHAD(IDHKK(MO1))
7406             KTARG = IDT_ICIHAD(IDHKK(MO2))
7407 *   Lab momentum of projectile hadron
7408             CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7409             PTOT  = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7410      &                                  PHKK(3,MO1)**2)
7411
7412             SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7413             IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7414                ICVV2S = ICVV2S+1
7415 *   single chain requested
7416 *      get flavors of chain-end partons
7417                MO(1) = JMOHKK(1,NC)
7418                MO(2) = JMOHKK(2,NC)
7419                MO(3) = JMOHKK(1,NC+3)
7420                MO(4) = JMOHKK(2,NC+3)
7421                DO 3 I=1,4
7422                   IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7423                   IF(I,2) = 0
7424                   IF (ABS(IDHKK(MO(I))).GE.1000)
7425      &               IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7426     3          CONTINUE
7427 *      which one is the q-aq chain?
7428 *        N1,N1+1 - DTEVT1-entries for q-aq system
7429 *        N2,N2+1 - DTEVT1-entries for the other chain
7430                IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7431                   K1 = 1
7432                   K2 = 3
7433                   N1 = NC-2
7434                   N2 = NC+1
7435                ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7436                   K1 = 3
7437                   K2 = 1
7438                   N1 = NC+1
7439                   N2 = NC-2
7440                ELSE
7441                   GOTO 10
7442                ENDIF
7443                DO 4 K=1,4
7444                   PP1(K) = PHKK(K,N1)
7445                   PT1(K) = PHKK(K,N1+1)
7446                   PP2(K) = PHKK(K,N2)
7447                   PT2(K) = PHKK(K,N2+1)
7448     4          CONTINUE
7449                AMCH1 = PHKK(5,N1+2)
7450                AMCH2 = PHKK(5,N2+2)
7451 *      get meson-identity corresponding to flavors of q-aq chain
7452                ITMP   = IRESRJ
7453                IRESRJ = 0
7454                CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7455      &                     ZERO,AMCH1N,1,IDUM)
7456                IRESRJ = ITMP
7457 *      change kinematics of chains
7458                CALL DT_CHKINE(PP1,IDHKK(N1),  PP2,IDHKK(N2),
7459      &                     PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7460      &                     AMCH1,AMCH1N,AMCH2,IREJ1)
7461                IF (IREJ1.NE.0) GOTO 10
7462 *      check second chain for resonance
7463                IDCHAI = 2
7464                IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7465                CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7466      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7467                IF (IREJ1.NE.0) GOTO 10
7468                IF (IDR2.NE.0) IDR2 = 100*IDR2
7469 *      add partons and chains to DTEVT1
7470                DO 5 K=1,4
7471                   PCH1(K) = PP1(K)+PT1(K)
7472                   PCH2(K) = PP2(K)+PT2(K)
7473     5          CONTINUE
7474                CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7475      &                                             PP1(3),PP1(4),0,0,0)
7476                CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7477      &                                      PT1(2),PT1(3),PT1(4),0,0,0)
7478                KCH = ISTHKK(N1+2)+100
7479                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7480      &                     PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7481                IDHKK(N1+2) = 22222
7482                CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7483      &                                             PP2(3),PP2(4),0,0,0)
7484                CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7485      &                                      PT2(2),PT2(3),PT2(4),0,0,0)
7486                KCH = ISTHKK(N2+2)+100
7487                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7488      &                     PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7489                IDHKK(N2+2) = 22222
7490             ENDIF
7491          ENDIF
7492       ELSE
7493          GOTO 11
7494       ENDIF
7495    10 CONTINUE
7496       NC = NC+6
7497       GOTO 2
7498
7499    11 CONTINUE
7500
7501       RETURN
7502       END
7503 *
7504 *=== phnsch ===========================================================*
7505 *
7506 CDECK  ID>, DT_PHNSCH
7507       DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7508
7509 *----------------------------------------------------------------------*
7510 *                                                                      *
7511 *     Probability for Hadron Nucleon Single CHain interactions:        *
7512 *                                                                      *
7513 *     Created on 30 december 1993  by    Alfredo Ferrari & Paola Sala  *
7514 *                                                   Infn - Milan       *
7515 *                                                                      *
7516 *     Last change on 04-jan-94     by    Alfredo Ferrari               *
7517 *                                                                      *
7518 *             modified by J.R.for use in DTUNUC  6.1.94                *
7519 *                                                                      *
7520 *     Input variables:                                                 *
7521 *                      Kp = hadron projectile index (Part numbering    *
7522 *                           scheme)                                    *
7523 *                   Ktarg = target nucleon index (1=proton, 8=neutron) *
7524 *                    Plab = projectile laboratory momentum (GeV/c)     *
7525 *     Output variable:                                                 *
7526 *                  Phnsch = probability per single chain (particle     *
7527 *                           exchange) interactions                     *
7528 *                                                                      *
7529 *----------------------------------------------------------------------*
7530
7531       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7532       SAVE
7533
7534       PARAMETER ( LUNOUT = 6  )
7535       PARAMETER ( LUNERR = 6  )
7536       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
7537       PARAMETER ( ZERZER = 0.D+00 )
7538       PARAMETER ( ONEONE = 1.D+00 )
7539       PARAMETER ( TWOTWO = 2.D+00 )
7540       PARAMETER ( FIVFIV = 5.D+00 )
7541       PARAMETER ( HLFHLF = 0.5D+00 )
7542
7543       PARAMETER ( NALLWP = 39   )
7544       PARAMETER ( IDMAXP = 210  )
7545
7546       DIMENSION ICHRGE(39),AM(39)
7547
7548 * particle properties (BAMJET index convention)
7549       CHARACTER*8  ANAME
7550       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7551      &                IICH(210),IIBAR(210),K1(210),K2(210)
7552
7553       DIMENSION KPTOIP(210)
7554 * auxiliary common for reggeon exchange (DTUNUC 1.x)
7555       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7556      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7557      &                IQTCHR(-6:6),MQUARK(3,39)
7558
7559       DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7560       DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7561       SAVE SGTCOE, IHLP
7562       SAVE IQFSC1, IQFSC2, IQBSC1, IQBSC2
7563       EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7564       EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7565       EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7566
7567 * Conversion from part to paprop numbering
7568       DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7569      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7570      & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7571
7572 *  1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7573       DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7574      &    2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7575 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7576       DATA  SGTCO1  /
7577 * 1st reaction: gamma p total
7578      &0.147 D+00, ZERZER  , ZERZER   , 0.0022D+00, -0.0170D+00,
7579 * 2nd reaction: gamma d total
7580      &0.300 D+00, ZERZER  , ZERZER   , 0.0095D+00, -0.057 D+00,
7581 * 3rd reaction: pi+ p total
7582      &16.4  D+00, 19.3D+00, -0.42D+00, 0.19  D+00, ZERZER     ,
7583 * 4th reaction: pi- p total
7584      &33.0  D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03  D+00,
7585 * 5th reaction: pi+/- d total
7586      &56.8  D+00, 42.2D+00, -1.45D+00, 0.65  D+00, -5.39  D+00,
7587 * 6th reaction: K+ p total
7588      &18.1  D+00, ZERZER  , ZERZER   , 0.26  D+00, -1.0   D+00,
7589 * 7th reaction: K+ n total
7590      &18.7  D+00, ZERZER  , ZERZER   , 0.21  D+00, -0.89  D+00,
7591 * 8th reaction: K+ d total
7592      &34.2  D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99  D+00,
7593 * 9th reaction: K- p total
7594      &32.1  D+00, ZERZER  , ZERZER   , 0.66  D+00, -5.6   D+00,
7595 * 10th reaction: K- n total
7596      &25.2  D+00, ZERZER  , ZERZER   , 0.38  D+00, -2.9   D+00/
7597 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7598       DATA  SGTCO2  /
7599 * 11th reaction: K- d total
7600      &57.6  D+00, ZERZER  , ZERZER   , 1.17  D+00, -9.5   D+00,
7601 * 12th reaction: p p total
7602      &48.0  D+00, ZERZER  , ZERZER   , 0.522 D+00, -4.51  D+00,
7603 * 13th reaction: p n total
7604      &47.30 D+00, ZERZER  , ZERZER   , 0.513 D+00, -4.27  D+00,
7605 * 14th reaction: p d total
7606      &91.3  D+00, ZERZER  , ZERZER   , 1.05  D+00, -8.8   D+00,
7607 * 15th reaction: pbar p total
7608      &38.4  D+00, 77.6D+00, -0.64D+00, 0.26  D+00, -1.2   D+00,
7609 * 16th reaction: pbar n total
7610      &ZERZER    ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7   D+00,
7611 * 17th reaction: pbar d total
7612      &112.  D+00, 125.D+00, -1.08D+00, 1.14  D+00, -12.4  D+00,
7613 * 18th reaction: Lamda p total
7614      &30.4  D+00, ZERZER  , ZERZER   , ZERZER    , 1.6    D+00/
7615 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
7616       DATA SGTCO3  /
7617 * 19th reaction: pi+ p elastic
7618      &ZERZER    , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER     ,
7619 * 20th reaction: pi- p elastic
7620      &1.76  D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER     ,
7621 * 21st reaction: K+ p elastic
7622      &5.0   D+00, 8.1 D+00, -1.8 D+00, 0.16  D+00, -1.3   D+00,
7623 * 22nd reaction: K- p elastic
7624      &7.3   D+00, ZERZER  , ZERZER   , 0.29  D+00, -2.40  D+00,
7625 * 23rd reaction: p p elastic
7626      &11.9  D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85  D+00,
7627 * 24th reaction: p d elastic
7628      &16.1  D+00, ZERZER  , ZERZER   , 0.32  D+00, -3.4   D+00,
7629 * 25th reaction: pbar p elastic
7630      &10.2  D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28  D+00,
7631 * 26th reaction: pbar p elastic bis
7632      &10.6  D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41  D+00,
7633 * 27th reaction: pbar n elastic
7634      &36.5  D+00, ZERZER  , ZERZER   , ZERZER    , -11.9  D+00,
7635 * 28th reaction: Lamda p elastic
7636      &12.3  D+00, ZERZER  , ZERZER   , ZERZER    , -2.4   D+00,
7637 * 29th reaction: K- p ela bis
7638      &7.24  D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35  D+00,
7639 * 30th reaction: pi- p cx
7640      &ZERZER    ,0.912D+00, -1.22D+00, ZERZER    , ZERZER     ,
7641 * 31st reaction: K- p cx
7642      &ZERZER    , 3.39D+00, -1.75D+00, ZERZER    , ZERZER     ,
7643 * 32nd reaction: K+ n cx
7644      &ZERZER    , 7.18D+00, -2.01D+00, ZERZER    , ZERZER     ,
7645 * 33rd reaction: pbar p cx
7646      &ZERZER    , 18.8D+00, -2.01D+00, ZERZER    , ZERZER     /
7647 *
7648 *  +-------------------------------------------------------------------*
7649          ICHRGE(KTARG)=IICH(KTARG)
7650          AM    (KTARG)=AAM (KTARG)
7651 *  |  Check for pi0 (d-dbar)
7652       IF ( KP .NE. 26 ) THEN
7653          IP  = KPTOIP (KP)
7654          IF(IP.EQ.0)IP=1
7655          ICHRGE(IP)=IICH(KP)
7656          AM    (IP)=AAM (KP)
7657 *  |
7658 *  +-------------------------------------------------------------------*
7659 *  |
7660       ELSE
7661          IP = 23
7662          ICHRGE(IP)=0
7663       END IF
7664 *  |
7665 *  +-------------------------------------------------------------------*
7666 *  +-------------------------------------------------------------------*
7667 *  |  No such interactions for baryon-baryon
7668       IF ( IIBAR (KP) .GT. 0 ) THEN
7669          DT_PHNSCH = ZERZER
7670          RETURN
7671 *  |
7672 *  +-------------------------------------------------------------------*
7673 *  |  No "annihilation" diagram possible for K+ p/n
7674       ELSE IF ( IP .EQ. 15 ) THEN
7675          DT_PHNSCH = ZERZER
7676          RETURN
7677 *  |
7678 *  +-------------------------------------------------------------------*
7679 *  |  No "annihilation" diagram possible for K0 p/n
7680       ELSE IF ( IP .EQ. 24 ) THEN
7681          DT_PHNSCH = ZERZER
7682          RETURN
7683 *  |
7684 *  +-------------------------------------------------------------------*
7685 *  |  No "annihilation" diagram possible for Omebar p/n
7686       ELSE IF ( IP .GE. 38 ) THEN
7687          DT_PHNSCH = ZERZER
7688          RETURN
7689       END IF
7690 *  |
7691 *  +-------------------------------------------------------------------*
7692 *  +-------------------------------------------------------------------*
7693 *  |  If the momentum is larger than 50 GeV/c, compute the single
7694 *  |  chain probability at 50 GeV/c and extrapolate to the present
7695 *  |  momentum according to 1/sqrt(s)
7696 *  |  sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
7697 *  |  P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
7698 *  |  sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
7699 *  |  sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
7700 *  |                        x sqrt(s/s(50))
7701 *  |  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
7702       IF ( PLAB .GT. 50.D+00 ) THEN
7703          PLA    = 50.D+00
7704          AMPSQ  = AM (IP)**2
7705          AMTSQ  = AM (KTARG)**2
7706          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
7707          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7708          EPROJ  = SQRT ( PLA**2 + AMPSQ )
7709          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7710          UMORAT = SQRT ( UMOSQ / UMO50 )
7711 *  |
7712 *  +-------------------------------------------------------------------*
7713 *  |  P < 3 GeV/c
7714       ELSE IF ( PLAB .LT. 3.D+00 ) THEN
7715          PLA    = 3.D+00
7716          AMPSQ  = AM (IP)**2
7717          AMTSQ  = AM (KTARG)**2
7718          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
7719          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7720          EPROJ  = SQRT ( PLA**2 + AMPSQ )
7721          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7722          UMORAT = SQRT ( UMOSQ / UMO50 )
7723 *  |
7724 *  +-------------------------------------------------------------------*
7725 *  |  P < 50 GeV/c
7726       ELSE
7727          PLA    = PLAB
7728          UMORAT = ONEONE
7729       END IF
7730 *  |
7731 *  +-------------------------------------------------------------------*
7732       ALGPLA = LOG (PLA)
7733 *  +-------------------------------------------------------------------*
7734 *  |  Pions:
7735       IF ( IHLP (IP) .EQ. 2 ) THEN
7736          ACOF = SGTCOE (1,3)
7737          BCOF = SGTCOE (2,3)
7738          ENNE = SGTCOE (3,3)
7739          CCOF = SGTCOE (4,3)
7740          DCOF = SGTCOE (5,3)
7741 *  |  Compute the pi+ p total cross section:
7742          SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7743      &          + DCOF * ALGPLA
7744          ACOF = SGTCOE (1,19)
7745          BCOF = SGTCOE (2,19)
7746          ENNE = SGTCOE (3,19)
7747          CCOF = SGTCOE (4,19)
7748          DCOF = SGTCOE (5,19)
7749 *  |  Compute the pi+ p elastic cross section:
7750          SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7751      &          + DCOF * ALGPLA
7752 *  |  Compute the pi+ p inelastic cross section:
7753          SPPPIN = SPPPTT - SPPPEL
7754          ACOF = SGTCOE (1,4)
7755          BCOF = SGTCOE (2,4)
7756          ENNE = SGTCOE (3,4)
7757          CCOF = SGTCOE (4,4)
7758          DCOF = SGTCOE (5,4)
7759 *  |  Compute the pi- p total cross section:
7760          SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7761      &          + DCOF * ALGPLA
7762          ACOF = SGTCOE (1,20)
7763          BCOF = SGTCOE (2,20)
7764          ENNE = SGTCOE (3,20)
7765          CCOF = SGTCOE (4,20)
7766          DCOF = SGTCOE (5,20)
7767 *  |  Compute the pi- p elastic cross section:
7768          SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7769      &          + DCOF * ALGPLA
7770 *  |  Compute the pi- p inelastic cross section:
7771          SPMPIN = SPMPTT - SPMPEL
7772          SIGDIA = SPMPIN - SPPPIN
7773 *  |  +----------------------------------------------------------------*
7774 *  |  |  Charged pions: besides isospin consideration it is supposed
7775 *  |  |                 that (pi+ n)el is almost equal to (pi- p)el
7776 *  |  |                 and  (pi+ p)el "    "     "    "  (pi- n)el
7777 *  |  |                 and all are almost equal among each others
7778 *  |  |                 (reasonable above 5 GeV/c)
7779          IF ( ICHRGE (IP) .NE. 0 ) THEN
7780             KHELP = KTARG / 8
7781             JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
7782             ACOF = SGTCOE (1,JREAC)
7783             BCOF = SGTCOE (2,JREAC)
7784             ENNE = SGTCOE (3,JREAC)
7785             CCOF = SGTCOE (4,JREAC)
7786             DCOF = SGTCOE (5,JREAC)
7787 *  |  |  Compute the total cross section:
7788             SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7789      &             + DCOF * ALGPLA
7790             JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
7791             ACOF = SGTCOE (1,JREAC)
7792             BCOF = SGTCOE (2,JREAC)
7793             ENNE = SGTCOE (3,JREAC)
7794             CCOF = SGTCOE (4,JREAC)
7795             DCOF = SGTCOE (5,JREAC)
7796 *  |  |  Compute the elastic cross section:
7797             SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7798      &             + DCOF * ALGPLA
7799 *  |  |  Compute the inelastic cross section:
7800             SHNCIN = SHNCTT - SHNCEL
7801 *  |  |  Number of diagrams:
7802             NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
7803 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7804             IQFSC1 = 1 + IP - 13
7805             IQFSC2 = 0
7806             IQBSC1 = 1 + KHELP
7807             IQBSC2 = 1 + IP - 13
7808 *  |  |
7809 *  |  +----------------------------------------------------------------*
7810 *  |  |  pi0: besides isospin consideration it is supposed that the
7811 *  |  |       elastic cross section is not very different from
7812 *  |  |       pi+ p and/or pi- p (reasonable above 5 GeV/c)
7813          ELSE
7814             KHELP  = KTARG / 8
7815             K2HLP  = ( KP - 23 ) / 3
7816 *  |  |  Number of diagrams:
7817 *  |  |  For u ubar (k2hlp=0):
7818 *           NDIAGR = 2 - KHELP
7819 *  |  |  For d dbar (k2hlp=1):
7820 *           NDIAGR = 2 + KHELP - K2HLP
7821             NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
7822             SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
7823 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7824             IQFSC1 = 1 + K2HLP
7825             IQFSC2 = 0
7826             IQBSC1 = 1 + KHELP
7827             IQBSC2 = 2 - K2HLP
7828          END IF
7829 *  |  |
7830 *  |  +----------------------------------------------------------------*
7831 *  |                                                   end pi's
7832 *  +-------------------------------------------------------------------*
7833 *  |  Kaons:
7834       ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
7835          ACOF = SGTCOE (1,6)
7836          BCOF = SGTCOE (2,6)
7837          ENNE = SGTCOE (3,6)
7838          CCOF = SGTCOE (4,6)
7839          DCOF = SGTCOE (5,6)
7840 *  |  Compute the K+ p total cross section:
7841          SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7842      &          + DCOF * ALGPLA
7843          ACOF = SGTCOE (1,21)
7844          BCOF = SGTCOE (2,21)
7845          ENNE = SGTCOE (3,21)
7846          CCOF = SGTCOE (4,21)
7847          DCOF = SGTCOE (5,21)
7848 *  |  Compute the K+ p elastic cross section:
7849          SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7850      &          + DCOF * ALGPLA
7851 *  |  Compute the K+ p inelastic cross section:
7852          SKPPIN = SKPPTT - SKPPEL
7853          ACOF = SGTCOE (1,9)
7854          BCOF = SGTCOE (2,9)
7855          ENNE = SGTCOE (3,9)
7856          CCOF = SGTCOE (4,9)
7857          DCOF = SGTCOE (5,9)
7858 *  |  Compute the K- p total cross section:
7859          SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7860      &          + DCOF * ALGPLA
7861          ACOF = SGTCOE (1,22)
7862          BCOF = SGTCOE (2,22)
7863          ENNE = SGTCOE (3,22)
7864          CCOF = SGTCOE (4,22)
7865          DCOF = SGTCOE (5,22)
7866 *  |  Compute the K- p elastic cross section:
7867          SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7868      &          + DCOF * ALGPLA
7869 *  |  Compute the K- p inelastic cross section:
7870          SKMPIN = SKMPTT - SKMPEL
7871          SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
7872 *  |  +----------------------------------------------------------------*
7873 *  |  |  Charged Kaons: actually only K-
7874          IF ( ICHRGE (IP) .NE. 0 ) THEN
7875             KHELP = KTARG / 8
7876 *  |  |  +-------------------------------------------------------------*
7877 *  |  |  |  Proton target:
7878             IF ( KHELP .EQ. 0 ) THEN
7879                SHNCIN = SKMPIN
7880 *  |  |  |  Number of diagrams:
7881                NDIAGR = 2
7882 *  |  |  |
7883 *  |  |  +-------------------------------------------------------------*
7884 *  |  |  |  Neutron target: besides isospin consideration it is supposed
7885 *  |  |  |              that (K- n)el is almost equal to (K- p)el
7886 *  |  |  |              (reasonable above 5 GeV/c)
7887             ELSE
7888                ACOF = SGTCOE (1,10)
7889                BCOF = SGTCOE (2,10)
7890                ENNE = SGTCOE (3,10)
7891                CCOF = SGTCOE (4,10)
7892                DCOF = SGTCOE (5,10)
7893 *  |  |  |  Compute the total cross section:
7894                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7895      &                + DCOF * ALGPLA
7896 *  |  |  |  Compute the elastic cross section:
7897                SHNCEL = SKMPEL
7898 *  |  |  |  Compute the inelastic cross section:
7899                SHNCIN = SHNCTT - SHNCEL
7900 *  |  |  |  Number of diagrams:
7901                NDIAGR = 1
7902             END IF
7903 *  |  |  |
7904 *  |  |  +-------------------------------------------------------------*
7905 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7906             IQFSC1 = 3
7907             IQFSC2 = 0
7908             IQBSC1 = 1 + KHELP
7909             IQBSC2 = 2
7910 *  |  |
7911 *  |  +----------------------------------------------------------------*
7912 *  |  |  K0's: (actually only K0bar)
7913          ELSE
7914             KHELP  = KTARG / 8
7915 *  |  |  +-------------------------------------------------------------*
7916 *  |  |  |  Proton target: (K0bar p)in supposed to be given by
7917 *  |  |  |                 (K- p)in - Sig_diagr
7918             IF ( KHELP .EQ. 0 ) THEN
7919                SHNCIN = SKMPIN - SIGDIA
7920 *  |  |  |  Number of diagrams:
7921                NDIAGR = 1
7922 *  |  |  |
7923 *  |  |  +-------------------------------------------------------------*
7924 *  |  |  |  Neutron target: (K0bar n)in supposed to be given by
7925 *  |  |  |                 (K- n)in + Sig_diagr
7926 *  |  |  |              besides isospin consideration it is supposed
7927 *  |  |  |              that (K- n)el is almost equal to (K- p)el
7928 *  |  |  |              (reasonable above 5 GeV/c)
7929             ELSE
7930                ACOF = SGTCOE (1,10)
7931                BCOF = SGTCOE (2,10)
7932                ENNE = SGTCOE (3,10)
7933                CCOF = SGTCOE (4,10)
7934                DCOF = SGTCOE (5,10)
7935 *  |  |  |  Compute the total cross section:
7936                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7937      &                + DCOF * ALGPLA
7938 *  |  |  |  Compute the elastic cross section:
7939                SHNCEL = SKMPEL
7940 *  |  |  |  Compute the inelastic cross section:
7941                SHNCIN = SHNCTT - SHNCEL + SIGDIA
7942 *  |  |  |  Number of diagrams:
7943                NDIAGR = 2
7944             END IF
7945 *  |  |  |
7946 *  |  |  +-------------------------------------------------------------*
7947 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7948             IQFSC1 = 3
7949             IQFSC2 = 0
7950             IQBSC1 = 1
7951             IQBSC2 = 1 + KHELP
7952          END IF
7953 *  |  |
7954 *  |  +----------------------------------------------------------------*
7955 *  |                                                   end Kaon's
7956 *  +-------------------------------------------------------------------*
7957 *  |  Antinucleons:
7958       ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
7959 *  |  For momenta between 3 and 5 GeV/c the use of tabulated data
7960 *  |  should be implemented!
7961          ACOF = SGTCOE (1,15)
7962          BCOF = SGTCOE (2,15)
7963          ENNE = SGTCOE (3,15)
7964          CCOF = SGTCOE (4,15)
7965          DCOF = SGTCOE (5,15)
7966 *  |  Compute the pbar p total cross section:
7967          SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7968      &          + DCOF * ALGPLA
7969          IF ( PLA .LT. FIVFIV ) THEN
7970             JREAC = 26
7971          ELSE
7972             JREAC = 25
7973          END IF
7974          ACOF = SGTCOE (1,JREAC)
7975          BCOF = SGTCOE (2,JREAC)
7976          ENNE = SGTCOE (3,JREAC)
7977          CCOF = SGTCOE (4,JREAC)
7978          DCOF = SGTCOE (5,JREAC)
7979 *  |  Compute the pbar p elastic cross section:
7980          SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7981      &          + DCOF * ALGPLA
7982 *  |  Compute the pbar p inelastic cross section:
7983          SAPPIN = SAPPTT - SAPPEL
7984          ACOF = SGTCOE (1,12)
7985          BCOF = SGTCOE (2,12)
7986          ENNE = SGTCOE (3,12)
7987          CCOF = SGTCOE (4,12)
7988          DCOF = SGTCOE (5,12)
7989 *  |  Compute the p p total cross section:
7990          SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7991      &          + DCOF * ALGPLA
7992          ACOF = SGTCOE (1,23)
7993          BCOF = SGTCOE (2,23)
7994          ENNE = SGTCOE (3,23)
7995          CCOF = SGTCOE (4,23)
7996          DCOF = SGTCOE (5,23)
7997 *  |  Compute the p p elastic cross section:
7998          SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7999      &          + DCOF * ALGPLA
8000 *  |  Compute the K- p inelastic cross section:
8001          SPPINE = SPPTOT - SPPELA
8002          SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
8003          KHELP  = KTARG / 8
8004 *  |  +----------------------------------------------------------------*
8005 *  |  |  Pbar:
8006          IF ( ICHRGE (IP) .NE. 0 ) THEN
8007             NDIAGR = 5 - KHELP
8008 *  |  |  +-------------------------------------------------------------*
8009 *  |  |  |  Proton target:
8010             IF ( KHELP .EQ. 0 ) THEN
8011 *  |  |  |  Number of diagrams:
8012                SHNCIN = SAPPIN
8013                PUUBAR = 0.8D+00
8014 *  |  |  |
8015 *  |  |  +-------------------------------------------------------------*
8016 *  |  |  |  Neutron target: it is supposed that (ap n)el is almost equal
8017 *  |  |  |                  to (ap p)el (reasonable above 5 GeV/c)
8018             ELSE
8019                ACOF = SGTCOE (1,16)
8020                BCOF = SGTCOE (2,16)
8021                ENNE = SGTCOE (3,16)
8022                CCOF = SGTCOE (4,16)
8023                DCOF = SGTCOE (5,16)
8024 *  |  |  |  Compute the total cross section:
8025                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8026      &                + DCOF * ALGPLA
8027 *  |  |  |  Compute the elastic cross section:
8028                SHNCEL = SAPPEL
8029 *  |  |  |  Compute the inelastic cross section:
8030                SHNCIN = SHNCTT - SHNCEL
8031                PUUBAR = HLFHLF
8032             END IF
8033 *  |  |  |
8034 *  |  |  +-------------------------------------------------------------*
8035 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8036 *  |  |  there are different possibilities, make a random choiche:
8037             IQFSC1 = -1
8038             RNCHEN = DT_RNDM(PUUBAR)
8039             IF ( RNCHEN .LT. PUUBAR ) THEN
8040                IQFSC2 = -2
8041             ELSE
8042                IQFSC2 = -1
8043             END IF
8044             IQBSC1 = -IQFSC1 + KHELP
8045             IQBSC2 = -IQFSC2
8046 *  |  |
8047 *  |  +----------------------------------------------------------------*
8048 *  |  |  nbar:
8049          ELSE
8050             NDIAGR = 4 + KHELP
8051 *  |  |  +-------------------------------------------------------------*
8052 *  |  |  |  Proton target: (nbar p)in supposed to be given by
8053 *  |  |  |                 (pbar p)in - Sig_diagr
8054             IF ( KHELP .EQ. 0 ) THEN
8055                SHNCIN = SAPPIN - SIGDIA
8056                PDDBAR = HLFHLF
8057 *  |  |  |
8058 *  |  |  +-------------------------------------------------------------*
8059 *  |  |  |  Neutron target: (nbar n)el is supposed to be equal to
8060 *  |  |  |                  (pbar p)el (reasonable above 5 GeV/c)
8061             ELSE
8062 *  |  |  |  Compute the total cross section:
8063                SHNCTT = SAPPTT
8064 *  |  |  |  Compute the elastic cross section:
8065                SHNCEL = SAPPEL
8066 *  |  |  |  Compute the inelastic cross section:
8067                SHNCIN = SHNCTT - SHNCEL
8068                PDDBAR = 0.8D+00
8069             END IF
8070 *  |  |  |
8071 *  |  |  +-------------------------------------------------------------*
8072 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8073 *  |  |  there are different possibilities, make a random choiche:
8074             IQFSC1 = -2
8075             RNCHEN = DT_RNDM(RNCHEN)
8076             IF ( RNCHEN .LT. PDDBAR ) THEN
8077                IQFSC2 = -1
8078             ELSE
8079                IQFSC2 = -2
8080             END IF
8081             IQBSC1 = -IQFSC1 + KHELP - 1
8082             IQBSC2 = -IQFSC2
8083          END IF
8084 *  |  |
8085 *  |  +----------------------------------------------------------------*
8086 *  |
8087 *  +-------------------------------------------------------------------*
8088 *  |  Others: not yet implemented
8089       ELSE
8090          SIGDIA = ZERZER
8091          SHNCIN = ONEONE
8092          NDIAGR = 0
8093          DT_PHNSCH = ZERZER
8094          RETURN
8095       END IF
8096 *  |                                                   end others
8097 *  +-------------------------------------------------------------------*
8098       DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8099       IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8100      &       + IQECHR (IQBSC2)
8101       IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8102      &       + IQBCHR (IQBSC2)
8103       IQECHC = IQECHC / 3
8104       IQBCHC = IQBCHC / 3
8105       IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8106      &       + IQSCHR (IQBSC2)
8107       IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8108      &       + IQSCHR (MQUARK(3,IP))
8109 *  +-------------------------------------------------------------------*
8110 *  |  Consistency check:
8111       IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8112          WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8113      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8114          WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8115      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8116          DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8117          DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8118       END IF
8119 *  |
8120 *  +-------------------------------------------------------------------*
8121 *  +-------------------------------------------------------------------*
8122 *  |  Consistency check:
8123       IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8124      &     .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8125          WRITE (LUNOUT,*)
8126      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8127      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8128          WRITE (LUNERR,*)
8129      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8130      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8131       END IF
8132 *  |
8133 *  +-------------------------------------------------------------------*
8134 *  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8135       IF ( UMORAT .GT. ONEPLS )
8136      &   DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8137      &                                 - ONEONE ) * UMORAT + ONEONE )
8138       RETURN
8139 *
8140       ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8141       DT_SCHQUA = ONEONE
8142       JQFSC1 = IQFSC1
8143       JQFSC2 = IQFSC2
8144       JQBSC1 = IQBSC1
8145       JQBSC2 = IQBSC2
8146 *=== End of function Phnsch ===========================================*
8147       RETURN
8148       END
8149 *
8150 *===respt==============================================================*
8151 *
8152 CDECK  ID>, DT_RESPT
8153       SUBROUTINE DT_RESPT
8154
8155 ************************************************************************
8156 * Check DTEVT1 for two-resonance systems and sample intrinsic p_t.     *
8157 * This version dated 18.01.95 is written by S. Roesler                 *
8158 ************************************************************************
8159
8160       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8161       SAVE
8162
8163       PARAMETER ( LINP = 5 ,
8164      &            LOUT = 6 ,
8165      &            LDAT = 9 )
8166
8167       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8168
8169 * event history
8170
8171       PARAMETER (NMXHKK=200000)
8172
8173       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8174      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8175      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8176 * extended event history
8177       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8178      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8179      &                IHIST(2,NMXHKK)
8180
8181 * get index of first chain
8182       DO 1 I=NPOINT(3),NHKK
8183          IF (IDHKK(I).EQ.88888) THEN
8184             NC = I
8185             GOTO 2
8186          ENDIF
8187     1 CONTINUE
8188
8189     2 CONTINUE
8190       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8191 C        WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8192 * skip VV-,SS- systems
8193          IF ((IDCH(NC  ).NE.1).AND.(IDCH(NC  ).NE.8).AND.
8194      &       (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8195 * check if both "chains" are resonances
8196             IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8197                CALL DT_SAPTRE(NC,NC+3)
8198             ENDIF
8199          ENDIF
8200       ELSE
8201          GOTO 3
8202       ENDIF
8203       NC = NC+6
8204       GOTO 2
8205
8206     3 CONTINUE
8207
8208       RETURN
8209       END
8210 *
8211 *===evtres=============================================================*
8212 *
8213 CDECK  ID>, DT_EVTRES
8214       SUBROUTINE DT_EVTRES(IREJ)
8215
8216 ************************************************************************
8217 * This version dated 14.12.94 is written by S. Roesler                 *
8218 ************************************************************************
8219
8220       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8221       SAVE
8222
8223       PARAMETER ( LINP = 5 ,
8224      &            LOUT = 6 ,
8225      &            LDAT = 9 )
8226
8227       PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8228
8229 * event history
8230
8231       PARAMETER (NMXHKK=200000)
8232
8233       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8234      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8235      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8236 * extended event history
8237       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8238      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8239      &                IHIST(2,NMXHKK)
8240 * flags for input different options
8241       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8242       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8243      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8244 * particle properties (BAMJET index convention)
8245       CHARACTER*8  ANAME
8246       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8247      &                IICH(210),IIBAR(210),K1(210),K2(210)
8248
8249       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8250
8251       IREJ = 0
8252
8253       DO 1 I=NPOINT(3),NHKK
8254          IF (ABS(IDRES(I)).GE.100) THEN
8255             AMMX = 0.0D0
8256             DO 2 J=NPOINT(3),NHKK
8257                IF (IDHKK(J).EQ.88888) THEN
8258                   IF (PHKK(5,J).GT.AMMX) THEN
8259                      AMMX = PHKK(5,J)
8260                      IMMX = J
8261                   ENDIF
8262                ENDIF
8263     2       CONTINUE
8264             IF (IDRES(IMMX).NE.0) THEN
8265                IF (IOULEV(3).GT.0) THEN
8266                   WRITE(LOUT,'(1X,A)')
8267      &               'EVTRES: no chain for correc. found'
8268 C                 GOTO 6
8269                   GOTO 9999
8270                ELSE
8271                   GOTO 9999
8272                ENDIF
8273             ENDIF
8274             IMO11  = JMOHKK(1,I)
8275             IMO12  = JMOHKK(2,I)
8276             IF (PHKK(3,IMO11).LT.0.0D0) THEN
8277                IMO11 = JMOHKK(2,I)
8278                IMO12 = JMOHKK(1,I)
8279             ENDIF
8280             IMO21  = JMOHKK(1,IMMX)
8281             IMO22  = JMOHKK(2,IMMX)
8282             IF (PHKK(3,IMO21).LT.0.0D0) THEN
8283                IMO21 = JMOHKK(2,IMMX)
8284                IMO22 = JMOHKK(1,IMMX)
8285             ENDIF
8286             AMCH1  = PHKK(5,I)
8287             AMCH1N = AAM(IDXRES(I))
8288
8289             IFPR1 = IDHKK(IMO11)
8290             IFPR2 = IDHKK(IMO21)
8291             IFTA1 = IDHKK(IMO12)
8292             IFTA2 = IDHKK(IMO22)
8293             DO 4 J=1,4
8294                PP1(J) = PHKK(J,IMO11)
8295                PP2(J) = PHKK(J,IMO21)
8296                PT1(J) = PHKK(J,IMO12)
8297                PT2(J) = PHKK(J,IMO22)
8298     4       CONTINUE
8299 * store initial configuration for energy-momentum cons. check
8300             IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8301 * correct kinematics of second chain
8302             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8303      &                  AMCH1,AMCH1N,AMCH2,IREJ1)
8304             IF (IREJ1.NE.0) GOTO 9999
8305 * check now this chain for resonance mass
8306             IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8307             IFP(2) = 0
8308             IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8309             IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8310             IFT(2) = 0
8311             IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8312             IDCH2 = 2
8313             IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8314             IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8315             CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8316      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
8317             IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8318                IF (IOULEV(1).GT.0)
8319      &            WRITE(LOUT,*) ' correction for resonance not poss.'
8320 **sr test
8321 C              GOTO 1
8322 C              GOTO 9999
8323 **
8324             ENDIF
8325 * store final configuration for energy-momentum cons. check
8326             IF (LEMCCK) THEN
8327                CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8328                CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8329                IF (IREJ1.NE.0) GOTO 9999
8330             ENDIF
8331             DO 5 J=1,4
8332                PHKK(J,IMO11) = PP1(J)
8333                PHKK(J,IMO21) = PP2(J)
8334                PHKK(J,IMO12) = PT1(J)
8335                PHKK(J,IMO22) = PT2(J)
8336     5       CONTINUE
8337 * correct entries of chains
8338             DO 3 K=1,4
8339                PHKK(K,I)    = PHKK(K,IMO11)+PHKK(K,IMO12)
8340                PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8341     3       CONTINUE
8342             AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8343             AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8344      &            PHKK(3,IMMX)**2
8345 * ?? the following should now be obsolete
8346 **sr test
8347 C           IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8348             IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8349 **
8350                WRITE(LOUT,'(1X,A,4G10.3)')
8351      &          'EVTRES: inonsistent mass-corr.',AM1,AM2
8352 C              GOTO 9999
8353                GOTO 1
8354             ENDIF
8355             PHKK(5,I)    = SQRT(AM1)
8356             PHKK(5,IMMX) = SQRT(AM2)
8357             IDRES(I)     = IDRES(I)/100
8358             IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8359      &          (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8360                WRITE(LOUT,'(1X,A,4G10.3)')
8361      &          'EVTRES: inconsistent chain-masses',
8362      &          PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8363                GOTO 9999
8364             ENDIF
8365          ENDIF
8366     1 CONTINUE
8367     6 CONTINUE
8368       RETURN
8369
8370  9999 CONTINUE
8371       IREJ = 1
8372       RETURN
8373       END
8374 *
8375 *===getspt=============================================================*
8376 *
8377 CDECK  ID>, DT_GETSPT
8378       SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8379      &                  PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8380      &                  AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8381
8382 ************************************************************************
8383 * This version dated 12.12.94 is written by S. Roesler                 *
8384 ************************************************************************
8385
8386       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8387       SAVE
8388
8389       PARAMETER ( LINP = 5 ,
8390      &            LOUT = 6 ,
8391      &            LDAT = 9 )
8392
8393       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8394
8395 * various options for treatment of partons (DTUNUC 1.x)
8396 * (chain recombination, Cronin,..)
8397       LOGICAL LCO2CR,LINTPT
8398       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8399      &                LCO2CR,LINTPT
8400 * flags for input different options
8401       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8402       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8403      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8404 * flags for diffractive interactions (DTUNUC 1.x)
8405       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8406
8407       DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8408      &          PT2(4),PT2I(4),P1(4),P2(4),
8409      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8410      &          PTOTI(4),PTOTF(4),DIFF(4)
8411
8412       IC   = 0
8413       IREJ = 0
8414 C     B33P = 4.0D0
8415 C     B33T = 4.0D0
8416 C     IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8417 C     IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8418       REDU = 1.0D0
8419 C     B33P = 3.5D0
8420 C     B33T = 3.5D0
8421       B33P = 4.0D0
8422       B33T = 4.0D0
8423       IF (IDIFF.NE.0) THEN
8424          B33P = 16.0D0
8425          B33T = 16.0D0
8426       ENDIF
8427
8428       DO 1 I=1,4
8429          PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8430          PP1(I)   = PP1I(I)
8431          PP2(I)   = PP2I(I)
8432          PT1(I)   = PT1I(I)
8433          PT2(I)   = PT2I(I)
8434     1 CONTINUE
8435 * get initial chain masses
8436       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8437      &                               +(PP1(3)+PT1(3))**2)
8438       ECH   = PP1(4)+PT1(4)
8439       AM1   = (ECH+PTOCH)*(ECH-PTOCH)
8440       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8441      &                               +(PP2(3)+PT2(3))**2)
8442       ECH   = PP2(4)+PT2(4)
8443       AM2   = (ECH+PTOCH)*(ECH-PTOCH)
8444       IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8445          IF (IOULEV(1).GT.0)
8446      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8447      &                              AM1,AM2
8448          GOTO 9999
8449       ENDIF
8450       AM1  = SQRT(AM1)
8451       AM2  = SQRT(AM2)
8452       AM1N = ZERO
8453       AM2N = ZERO
8454
8455       MODE = 0
8456 C      IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8457 C        MODE = 0
8458 C      ELSE
8459 C         MODE = 1
8460 C         IF (AM1.LT.0.6) THEN
8461 C            B33P = 10.0D0
8462 C         ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8463 CC           B33P = 4.0D0
8464 C         ENDIF
8465 C         IF (AM2.LT.0.6) THEN
8466 C            B33T = 10.0D0
8467 C         ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8468 CC           B33T = 4.0D0
8469 C         ENDIF
8470 C      ENDIF
8471
8472 * check chain masses for very low mass chains
8473 C     CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8474 C    &            AM1,DUM,-IDCH1,IREJ1)
8475 C     CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8476 C    &            AM2,DUM,-IDCH2,IREJ2)
8477 C     IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8478 C        B33P = 20.0D0
8479 C        B33T = 20.0D0
8480 C     ENDIF
8481
8482       JMSHL = IMSHL
8483
8484     2 CONTINUE
8485       IC = IC+1
8486       IF (MOD(IC,15).EQ.0) B33P  = 2.0D0*B33P
8487       IF (MOD(IC,15).EQ.0) B33T  = 2.0D0*B33T
8488       IF (MOD(IC,18).EQ.0) REDU  = 0.0D0
8489 C     IF (MOD(IC,19).EQ.0) JMSHL = 0
8490       IF (MOD(IC,20).EQ.0) GOTO 7
8491 C        WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8492 C        RETURN
8493 C        GOTO 9999
8494 C     ENDIF
8495
8496 * get transverse momentum
8497       IF (LINTPT) THEN
8498          ES   = -2.0D0/(B33P**2)
8499      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8500          HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8501          HPSP = HPSP*REDU
8502          ES   = -2.0D0/(B33T**2)
8503      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8504          HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8505          HPST = HPST*REDU
8506       ELSE
8507          HPSP = ZERO
8508          HPST = ZERO
8509       ENDIF
8510       CALL DT_DSFECF(SFE1,CFE1)
8511       CALL DT_DSFECF(SFE2,CFE2)
8512       IF (MODE.EQ.0) THEN
8513          PP1(1) = PP1I(1)+HPSP*CFE1
8514          PP1(2) = PP1I(2)+HPSP*SFE1
8515          PP2(1) = PP2I(1)-HPSP*CFE1
8516          PP2(2) = PP2I(2)-HPSP*SFE1
8517          PT1(1) = PT1I(1)+HPST*CFE2
8518          PT1(2) = PT1I(2)+HPST*SFE2
8519          PT2(1) = PT2I(1)-HPST*CFE2
8520          PT2(2) = PT2I(2)-HPST*SFE2
8521       ELSE
8522          PP1(1) = PP1I(1)+HPSP*CFE1
8523          PP1(2) = PP1I(2)+HPSP*SFE1
8524          PT1(1) = PT1I(1)-HPSP*CFE1
8525          PT1(2) = PT1I(2)-HPSP*SFE1
8526          PP2(1) = PP2I(1)+HPST*CFE2
8527          PP2(2) = PP2I(2)+HPST*SFE2
8528          PT2(1) = PT2I(1)-HPST*CFE2
8529          PT2(2) = PT2I(2)-HPST*SFE2
8530       ENDIF
8531
8532 * put partons on mass shell
8533       XMP1 = 0.0D0
8534       XMT1 = 0.0D0
8535       IF (JMSHL.EQ.1) THEN
8536
8537          XMP1 = PYMASS(IFPR1)
8538          XMT1 = PYMASS(IFTA1)
8539
8540       ENDIF
8541       CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8542       IF (IREJ1.NE.0) GOTO 2
8543       DO 3 I=1,4
8544          PTOTF(I) = P1(I)+P2(I)
8545          PP1(I)   = P1(I)
8546          PT1(I)   = P2(I)
8547     3 CONTINUE
8548       XMP2 = 0.0D0
8549       XMT2 = 0.0D0
8550       IF (JMSHL.EQ.1) THEN
8551
8552          XMP2 = PYMASS(IFPR2)
8553          XMT2 = PYMASS(IFTA2)
8554
8555       ENDIF
8556       CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8557       IF (IREJ1.NE.0) GOTO 2
8558       DO 4 I=1,4
8559          PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8560          PP2(I)   = P1(I)
8561          PT2(I)   = P2(I)
8562     4 CONTINUE
8563
8564 * check consistency
8565       DO 5 I=1,4
8566          DIFF(I) = PTOTI(I)-PTOTF(I)
8567     5 CONTINUE
8568       IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8569      &    (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8570          WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8571          GOTO 9999
8572       ENDIF
8573       PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8574       AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8575       PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8576       AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8577       PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8578       AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8579       PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8580       AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8581       IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8582      &    (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8583      &                                                           THEN
8584          WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8585      &     'GETSPT: inconsistent masses',
8586      &     AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8587 * sr 22.11.00: commented. It should only have inconsistent masses for
8588 * ultrahigh energies due to rounding problems
8589 C        GOTO 9999
8590       ENDIF
8591
8592 * get chain masses
8593       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8594      &                               +(PP1(3)+PT1(3))**2)
8595       ECH   = PP1(4)+PT1(4)
8596       AM1N  = (ECH+PTOCH)*(ECH-PTOCH)
8597       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8598      &                               +(PP2(3)+PT2(3))**2)
8599       ECH   = PP2(4)+PT2(4)
8600       AM2N  = (ECH+PTOCH)*(ECH-PTOCH)
8601       IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
8602          IF (IOULEV(1).GT.0)
8603      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
8604      &                              AM1N,AM2N
8605          GOTO 2
8606       ENDIF
8607       AM1N = SQRT(AM1N)
8608       AM2N = SQRT(AM2N)
8609
8610 * check chain masses for very low mass chains
8611       CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8612      &            AM1N,DUM,-IDCH1,IREJ1)
8613       IF (IREJ1.NE.0) GOTO 2
8614       CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8615      &            AM2N,DUM,-IDCH2,IREJ2)
8616       IF (IREJ2.NE.0) GOTO 2
8617
8618     7 CONTINUE
8619       IF (AM1N.GT.ZERO) THEN
8620          AM1 = AM1N
8621          AM2 = AM2N
8622       ENDIF
8623       DO 6 I=1,4
8624          PP1I(I)   = PP1(I)
8625          PP2I(I)   = PP2(I)
8626          PT1I(I)   = PT1(I)
8627          PT2I(I)   = PT2(I)
8628     6 CONTINUE
8629
8630       RETURN
8631
8632  9999 CONTINUE
8633       IREJ = 1
8634       RETURN
8635       END
8636 *
8637 *===saptre=============================================================*
8638 *
8639 CDECK  ID>, DT_SAPTRE
8640       SUBROUTINE DT_SAPTRE(IDX1,IDX2)
8641
8642 ************************************************************************
8643 * p-t sampling for two-resonance systems. ("BAMJET-like" method)       *
8644 *        IDX1,IDX2       indices of resonances ("chains") in DTEVT1    *
8645 * Adopted from the original SAPTRE written by J. Ranft.                *
8646 * This version dated 18.01.95 is written by S. Roesler                 *
8647 ************************************************************************
8648
8649       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8650       SAVE
8651
8652       PARAMETER ( LINP = 5 ,
8653      &            LOUT = 6 ,
8654      &            LDAT = 9 )
8655
8656       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8657
8658 * event history
8659
8660       PARAMETER (NMXHKK=200000)
8661
8662       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8663      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8664      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8665 * extended event history
8666       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8667      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8668      &                IHIST(2,NMXHKK)
8669 * flags for input different options
8670       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8671       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8672      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8673
8674       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
8675
8676       DATA B3 /4.0D0/
8677
8678       ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
8679       ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
8680       ESMAX  = MIN(ESMAX1,ESMAX2)
8681       IF (ESMAX.LE.0.05D0) RETURN
8682
8683       HMA    = PHKK(5,IDX1)
8684       DO 1 K=1,4
8685          PA1(K) = PHKK(K,IDX1)
8686          PA2(K) = PHKK(K,IDX2)
8687     1 CONTINUE
8688
8689       IF (LEMCCK) THEN
8690          CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
8691          CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
8692       ENDIF
8693
8694       EXEB   = 0.0D0
8695       IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
8696       BEXP   = HMA*(1.0D0-EXEB)/B3
8697       AXEXP  = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
8698       WA     = AXEXP/(BEXP+AXEXP)
8699       XAB    = DT_RNDM(WA)
8700    10 CONTINUE
8701 * ES is the transverse kinetic energy
8702       IF (XAB.LT.WA)THEN
8703         X  = DT_RNDM(WA)
8704         Y  = DT_RNDM(WA)
8705         ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
8706       ELSE
8707         X  = DT_RNDM(Y)
8708         ES = ABS(-LOG(X+TINY7)/B3)
8709       ENDIF
8710       IF (ES.GT.ESMAX) GOTO 10
8711       ES  = ES+HMA
8712 * transverse momentum
8713       HPS = SQRT((ES-HMA)*(ES+HMA))
8714
8715       CALL DT_DSFECF(SFE,CFE)
8716       HPX = HPS*CFE
8717       HPY = HPS*SFE
8718       PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
8719       PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
8720       IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
8721
8722 C     PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
8723 C     PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
8724       PA1(1) = PA1(1)+HPX
8725       PA1(2) = PA1(2)+HPY
8726       PA2(1) = PA2(1)-HPX
8727       PA2(2) = PA2(2)-HPY
8728
8729 * put resonances on mass-shell again
8730       XM1 = PHKK(5,IDX1)
8731       XM2 = PHKK(5,IDX2)
8732       CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
8733       IF (IREJ1.NE.0) RETURN
8734
8735       IF (LEMCCK) THEN
8736          CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
8737          CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
8738          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
8739          IF (IREJ1.NE.0) RETURN
8740       ENDIF
8741
8742       DO 2 K=1,4
8743          PHKK(K,IDX1) = P1(K)
8744          PHKK(K,IDX2) = P2(K)
8745     2 CONTINUE
8746
8747       RETURN
8748       END
8749 *
8750 *===cronin=============================================================*
8751 *
8752 CDECK  ID>, DT_CRONIN
8753       SUBROUTINE DT_CRONIN(INCL)
8754
8755 ************************************************************************
8756 * Cronin-Effect. Multiple scattering of partons at chain ends.         *
8757 *             INCL = 1     multiple sc. in projectile                  *
8758 *                  = 2     multiple sc. in target                      *
8759 * This version dated 05.01.96 is written by S. Roesler.                *
8760 ************************************************************************
8761
8762       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8763       SAVE
8764
8765       PARAMETER ( LINP = 5 ,
8766      &            LOUT = 6 ,
8767      &            LDAT = 9 )
8768
8769       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8770
8771 * event history
8772
8773       PARAMETER (NMXHKK=200000)
8774
8775       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8776      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8777      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8778 * extended event history
8779       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8780      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8781      &                IHIST(2,NMXHKK)
8782 * rejection counter
8783       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8784      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8785      &                IREXCI(3),IRDIFF(2),IRINC
8786 * Glauber formalism: collision properties
8787       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8788      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8789
8790       DIMENSION R(3),PIN(4),POUT(4),DEV(4)
8791
8792       DO 1 K=1,4
8793          DEV(K) = ZERO
8794     1 CONTINUE
8795
8796       DO 2 I=NPOINT(2),NHKK
8797          IF (ISTHKK(I).LT.0) THEN
8798 * get z-position of the chain
8799             R(1) = VHKK(1,I)*1.0D12
8800             IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
8801             R(2) = VHKK(2,I)*1.0D12
8802             IDXNU = JMOHKK(1,I)
8803             IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
8804      &                             IDXNU = JMOHKK(1,I-1)
8805             IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
8806      &                             IDXNU = JMOHKK(1,I+1)
8807             R(3) = VHKK(3,IDXNU)*1.0D12
8808 * position of target parton the chain is connected to
8809             DO 3 K=1,4
8810                PIN(K) = PHKK(K,I)
8811     3       CONTINUE
8812 * multiple scattering of parton with DTEVT1-index I
8813             CALL DT_CROMSC(PIN,R,POUT,INCL)
8814 **testprint
8815 C           IF (NEVHKK.EQ.5) THEN
8816 C              AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
8817 C              AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
8818 C              AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
8819 C              AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
8820 C              WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
8821 C              WRITE(6,'(A,4E15.5)')'PIN:       ',PIN
8822 C              WRITE(6,'(A,4E15.5)')'POUT:      ',POUT
8823 C           ENDIF
8824 **
8825 * increase accumulator by energy-momentum difference
8826             DO 4 K=1,4
8827                DEV(K)    = DEV(K)+POUT(K)-PIN(K)
8828                PHKK(K,I) = POUT(K)
8829     4       CONTINUE
8830             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8831      &                           PHKK(2,I)**2-PHKK(3,I)**2))
8832          ENDIF
8833     2 CONTINUE
8834
8835 * dump accumulator to momenta of valence partons
8836       NVAL = 0
8837       ETOT = 0.0D0
8838       DO 5 I=NPOINT(2),NHKK
8839          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8840             NVAL = NVAL+1
8841             ETOT = ETOT+PHKK(4,I)
8842          ENDIF
8843     5 CONTINUE
8844 C     WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
8845  1000 FORMAT(1X,'CRONIN :  number of val. partons ',I4,/,
8846      &       9X,4E12.4)
8847       DO 6 I=NPOINT(2),NHKK
8848          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8849             E = PHKK(4,I)
8850             DO 7 K=1,4
8851 C              PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
8852                PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
8853     7       CONTINUE
8854             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8855      &                           PHKK(2,I)**2-PHKK(3,I)**2))
8856          ENDIF
8857     6 CONTINUE
8858
8859       RETURN
8860       END
8861 *
8862 *===cromsc=============================================================*
8863 *
8864 CDECK  ID>, DT_CROMSC
8865       SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
8866
8867 ************************************************************************
8868 * Cronin-Effect. Multiple scattering of one parton passing through     *
8869 * nuclear matter.                                                      *
8870 *            PIN(4)       input 4-momentum of parton                   *
8871 *            POUT(4)      4-momentum of parton after mult. scatt.      *
8872 *            R(3)         spatial position of parton in target nucleus *
8873 *            INCL = 1     multiple sc. in projectile                   *
8874 *                 = 2     multiple sc. in target                       *
8875 * This is a revised version of the original version written by J. Ranft*
8876 * This version dated 17.01.95 is written by S. Roesler.                *
8877 ************************************************************************
8878
8879       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8880       SAVE
8881
8882       PARAMETER ( LINP = 5 ,
8883      &            LOUT = 6 ,
8884      &            LDAT = 9 )
8885
8886       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8887
8888       LOGICAL LSTART
8889
8890 * rejection counter
8891       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8892      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8893      &                IREXCI(3),IRDIFF(2),IRINC
8894 * Glauber formalism: collision properties
8895       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8896      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8897 * various options for treatment of partons (DTUNUC 1.x)
8898 * (chain recombination, Cronin,..)
8899       LOGICAL LCO2CR,LINTPT
8900       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8901      &                LCO2CR,LINTPT
8902
8903       DIMENSION PIN(4),POUT(4),R(3)
8904
8905       DATA LSTART /.TRUE./
8906
8907       IRCRON(1) = IRCRON(1)+1
8908
8909       IF (LSTART) THEN
8910          WRITE(LOUT,1000) CRONCO
8911  1000    FORMAT(/,1X,'CROMSC:  multiple scattering of chain ends',
8912      &          ' treated',/,10X,'with parameter CRONCO = ',F5.2)
8913          LSTART = .FALSE.
8914       ENDIF
8915
8916       NCBACK = 0
8917       RNCL   = RPROJ
8918       IF (INCL.EQ.2) RNCL = RTARG
8919
8920 * Lorentz-transformation into Lab.
8921       MODE = -(INCL+1)
8922       CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
8923
8924       PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
8925       IF (PTOT.LE.8.0D0) GOTO 9997
8926
8927 * direction cosines of parton before mult. scattering
8928       COSX = PIN(1)/PTOT
8929       COSY = PIN(2)/PTOT
8930       COSZ = PZ/PTOT
8931
8932       RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
8933       IF (RTESQ.GE.-TINY3) GOTO 9999
8934
8935 * calculate distance (DIST) from R to surface of nucleus (radius RNCL)
8936 * in the direction of particle motion
8937
8938       A    = COSX*R(1)+COSY*R(2)+COSZ*R(3)
8939       TMP  = A**2-RTESQ
8940       IF (TMP.LT.ZERO) GOTO 9998
8941       DIST = -A+SQRT(TMP)
8942
8943 * multiple scattering angle
8944       THETO = CRONCO*SQRT(DIST)/PTOT
8945       IF (THETO.GT.0.1D0) THETO=0.1D0
8946
8947     1 CONTINUE
8948 * Gaussian sampling of spatial angle
8949       CALL DT_RANNOR(R1,R2)
8950       THETA = ABS(R1*THETO)
8951       IF (THETA.GT.0.3D0) GOTO 9997
8952       CALL DT_DSFECF(SFE,CFE)
8953       COSTH = COS(THETA)
8954       SINTH = SIN(THETA)
8955
8956 * new direction cosines
8957       CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
8958      &                               COSXN,COSYN,COSZN)
8959
8960       POUT(1) = COSXN*PTOT
8961       POUT(2) = COSYN*PTOT
8962       PZ      = COSZN*PTOT
8963 * Lorentz-transformation into nucl.-nucl. cms
8964       MODE = INCL+1
8965       CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
8966
8967 C     IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
8968 C     IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
8969       IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
8970          THETO = THETO/2.0D0
8971          NCBACK = NCBACK+1
8972          IF (MOD(NCBACK,200).EQ.0) THEN
8973             WRITE(LOUT,1001) THETO,PIN,POUT
8974  1001       FORMAT(1X,'CROMSC: inconsistent scattering angle ',
8975      &             E12.4,/,1X,'        PIN :',4E12.4,/,
8976      &             1X,'       POUT:',4E12.4)
8977             GOTO 9997
8978          ENDIF
8979          GOTO 1
8980       ENDIF
8981
8982       RETURN
8983
8984  9997 IRCRON(2) = IRCRON(2)+1
8985       GOTO 9999
8986  9998 IRCRON(3) = IRCRON(3)+1
8987
8988  9999 CONTINUE
8989       DO 100 K=1,4
8990          POUT(K) = PIN(K)
8991   100 CONTINUE
8992       RETURN
8993       END
8994 *
8995 *===com2sr=============================================================*
8996 *
8997 CDECK  ID>, DT_COM2CR
8998       SUBROUTINE DT_COM2CR
8999
9000 ************************************************************************
9001 * COMbine q-aq chains to Color Ropes (qq-aqaq).                        *
9002 *        CUTOF      parameter determining minimum number of not        *
9003 *                   combined q-aq chains                               *
9004 * This subroutine replaces KKEVCC etc.                                 *
9005 * This version dated 11.01.95 is written by S. Roesler.                *
9006 ************************************************************************
9007
9008       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9009       SAVE
9010
9011       PARAMETER ( LINP = 5 ,
9012      &            LOUT = 6 ,
9013      &            LDAT = 9 )
9014
9015 * event history
9016
9017       PARAMETER (NMXHKK=200000)
9018
9019       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9020      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9021      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9022 * extended event history
9023       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9024      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9025      &                IHIST(2,NMXHKK)
9026 * statistics
9027       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9028      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9029      &                ICEVTG(8,0:30)
9030 * various options for treatment of partons (DTUNUC 1.x)
9031 * (chain recombination, Cronin,..)
9032       LOGICAL LCO2CR,LINTPT
9033       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9034      &                LCO2CR,LINTPT
9035
9036       DIMENSION IDXQA(248),IDXAQ(248)
9037
9038       ICCHAI(1,9) = ICCHAI(1,9)+1
9039       NQA = 0
9040       NAQ = 0
9041 * scan DTEVT1 for q-aq, aq-q chains
9042       DO 10 I=NPOINT(3),NHKK
9043 * skip "chains" which are resonances
9044          IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
9045             MO1 = JMOHKK(1,I)
9046             MO2 = JMOHKK(2,I)
9047             IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
9048 * q-aq, aq-q chain found, keep index
9049                IF (IDHKK(MO1).GT.0) THEN
9050                   NQA = NQA+1
9051                   IDXQA(NQA) = I
9052                ELSE
9053                   NAQ = NAQ+1
9054                   IDXAQ(NAQ) = I
9055                ENDIF
9056             ENDIF
9057          ENDIF
9058    10 CONTINUE
9059
9060 * minimum number of q-aq chains requested for the same projectile/
9061 * target
9062       NCHMIN = IDT_NPOISS(CUTOF)
9063
9064 * combine q-aq chains of the same projectile
9065       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
9066 * combine q-aq chains of the same target
9067       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
9068 * combine aq-q chains of the same projectile
9069       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
9070 * combine aq-q chains of the same target
9071       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
9072
9073       RETURN
9074       END
9075 *
9076 *===scn4cr=============================================================*
9077 *
9078 CDECK  ID>, DT_SCN4CR
9079       SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9080
9081 ************************************************************************
9082 * SCan q-aq chains for Color Ropes.                                    *
9083 * This version dated 11.01.95 is written by S. Roesler.                *
9084 ************************************************************************
9085
9086       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9087       SAVE
9088
9089       PARAMETER ( LINP = 5 ,
9090      &            LOUT = 6 ,
9091      &            LDAT = 9 )
9092
9093 * event history
9094
9095       PARAMETER (NMXHKK=200000)
9096
9097       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9098      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9099      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9100 * extended event history
9101       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9102      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9103      &                IHIST(2,NMXHKK)
9104
9105       DIMENSION IDXCH(248),IDXJN(248)
9106
9107       DO 1 I=1,NCH
9108          IF (IDXCH(I).GT.0) THEN
9109             NJOIN = 1
9110             IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9111             IDXJN(NJOIN) = I
9112             IF (I.LT.NCH) THEN
9113                DO 2 J=I+1,NCH
9114                   IF (IDXCH(J).GT.0) THEN
9115                      IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9116                      IF (IDXMO.EQ.IDXMO1) THEN
9117                         NJOIN = NJOIN+1
9118                         IDXJN(NJOIN) = J
9119                      ENDIF
9120                   ENDIF
9121     2          CONTINUE
9122             ENDIF
9123             IF (NJOIN.GE.NCHMIN+2) THEN
9124                NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9125                DO 3 J=1,2*NJ,2
9126                   CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9127                   IF (IREJ1.NE.0) GOTO 3
9128                   IDXCH(IDXJN(J))   = 0
9129                   IDXCH(IDXJN(J+1)) = 0
9130     3          CONTINUE
9131             ENDIF
9132          ENDIF
9133     1 CONTINUE
9134
9135       RETURN
9136       END
9137 *
9138 *===join===============================================================*
9139 *
9140 CDECK  ID>, DT_JOIN
9141       SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9142
9143 ************************************************************************
9144 * This subroutine joins two q-aq chains to one qq-aqaq chain.          *
9145 *     IDX1, IDX2       DTEVT1 indices of chains to be joined           *
9146 * This version dated 11.01.95 is written by S. Roesler.                *
9147 ************************************************************************
9148
9149       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9150       SAVE
9151
9152       PARAMETER ( LINP = 5 ,
9153      &            LOUT = 6 ,
9154      &            LDAT = 9 )
9155
9156 * event history
9157
9158       PARAMETER (NMXHKK=200000)
9159
9160       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9161      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9162      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9163 * extended event history
9164       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9165      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9166      &                IHIST(2,NMXHKK)
9167 * flags for input different options
9168       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9169       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9170      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9171 * statistics
9172       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9173      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9174      &                ICEVTG(8,0:30)
9175
9176       DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9177
9178       IREJ   = 0
9179
9180       IDX(1) = IDX1
9181       IDX(2) = IDX2
9182       DO 1 I=1,2
9183          DO 2 J=1,2
9184             MO(I,J) = JMOHKK(J,IDX(I))
9185             ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9186     2    CONTINUE
9187     1 CONTINUE
9188
9189 * check consistency
9190       IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9191      &    (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9192      &    ((ID(1,1)*ID(2,1)).LT.0).OR.
9193      &    ((ID(1,2)*ID(2,2)).LT.0)) THEN
9194          WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9195      &                    MO(2,2)
9196  1000    FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9197      &             2I5,' chain ',I4,':',2I5)
9198       ENDIF
9199
9200 * join chains
9201       DO 3 K=1,4
9202          PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9203          PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9204     3 CONTINUE
9205       IF1  = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9206       IF2  = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9207       IST1 = ISTHKK(MO(1,1))
9208       IST2 = ISTHKK(MO(1,2))
9209
9210 * put partons again on mass shell
9211       XM1 = 0.0D0
9212       XM2 = 0.0D0
9213       IF (IMSHL.EQ.1) THEN
9214
9215          XM1 = PYMASS(IF1)
9216          XM2 = PYMASS(IF2)
9217
9218       ENDIF
9219       CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9220       IF (IREJ1.NE.0) GOTO 9999
9221       DO 4 I=1,4
9222          PP(I) = P1(I)
9223          PT(I) = P2(I)
9224     4 CONTINUE
9225
9226 * store new partons in DTEVT1
9227       CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9228      &                                                       0,0,0)
9229       CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9230      &                                                       0,0,0)
9231       DO 5 K=1,4
9232          PCH(K) = PP(K)+PT(K)
9233     5 CONTINUE
9234
9235 * check new chain for lower mass limit
9236       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9237          AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9238          CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9239      &               AMCH,AMCHN,3,IREJ1)
9240          IF (IREJ1.NE.0) THEN
9241             NHKK = NHKK-2
9242             GOTO 9999
9243          ENDIF
9244       ENDIF
9245
9246       ICCHAI(2,9) = ICCHAI(2,9)+1
9247 * store new chain in DTEVT1
9248       KCH = 191
9249       CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9250       IDHKK(IDX(1)) = 22222
9251       IDHKK(IDX(2)) = 22222
9252 * special treatment for space-time coordinates
9253       DO 6 K=1,4
9254          VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9255          WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9256     6 CONTINUE
9257       RETURN
9258
9259  9999 CONTINUE
9260       IREJ = 1
9261       RETURN
9262       END
9263 *
9264 *===xsglau=============================================================*
9265 *
9266 CDECK  ID>, DT_XSGLAU
9267       SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9268
9269 ************************************************************************
9270 * Total, elastic, quasi-elastic, inelastic cross sections according to *
9271 * Glauber's approach.                                                  *
9272 *  NA / NB     mass numbers of proj./target nuclei                     *
9273 *  JJPROJ      bamjet-index of projectile (=1 in case of proj.nucleus) *
9274 *  XI,Q2I,ECMI kinematical variables x, Q^2, E_cm                      *
9275 *  IE,IQ       indices of energy and virtuality (the latter for gamma  *
9276 *              projectiles only)                                       *
9277 *  NIDX        index of projectile/target nucleus                      *
9278 * This version dated 17.3.98  is written by S. Roesler                 *
9279 ************************************************************************
9280
9281       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9282       SAVE
9283
9284       PARAMETER ( LINP = 5 ,
9285      &            LOUT = 6 ,
9286      &            LDAT = 9 )
9287
9288       COMPLEX*16 CZERO,CONE,CTWO
9289       CHARACTER*12 CFILE
9290       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9291      &           ONETHI=ONE/THREE,TINY25=1.0D-25)
9292       PARAMETER (TWOPI  = 6.283185307179586454D+00,
9293      &           PI     = TWOPI/TWO,
9294      &           GEV2MB = 0.38938D0,
9295      &           GEV2FM = 0.1972D0,
9296      &           ALPHEM = ONE/137.0D0,
9297 * proton mass
9298      &           AMP    = 0.938D0,
9299      &           AMP2   = AMP**2,
9300 * approx. nucleon radius
9301      &           RNUCLE = 1.12D0)
9302
9303 * particle properties (BAMJET index convention)
9304       CHARACTER*8  ANAME
9305       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9306      &                IICH(210),IIBAR(210),K1(210),K2(210)
9307
9308       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9309
9310       PARAMETER ( MAXNCL = 260,
9311
9312      &            MAXVQU = MAXNCL,
9313      &            MAXSQU = 20*MAXVQU,
9314      &            MAXINT = MAXVQU+MAXSQU)
9315 * Glauber formalism: parameters
9316       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9317      &                BMAX(NCOMPX),BSTEP(NCOMPX),
9318      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9319      &                NSITEB,NSTATB
9320 * Glauber formalism: cross sections
9321       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9322      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9323      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9324      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9325      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9326      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9327      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9328      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9329      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9330      &                BSLOPE,NEBINI,NQBINI
9331 * Glauber formalism: flags and parameters for statistics
9332       LOGICAL LPROD
9333       CHARACTER*8 CGLB
9334       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9335 * nucleon-nucleon event-generator
9336       CHARACTER*8 CMODEL
9337       LOGICAL LPHOIN
9338       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9339 * VDM parameter for photon-nucleus interactions
9340       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9341 * parameters for hA-diffraction
9342       COMMON /DTDIHA/ DIBETA,DIALPH
9343
9344       COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9345      &           OMPP11,OMPP12,OMPP21,OMPP22,
9346      &           DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9347      &           PPTMP1,PPTMP2
9348       COMPLEX*16 C,CA,CI
9349       DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9350      &          COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9351      &          BPROD(KSITEB)
9352
9353       PARAMETER (NPOINT=16)
9354       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9355
9356       LOGICAL LFIRST,LOPEN
9357       DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9358
9359       NTARG = ABS(NIDX)
9360 * for quasi-elastic neutrino scattering set projectile to proton
9361 * it should not have an effect since the whole Glauber-formalism is
9362 * not needed for these interactions..
9363       IF (MCGENE.EQ.4) THEN
9364          IJPROJ = 1
9365       ELSE
9366          IJPROJ = JJPROJ
9367       ENDIF
9368
9369       IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9370          I = INDEX(CGLB,' ')
9371          IF (I.EQ.0) THEN
9372             CFILE = CGLB//'.glb'
9373             OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9374          ELSEIF (I.GT.1) THEN
9375             CFILE = CGLB(1:I-1)//'.glb'
9376             OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9377          ELSE
9378             STOP 'XSGLAU 1'
9379          ENDIF
9380          LOPEN = .TRUE.
9381       ENDIF
9382
9383       CZERO  = DCMPLX(ZERO,ZERO)
9384       CONE   = DCMPLX(ONE,ZERO)
9385       CTWO   = DCMPLX(TWO,ZERO)
9386       NEBINI = IE
9387       NQBINI = IQ
9388
9389 * re-define kinematics
9390       S  = ECMI**2
9391       Q2 = Q2I
9392       X  = XI
9393 *  g(Q2=0)-A, h-A, A-A scattering
9394       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9395          Q2 = 0.0001D0
9396          X  = Q2/(S+Q2-AMP2)
9397 *  g(Q2>0)-A scattering
9398       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9399          X  = Q2/(S+Q2-AMP2)
9400       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9401          Q2 = (S-AMP2)*X/(ONE-X)
9402       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9403          S  = Q2*(ONE-X)/X+AMP2
9404       ELSE
9405          WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9406          STOP
9407       ENDIF
9408       ECMNN(IE) = SQRT(S)
9409       Q2G(IQ)   = Q2
9410       XNU = (S+Q2-AMP2)/(TWO*AMP)
9411
9412 * parameters determining statistics in evaluating Glauber-xsection
9413       NSTATB = JSTATB
9414       NSITEB = JBINSB
9415       IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9416
9417 * set up interaction geometry (common /DTGLAM/)
9418 *  projectile/target radii
9419       RPRNCL = DT_RNCLUS(NA)
9420       RTANCL = DT_RNCLUS(NB)
9421       IF (IJPROJ.EQ.7) THEN
9422          RASH(1) = ZERO
9423          RBSH(NTARG) = RTANCL
9424          BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9425       ELSE
9426          IF (NIDX.LE.-1) THEN
9427             RASH(1)     = RPRNCL
9428             RBSH(NTARG) = RTANCL
9429             BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9430          ELSE
9431             RASH(NTARG) = RPRNCL
9432             RBSH(1)     = RTANCL
9433             BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9434          ENDIF
9435       ENDIF
9436 *  maximum impact-parameter
9437       BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9438
9439 * slope, rho ( Re(f(0))/Im(f(0)) )
9440       IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9441          IF (MCGENE.EQ.2) THEN
9442             ZERO1 = ZERO
9443             CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9444      &                                                   BSLOPE,0)
9445          ELSE
9446             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9447          ENDIF
9448          IF (ECMNN(IE).LE.3.0D0) THEN
9449             ROSH = -0.43D0
9450          ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9451             ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9452          ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9453             ROSH = 0.1D0
9454          ENDIF
9455       ELSEIF (IJPROJ.EQ.7) THEN
9456          ROSH = 0.1D0
9457       ELSE
9458          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9459          ROSH   = 0.01D0
9460       ENDIF
9461
9462 * projectile-nucleon xsection (in fm)
9463       IF (IJPROJ.EQ.7) THEN
9464          SIGSH = DT_SIGVP(X,Q2)/10.0D0
9465       ELSE
9466          ELAB  = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9467          PLAB  = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9468 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9469          DUMZER = ZERO
9470          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9471          SIGSH = SIGSH/10.0D0
9472       ENDIF
9473
9474 * parameters for projectile diffraction (hA scattering only)
9475       IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9476      &                               .AND.(DIBETA.GE.ZERO)) THEN
9477          ZERO1 = ZERO
9478          CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9479 C        DIBETA = SDIF1/STOT
9480          DIBETA = 0.2D0
9481          DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9482          IF (DIBETA.LE.ZERO) THEN
9483             ALPGAM = ONE
9484          ELSE
9485             ALPGAM = DIALPH/DIGAMM
9486          ENDIF
9487          FACDI1 = ONE-ALPGAM
9488          FACDI2 = ONE+ALPGAM
9489          FACDI  = SQRT(FACDI1*FACDI2)
9490          WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9491       ELSE
9492          DIBETA = -1.0D0
9493          DIALPH = ZERO
9494          DIGAMM = ZERO
9495          FACDI1 = ZERO
9496          FACDI2 = 2.0D0
9497          FACDI  = ZERO
9498       ENDIF
9499
9500 * initializations
9501       DO 10 I=1,NSITEB
9502          BSITE( 0,IQ,NTARG,I) = ZERO
9503          BSITE(IE,IQ,NTARG,I) = ZERO
9504          BPROD(I) = ZERO
9505    10 CONTINUE
9506       STOT  = ZERO
9507       STOT2 = ZERO
9508       SELA  = ZERO
9509       SELA2 = ZERO
9510       SQEP  = ZERO
9511       SQEP2 = ZERO
9512       SQET  = ZERO
9513       SQET2 = ZERO
9514       SQE2  = ZERO
9515       SQE22 = ZERO
9516       SPRO  = ZERO
9517       SPRO2 = ZERO
9518       SDEL  = ZERO
9519       SDEL2 = ZERO
9520       SDQE  = ZERO
9521       SDQE2 = ZERO
9522       FACN   = ONE/DBLE(NSTATB)
9523
9524       IPNT = 0
9525       RPNT = ZERO
9526
9527 *  initialize Gauss-integration for photon-proj.
9528       JPOINT = 1
9529       IF (IJPROJ.EQ.7) THEN
9530          IF (INTRGE(1).EQ.1) THEN
9531             AMLO2 = (3.0D0*AAM(13))**2
9532          ELSEIF (INTRGE(1).EQ.2) THEN
9533             AMLO2 = AAM(33)**2
9534          ELSE
9535             AMLO2 = AAM(96)**2
9536          ENDIF
9537          IF (INTRGE(2).EQ.1) THEN
9538             AMHI2 = S/TWO
9539          ELSEIF (INTRGE(2).EQ.2) THEN
9540             AMHI2 = S/4.0D0
9541          ELSE
9542             AMHI2 = S
9543          ENDIF
9544          AMHI20 = (ECMNN(IE)-AMP)**2
9545          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9546          XAMLO = LOG( AMLO2+Q2 )
9547          XAMHI = LOG( AMHI2+Q2 )
9548 **PHOJET105a
9549 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9550 **PHOJET112
9551
9552          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9553
9554 **
9555          JPOINT = NPOINT
9556 * ratio direct/total photon-nucleon xsection
9557          CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
9558       ENDIF
9559
9560 * read pre-initialized profile-function from file
9561       IF (IOGLB.EQ.1) THEN
9562          READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
9563          IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
9564             WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
9565      &                             NA,NB,NSTATB,NSITEB
9566  1000       FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
9567      &             ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
9568      &             ' (NA,NB,NSTATB,NSITEB) ',4I10)
9569             STOP
9570          ENDIF
9571          IF (LFIRST) WRITE(LOUT,1001) CFILE
9572  1001    FORMAT(/,' XSGLAU: impact parameter distribution read from ',
9573      &          'file ',A12,/)
9574          READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
9575      &                         XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
9576      &                         XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9577          READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
9578      &                         XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
9579      &                         XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9580          NLINES = INT(DBLE(NSITEB)/7.0D0)
9581          IF (NLINES.GT.0) THEN
9582             DO 21 I=1,NLINES
9583                ISTART = 7*I-6
9584                READ(LDAT,'(7E11.4)')
9585      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9586    21       CONTINUE
9587          ENDIF
9588          ISTART = 7*NLINES+1
9589          IF (ISTART.LE.NSITEB) THEN
9590             READ(LDAT,'(7E11.4)')
9591      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9592          ENDIF
9593          LFIRST = .FALSE.
9594          GOTO 100
9595 * variable projectile/target/energy runs:
9596 * read pre-initialized profile-functions from file
9597       ELSEIF (IOGLB.EQ.100) THEN
9598          CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
9599          GOTO 100
9600       ENDIF
9601
9602 * cross sections averaged over NSTATB nucleon configurations
9603       DO 11 IS=1,NSTATB
9604 C        IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
9605          STOTN = ZERO
9606          SELAN = ZERO
9607          SQEPN = ZERO
9608          SQETN = ZERO
9609          SQE2N = ZERO
9610          SPRON = ZERO
9611          SDELN = ZERO
9612          SDQEN = ZERO
9613
9614          IF (NIDX.LE.-1) THEN
9615             CALL DT_CONUCL(COOP1,NA,RASH(1),0)
9616             CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
9617             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9618                CALL DT_CONUCL(COOP2,NA,RASH(1),0)
9619                CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
9620             ENDIF
9621          ELSE
9622             CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
9623             CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
9624             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9625                CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
9626                CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
9627             ENDIF
9628          ENDIF
9629
9630 *  integration over impact parameter B
9631          DO 12 IB=1,NSITEB-1
9632             STOTB = ZERO
9633             SELAB = ZERO
9634             SQEPB = ZERO
9635             SQETB = ZERO
9636             SQE2B = ZERO
9637             SPROB = ZERO
9638             SDIR  = ZERO
9639             SDELB = ZERO
9640             SDQEB = ZERO
9641             B     = DBLE(IB)*BSTEP(NTARG)
9642             FACB  = 10.0D0*TWOPI*B*BSTEP(NTARG)
9643
9644 *   integration over M_V^2 for photon-proj.
9645             DO 14 IM=1,JPOINT
9646                PP11(1) = CONE
9647                PP12(1) = CONE
9648                PP21(1) = CONE
9649                PP22(1) = CONE
9650                IF (IJPROJ.EQ.7) THEN
9651                   DO 13 K=2,NB
9652                      PP11(K) = CONE
9653                      PP12(K) = CONE
9654                      PP21(K) = CONE
9655                      PP22(K) = CONE
9656    13             CONTINUE
9657                ENDIF
9658                SHI  = ZERO
9659                FACM = ONE
9660                DCOH = 1.0D10
9661
9662                IF (IJPROJ.EQ.7) THEN
9663                   AMV2 = EXP(ABSZX(IM))-Q2
9664                   AMV  = SQRT(AMV2)
9665                   IF (AMV2.LT.16.0D0) THEN
9666                      R = TWO
9667                   ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
9668                      R = 10.0D0/3.0D0
9669                   ELSE
9670                      R = 11.0D0/3.0D0
9671                   ENDIF
9672 *    define M_V dependent properties of nucleon scattering amplitude
9673 *     V_M-nucleon xsection
9674                   SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
9675                   SIGMV  = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
9676 *     slope-parametrisation a la Kaidalov
9677                   BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
9678      &                           +0.25D0*LOG(S/(AMV2+Q2)))
9679 *    coherence length
9680                   IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
9681 *    integration weight factor
9682                   FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
9683      &                  R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
9684                ENDIF
9685                GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
9686                GAM = GSH
9687                IF (IJPROJ.EQ.7) THEN
9688                   RCA = GAM*SIGMV/TWOPI
9689                ELSE
9690                   RCA = GAM*SIGSH/TWOPI
9691                ENDIF
9692                FCA = -ROSH*RCA
9693                CA  = DCMPLX(RCA,FCA)
9694                CI  = CONE
9695
9696                DO 15 INA=1,NA
9697                   KK1  = 1
9698                   INT1 = 1
9699                   KK2  = 1
9700                   INT2 = 1
9701                   DO 16 INB=1,NB
9702 *    photon-projectile: check for supression by coherence length
9703                      IF (IJPROJ.EQ.7) THEN
9704                         IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
9705                            KK1  = INB
9706                            INT1 = INT1+1
9707                         ENDIF
9708                         IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
9709                            KK2  = INB
9710                            INT2 = INT2+1
9711                         ENDIF
9712                      ENDIF
9713
9714                      X11 = B+COOT1(1,INB)-COOP1(1,INA)
9715                      Y11 =   COOT1(2,INB)-COOP1(2,INA)
9716                      XY11 = GAM*(X11*X11+Y11*Y11)
9717                      IF (XY11.LE.15.0D0) THEN
9718                         C = CONE-CA*EXP(-XY11)
9719                         AR = DBLE(PP11(INT1))
9720                         AI = DIMAG(PP11(INT1))
9721                         IF (ABS(AR).LT.TINY25) AR = ZERO
9722                         IF (ABS(AI).LT.TINY25) AI = ZERO
9723                         PP11(INT1) = DCMPLX(AR,AI)
9724                         PP11(INT1) = PP11(INT1)*C
9725                         AR  = DBLE(C)
9726                         AI  = DIMAG(C)
9727                         SHI = SHI+LOG(AR*AR+AI*AI)
9728                      ENDIF
9729                      IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9730                         X12 = B+COOT2(1,INB)-COOP1(1,INA)
9731                         Y12 =   COOT2(2,INB)-COOP1(2,INA)
9732                         XY12 = GAM*(X12*X12+Y12*Y12)
9733                         IF (XY12.LE.15.0D0) THEN
9734                            C = CONE-CA*EXP(-XY12)
9735                            AR = DBLE(PP12(INT2))
9736                            AI = DIMAG(PP12(INT2))
9737                            IF (ABS(AR).LT.TINY25) AR = ZERO
9738                            IF (ABS(AI).LT.TINY25) AI = ZERO
9739                            PP12(INT2) = DCMPLX(AR,AI)
9740                            PP12(INT2) = PP12(INT2)*C
9741                         ENDIF
9742                         X21 = B+COOT1(1,INB)-COOP2(1,INA)
9743                         Y21 =   COOT1(2,INB)-COOP2(2,INA)
9744                         XY21 = GAM*(X21*X21+Y21*Y21)
9745                         IF (XY21.LE.15.0D0) THEN
9746                            C = CONE-CA*EXP(-XY21)
9747                            AR = DBLE(PP21(INT1))
9748                            AI = DIMAG(PP21(INT1))
9749                            IF (ABS(AR).LT.TINY25) AR = ZERO
9750                            IF (ABS(AI).LT.TINY25) AI = ZERO
9751                            PP21(INT1) = DCMPLX(AR,AI)
9752                            PP21(INT1) = PP21(INT1)*C
9753                         ENDIF
9754                         X22 = B+COOT2(1,INB)-COOP2(1,INA)
9755                         Y22 =   COOT2(2,INB)-COOP2(2,INA)
9756                         XY22 = GAM*(X22*X22+Y22*Y22)
9757                         IF (XY22.LE.15.0D0) THEN
9758                            C = CONE-CA*EXP(-XY22)
9759                            AR = DBLE(PP22(INT2))
9760                            AI = DIMAG(PP22(INT2))
9761                            IF (ABS(AR).LT.TINY25) AR = ZERO
9762                            IF (ABS(AI).LT.TINY25) AI = ZERO
9763                            PP22(INT2) = DCMPLX(AR,AI)
9764                            PP22(INT2) = PP22(INT2)*C
9765                         ENDIF
9766                      ENDIF
9767    16             CONTINUE
9768    15          CONTINUE
9769
9770                OMPP11 = CZERO
9771                OMPP21 = CZERO
9772                DIPP11 = CZERO
9773                DIPP21 = CZERO
9774                DO 17 K=1,INT1
9775                   IF (PP11(K).EQ.CZERO) THEN
9776                      PPTMP1 = CZERO
9777                      PPTMP2 = CZERO
9778                   ELSE
9779                      PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
9780                      PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
9781                   ENDIF
9782                   AVDIPP = 0.5D0*
9783      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9784                   OMPP11 = OMPP11+AVDIPP
9785 C                 OMPP11 = OMPP11+(CONE-PP11(K))
9786                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9787                   DIPP11 = DIPP11+AVDIPP
9788                   IF (PP21(K).EQ.CZERO) THEN
9789                      PPTMP1 = CZERO
9790                      PPTMP2 = CZERO
9791                   ELSE
9792                      PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
9793                      PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
9794                   ENDIF
9795                   AVDIPP = 0.5D0*
9796      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9797                   OMPP21 = OMPP21+AVDIPP
9798 C                 OMPP21 = OMPP21+(CONE-PP21(K))
9799                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9800                   DIPP21 = DIPP21+AVDIPP
9801    17          CONTINUE
9802                OMPP12 = CZERO
9803                OMPP22 = CZERO
9804                DIPP12 = CZERO
9805                DIPP22 = CZERO
9806                DO 18 K=1,INT2
9807                   IF (PP12(K).EQ.CZERO) THEN
9808                      PPTMP1 = CZERO
9809                      PPTMP2 = CZERO
9810                   ELSE
9811                      PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
9812                      PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
9813                   ENDIF
9814                   AVDIPP = 0.5D0*
9815      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9816                   OMPP12 = OMPP12+AVDIPP
9817 C                 OMPP12 = OMPP12+(CONE-PP12(K))
9818                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9819                   DIPP12 = DIPP12+AVDIPP
9820                   IF (PP22(K).EQ.CZERO) THEN
9821                      PPTMP1 = CZERO
9822                      PPTMP2 = CZERO
9823                   ELSE
9824                      PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
9825                      PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
9826                   ENDIF
9827                   AVDIPP = 0.5D0*
9828      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9829                   OMPP22 = OMPP22+AVDIPP
9830 C                 OMPP22 = OMPP22+(CONE-PP22(K))
9831                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9832                   DIPP22 = DIPP22+AVDIPP
9833    18          CONTINUE
9834
9835                SPROM = ONE-EXP(SHI)
9836                SPROB = SPROB+FACM*SPROM
9837                IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9838                   STOTM = DBLE(OMPP11+OMPP22)
9839                   SELAM = DBLE(OMPP11*DCONJG(OMPP22))
9840                   SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
9841                   SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
9842                   SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
9843                   SDELM = DBLE(DIPP11*DCONJG(DIPP22))
9844                   SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
9845                   STOTB = STOTB+FACM*STOTM
9846                   SELAB = SELAB+FACM*SELAM
9847                   SDELB = SDELB+FACM*SDELM
9848                   IF (NB.GT.1) THEN
9849                      SQEPB = SQEPB+FACM*SQEPM
9850                      SDQEB = SDQEB+FACM*SDQEM
9851                   ENDIF
9852                   IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
9853                   IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
9854                   IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
9855                ENDIF
9856
9857    14       CONTINUE
9858
9859             STOTN = STOTN+FACB*STOTB
9860             SELAN = SELAN+FACB*SELAB
9861             SQEPN = SQEPN+FACB*SQEPB
9862             SQETN = SQETN+FACB*SQETB
9863             SQE2N = SQE2N+FACB*SQE2B
9864             SPRON = SPRON+FACB*SPROB
9865             SDELN = SDELN+FACB*SDELB
9866             SDQEN = SDQEN+FACB*SDQEB
9867
9868             IF (IJPROJ.EQ.7) THEN
9869                BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
9870             ELSE
9871                IF (DIBETA.GT.ZERO) THEN
9872                   BPROD(IB+1)= BPROD(IB+1)
9873      &                        +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
9874                ELSE
9875                   BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
9876                ENDIF
9877             ENDIF
9878
9879    12    CONTINUE
9880
9881          STOT  = STOT +FACN*STOTN
9882          STOT2 = STOT2+FACN*STOTN**2
9883          SELA  = SELA +FACN*SELAN
9884          SELA2 = SELA2+FACN*SELAN**2
9885          SQEP  = SQEP +FACN*SQEPN
9886          SQEP2 = SQEP2+FACN*SQEPN**2
9887          SQET  = SQET +FACN*SQETN
9888          SQET2 = SQET2+FACN*SQETN**2
9889          SQE2  = SQE2 +FACN*SQE2N
9890          SQE22 = SQE22+FACN*SQE2N**2
9891          SPRO  = SPRO +FACN*SPRON
9892          SPRO2 = SPRO2+FACN*SPRON**2
9893          SDEL  = SDEL +FACN*SDELN
9894          SDEL2 = SDEL2+FACN*SDELN**2
9895          SDQE  = SDQE +FACN*SDQEN
9896          SDQE2 = SDQE2+FACN*SDQEN**2
9897
9898    11 CONTINUE
9899
9900 * final cross sections
9901 * 1) total
9902       XSTOT(IE,IQ,NTARG) = STOT
9903       IF (IJPROJ.EQ.7)
9904      &   XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
9905 * 2) elastic
9906       XSELA(IE,IQ,NTARG) = SELA
9907 * 3) quasi-el.: A+B-->A+X (excluding 2)
9908       XSQEP(IE,IQ,NTARG) = SQEP
9909 * 4) quasi-el.: A+B-->X+B (excluding 2)
9910       XSQET(IE,IQ,NTARG) = SQET
9911 * 5) quasi-el.: A+B-->X (excluding 2-4)
9912       XSQE2(IE,IQ,NTARG) = SQE2
9913 * 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
9914       IF (SDEL.GT.ZERO) THEN
9915          XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
9916       ELSE
9917          XSPRO(IE,IQ,NTARG) = SPRO
9918       ENDIF
9919 * 7) projectile diffraction (el. scatt. off target)
9920       XSDEL(IE,IQ,NTARG) = SDEL
9921 * 8) projectile diffraction (quasi-el. scatt. off target)
9922       XSDQE(IE,IQ,NTARG) = SDQE
9923 *  stat. errors
9924       XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
9925       XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
9926       XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
9927       XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
9928       XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
9929       XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
9930       XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
9931       XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
9932
9933       IF (IJPROJ.EQ.7) THEN
9934          BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
9935      &          -XSQEP(IE,IQ,NTARG)
9936       ELSE
9937          BNORM = XSPRO(IE,IQ,NTARG)
9938       ENDIF
9939       DO 19 I=2,NSITEB
9940          BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
9941          IF ((IE.EQ.1).AND.(IQ.EQ.1))
9942      &      BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
9943    19 CONTINUE
9944
9945 * write profile function data into file
9946       IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
9947          WRITE(LDAT,'(5I10,1P,E15.5)')
9948      &      IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
9949          WRITE(LDAT,'(1P,6E12.5)')
9950      &      XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
9951      &      XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9952          WRITE(LDAT,'(1P,6E12.5)')
9953      &      XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
9954      &      XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9955          NLINES = INT(DBLE(NSITEB)/7.0D0)
9956          IF (NLINES.GT.0) THEN
9957             DO 20 I=1,NLINES
9958                ISTART = 7*I-6
9959                WRITE(LDAT,'(1P,7E11.4)')
9960      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9961    20       CONTINUE
9962          ENDIF
9963          ISTART = 7*NLINES+1
9964          IF (ISTART.LE.NSITEB) THEN
9965             WRITE(LDAT,'(1P,7E11.4)')
9966      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9967          ENDIF
9968       ENDIF
9969
9970   100 CONTINUE
9971
9972 C     IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
9973
9974       RETURN
9975       END
9976 *
9977 *===getbxs=============================================================*
9978 *
9979 CDECK  ID>, DT_GETBXS
9980       SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
9981
9982 ************************************************************************
9983 * Biasing in impact parameter space.                                   *
9984 *     XSFRAC = 0 :  BLO    - minimum impact parameter  (input)         *
9985 *                   BHI    - maximum impact parameter  (input)         *
9986 *                   XSFRAC - fraction of cross section corresponding   *
9987 *                            to impact parameter range (BLO,BHI)       *
9988 *                                                      (output)        *
9989 *     XSFRAC > 0 :  XSFRAC - fraction of cross section (input)         *
9990 *                   BHI    - maximum impact parameter giving requested *
9991 *                            fraction of cross section in impact       *
9992 *                            parameter range (0,BMAX)  (output)        *
9993 * This version dated 17.03.00  is written by S. Roesler                *
9994 ************************************************************************
9995
9996       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9997       SAVE
9998
9999       PARAMETER ( LINP = 5 ,
10000      &            LOUT = 6 ,
10001      &            LDAT = 9 )
10002
10003       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10004
10005 * Glauber formalism: parameters
10006       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10007      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10008      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10009      &                NSITEB,NSTATB
10010
10011       NTARG = ABS(NIDX)
10012       IF (XSFRAC.LE.0.0D0) THEN
10013          ILO    = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
10014          IHI    = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
10015          IF (ILO.GE.IHI) THEN
10016             XSFRAC = 0.0D0
10017             RETURN
10018          ENDIF
10019          IF (ILO.EQ.NSITEB-1) THEN
10020             FRCLO = BSITE(0,1,NTARG,NSITEB)
10021          ELSE
10022             FRCLO = BSITE(0,1,NTARG,ILO+1)
10023      &              +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
10024      &              *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
10025          ENDIF
10026          IF (IHI.EQ.NSITEB-1) THEN
10027             FRCHI = BSITE(0,1,NTARG,NSITEB)
10028          ELSE
10029             FRCHI = BSITE(0,1,NTARG,IHI+1)
10030      &              +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
10031      &              *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
10032          ENDIF
10033          XSFRAC = FRCHI-FRCLO
10034       ELSE
10035          BLO = 0.0D0
10036          BHI = BMAX(NTARG)
10037          DO 1 I=1,NSITEB-1
10038             IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
10039                FAC = (XSFRAC              -BSITE(0,1,NTARG,I))/
10040      &               (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
10041                BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
10042                GOTO 2
10043             ENDIF
10044     1    CONTINUE
10045     2    CONTINUE
10046       ENDIF
10047
10048       RETURN
10049       END
10050 *
10051 *===conucl=============================================================*
10052 *
10053 CDECK  ID>, DT_CONUCL
10054       SUBROUTINE DT_CONUCL(X,N,R,MODE)
10055
10056 ************************************************************************
10057 * Calculation of coordinates of nucleons within nuclei.                *
10058 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
10059 *        N / R    number of nucleons / radius of nucleus   (input)     *
10060 *        MODE = 0 coordinates not sorted                               *
10061 *             = 1 coordinates sorted with increasing X(3,i)            *
10062 *             = 2 coordinates sorted with decreasing X(3,i)            *
10063 * This version dated 26.10.95 is revised by S. Roesler                 *
10064 ************************************************************************
10065
10066       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10067       SAVE
10068
10069       PARAMETER ( LINP = 5 ,
10070      &            LOUT = 6 ,
10071      &            LDAT = 9 )
10072
10073       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10074      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10075
10076       PARAMETER (TWOPI = 6.283185307179586454D+00 )
10077
10078       PARAMETER (NSRT=10)
10079       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10080       DIMENSION X(3,N),XTMP(3,260)
10081
10082       CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10083
10084       IF ((MODE.NE.0).AND.((N.EQ.3).OR.(N.GT.4))) THEN
10085          K = 0
10086          DO 1 I=1,NSRT
10087             IF (MODE.EQ.2) THEN
10088                ISRT = NSRT+1-I
10089             ELSE
10090                ISRT = I
10091             ENDIF
10092             K1 = K
10093             DO 2 J=1,ICSRT(ISRT)
10094                K = K+1
10095                X(1,K) = XTMP(1,IDXSRT(ISRT,J))
10096                X(2,K) = XTMP(2,IDXSRT(ISRT,J))
10097                X(3,K) = XTMP(3,IDXSRT(ISRT,J))
10098     2       CONTINUE
10099             IF (ICSRT(ISRT).GT.1) THEN
10100                I0 = K1+1
10101                I1 = K
10102                CALL DT_SORT(X,N,I0,I1,MODE)
10103             ENDIF
10104     1    CONTINUE
10105       ELSEIF ((MODE.NE.0).AND.((N.EQ.2).OR.(N.EQ.4))) THEN
10106          DO 3 I=1,N
10107             X(1,I) = XTMP(1,I)
10108             X(2,I) = XTMP(2,I)
10109             X(3,I) = XTMP(3,I)
10110     3    CONTINUE
10111          CALL DT_SORT(X,N,1,N,MODE)
10112       ELSE
10113          DO 4 I=1,N
10114             X(1,I) = XTMP(1,I)
10115             X(2,I) = XTMP(2,I)
10116             X(3,I) = XTMP(3,I)
10117     4    CONTINUE
10118       ENDIF
10119
10120       RETURN
10121       END
10122 *
10123 *===coordi=============================================================*
10124 *
10125 CDECK  ID>, DT_COORDI
10126       SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10127
10128 ************************************************************************
10129 * Calculation of coordinates of nucleons within nuclei.                *
10130 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
10131 *        N / R    number of nucleons / radius of nucleus   (input)     *
10132 * Based on the original version by Shmakov et al.                      *
10133 * This version dated 26.10.95 is revised by S. Roesler                 *
10134 ************************************************************************
10135
10136       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10137       SAVE
10138
10139       PARAMETER ( LINP = 5 ,
10140      &            LOUT = 6 ,
10141      &            LDAT = 9 )
10142
10143       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10144      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10145
10146       PARAMETER (TWOPI = 6.283185307179586454D+00 )
10147
10148       LOGICAL LSTART
10149
10150       PARAMETER (NSRT=10)
10151       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10152       DIMENSION X(3,260),WD(4),RD(3)
10153
10154       DATA PDIF/0.545D0/,R2MIN/0.16D0/
10155       DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10156       DATA RD /2.09D0, 0.935D0, 0.697D0/
10157
10158       X1SUM = ZERO
10159       X2SUM = ZERO
10160       X3SUM = ZERO
10161
10162       IF (N.EQ.1) THEN
10163          X(1,1) = ZERO
10164          X(2,1) = ZERO
10165          X(3,1) = ZERO
10166       ELSEIF (N.EQ.2) THEN
10167          EPS = DT_RNDM(RD(1))
10168          DO 30 I=1,3
10169             IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10170    30    CONTINUE
10171    40    CONTINUE
10172          DO 50 J=1,3
10173             CALL DT_RANNOR(X1,X2)
10174             X(J,1) = RD(I)*X1
10175             X(J,2) = -X(J,1)
10176    50    CONTINUE
10177       ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10178          SIGMA = R/SQRTWO
10179          LSTART = .TRUE.
10180          CALL DT_RANNOR(X3,X4)
10181          DO 100 I=1,N
10182             CALL DT_RANNOR(X1,X2)
10183             X(1,I) = SIGMA*X1
10184             X(2,I) = SIGMA*X2
10185             IF (LSTART) GOTO 80
10186             X(3,I) = SIGMA*X4
10187             CALL DT_RANNOR(X3,X4)
10188             GOTO 90
10189    80       CONTINUE
10190             X(3,I) = SIGMA*X3
10191    90       CONTINUE
10192             LSTART = .NOT.LSTART
10193             X1SUM = X1SUM+X(1,I)
10194             X2SUM = X2SUM+X(2,I)
10195             X3SUM = X3SUM+X(3,I)
10196   100    CONTINUE
10197          X1SUM = X1SUM/DBLE(N)
10198          X2SUM = X2SUM/DBLE(N)
10199          X3SUM = X3SUM/DBLE(N)
10200          DO 101 I=1,N
10201             X(1,I) = X(1,I)-X1SUM
10202             X(2,I) = X(2,I)-X2SUM
10203             X(3,I) = X(3,I)-X3SUM
10204   101    CONTINUE
10205       ELSE
10206
10207 * maximum nuclear radius for coordinate sampling
10208          RMAX = R+4.605D0*PDIF
10209
10210 * initialize pre-sorting
10211          DO 121 I=1,NSRT
10212             ICSRT(I) = 0
10213   121    CONTINUE
10214          DR = TWO*RMAX/DBLE(NSRT)
10215
10216 * sample coordinates for N nucleons
10217          DO 140 I=1,N
10218   120       CONTINUE
10219             RAD = RMAX*(DT_RNDM(DR))**ONETHI
10220             F   = DT_DENSIT(N,RAD,R)
10221             IF (DT_RNDM(RAD).GT.F) GOTO 120
10222 *   theta, phi uniformly distributed
10223             CT  = ONE-TWO*DT_RNDM(F)
10224             ST  = SQRT((ONE-CT)*(ONE+CT))
10225             CALL DT_DSFECF(SFE,CFE)
10226             X(1,I) = RAD*ST*CFE
10227             X(2,I) = RAD*ST*SFE
10228             X(3,I) = RAD*CT
10229 *   ensure that distance between two nucleons is greater than R2MIN
10230             IF (I.LT.2) GOTO 122
10231             I1 = I-1
10232             DO 130 I2=1,I1
10233                DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10234      &                 (X(3,I)-X(3,I2))**2
10235                IF (DIST2.LE.R2MIN) GOTO 120
10236   130       CONTINUE
10237   122       CONTINUE
10238 *   save index according to z-bin
10239             IDXZ        = INT( (X(3,I)+RMAX)/DR )+1
10240             ICSRT(IDXZ) = ICSRT(IDXZ)+1
10241             IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10242             X1SUM = X1SUM+X(1,I)
10243             X2SUM = X2SUM+X(2,I)
10244             X3SUM = X3SUM+X(3,I)
10245   140    CONTINUE
10246          X1SUM = X1SUM/DBLE(N)
10247          X2SUM = X2SUM/DBLE(N)
10248          X3SUM = X3SUM/DBLE(N)
10249          DO 141 I=1,N
10250             X(1,I) = X(1,I)-X1SUM
10251             X(2,I) = X(2,I)-X2SUM
10252             X(3,I) = X(3,I)-X3SUM
10253   141    CONTINUE
10254
10255       ENDIF
10256
10257       RETURN
10258       END
10259 *
10260 *===densit=============================================================*
10261 *
10262 CDECK  ID>, DT_DENSIT
10263       DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10264
10265       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10266       SAVE
10267
10268       PARAMETER ( LINP = 5 ,
10269      &            LOUT = 6 ,
10270      &            LDAT = 9 )
10271
10272       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10273       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10274      &           PI    = TWOPI/TWO)
10275
10276       DIMENSION R0(18),FNORM(18)
10277       DATA R0 /  ZERO,   ZERO,   ZERO,   ZERO, 2.12D0,
10278      &         2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10279      &         2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10280      &         2.72D0, 2.66D0, 2.79D0/
10281       DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10282      &            .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10283      &            .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10284      &            .1214D+01,.1265D+01,.1318D+01/
10285       DATA PDIF /0.545D0/
10286
10287       DT_DENSIT = ZERO
10288 * shell model
10289       IF (NA.LE.4) THEN
10290          STOP 'DT_DENSIT-0'
10291       ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10292          R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10293          DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10294      &            *EXP(-(R/R1)**2)/FNORM(NA)
10295 * Woods-Saxon
10296       ELSEIF (NA.GT.18) THEN
10297          DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10298       ENDIF
10299
10300       RETURN
10301       END
10302 *
10303 *===rnclus=============================================================*
10304 *
10305 CDECK  ID>, DT_RNCLUS
10306       DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10307
10308 ************************************************************************
10309 * Nuclear radius for nucleus with mass number N.                       *
10310 * This version dated 26.9.00  is written by S. Roesler                 *
10311 ************************************************************************
10312
10313       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10314       SAVE
10315
10316       PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10317
10318 * nucleon radius
10319       PARAMETER (RNUCLE = 1.12D0)
10320
10321 * nuclear radii for selected nuclei
10322       DIMENSION RADNUC(18)
10323       DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10324      &               2.58D0,2.71D0,2.66D0,2.71D0/
10325
10326       IF (N.LE.18) THEN
10327          IF (RADNUC(N).GT.0.0D0) THEN
10328             DT_RNCLUS = RADNUC(N)
10329          ELSE
10330             DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10331          ENDIF
10332       ELSE
10333          DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10334       ENDIF
10335
10336       RETURN
10337       END
10338 *
10339 *===dentst=============================================================*
10340 *
10341 C      PROGRAM DT_DENTST
10342 CDECK  ID>, DT_DENTST
10343       SUBROUTINE DT_DENTST
10344
10345       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10346       SAVE
10347
10348       OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10349       OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10350
10351       RMIN  = 0.0D0
10352       RMAX  = 8.0D0
10353       NBINS = 500.0D0
10354       DR    = (RMAX-RMIN)/DBLE(NBINS)
10355       DO 1 IA=5,18
10356          FMAX = 0.0D0
10357          DO 2 IR=1,NBINS+1
10358             R = RMIN+DBLE(IR-1)*DR
10359             F = DT_DENSIT(IA,R,R)
10360             IF (F.GT.FMAX) FMAX = F
10361             WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10362     2    CONTINUE
10363          WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10364     1 CONTINUE
10365
10366       CLOSE(40)
10367       CLOSE(41)
10368
10369       END
10370 *
10371 *===shmaki=============================================================*
10372 *
10373 CDECK  ID>, DT_SHMAKI
10374       SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10375
10376 ************************************************************************
10377 * Initialisation of Glauber formalism. This subroutine has to be       *
10378 * called once (in case of target emulsions as often as many different  *
10379 * target nuclei are considered) before events are sampled.             *
10380 *         NA / NCA   mass number/charge of projectile nucleus          *
10381 *         NB / NCB   mass number/charge of target     nucleus          *
10382 *         IJP        identity of projectile (hadrons/leptons/photons)  *
10383 *         PPN        projectile momentum (for projectile nuclei:       *
10384 *                    momentum per nucleon) in target rest system       *
10385 *         MODE = 0   Glauber formalism invoked                         *
10386 *              = 1   fitted results are loaded from data-file          *
10387 *              = 99  NTARG is forced to be 1                           *
10388 *                    (used in connection with GLAUBERI-card only)      *
10389 * This version dated 22.03.96 is based on the original SHMAKI-routine  *
10390 * and revised by S. Roesler.                                           *
10391 ************************************************************************
10392
10393       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10394       SAVE
10395
10396       PARAMETER ( LINP = 5 ,
10397      &            LOUT = 6 ,
10398      &            LDAT = 9 )
10399
10400       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10401      &           THREE=3.0D0)
10402
10403       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10404
10405 * Glauber formalism: parameters
10406       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10407      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10408      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10409      &                NSITEB,NSTATB
10410 * Lorentz-parameters of the current interaction
10411       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10412      &                UMO,PPCM,EPROJ,PPROJ
10413 * properties of photon/lepton projectiles
10414       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10415 * kinematical cuts for lepton-nucleus interactions
10416       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10417      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10418 * Glauber formalism: cross sections
10419       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10420      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10421      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10422      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10423      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10424      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10425      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10426      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10427      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10428      &                BSLOPE,NEBINI,NQBINI
10429 * cuts for variable energy runs
10430       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10431 * nucleon-nucleon event-generator
10432       CHARACTER*8 CMODEL
10433       LOGICAL LPHOIN
10434       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10435 * Glauber formalism: flags and parameters for statistics
10436       LOGICAL LPROD
10437       CHARACTER*8 CGLB
10438       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10439
10440       DATA NTARG,ICOUT,IVEOUT /0,0,0/
10441
10442 C     CALL DT_HISHAD
10443 C     STOP
10444
10445       NTARG = NTARG+1
10446       IF (MODE.EQ.99) NTARG = 1
10447       NIDX = -NTARG
10448       IF (MODE.EQ.-1) NIDX = NTARG
10449
10450       IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10451       IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10452  1000    FORMAT(//,1X,'SHMAKI:    Glauber formalism (Shmakov et. al) -',
10453      &          ' initialization',/,12X,'--------------------------',
10454      &          '-------------------------',/)
10455
10456       IF (MODE.EQ.2) THEN
10457          CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10458          CALL DT_SHFAST(MODE,PPN,IBACK)
10459          STOP ' Glauber pre-initialization done'
10460       ENDIF
10461       IF (MODE.EQ.1) THEN
10462          CALL DT_PROFBI(NA,NB,PPN,NTARG)
10463       ELSE
10464          IBACK = 1
10465          IF (MODE.EQ.3)  CALL DT_SHFAST(MODE,PPN,IBACK)
10466          IF (IBACK.EQ.1) THEN
10467 * lepton-nucleus (variable energy runs)
10468             IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10469      &          (IJP.EQ.10).OR.(IJP.EQ.11))   THEN
10470                IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10471      &            WRITE(LOUT,1002) NB,NCB
10472  1002          FORMAT(1X,'variable energy run:     projectile-id:  7',
10473      &                '    target A/Z: ',I3,' /',I3,/,/,8X,
10474      &                'E_cm (GeV)    Q^2 (GeV^2)',
10475      &                '    Sigma_tot (mb)     Sigma_in (mb)',/,7X,
10476      &                '--------------------------------',
10477      &                '------------------------------')
10478                AECMLO = LOG10(MIN(UMO,ECMLI))
10479                AECMHI = LOG10(MIN(UMO,ECMHI))
10480                IESTEP = NEB-1
10481                DAECM  = (AECMHI-AECMLO)/DBLE(IESTEP)
10482                IF (AECMLO.EQ.AECMHI) IESTEP = 0
10483                DO 1 I=1,IESTEP+1
10484                   ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10485                   IF (Q2HI.GT.0.1D0) THEN
10486                      IF (Q2LI.LT.0.01D0) THEN
10487                         CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10488                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10489      &                     WRITE(LOUT,1003)
10490      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10491                         Q2LI = 0.01D0
10492                         IBIN = 2
10493                      ELSE
10494                         IBIN = 1
10495                      ENDIF
10496                      IQSTEP = NQB-IBIN
10497                      AQ2LO  = LOG10(Q2LI)
10498                      AQ2HI  = LOG10(Q2HI)
10499                      DAQ2   = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10500                      DO 2 J=IBIN,IQSTEP+IBIN
10501                         Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10502                         CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10503                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10504      &                     WRITE(LOUT,1003) ECMNN(I),
10505      &                     Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10506     2                CONTINUE
10507                   ELSE
10508                      CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10509                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10510      &                  WRITE(LOUT,1003)
10511      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10512                   ENDIF
10513  1003             FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10514     1          CONTINUE
10515                IVEOUT = 1
10516             ELSE
10517 * hadron/photon/nucleus-nucleus
10518                IF ((ABS(VAREHI).GT.ZERO).AND.
10519      &             (ABS(VAREHI).GT.ABS(VARELO))) THEN
10520                   IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10521                      WRITE(LOUT,1004) NA,NB,NCB
10522  1004                FORMAT(1X,'variable energy run:    projectile-id:',
10523      &                      I3,'    target A/Z: ',I3,' /',I3,/)
10524                      WRITE(LOUT,1005)
10525  1005                FORMAT('  E_cm (GeV)  E_Lab (GeV)  sig_tot^pp (mb)'
10526      &                      ,'  Sigma_tot (mb)  Sigma_prod (mb)',/,
10527      &                      ' -------------------------------------',
10528      &                      '--------------------------------------')
10529                   ENDIF
10530                   AECMLO = LOG10(VARCLO)
10531                   AECMHI = LOG10(VARCHI)
10532                   IESTEP = NEB-1
10533                   DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10534                   IF (AECMLO.EQ.AECMHI) IESTEP = 0
10535                   DO 3 I=1,IESTEP+1
10536                      ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10537                      AMP = 0.938D0
10538                      AMT = 0.938D0
10539                      AMP2 = AMP**2
10540                      AMT2 = AMT**2
10541                      ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
10542                      PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
10543                      CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
10544                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10545      &                 WRITE(LOUT,1006)
10546      &                 ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10547  1006             FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
10548     3             CONTINUE
10549                   IVEOUT = 1
10550                ELSE
10551                   CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10552                ENDIF
10553             ENDIF
10554          ENDIF
10555       ENDIF
10556
10557       IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
10558      &    (IOGLB.NE.100)) THEN
10559          WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
10560      &                    BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
10561  1001    FORMAT(38X,'projectile',
10562      &          '      target',/,1X,'Mass number / charge',
10563      &          17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
10564      &          'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
10565      &          'Parameters of elastic scattering amplitude:',/,5X,
10566      &          'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
10567      &          F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
10568      &          'statistics at each b-step',4X,I5,/,/,1X,
10569      &          'Prod. cross section  ',5X,F10.4,' mb',/)
10570       ENDIF
10571
10572       RETURN
10573       END
10574 *
10575 *===profbi=============================================================*
10576 *
10577 CDECK  ID>, DT_PROFBI
10578       SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
10579
10580 ************************************************************************
10581 * Integral over profile function (to be used for impact-parameter      *
10582 * sampling during event generation).                                   *
10583 * Fitted results are used.                                             *
10584 *         NA / NB    mass numbers of proj./target nuclei               *
10585 *         PPN        projectile momentum (for projectile nuclei:       *
10586 *                    momentum per nucleon) in target rest system       *
10587 *         NTARG      index of target material (i.e. kind of nucleus)   *
10588 * This version dated 31.05.95 is revised by S. Roesler                 *
10589 ************************************************************************
10590
10591       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10592       SAVE
10593
10594       PARAMETER ( LINP = 5 ,
10595      &            LOUT = 6 ,
10596      &            LDAT = 9 )
10597
10598       SAVE
10599
10600       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
10601
10602       LOGICAL LSTART
10603       CHARACTER CNAME*80
10604
10605       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10606
10607 * Glauber formalism: parameters
10608       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10609      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10610      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10611      &                NSITEB,NSTATB
10612 * Glauber formalism: cross sections
10613       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10614      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10615      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10616      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10617      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10618      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10619      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10620      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10621      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10622      &                BSLOPE,NEBINI,NQBINI
10623
10624       PARAMETER (NGLMAX=8000)
10625       DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
10626      &          GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
10627
10628       DATA LSTART /.TRUE./
10629
10630       IF (LSTART) THEN
10631 * read fit-parameters from file
10632          OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
10633          I = 0
10634     1    CONTINUE
10635          READ(47,'(A80)') CNAME
10636          IF (CNAME.EQ.'STOP') GOTO 2
10637          I = I+1
10638          READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
10639      &                 GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
10640      &                 GLAFIT(4,I),GLAFIT(5,I)
10641          IF (I+1.GT.NGLMAX) THEN
10642             WRITE(LOUT,1000)
10643  1000       FORMAT(1X,'PROFBI:    warning! array size exceeded - ',
10644      &             'program stopped')
10645             STOP
10646          ENDIF
10647          GOTO 1
10648     2    CONTINUE
10649          NGLPAR = I
10650          LSTART = .FALSE.
10651       ENDIF
10652
10653       NNA = NA
10654       NNB = NB
10655       IF (NA.GT.NB) THEN
10656          NNA = NB
10657          NNB = NA
10658       ENDIF
10659       IDXGLA = 0
10660       DO 3 J=1,NGLPAR
10661          IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
10662             IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
10663             DO 4 K=1,J-1
10664                IPOINT = J-K
10665                IF (J.EQ.NGLPAR) IPOINT = J+1-K
10666                IF ((NNA.GT.NGLIP(IPOINT)).OR.
10667      &             (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
10668                   IF (IPOINT.EQ.1) IPOINT = 0
10669                   NATMP = NGLIP(IPOINT+1)
10670                   IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
10671                      IDXGLA = IPOINT+1
10672                      GOTO 6
10673                   ELSE
10674                      J1BEG = IPOINT+1
10675                      J1END = J
10676 C                    IF (J.EQ.NGLPAR) THEN
10677 C                       J1BEG = IPOINT
10678 C                       J1END = J
10679 C                    ENDIF
10680                      DO 5 J1=J1BEG,J1END
10681                         IF (NGLIP(J1).EQ.NATMP) THEN
10682                            IF (PPN.LT.GLAPPN(J1)) THEN
10683                               IDXGLA = J1
10684                               GOTO 6
10685                            ENDIF
10686                         ELSE
10687                            IDXGLA = J1-1
10688                            GOTO 6
10689                         ENDIF
10690     5                CONTINUE
10691                      IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
10692      &                  IDXGLA = NGLPAR
10693                   ENDIF
10694                ENDIF
10695     4       CONTINUE
10696          ENDIF
10697     3 CONTINUE
10698
10699     6 CONTINUE
10700       IF (IDXGLA.EQ.0) THEN
10701          WRITE(LOUT,1001) NNA,NNB,PPN
10702  1001    FORMAT(1X,'PROFBI:   configuration (NA,NB,PPN = ',
10703      &          2I4,F6.0,') not found ')
10704          STOP
10705       ENDIF
10706
10707 * no interpolation yet available
10708       XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
10709
10710       BSITE(1,1,NTARG,1) = ZERO
10711       DO 10 I=2,NSITEB
10712          XX = DBLE(I)
10713          POLY  = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
10714      &           GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
10715      &           GLAFIT(5,IDXGLA)*XX**4
10716          IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
10717          BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
10718          IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
10719    10 CONTINUE
10720
10721       RETURN
10722       END
10723 *
10724 *===glaube=============================================================*
10725 *
10726 CDECK  ID>, DT_GLAUBE
10727       SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
10728
10729 ************************************************************************
10730 * Calculation of configuartion of interacting nucleons for one event.  *
10731 *    NA / NB    mass numbers of proj./target nuclei           (input)  *
10732 *    B          impact parameter                              (output) *
10733 *    INTT       total number of wounded nucleons                 "     *
10734 *    INTA / INTB number of wounded nucleons in proj. / target    "     *
10735 *    JS / JT(i) number of collisions proj. / target nucleon i is       *
10736 *                                                   involved  (output) *
10737 *    NIDX       index of projectile/target material             (input)*
10738 * This is an update of the original routine SHMAKO by J.Ranft/HJM      *
10739 * This version dated 22.03.96 is revised by S. Roesler                 *
10740 ************************************************************************
10741
10742       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10743       SAVE
10744
10745       PARAMETER ( LINP = 5 ,
10746      &            LOUT = 6 ,
10747      &            LDAT = 9 )
10748
10749       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
10750      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
10751
10752       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10753
10754       PARAMETER ( MAXNCL = 260,
10755
10756      &            MAXVQU = MAXNCL,
10757      &            MAXSQU = 20*MAXVQU,
10758      &            MAXINT = MAXVQU+MAXSQU)
10759 * Glauber formalism: parameters
10760       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10761      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10762      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10763      &                NSITEB,NSTATB
10764 * Glauber formalism: cross sections
10765       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10766      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10767      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10768      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10769      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10770      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10771      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10772      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10773      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10774      &                BSLOPE,NEBINI,NQBINI
10775 * Lorentz-parameters of the current interaction
10776       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10777      &                UMO,PPCM,EPROJ,PPROJ
10778 * properties of photon/lepton projectiles
10779       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10780 * Glauber formalism: collision properties
10781       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
10782      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
10783 * Glauber formalism: flags and parameters for statistics
10784       LOGICAL LPROD
10785       CHARACTER*8 CGLB
10786       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10787
10788       DIMENSION JS(MAXNCL),JT(MAXNCL)
10789
10790       NTARG = ABS(NIDX)
10791
10792 * get actual energy from /DTLTRA/
10793       ECMNOW = UMO
10794       Q2     = VIRT
10795 *
10796 * new patch for pre-initialized variable projectile/target/energy runs
10797       IF (IOGLB.EQ.100) THEN
10798          CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
10799 *
10800 * variable energy run, interpolate profile function
10801       ELSE
10802          I1   = 1
10803          I2   = 1
10804          RATE = ONE
10805          IF (NEBINI.GT.1) THEN
10806             IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
10807                I1   = NEBINI
10808                I2   = NEBINI
10809                RATE = ONE
10810             ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
10811                DO 1 I=2,NEBINI
10812                   IF (ECMNOW.LT.ECMNN(I)) THEN
10813                      I1   = I-1
10814                      I2   = I
10815                      RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
10816                      GOTO 2
10817                   ENDIF
10818     1          CONTINUE
10819     2          CONTINUE
10820             ENDIF
10821          ENDIF
10822          J1   = 1
10823          J2   = 1
10824          RATQ = ONE
10825          IF (NQBINI.GT.1) THEN
10826             IF (Q2.GE.Q2G(NQBINI)) THEN
10827                J1   = NQBINI
10828                J2   = NQBINI
10829                RATQ = ONE
10830             ELSEIF (Q2.GT.Q2G(1)) THEN
10831                DO 3 I=2,NQBINI
10832                   IF (Q2.LT.Q2G(I)) THEN
10833                      J1   = I-1
10834                      J2   = I
10835                      RATQ = LOG10(     Q2/MAX(Q2G(J1),TINY14))/
10836      &                      LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
10837 C                    RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
10838                      GOTO 4
10839                   ENDIF
10840     3          CONTINUE
10841     4          CONTINUE
10842             ENDIF
10843          ENDIF
10844
10845          DO 5 I=1,KSITEB
10846             BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
10847      &         RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10848      &         RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10849      &         RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
10850      &                    BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
10851     5    CONTINUE
10852       ENDIF
10853
10854       CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
10855       IF (NIDX.LE.-1) THEN
10856          RPROJ = RASH(1)
10857          RTARG = RBSH(NTARG)
10858       ELSE
10859          RPROJ = RASH(NTARG)
10860          RTARG = RBSH(1)
10861       ENDIF
10862
10863       RETURN
10864       END
10865 *
10866 *===diagr==============================================================*
10867 *
10868 CDECK  ID>, DT_DIAGR
10869       SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
10870      &                                                         NIDX)
10871
10872 ************************************************************************
10873 * Based on the original version by Shmakov et al.                      *
10874 * This version dated 21.04.95 is revised by S. Roesler                 *
10875 ************************************************************************
10876
10877       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10878       SAVE
10879
10880       PARAMETER ( LINP = 5 ,
10881      &            LOUT = 6 ,
10882      &            LDAT = 9 )
10883
10884       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10885       PARAMETER (TWOPI  = 6.283185307179586454D+00,
10886      &           PI     = TWOPI/TWO,
10887      &           GEV2MB = 0.38938D0,
10888      &           GEV2FM = 0.1972D0,
10889      &           ALPHEM = ONE/137.0D0,
10890 * proton mass
10891      &           AMP    = 0.938D0,
10892      &           AMP2   = AMP**2,
10893 * rho0 mass
10894      &           AMRHO0 = 0.77D0)
10895
10896       COMPLEX*16 C,CA,CI
10897
10898       PARAMETER ( MAXNCL = 260,
10899
10900      &            MAXVQU = MAXNCL,
10901      &            MAXSQU = 20*MAXVQU,
10902      &            MAXINT = MAXVQU+MAXSQU)
10903 * particle properties (BAMJET index convention)
10904       CHARACTER*8  ANAME
10905       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
10906      &                IICH(210),IIBAR(210),K1(210),K2(210)
10907
10908       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10909
10910 * emulsion treatment
10911       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
10912      &                NCOMPO,IEMUL
10913 * Glauber formalism: parameters
10914       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10915      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10916      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10917      &                NSITEB,NSTATB
10918 * Glauber formalism: cross sections
10919       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10920      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10921      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10922      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10923      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10924      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10925      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10926      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10927      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10928      &                BSLOPE,NEBINI,NQBINI
10929 * VDM parameter for photon-nucleus interactions
10930       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
10931 * nucleon-nucleon event-generator
10932       CHARACTER*8 CMODEL
10933       LOGICAL LPHOIN
10934       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10935 **PHOJET105a
10936 C     COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10937 **PHOJET112
10938 C  obsolete cut-off information
10939       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
10940       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10941 **
10942 * coordinates of nucleons
10943       COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
10944 * interface between Glauber formalism and DPM
10945       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
10946      &                INTER1(MAXINT),INTER2(MAXINT)
10947 * statistics: Glauber-formalism
10948       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
10949 * n-n cross section fluctuations
10950       PARAMETER (NBINS = 1000)
10951       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
10952
10953       DIMENSION JS(MAXNCL),JT(MAXNCL),
10954      &          JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
10955      &          JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
10956       DIMENSION NWA(0:210),NWB(0:210)
10957
10958       LOGICAL LFIRST
10959       DATA LFIRST /.TRUE./
10960
10961       DATA NTARGO,ICNT /0,0/
10962
10963       NTARG = ABS(NIDX)
10964
10965       IF (LFIRST) THEN
10966          LFIRST = .FALSE.
10967          IF (NCOMPO.EQ.0) THEN
10968             NCALL  = 0
10969             NWAMAX = NA
10970             NWBMAX = NB
10971             DO 17 I=0,210
10972                NWA(I) = 0
10973                NWB(I) = 0
10974    17       CONTINUE
10975          ENDIF
10976       ENDIF
10977       IF (NTARG.EQ.-1) THEN
10978          IF (NCOMPO.EQ.0) THEN
10979             WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
10980             WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
10981      &                                NCALL,NWAMAX,NWBMAX
10982             DO 18 I=1,MAX(NWAMAX,NWBMAX)
10983                WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
10984      &                          I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
10985      &                            NWB(I),DBLE(NWB(I))/DBLE(NCALL)
10986    18       CONTINUE
10987          ENDIF
10988          RETURN
10989       ENDIF
10990
10991       DCOH   = 1.0D10
10992       IPNT   = 0
10993
10994       SQ2  = Q2
10995       IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
10996       S   = ECMNOW**2
10997       X   = SQ2/(S+SQ2-AMP2)
10998       XNU = (S+SQ2-AMP2)/(TWO*AMP)
10999 * photon projectiles: recalculate photon-nucleon amplitude
11000       IF (IJPROJ.EQ.7) THEN
11001    15    CONTINUE
11002 *  VDM assumption: mass of V-meson
11003          AMV2   = DT_SAM2(SQ2,ECMNOW)
11004          AMV    = SQRT(AMV2)
11005          IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
11006 *  check for pointlike interaction
11007          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
11008 **sr 27.10.
11009 C        SIGSH  = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11010          SIGSH  = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11011 **
11012          ROSH   = 0.1D0
11013          BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
11014      &                   +0.25D0*LOG(S/(AMV2+SQ2)))
11015 *  coherence length
11016          IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
11017       ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
11018          IF (MCGENE.EQ.2) THEN
11019             ZERO1 = ZERO
11020             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
11021      &                                                BSLOPE,0)
11022          ELSE
11023             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
11024          ENDIF
11025          IF (ECMNOW.LE.3.0D0) THEN
11026             ROSH = -0.43D0
11027          ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
11028             ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
11029          ELSEIF (ECMNOW.GT.50.0D0) THEN
11030             ROSH = 0.1D0
11031          ENDIF
11032          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11033          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11034          IF (MCGENE.EQ.2) THEN
11035             ZERO1 = ZERO
11036             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
11037      &                                                  BDUM,0)
11038             SIGSH = SIGSH/10.0D0
11039          ELSE
11040 C           SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11041             DUMZER = ZERO
11042             CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11043             SIGSH = SIGSH/10.0D0
11044          ENDIF
11045       ELSE
11046          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
11047          ROSH   = 0.01D0
11048          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11049          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11050 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11051          DUMZER = ZERO
11052          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11053          SIGSH = SIGSH/10.0D0
11054       ENDIF
11055       GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
11056       GAM = GSH
11057       RCA = GAM*SIGSH/TWOPI
11058       FCA = -ROSH*RCA
11059       CA  = DCMPLX(RCA,FCA)
11060       CI  = DCMPLX(ONE,ZERO)
11061
11062    16 CONTINUE
11063 * impact parameter
11064       IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
11065
11066       NTRY = 0
11067     3 CONTINUE
11068       NTRY = NTRY+1
11069 * initializations
11070       JNT  = 0
11071       DO 1 I=1,NA
11072          JS(I) = 0
11073     1 CONTINUE
11074       DO 2 I=1,NB
11075          JT(I) = 0
11076     2 CONTINUE
11077       IF (IJPROJ.EQ.7) THEN
11078          DO 8 I=1,MAXNCL
11079             JS0(I) = 0
11080             JNT0(I)= 0
11081             DO 9 J=1,NB
11082                JT0(I,J) = 0
11083     9       CONTINUE
11084     8    CONTINUE
11085       ENDIF
11086
11087 * nucleon configuration
11088 C     IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11089       IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11090 C        CALL DT_CONUCL(PKOO,NA,RASH,2)
11091 C        CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
11092          IF (NIDX.LE.-1) THEN
11093             CALL DT_CONUCL(PKOO,NA,RASH(1),0)
11094             CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
11095          ELSE
11096             CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11097             CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11098          ENDIF
11099          NTARGO = NTARG
11100       ENDIF
11101       ICNT = ICNT+1
11102
11103 * LEPTO: pick out one struck nucleon
11104       IF (MCGENE.EQ.3) THEN
11105          JNT     = 1
11106          JS(1)   = 1
11107          IDX     = INT(DT_RNDM(X)*NB)+1
11108          JT(IDX) = 1
11109          B       = ZERO
11110          GOTO 19
11111       ENDIF
11112
11113       DO 4 INA=1,NA
11114 * cross section fluctuations
11115          AFLUC = ONE
11116          IF (IFLUCT.EQ.1) THEN
11117             IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11118             AFLUC = FLUIXX(IFLUK)
11119          ENDIF
11120          KK1  = 1
11121          KINT = 1
11122          DO 5 INB=1,NB
11123 * photon-projectile: check for supression by coherence length
11124             IF (IJPROJ.EQ.7) THEN
11125                IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11126                   KK1  = INB
11127                   KINT = KINT+1
11128                ENDIF
11129             ENDIF
11130             QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11131             QQ2 =   TKOO(2,INB)-PKOO(2,INA)
11132             XY  = GAM*(QQ1*QQ1+QQ2*QQ2)
11133             IF (XY.LE.15.0D0) THEN
11134                C  = CI-CA*AFLUC*EXP(-XY)
11135                AR = DBLE(C)
11136                AI = DIMAG(C)
11137                P  = AR*AR+AI*AI
11138                IF (DT_RNDM(XY).GE.P) THEN
11139                   JNT = JNT+1
11140                   IF (IJPROJ.EQ.7) THEN
11141                      JNT0(KINT) = JNT0(KINT)+1
11142                      IF (JNT0(KINT).GT.MAXNCL) THEN
11143                         WRITE(LOUT,1001) MAXNCL
11144  1001                   FORMAT(1X,
11145      &                        'DIAGR:  no. of requested interactions',
11146      &                        ' exceeds array dimensions ',I4)
11147                         STOP
11148                      ENDIF
11149                      JS0(KINT)      = JS0(KINT)+1
11150                      JT0(KINT,INB)  = JT0(KINT,INB)+1
11151                      JI1(KINT,JNT0(KINT)) = INA
11152                      JI2(KINT,JNT0(KINT)) = INB
11153                   ELSE
11154                      IF (JNT.GT.MAXINT) THEN
11155                         WRITE(LOUT,1000) JNT, MAXINT
11156  1000                   FORMAT(1X,
11157      &                        'DIAGR:  no. of requested interactions ('
11158      &                        ,I4,') exceeds array dimensions (',I4,')')
11159                         STOP
11160                      ENDIF
11161                      JS(INA) = JS(INA)+1
11162                      JT(INB) = JT(INB)+1
11163                      INTER1(JNT) = INA
11164                      INTER2(JNT) = INB
11165                   ENDIF
11166                ENDIF
11167             ENDIF
11168     5    CONTINUE
11169     4 CONTINUE
11170
11171       IF (JNT.EQ.0) THEN
11172          IF (NTRY.LT.500) THEN
11173             GOTO 3
11174          ELSE
11175 C           WRITE(6,*) ' new impact parameter required (old= ',B,')'
11176             GOTO 16
11177          ENDIF
11178       ENDIF
11179
11180       IDIREC = 0
11181       IF (IJPROJ.EQ.7) THEN
11182          K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11183    10    CONTINUE
11184          IF (JNT0(K).EQ.0) THEN
11185             K = K+1
11186             IF (K.GT.KINT) K = 1
11187             GOTO 10
11188          ENDIF
11189 * supress Glauber-cascade by direct photon processes
11190          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11191          IF (IPNT.GT.0) THEN
11192             JNT   = 1
11193             JS(1) = 1
11194             DO 11 INB=1,NB
11195                JT(INB) = JT0(K,INB)
11196                IF (JT(INB).GT.0) GOTO 12
11197    11       CONTINUE
11198    12       CONTINUE
11199             INTER1(1) = 1
11200             INTER2(1) = INB
11201             IDIREC    = IPNT
11202          ELSE
11203             JNT   = JNT0(K)
11204             JS(1) = JS0(K)
11205             DO 13 INB=1,NB
11206                JT(INB) = JT0(K,INB)
11207    13       CONTINUE
11208             DO 14 I=1,JNT
11209                INTER1(I) = JI1(K,I)
11210                INTER2(I) = JI2(K,I)
11211    14       CONTINUE
11212          ENDIF
11213       ENDIF
11214
11215    19 CONTINUE
11216       INTA = 0
11217       INTB = 0
11218       DO 6 I=1,NA
11219         IF (JS(I).NE.0) INTA=INTA+1
11220     6 CONTINUE
11221       DO 7 I=1,NB
11222         IF (JT(I).NE.0) INTB=INTB+1
11223     7 CONTINUE
11224       ICWPG = INTA
11225       ICWTG = INTB
11226       ICIG  = JNT
11227       IPGLB = IPGLB+INTA
11228       ITGLB = ITGLB+INTB
11229       NGLB = NGLB+1
11230
11231       IF (NCOMPO.EQ.0) THEN
11232          NCALL = NCALL+1
11233          NWA(INTA) = NWA(INTA)+1
11234          NWB(INTB) = NWB(INTB)+1
11235       ENDIF
11236
11237       RETURN
11238       END
11239 *
11240 *===modb===============================================================*
11241 *
11242 CDECK  ID>, DT_MODB
11243       SUBROUTINE DT_MODB(B,NIDX)
11244
11245 ************************************************************************
11246 * Sampling of impact parameter of collision.                           *
11247 *    B          impact parameter    (output)                           *
11248 *    NIDX       index of projectile/target material             (input)*
11249 * Based on the original version by Shmakov et al.                      *
11250 * This version dated 21.04.95 is revised by S. Roesler                 *
11251 ************************************************************************
11252
11253       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11254       SAVE
11255
11256       PARAMETER ( LINP = 5 ,
11257      &            LOUT = 6 ,
11258      &            LDAT = 9 )
11259
11260       PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11261
11262       LOGICAL LEFT,LFIRST
11263
11264 * central particle production, impact parameter biasing
11265       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11266
11267       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11268
11269 * Glauber formalism: parameters
11270       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11271      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11272      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11273      &                NSITEB,NSTATB
11274 * Glauber formalism: cross sections
11275       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11276      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11277      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11278      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11279      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11280      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11281      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11282      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11283      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11284      &                BSLOPE,NEBINI,NQBINI
11285
11286       DATA LFIRST /.TRUE./
11287
11288       NTARG = ABS(NIDX)
11289       IF (NIDX.LE.-1) THEN
11290          RA = RASH(1)
11291          RB = RBSH(NTARG)
11292       ELSE
11293          RA = RASH(NTARG)
11294          RB = RBSH(1)
11295       ENDIF
11296
11297       IF (ICENTR.EQ.2) THEN
11298          IF (RA.EQ.RB) THEN
11299             BB = DT_RNDM(B)*(0.3D0*RA)**2
11300             B  = SQRT(BB)
11301          ELSEIF(RA.LT.RB)THEN
11302             BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11303             B  = SQRT(BB)
11304          ELSEIF(RA.GT.RB)THEN
11305             BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11306             B  = SQRT(BB)
11307          ENDIF
11308       ELSE
11309     9    CONTINUE
11310          Y  = DT_RNDM(BB)
11311          I0 = 1
11312          I2 = NSITEB
11313    10    CONTINUE
11314          I1 = (I0+I2)/2
11315          LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11316      &          *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11317          IF (LEFT) GOTO 20
11318          I0 = I1
11319          GOTO 30
11320    20    CONTINUE
11321          I2 = I1
11322    30    CONTINUE
11323          IF (I2-I0-2) 40,50,60
11324    40    CONTINUE
11325          I1 = I2+1
11326          IF (I1.GT.NSITEB) I1 = I0-1
11327          GOTO 70
11328    50    CONTINUE
11329          I1 = I0+1
11330          GOTO 70
11331    60    CONTINUE
11332          GOTO 10
11333    70    CONTINUE
11334          X0 = DBLE(I0-1)*BSTEP(NTARG)
11335          X1 = DBLE(I1-1)*BSTEP(NTARG)
11336          X2 = DBLE(I2-1)*BSTEP(NTARG)
11337          Y0 = BSITE(0,1,NTARG,I0)
11338          Y1 = BSITE(0,1,NTARG,I1)
11339          Y2 = BSITE(0,1,NTARG,I2)
11340    80    CONTINUE
11341          B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11342      &       X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11343      &       X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11344 **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11345          B = B+0.5D0*BSTEP(NTARG)
11346          IF (B.LT.ZERO) B = X1
11347          IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11348          IF (ICENTR.LT.0) THEN
11349             IF (LFIRST) THEN
11350                LFIRST = .FALSE.
11351                IF (ICENTR.LE.-100) THEN
11352                   BIMIN  = 0.0D0
11353                ELSE
11354                   XSFRAC = 0.0D0
11355                ENDIF
11356                CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11357                WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11358      &                          BIMIN,BIMAX,XSFRAC*100.0D0,
11359      &                          XSFRAC*XSPRO(1,1,NTARG)
11360  10000         FORMAT(/,1X,'DT_MODB:      Biasing in impact parameter',
11361      &                /,15X,'---------------------------'/,/,4X,
11362      &                'average radii of proj / targ :',F10.3,' fm /',
11363      &                F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11364      &                F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11365      &                F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11366      &                ' cross section :',F10.3,' %',/,5X,
11367      &                'corresponding cross section :',F10.3,' mb',/)
11368             ENDIF
11369             IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11370                B = BIMIN
11371             ELSE
11372                IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11373             ENDIF
11374          ENDIF
11375       ENDIF
11376
11377       RETURN
11378       END
11379 *
11380 *===shfast=============================================================*
11381 *
11382 CDECK  ID>, DT_SHFAST
11383       SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11384
11385       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11386       SAVE
11387
11388       PARAMETER ( LINP = 5 ,
11389      &            LOUT = 6 ,
11390      &            LDAT = 9 )
11391
11392       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11393      &           ONE=1.0D0,TWO=2.0D0)
11394
11395       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11396
11397 * Glauber formalism: parameters
11398       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11399      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11400      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11401      &                NSITEB,NSTATB
11402 * properties of interacting particles
11403       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
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       IBACK = 0
11417
11418       IF (MODE.EQ.2) THEN
11419          OPEN(47,FILE='shmakov.out',STATUS='UNKNOWN')
11420          WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11421  1000    FORMAT(1X,8I5,E15.5)
11422          WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11423  1001    FORMAT(1X,4E15.5)
11424          WRITE(47,1002) SIGSH,ROSH,GSH
11425  1002    FORMAT(1X,3E15.5)
11426          DO 10 I=1,100
11427             WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11428    10    CONTINUE
11429          WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11430  1003    FORMAT(1X,2I10,3E15.5)
11431          CLOSE(47)
11432       ELSE
11433          OPEN(47,FILE='shmakov.out',STATUS='UNKNOWN')
11434          READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11435          IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11436      &       (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11437      &       .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11438      &       (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11439             READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11440             READ(47,1002) SIGSH,ROSH,GSH
11441             DO 11 I=1,100
11442                READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11443    11       CONTINUE
11444             READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11445          ELSE
11446             IBACK = 1
11447          ENDIF
11448          CLOSE(47)
11449       ENDIF
11450
11451       RETURN
11452       END
11453 *
11454 *===poilik=============================================================*
11455 *
11456 CDECK  ID>, DT_POILIK
11457       SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11458
11459       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11460       SAVE
11461
11462       PARAMETER ( LINP = 5 ,
11463      &            LOUT = 6 ,
11464      &            LDAT = 9 )
11465
11466       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11467       PARAMETER (NE = 8)
11468
11469 **PHOJET105a
11470 C     CHARACTER*8 MDLNA
11471 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11472 C     PARAMETER (IEETAB=10)
11473 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11474 **PHOJET110
11475 C  model switches and parameters
11476       CHARACTER*8 MDLNA
11477       INTEGER ISWMDL,IPAMDL
11478       DOUBLE PRECISION PARMDL
11479       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11480 C  energy-interpolation table
11481       INTEGER IEETA2
11482       PARAMETER ( IEETA2 = 20 )
11483       INTEGER ISIMAX
11484       DOUBLE PRECISION SIGTAB,SIGECM
11485       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11486 **
11487 * VDM parameter for photon-nucleus interactions
11488       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11489 **sr 22.7.97
11490
11491       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11492
11493 * Glauber formalism: cross sections
11494       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11495      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11496      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11497      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11498      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11499      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11500      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11501      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11502      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11503      &                BSLOPE,NEBINI,NQBINI
11504 **
11505
11506       DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
11507
11508       IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
11509
11510 * load cross sections from interpolation table
11511       IP = 1
11512       IF(ECM.LE.SIGECM(IP,1)) THEN
11513         I1 = 1
11514         I2 = 1
11515       ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
11516         DO 50 I=2,ISIMAX
11517           IF(ECM.LE.SIGECM(IP,I)) GOTO 200
11518   50    CONTINUE
11519  200    CONTINUE
11520         I1 = I-1
11521         I2 = I
11522       ELSE
11523         WRITE(LOUT,'(/1X,A,2E12.3)')
11524      &    'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
11525         I1 = ISIMAX
11526         I2 = ISIMAX
11527       ENDIF
11528       FAC2 = ZERO
11529       IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
11530      &                     /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
11531       FAC1 = ONE-FAC2
11532
11533       SIGANO = DT_SANO(ECM)
11534
11535 * cross section dependence on photon virtuality
11536       FSUP1 = ZERO
11537       DO  150 I=1,3
11538          FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
11539      &                             /(ONE+VIRT/PARMDL(30+I))**2
11540  150  CONTINUE
11541       FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
11542       FAC1  = FAC1*FSUP1
11543       FAC2  = FAC2*FSUP1
11544       FSUP2 = ONE
11545
11546       ECMOLD = ECM
11547       Q2OLD  = VIRT
11548
11549     3 CONTINUE
11550
11551 C     SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
11552       CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
11553       IF (ISHAD(1).EQ.1) THEN
11554          SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
11555       ELSE
11556          SIGDIR = ZERO
11557       ENDIF
11558       SIGANO = FSUP1*FSUP2*SIGANO
11559       SIGTOT = SIGTOT-SIGDIR-SIGANO
11560       SIGDIR = SIGDIR/(FSUP1*FSUP2)
11561       SIGANO = SIGANO/(FSUP1*FSUP2)
11562       SIGTOT = SIGTOT+SIGDIR+SIGANO
11563
11564       RR = DT_RNDM(SIGTOT)
11565       IF (RR.LT.SIGDIR/SIGTOT) THEN
11566          IPNT = 1
11567       ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
11568      &        (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
11569          IPNT = 2
11570       ELSE
11571          IPNT = 0
11572       ENDIF
11573       RPNT = (SIGDIR+SIGANO)/SIGTOT
11574 C     WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
11575 C     WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
11576 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
11577 C     WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
11578       IF (MODE.EQ.1) RETURN
11579
11580 **sr 22.7.97
11581       K1   = 1
11582       K2   = 1
11583       RATE = ZERO
11584       IF (ECM.GE.ECMNN(NEBINI)) THEN
11585          K1   = NEBINI
11586          K2   = NEBINI
11587          RATE = ONE
11588       ELSEIF (ECM.GT.ECMNN(1)) THEN
11589          DO 10 I=2,NEBINI
11590             IF (ECM.LT.ECMNN(I)) THEN
11591                K1   = I-1
11592                K2   = I
11593                RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
11594                GOTO 11
11595             ENDIF
11596    10    CONTINUE
11597    11    CONTINUE
11598       ENDIF
11599       J1   = 1
11600       J2   = 1
11601       RATQ = ZERO
11602       IF (NQBINI.GT.1) THEN
11603          IF (VIRT.GE.Q2G(NQBINI)) THEN
11604             J1   = NQBINI
11605             J2   = NQBINI
11606             RATQ = ONE
11607          ELSEIF (VIRT.GT.Q2G(1)) THEN
11608             DO 12 I=2,NQBINI
11609                IF (VIRT.LT.Q2G(I)) THEN
11610                   J1   = I-1
11611                   J2   = I
11612                   RATQ = LOG10(   VIRT/MAX(Q2G(J1),TINY14))/
11613      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11614                   GOTO 13
11615                ENDIF
11616    12       CONTINUE
11617    13       CONTINUE
11618          ENDIF
11619       ENDIF
11620       SGA = XSPRO(K1,J1,NTARG)+
11621      &      RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
11622      &      RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
11623      &      RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
11624      &                 XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
11625       SDI = DBLE(NB)*SIGDIR
11626       SAN = DBLE(NB)*SIGANO
11627       SPL = SDI+SAN
11628       RR = DT_RNDM(SPL)
11629       IF (RR.LT.SDI/SGA) THEN
11630          IPNT = 1
11631       ELSEIF ((RR.GE.SDI/SGA).AND.
11632      &        (RR.LT.SPL/SGA)) THEN
11633          IPNT = 2
11634       ELSE
11635          IPNT = 0
11636       ENDIF
11637       RPNT = SPL/SGA
11638 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
11639 **
11640
11641       RETURN
11642       END
11643 *
11644 *===glbini=============================================================*
11645 *
11646 CDECK  ID>, DT_GLBINI
11647       SUBROUTINE DT_GLBINI(WHAT)
11648
11649 ************************************************************************
11650 * Pre-initialization of profile function                               *
11651 * This version dated 28.11.00 is written by S. Roesler.                *
11652 ************************************************************************
11653
11654       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11655       SAVE
11656
11657       PARAMETER ( LINP = 5 ,
11658      &            LOUT = 6 ,
11659      &            LDAT = 9 )
11660
11661       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
11662
11663       LOGICAL LCMS
11664
11665 * particle properties (BAMJET index convention)
11666       CHARACTER*8  ANAME
11667       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11668      &                IICH(210),IIBAR(210),K1(210),K2(210)
11669 * properties of interacting particles
11670       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11671
11672       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11673
11674 * emulsion treatment
11675       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11676      &                NCOMPO,IEMUL
11677 * Glauber formalism: flags and parameters for statistics
11678       LOGICAL LPROD
11679       CHARACTER*8 CGLB
11680       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11681 * number of data sets other than protons and nuclei
11682 * at the moment = 2 (pions and kaons)
11683       PARAMETER (MAXOFF=2)
11684       DIMENSION IJPINI(5),IOFFST(25)
11685       DATA IJPINI / 13, 15,  0,  0,  0/
11686 * Glauber data-set to be used for hadron projectiles
11687 * (0=proton, 1=pion, 2=kaon)
11688       DATA (IOFFST(K),K=1,25) /
11689      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11690      &  0, 0, 1, 2, 2/
11691 * Acceptance interval for target nucleus mass
11692       PARAMETER (KBACC = 6)
11693
11694       PARAMETER (MAXMSS = 100)
11695       DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
11696       DIMENSION WHAT(6)
11697
11698       DATA JPEACH,JPSTEP / 18, 5 /
11699
11700 * temporary patch until fix has been implemented in phojet:
11701 *  maximum energy for pion projectile
11702       DATA ECMXPI / 100000.0D0 /
11703 *
11704 *--------------------------------------------------------------------------
11705 * general initializations
11706 *
11707 *  steps in projectile mass number for initialization
11708       IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
11709       IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
11710 *
11711 *  energy range and binning
11712       ELO  = ABS(WHAT(1))
11713       EHI  = ABS(WHAT(2))
11714       IF (ELO.GT.EHI) ELO = EHI
11715       NEBIN = MAX(INT(WHAT(3)),1)
11716       IF (ELO.EQ.EHI) NEBIN = 0
11717       LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
11718       IF (LCMS) THEN
11719          ECMINI = EHI
11720       ELSE
11721          ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
11722      &                 +2.0D0*AAM(IJTARG)*EHI)
11723       ENDIF
11724 *
11725 *  default arguments for Glauber-routine
11726       XI  = ZERO
11727       Q2I = ZERO
11728 *
11729 *  initialize nuclear parameters, etc.
11730
11731       CALL BERTTP
11732       CALL INCINI
11733
11734 *
11735 *  open Glauber-data output file
11736       IDX = INDEX(CGLB,' ')
11737       K   = 12
11738       IF (IDX.GT.1) K = IDX-1
11739       OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11740 *
11741 *--------------------------------------------------------------------------
11742 * Glauber-initialization for proton and nuclei projectiles
11743 *
11744 *  initialize phojet for proton-proton interactions
11745       ELAB = ZERO
11746       PLAB = ZERO
11747       CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11748       CALL DT_PHOINI
11749 *
11750 *  record projectile masses
11751       NASAV = 0
11752       NPROJ = MIN(IP,JPEACH)
11753       DO 10 KPROJ=1,NPROJ
11754          NASAV = NASAV+1
11755          IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11756          IASAV(NASAV) = KPROJ
11757    10 CONTINUE
11758       IF (IP.GT.JPEACH) THEN
11759          NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
11760          IF (NPROJ.EQ.0) THEN
11761             NASAV = NASAV+1
11762             IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11763             IASAV(NASAV) = IP
11764          ELSE
11765             DO 11 IPROJ=1,NPROJ
11766                KPROJ = JPEACH+IPROJ*JPSTEP
11767                NASAV = NASAV+1
11768                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11769                IASAV(NASAV) = KPROJ
11770    11       CONTINUE
11771             IF (KPROJ.LT.IP) THEN
11772                NASAV = NASAV+1
11773                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11774                IASAV(NASAV) = IP
11775             ENDIF
11776          ENDIF
11777       ENDIF
11778 *
11779 *  record target masses
11780       NBSAV = 0
11781       NTARG = 1
11782       IF (NCOMPO.GT.0) NTARG = NCOMPO
11783       DO 12 ITARG=1,NTARG
11784          NBSAV = NBSAV+1
11785          IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
11786          IF (NCOMPO.GT.0) THEN
11787             IBSAV(NBSAV) = IEMUMA(ITARG)
11788          ELSE
11789             IBSAV(NBSAV) = IT
11790          ENDIF
11791    12 CONTINUE
11792 *
11793 *  print masses
11794       WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
11795  1000 FORMAT(I4,A,1P,2E13.5)
11796       NLINES = DBLE(NASAV)/18.0D0
11797       IF (NLINES.GT.0) THEN
11798          DO 13 I=1,NLINES
11799             IF (I.EQ.1) THEN
11800                WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
11801             ELSE
11802                WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
11803             ENDIF
11804    13    CONTINUE
11805       ENDIF
11806       I0 = 18*NLINES+1
11807       IF (I0.LE.NASAV) THEN
11808          IF (I0.EQ.1) THEN
11809             WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
11810          ELSE
11811             WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
11812          ENDIF
11813       ENDIF
11814       NLINES = DBLE(NBSAV)/18.0D0
11815       IF (NLINES.GT.0) THEN
11816          DO 14 I=1,NLINES
11817             IF (I.EQ.1) THEN
11818                WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
11819             ELSE
11820                WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
11821             ENDIF
11822    14    CONTINUE
11823       ENDIF
11824       I0 = 18*NLINES+1
11825       IF (I0.LE.NBSAV) THEN
11826          IF (I0.EQ.1) THEN
11827             WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
11828          ELSE
11829             WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
11830          ENDIF
11831       ENDIF
11832 *
11833 *  calculate Glauber-data for each energy and mass combination
11834 *
11835 *   loop over energy bins
11836       ELO = LOG10(ELO)
11837       EHI = LOG10(EHI)
11838       DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
11839       DO 1 IE=1,NEBIN+1
11840          E = ELO+DBLE(IE-1)*DEBIN
11841          E = 10**E
11842          IF (LCMS) THEN
11843             E   = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
11844             ECM = E
11845          ELSE
11846             PLAB = ZERO
11847             ECM  = ZERO
11848             E    = MAX(AAM(IJPROJ)+0.1D0,E)
11849             CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11850          ENDIF
11851 *
11852 *   loop over projectile and target masses
11853          DO 2 ITARG=1,NBSAV
11854             DO 3 IPROJ=1,NASAV
11855                CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
11856      &                                       XI,Q2I,ECM,1,1,-1)
11857     3       CONTINUE
11858     2    CONTINUE
11859 *
11860     1 CONTINUE
11861 *
11862 *--------------------------------------------------------------------------
11863 * Glauber-initialization for pion, kaon, ... projectiles
11864 *
11865       DO 6 IJ=1,MAXOFF
11866 *
11867 *  initialize phojet for this interaction
11868          ELAB = ZERO
11869          PLAB = ZERO
11870          IJPROJ = IJPINI(IJ)
11871          IP     = 1
11872          IPZ    = 1
11873 *
11874 *   temporary patch until fix has been implemented in phojet:
11875          IF (ECMINI.GT.ECMXPI) THEN
11876             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
11877          ELSE
11878             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11879          ENDIF
11880          CALL DT_PHOINI
11881 *
11882 *  calculate Glauber-data for each energy and mass combination
11883 *
11884 *   loop over energy bins
11885          DO 4 IE=1,NEBIN+1
11886             E = ELO+DBLE(IE-1)*DEBIN
11887             E = 10**E
11888             IF (LCMS) THEN
11889                E   = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
11890                ECM = E
11891             ELSE
11892                PLAB = ZERO
11893                ECM  = ZERO
11894                E    = MAX(AAM(IJPROJ)+TINY14,E)
11895                CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11896             ENDIF
11897 *
11898 *   loop over projectile and target masses
11899             DO 5 ITARG=1,NBSAV
11900                CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
11901     5       CONTINUE
11902 *
11903     4    CONTINUE
11904 *
11905     6 CONTINUE
11906
11907 *--------------------------------------------------------------------------
11908 * close output unit(s), etc.
11909 *
11910       CLOSE(LDAT)
11911
11912       RETURN
11913       END
11914 *
11915 *===glbset=============================================================*
11916 *
11917 CDECK  ID>, DT_GLBSET
11918       SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
11919 ************************************************************************
11920 * Interpolation of pre-initialized profile functions                   *
11921 * This version dated 28.11.00 is written by S. Roesler.                *
11922 ************************************************************************
11923
11924       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11925       SAVE
11926
11927       PARAMETER ( LINP = 5 ,
11928      &            LOUT = 6 ,
11929      &            LDAT = 9 )
11930
11931       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
11932
11933       LOGICAL LCMS,LREAD,LFRST1,LFRST2
11934
11935 * particle properties (BAMJET index convention)
11936       CHARACTER*8  ANAME
11937       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11938      &                IICH(210),IIBAR(210),K1(210),K2(210)
11939 * Glauber formalism: flags and parameters for statistics
11940       LOGICAL LPROD
11941       CHARACTER*8 CGLB
11942       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11943
11944       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11945
11946 * Glauber formalism: parameters
11947       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11948      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11949      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11950      &                NSITEB,NSTATB
11951 * Glauber formalism: cross sections
11952       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11953      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11954      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11955      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11956      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11957      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11958      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11959      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11960      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11961      &                BSLOPE,NEBINI,NQBINI
11962 * number of data sets other than protons and nuclei
11963 * at the moment = 2 (pions and kaons)
11964       PARAMETER (MAXOFF=2)
11965       DIMENSION IJPINI(5),IOFFST(25)
11966       DATA IJPINI / 13, 15,  0,  0,  0/
11967 * Glauber data-set to be used for hadron projectiles
11968 * (0=proton, 1=pion, 2=kaon)
11969       DATA (IOFFST(K),K=1,25) /
11970      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11971      &  0, 0, 1, 2, 2/
11972 * Acceptance interval for target nucleus mass
11973       PARAMETER (KBACC = 6)
11974 * emulsion treatment
11975       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11976      &                NCOMPO,IEMUL
11977
11978       PARAMETER (MAXSET=5000,
11979      &           MAXBIN=100)
11980       DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
11981       DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
11982      &          BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
11983      &          IAIDX(10)
11984
11985       DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
11986 *
11987 * read data from file
11988 *
11989       IF (MODE.EQ.0) THEN
11990
11991          IF (LREAD) RETURN
11992
11993          DO 1 I=1,MAXSET
11994             DO 2 J=1,6
11995                XSIG(I,J) = ZERO
11996                XERR(I,J) = ZERO
11997     2       CONTINUE
11998             DO 3 J=1,KSITEB
11999                BPROFL(I,J) = ZERO
12000     3       CONTINUE
12001     1    CONTINUE
12002          DO 4 I=1,MAXBIN
12003             IABIN(I) = 0
12004             IBBIN(I) = 0
12005     4    CONTINUE
12006          DO 5 I=1,KSITEB
12007             BPRO0(I) = ZERO
12008             BPRO1(I) = ZERO
12009             BPRO(I)  = ZERO
12010     5    CONTINUE
12011
12012          IDX = INDEX(CGLB,' ')
12013          K   = 12
12014          IF (IDX.GT.1) K = IDX-1
12015          OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12016          WRITE(LOUT,1000) CGLB(1:K)//'.glb'
12017  1000    FORMAT(/,' GLBSET: impact parameter distributions read from ',
12018      &          'file ',A12,/)
12019 *
12020 *  read binning information
12021          READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
12022 *  return lower energy threshold to Fluka-interface
12023          ELAB = ELO
12024          LCMS = ELO.LT.ZERO
12025          WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
12026          IF (LCMS) THEN
12027             WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
12028          ELSE
12029             WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
12030          ENDIF
12031  1001    FORMAT(2X,A5,'  E_lo = ',1P,E9.3,'  E_hi = ',1P,E9.3,4X,
12032      &          'No. of bins:',I5,/)
12033          ELO  = LOG10(ABS(ELO))
12034          EHI  = LOG10(ABS(EHI))
12035          DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
12036          WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
12037          READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
12038          IF (NABIN.LT.18) THEN
12039             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
12040          ELSE
12041             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
12042          ENDIF
12043          IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
12044          IF (NABIN.GT.18) THEN
12045             NLINES = DBLE(NABIN-18)/18.0D0
12046             IF (NLINES.GT.0) THEN
12047                DO 7 I=1,NLINES
12048                   I0 = 18*(I+1)-17
12049                   READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12050                   WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12051     7          CONTINUE
12052             ENDIF
12053             I0 = 18*(NLINES+1)+1
12054             IF (I0.LE.NABIN) THEN
12055                READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12056                WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12057             ENDIF
12058          ENDIF
12059          WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
12060          READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
12061          IF (NBBIN.LT.18) THEN
12062             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
12063          ELSE
12064             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
12065          ENDIF
12066          IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
12067          IF (NBBIN.GT.18) THEN
12068             NLINES = DBLE(NBBIN-18)/18.0D0
12069             IF (NLINES.GT.0) THEN
12070                DO 8 I=1,NLINES
12071                   I0 = 18*(I+1)-17
12072                   READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12073                   WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12074     8          CONTINUE
12075             ENDIF
12076             I0 = 18*(NLINES+1)+1
12077             IF (I0.LE.NBBIN) THEN
12078                READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12079                WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12080             ENDIF
12081          ENDIF
12082 *  number of data sets to follow in the Glauber data file
12083 *   this variable is used for checks of consistency of projectile
12084 *   and target mass configurations given in header of Glauber data
12085 *   file and the data-sets which follow in this file
12086          NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
12087 *
12088 *  read profile function data
12089          NSET  = 0
12090          NAIDX = 0
12091          IPOLD = 0
12092    10    CONTINUE
12093          NSET = NSET+1
12094          IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
12095          READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
12096  1002    FORMAT(5I10,E15.5)
12097          IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12098             NAIDX = NAIDX+1
12099             IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12100             IAIDX(NAIDX) = IP
12101             IPOLD = IP
12102          ENDIF
12103          READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12104          READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12105          NLINES = INT(DBLE(ISITEB)/7.0D0)
12106          IF (NLINES.GT.0) THEN
12107             DO 11 I=1,NLINES
12108                READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12109    11       CONTINUE
12110          ENDIF
12111          I0 = 7*NLINES+1
12112          IF (I0.LE.ISITEB)
12113      &      READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12114          GOTO 10
12115   100    CONTINUE
12116          NSET = NSET-1
12117          IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12118          WRITE(LOUT,'(/,1X,A)')
12119      &   ' projectiles other than protons and nuclei: (particle index)'
12120          IF (NAIDX.GT.0) THEN
12121             WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12122          ELSE
12123             WRITE(LOUT,'(6X,A)') 'none'
12124          ENDIF
12125 *
12126          CLOSE(LDAT)
12127          WRITE(LOUT,*)
12128          LREAD = .TRUE.
12129
12130          IF (NCOMPO.EQ.0) THEN
12131             DO 12 J=1,NBBIN
12132                NCOMPO = NCOMPO+1
12133                IEMUMA(NCOMPO) = IBBIN(J)
12134                IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12135                EMUFRA(NCOMPO) = 1.0D0
12136    12       CONTINUE
12137             IEMUL = 1
12138          ENDIF
12139 *
12140 * calculate profile function for certain set of parameters
12141 *
12142       ELSE
12143
12144 c        write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12145 *
12146 * check for type of projectile and set index-offset to entry in
12147 * Glauber data array correspondingly
12148          IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12149          IF (IOFFST(IDPROJ).EQ.-1) THEN
12150             STOP ' GLBSET: no data for this projectile !'
12151          ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12152             IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12153          ELSE
12154             IDXOFF = 0
12155          ENDIF
12156 *
12157 * get energy bin and interpolation factor
12158          IF (LCMS) THEN
12159             E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12160          ELSE
12161             E = ELAB
12162          ENDIF
12163          E = LOG10(E)
12164          IF (E.LT.ELO) THEN
12165             IF (LFRST1) THEN
12166                WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12167                LFRST1 = .FALSE.
12168             ENDIF
12169             E = ELO
12170          ENDIF
12171          IF (E.GT.EHI) THEN
12172             IF (LFRST2) THEN
12173                WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12174                LFRST2 = .FALSE.
12175             ENDIF
12176             E = EHI
12177          ENDIF
12178          IE0  = (E-ELO)/DEBIN+1
12179          IE1  = IE0+1
12180          FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12181 *
12182 * get target nucleus index
12183          KB = 0
12184          NBACC = KBACC
12185          DO 20 I=1,NBBIN
12186             NBDIFF = ABS(NB-IBBIN(I))
12187             IF (NB.EQ.IBBIN(I)) THEN
12188                KB = I
12189                GOTO 21
12190             ELSEIF (NBDIFF.LE.NBACC) THEN
12191                KB = I
12192                NBACC = NBDIFF
12193             ENDIF
12194    20    CONTINUE
12195          IF (KB.NE.0) GOTO 21
12196          WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12197          STOP
12198    21    CONTINUE
12199 *
12200 * get projectile nucleus bin and interpolation factor
12201          KA0 = 0
12202          KA1 = 0
12203          FACNA = 0
12204          IF (IDXOFF.GT.0) THEN
12205             KA0 = 1
12206             KA1 = 1
12207             KABIN = 1
12208          ELSE
12209             IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12210             DO 22 I=1,NABIN
12211                IF (NA.EQ.IABIN(I)) THEN
12212                   KA0 = I
12213                   KA1 = I
12214                   GOTO 23
12215                ELSEIF (NA.LT.IABIN(I)) THEN
12216                   KA0 = I-1
12217                   KA1 = I
12218                   GOTO 23
12219                ENDIF
12220    22       CONTINUE
12221             WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12222             STOP
12223    23       CONTINUE
12224             IF (KA0.NE.KA1)
12225      &         FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12226             KABIN = NABIN
12227          ENDIF
12228 *
12229 * interpolate profile functions for interactions ka0-kb and ka1-kb
12230 * for energy E separately
12231          IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12232          IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12233          IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12234          IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12235          DO 30 I=1,ISITEB
12236             BPRO0(I) = BPROFL(IDX0,I)
12237      &                 +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12238             BPRO1(I) = BPROFL(IDY0,I)
12239      &                 +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12240    30    CONTINUE
12241          RADB  = DT_RNCLUS(NB)
12242          BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12243          BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12244 *
12245 * interpolate cross sections for energy E and projectile mass
12246          DO 31 I=1,6
12247             XS0   = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12248             XS1   = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12249             XS(I) = XS0+FACNA*(XS1-XS0)
12250             XE0   = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12251             XE1   = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12252             XE(I) = XE0+FACNA*(XE1-XE0)
12253    31    CONTINUE
12254 *
12255 * interpolate between ka0 and ka1
12256          RADA = DT_RNCLUS(NA)
12257          BMX  = 2.0D0*(RADA+RADB)
12258          BSTP = BMX/DBLE(ISITEB-1)
12259          BPRO(1) = ZERO
12260          DO 32 I=1,ISITEB-1
12261             B = DBLE(I)*BSTP
12262 *
12263 *   calculate values of profile functions at B
12264             IDX0 = B/BSTP0+1
12265             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12266             IDX1 = MIN(IDX0+1,ISITEB)
12267             FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12268             BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12269             IDX0 = B/BSTP1+1
12270             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12271             IDX1 = MIN(IDX0+1,ISITEB)
12272             FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12273             BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12274 *
12275             BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12276    32    CONTINUE
12277 *
12278 * fill common dtglam
12279          NSITEB   = ISITEB
12280          RASH(1)  = RADA
12281          RBSH(1)  = RADB
12282          BMAX(1)  = BMX
12283          BSTEP(1) = BSTP
12284          DO 33 I=1,KSITEB
12285             BSITE(0,1,1,I) = BPRO(I)
12286    33    CONTINUE
12287 *
12288 * fill common dtglxs
12289          XSTOT(1,1,1) = XS(1)
12290          XSELA(1,1,1) = XS(2)
12291          XSQEP(1,1,1) = XS(3)
12292          XSQET(1,1,1) = XS(4)
12293          XSQE2(1,1,1) = XS(5)
12294          XSPRO(1,1,1) = XS(6)
12295          XETOT(1,1,1) = XE(1)
12296          XEELA(1,1,1) = XE(2)
12297          XEQEP(1,1,1) = XE(3)
12298          XEQET(1,1,1) = XE(4)
12299          XEQE2(1,1,1) = XE(5)
12300          XEPRO(1,1,1) = XE(6)
12301
12302       ENDIF
12303
12304       RETURN
12305       END
12306 *
12307 *===xksamp=============================================================*
12308 *
12309 CDECK  ID>, DT_XKSAMP
12310       SUBROUTINE DT_XKSAMP(NN,ECM)
12311
12312 ************************************************************************
12313 * Sampling of parton x-values and chain system for one interaction.    *
12314 *                                   processed by S. Roesler, 9.8.95    *
12315 ************************************************************************
12316
12317       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12318       SAVE
12319
12320       PARAMETER ( LINP = 5 ,
12321      &            LOUT = 6 ,
12322      &            LDAT = 9 )
12323
12324       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12325       SAVE
12326
12327       PARAMETER (
12328 * lower cuts for (valence-sea/sea-valence) chain masses
12329 *   antiquark-quark (u/d-sea quark)    (s-sea quark)
12330      &               AMIU = 0.5D0,      AMIS = 0.8D0,
12331 *   quark-diquark   (u/d-sea quark)    (s-sea quark)
12332      &               AMAU = 2.6D0,      AMAS = 2.6D0,
12333 * maximum lower valence-x threshold
12334      &           XVMAX  = 0.98D0,
12335 * fraction of sea-diquarks sampled out of sea-partons
12336 **test
12337 C    &           FRCDIQ = 0.9D0,
12338 **
12339 *
12340      &           SQMA   = 0.7D0,
12341 *
12342 * maximum number of trials to generate x's for the required number
12343 * of sea quark pairs for a given hadron
12344 C    &           NSEATY = 12
12345      &           NSEATY = 3
12346      &          )
12347
12348       LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12349
12350       PARAMETER ( MAXNCL = 260,
12351
12352      &            MAXVQU = MAXNCL,
12353      &            MAXSQU = 20*MAXVQU,
12354      &            MAXINT = MAXVQU+MAXSQU)
12355 * event history
12356
12357       PARAMETER (NMXHKK=200000)
12358
12359       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12360      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12361      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12362 * particle properties (BAMJET index convention)
12363       CHARACTER*8  ANAME
12364       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12365      &                IICH(210),IIBAR(210),K1(210),K2(210)
12366 * interface between Glauber formalism and DPM
12367       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12368      &                INTER1(MAXINT),INTER2(MAXINT)
12369 * properties of interacting particles
12370       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12371 * threshold values for x-sampling (DTUNUC 1.x)
12372       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12373      &                SSMIMQ,VVMTHR
12374 * x-values of partons (DTUNUC 1.x)
12375       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12376      &                XTVQ(MAXVQU),XTVD(MAXVQU),
12377      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
12378      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
12379 * flavors of partons (DTUNUC 1.x)
12380       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12381      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12382      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
12383      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12384      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
12385      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12386      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
12387 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12388       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12389      &                IXPV,IXPS,IXTV,IXTS,
12390      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
12391      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
12392      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
12393      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
12394      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
12395      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
12396      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
12397      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
12398 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12399       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12400      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12401 * auxiliary common for chain system storage (DTUNUC 1.x)
12402       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12403 * flags for input different options
12404       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12405       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12406      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12407 * various options for treatment of partons (DTUNUC 1.x)
12408 * (chain recombination, Cronin,..)
12409       LOGICAL LCO2CR,LINTPT
12410       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12411      &                LCO2CR,LINTPT
12412
12413       DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12414      &          INTLO(MAXINT)
12415
12416 * (1) initializations
12417 *-----------------------------------------------------------------------
12418
12419 **test
12420       IF (ECM.LT.4.5D0) THEN
12421 C        FRCDIQ = 0.6D0
12422          FRCDIQ = 0.4D0
12423       ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12424 C        FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12425          FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12426       ELSE
12427 C        FRCDIQ = 0.9D0
12428          FRCDIQ = 0.7D0
12429       ENDIF
12430 **
12431       DO 30 I=1,MAXSQU
12432          ZUOSP(I) = .FALSE.
12433          ZUOST(I) = .FALSE.
12434          IF (I.LE.MAXVQU) THEN
12435             ZUOVP(I) = .FALSE.
12436             ZUOVT(I) = .FALSE.
12437          ENDIF
12438    30 CONTINUE
12439
12440 * lower thresholds for x-selection
12441 *  sea-quarks       (default: CSEA=0.2)
12442       IF (ECM.LT.10.0D0) THEN
12443 **!!test
12444          XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12445 C        XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12446          NSEA  = NSEATY
12447 C        XSTHR = ONE/ECM**2
12448       ELSE
12449 **sr 30.3.98
12450 C        XSTHR = CSEA/ECM
12451          XSTHR = CSEA/ECM**2
12452 C        XSTHR = ONE/ECM**2
12453 **
12454          IF ((IP.GE.150).AND.(IT.GE.150))
12455      &      XSTHR = 2.5D0/(ECM*SQRT(ECM))
12456          NSEA  = NSEATY
12457       ENDIF
12458 *                   (default: SSMIMA=0.14) used for sea-diquarks (?)
12459       XSSTHR = SSMIMA/ECM
12460       BSQMA  = SQMA/ECM
12461 *  valence-quarks   (default: CVQ=1.0)
12462       XVTHR  = CVQ/ECM
12463 *  valence-diquarks (default: CDQ=2.0)
12464       XDTHR  = CDQ/ECM
12465
12466 * maximum-x for sea-quarks
12467       XVCUT  = XVTHR+XDTHR
12468       IF (XVCUT.GT.XVMAX) THEN
12469          XVCUT = XVMAX
12470          XVTHR = XVCUT/3.0D0
12471          XDTHR = XVCUT-XVTHR
12472       ENDIF
12473       XXSEAM = ONE-XVCUT
12474 **sr 18.4. test: DPMJET
12475 C     XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
12476 C    &            - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
12477 C    &             -0.01*(1.D0+1.5D0*DT_RNDM(V3))
12478 **
12479 * maximum number of sea-pairs allowed kinematically
12480 C     NSMAX  = INT(OHALF*XXSEAM/XSTHR)
12481       RNSMAX = OHALF*XXSEAM/XSTHR
12482       IF (RNSMAX.GT.10000.0D0) THEN
12483          NSMAX = 10000
12484       ELSE
12485          NSMAX = INT(OHALF*XXSEAM/XSTHR)
12486       ENDIF
12487 * check kinematical limit for valence-x thresholds
12488 * (should be obsolete now)
12489       IF (XVCUT.GT.XVMAX) THEN
12490          WRITE(LOUT,1000) XVCUT,ECM
12491  1000    FORMAT(' XKSAMP:    kin. limit for valence-x',
12492      &          '  thresholds not allowed (',2E9.3,')')
12493 C        XVTHR = XVMAX-XDTHR
12494 C        IF (XVTHR.LT.ZERO) STOP
12495          STOP
12496       ENDIF
12497
12498 * set eta for valence-x sampling (BETREJ)
12499 *   (UNON per default, UNOM used for projectile mesons only)
12500       IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
12501          UNOPRV = UNOM
12502       ELSE
12503          UNOPRV = UNON
12504       ENDIF
12505
12506 * (2) select parton x-values of interacting projectile nucleons
12507 *-----------------------------------------------------------------------
12508
12509       IXPV = 0
12510       IXPS = 0
12511
12512       DO 100 IPP=1,IP
12513 *   get interacting projectile nucleon as sampled by Glauber
12514          IF (JSSH(IPP).NE.0) THEN
12515             IXSTMP = IXPS
12516             IXVTMP = IXPV
12517    99       CONTINUE
12518             IXPS   = IXSTMP
12519             IXPV   = IXVTMP
12520 *     JIPP is the actual number of sea-pairs sampled for this nucleon
12521             JIPP   = MIN(JSSH(IPP)-1,NSMAX)
12522    41       CONTINUE
12523             XXSEA  = ZERO
12524             IF (JIPP.GT.0) THEN
12525                XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
12526 *???
12527                IF (XSTHR.GE.XSMAX) THEN
12528                   JIPP = JIPP-1
12529                   GOTO 41
12530                ENDIF
12531
12532 *>>>get x-values of sea-quark pairs
12533                NSCOUN = 0
12534                PLW = 0.5D0
12535    40          CONTINUE
12536 *     accumulator for sea x-values
12537                XXSEA  = ZERO
12538                NSCOUN = NSCOUN+1
12539                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12540                IF (NSCOUN.GT.NSEA) THEN
12541 *     decrease the number of interactions after NSEA trials
12542                   JIPP   = JIPP-1
12543                   NSCOUN = 0
12544                ENDIF
12545                DO 70 ISQ=1,JIPP
12546 *     sea-quarks
12547                   IF (IPSQ(IXPS+1).LE.2) THEN
12548 **sr 8.4.98 (1/sqrt(x))
12549 C                    XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12550 C                    XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12551                      XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12552 **
12553                   ELSE
12554                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12555                         XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12556                      ELSE
12557 **sr 8.4.98 (1/sqrt(x))
12558 C                       XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12559 C                       XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12560                         XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12561 **
12562                      ENDIF
12563                   ENDIF
12564 *     sea-antiquarks
12565                   IF (IPSAQ(IXPS+1).GE.-2) THEN
12566 **sr 8.4.98 (1/sqrt(x))
12567 C                    XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12568 C                    XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12569                      XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12570 **
12571                   ELSE
12572                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12573                         XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12574                      ELSE
12575 **sr 8.4.98 (1/sqrt(x))
12576 C                       XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12577 C                       XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12578                         XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12579 **
12580                      ENDIF
12581                   ENDIF
12582                   XXSEA = XXSEA+XPSQI+XPSAQI
12583 *     check for maximum allowed sea x-value
12584                   IF (XXSEA.GE.XXSEAM) THEN
12585                      IXPS = IXPS-ISQ+1
12586                      GOTO 40
12587                   ENDIF
12588 *     accept this sea-quark pair
12589                   IXPS         = IXPS+1
12590                   XPSQ(IXPS)   = XPSQI
12591                   XPSAQ(IXPS)  = XPSAQI
12592                   IFROSP(IXPS) = IPP
12593                   ZUOSP(IXPS)  = .TRUE.
12594    70          CONTINUE
12595             ENDIF
12596
12597 *>>>get x-values of valence partons
12598 *     valence quark
12599             IF (XVTHR.GT.0.05D0) THEN
12600                XVHI  = ONE-XXSEA-XDTHR
12601                XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
12602             ELSE
12603    90          CONTINUE
12604                XPVQI = DT_DBETAR(OHALF,UNOPRV)
12605                IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
12606      &                                                     GOTO 90
12607             ENDIF
12608 *     valence diquark
12609             XPVDI = ONE-XPVQI-XXSEA
12610 *       reject according to x**1.5
12611             XDTMP = XPVDI**1.5D0
12612             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
12613 *     accept these valence partons
12614             IXPV         = IXPV+1
12615             XPVQ(IXPV)   = XPVQI
12616             XPVD(IXPV)   = XPVDI
12617             IFROVP(IXPV) = IPP
12618             ITOVP(IPP)   = IXPV
12619             ZUOVP(IXPV)  = .TRUE.
12620
12621          ENDIF
12622   100 CONTINUE
12623
12624 * (3) select parton x-values of interacting target nucleons
12625 *-----------------------------------------------------------------------
12626
12627       IXTV = 0
12628       IXTS = 0
12629
12630       DO 170 ITT=1,IT
12631 *   get interacting target nucleon as sampled by Glauber
12632          IF (JTSH(ITT).NE.0) THEN
12633             IXSTMP = IXTS
12634             IXVTMP = IXTV
12635   169       CONTINUE
12636             IXTS   = IXSTMP
12637             IXTV   = IXVTMP
12638 *     JITT is the actual number of sea-pairs sampled for this nucleon
12639             JITT   = MIN(JTSH(ITT)-1,NSMAX)
12640   111       CONTINUE
12641             XXSEA  = ZERO
12642             IF (JITT.GT.0) THEN
12643                XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
12644 *???
12645                IF (XSTHR.GE.XSMAX) THEN
12646                   JITT = JITT-1
12647                   GOTO 111
12648                ENDIF
12649
12650 *>>>get x-values of sea-quark pairs
12651                NSCOUN = 0
12652                PLW = 0.5D0
12653   110          CONTINUE
12654 *     accumulator for sea x-values
12655                XXSEA  = ZERO
12656                NSCOUN = NSCOUN+1
12657                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12658                IF (NSCOUN.GT.NSEA)THEN
12659 *     decrease the number of interactions after NSEA trials
12660                   JITT   = JITT-1
12661                   NSCOUN = 0
12662                ENDIF
12663                DO 140 ISQ=1,JITT
12664 *     sea-quarks
12665                   IF (ITSQ(IXTS+1).LE.2) THEN
12666 **sr 8.4.98 (1/sqrt(x))
12667 C                    XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12668 C                    XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12669                      XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12670 **
12671                   ELSE
12672                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12673                         XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12674                      ELSE
12675 **sr 8.4.98 (1/sqrt(x))
12676 C                       XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12677 C                       XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12678                         XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12679 **
12680                      ENDIF
12681                   ENDIF
12682 *     sea-antiquarks
12683                   IF (ITSAQ(IXTS+1).GE.-2) THEN
12684 **sr 8.4.98 (1/sqrt(x))
12685 C                    XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12686 C                    XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12687                      XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12688 **
12689                   ELSE
12690                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12691                         XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12692                      ELSE
12693 **sr 8.4.98 (1/sqrt(x))
12694 C                       XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12695 C                       XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12696                         XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12697 **
12698                      ENDIF
12699                   ENDIF
12700                   XXSEA = XXSEA+XTSQI+XTSAQI
12701 *     check for maximum allowed sea x-value
12702                   IF (XXSEA.GE.XXSEAM) THEN
12703                      IXTS = IXTS-ISQ+1
12704                      GOTO 110
12705                   ENDIF
12706 *     accept this sea-quark pair
12707                   IXTS         = IXTS+1
12708                   XTSQ(IXTS)   = XTSQI
12709                   XTSAQ(IXTS)  = XTSAQI
12710                   IFROST(IXTS) = ITT
12711                   ZUOST(IXTS)  = .TRUE.
12712   140          CONTINUE
12713             ENDIF
12714
12715 *>>>get x-values of valence partons
12716 *     valence quark
12717             IF (XVTHR.GT.0.05D0) THEN
12718                XVHI  = ONE-XXSEA-XDTHR
12719                XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
12720             ELSE
12721   160          CONTINUE
12722                XTVQI = DT_DBETAR(OHALF,UNON)
12723                IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
12724      &                                                    GOTO 160
12725             ENDIF
12726 *     valence diquark
12727             XTVDI = ONE-XTVQI-XXSEA
12728 *       reject according to x**1.5
12729             XDTMP = XTVDI**1.5D0
12730             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
12731 *     accept these valence partons
12732             IXTV         = IXTV+1
12733             XTVQ(IXTV)   = XTVQI
12734             XTVD(IXTV)   = XTVDI
12735             IFROVT(IXTV) = ITT
12736             ITOVT(ITT)   = IXTV
12737             ZUOVT(IXTV)  = .TRUE.
12738
12739          ENDIF
12740   170 CONTINUE
12741
12742 * (4) get valence-valence chains
12743 *-----------------------------------------------------------------------
12744
12745       NVV = 0
12746       DO 240 I=1,NN
12747          INTLO(I) = .TRUE.
12748          IPVAL    = ITOVP(INTER1(I))
12749          ITVAL    = ITOVT(INTER2(I))
12750          IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
12751             INTLO(I)      = .FALSE.
12752             ZUOVP(IPVAL)  = .FALSE.
12753             ZUOVT(ITVAL)  = .FALSE.
12754             NVV           = NVV+1
12755             ISKPCH(8,NVV) = 0
12756             INTVV1(NVV)   = IPVAL
12757             INTVV2(NVV)   = ITVAL
12758          ENDIF
12759   240 CONTINUE
12760
12761 * (5) get sea-valence chains
12762 *-----------------------------------------------------------------------
12763
12764       NSV = 0
12765       NDV = 0
12766       PLW = 0.5D0
12767       DO 270 I=1,NN
12768          IF (INTLO(I)) THEN
12769             IPVAL = ITOVP(INTER1(I))
12770             ITVAL = ITOVT(INTER2(I))
12771             DO 250 J=1,IXPS
12772                IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
12773      &                                ZUOVT(ITVAL)) THEN
12774                   ZUOSP(J)     = .FALSE.
12775                   ZUOVT(ITVAL) = .FALSE.
12776                   INTLO(I)     = .FALSE.
12777                   IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
12778 *   sample sea-diquark pair
12779                      CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
12780                      IF (IREJ1.EQ.0) GOTO 260
12781                   ENDIF
12782                   NSV           = NSV+1
12783                   ISKPCH(4,NSV) = 0
12784                   INTSV1(NSV)   = J
12785                   INTSV2(NSV)   = ITVAL
12786
12787 *>>>correct chain kinematics according to minimum chain masses
12788 *     the actual chain masses
12789                   AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
12790                   AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
12791 *     get lower mass cuts
12792                   IF (IPSQ(J).EQ.3) THEN
12793 *       q being s-quark
12794                      AMCHK1 = AMAS
12795                      AMCHK2 = AMIS
12796                   ELSE
12797 *       q being u/d-quark
12798                      AMCHK1 = AMAU
12799                      AMCHK2 = AMIU
12800                   ENDIF
12801 *       q-qq chain
12802 *         chain mass above minimum - resampling of sea-q x-value
12803                   IF (AMSVQ1.GT.AMCHK1) THEN
12804                      XPSQTH      = AMCHK1/(XTVD(ITVAL)*ECM**2)
12805 **sr 8.4.98 (1/sqrt(x))
12806 C                    XPSQXX      = DT_SAMPEX(XPSQTH,XPSQ(J))
12807 C                    XPSQXX      = DT_SAMSQX(XPSQTH,XPSQ(J))
12808                      XPSQXX      = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
12809 **
12810                      XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
12811                      XPSQ(J)     = XPSQXX
12812 *         chain mass below minimum - reset sea-q x-value and correct
12813 *                                    diquark-x of the same nucleon
12814                   ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12815                      XPSQW       = AMCHK1/(XTVD(ITVAL)*ECM**2)
12816                      DXPSQ       = XPSQW-XPSQ(J)
12817                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12818                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12819                         XPSQ(J)     = XPSQW
12820                      ENDIF
12821                   ENDIF
12822 *       aq-q chain
12823 *         chain mass below minimum - reset sea-aq x-value and correct
12824 *                                    diquark-x of the same nucleon
12825                   IF (AMSVQ2.LT.AMCHK2) THEN
12826                      XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
12827                      DXPSQ = XPSQW-XPSAQ(J)
12828                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12829                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12830                         XPSAQ(J)    = XPSQW
12831                      ENDIF
12832                   ENDIF
12833 *>>>end of chain mass correction
12834
12835                   GOTO 260
12836                ENDIF
12837   250       CONTINUE
12838          ENDIF
12839   260    CONTINUE
12840   270 CONTINUE
12841
12842 * (6) get valence-sea chains
12843 *-----------------------------------------------------------------------
12844
12845       NVS = 0
12846       NVD = 0
12847       DO 300 I=1,NN
12848          IF (INTLO(I)) THEN
12849             IPVAL = ITOVP(INTER1(I))
12850             ITVAL = ITOVT(INTER2(I))
12851             DO 280 J=1,IXTS
12852                IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
12853      &                  (IFROST(J).EQ.INTER2(I))) THEN
12854                   ZUOST(J)     = .FALSE.
12855                   ZUOVP(IPVAL) = .FALSE.
12856                   INTLO(I)     = .FALSE.
12857                   IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
12858 *   sample sea-diquark pair
12859                      CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
12860                      IF (IREJ1.EQ.0) GOTO 290
12861                   ENDIF
12862                   NVS           = NVS + 1
12863                   ISKPCH(6,NVS) = 0
12864                   INTVS1(NVS)   = IPVAL
12865                   INTVS2(NVS)   = J
12866
12867 *>>>correct chain kinematics according to minimum chain masses
12868 *     the actual chain masses
12869                   AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
12870                   AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
12871 *     get lower mass cuts
12872                   IF (ITSQ(J).EQ.3) THEN
12873 *       q being s-quark
12874                      AMCHK1 = AMIS
12875                      AMCHK2 = AMAS
12876                   ELSE
12877 *       q being u/d-quark
12878                      AMCHK1 = AMIU
12879                      AMCHK2 = AMAU
12880                   ENDIF
12881 *       q-aq chain
12882 *         chain mass below minimum - reset sea-aq x-value and correct
12883 *                                    diquark-x of the same nucleon
12884                   IF (AMVSQ1.LT.AMCHK1) THEN
12885                      XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
12886                      DXTSQ = XTSQW-XTSAQ(J)
12887                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12888                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12889                         XTSAQ(J)    = XTSQW
12890                      ENDIF
12891                   ENDIF
12892 *       qq-q chain
12893 *         chain mass above minimum - resampling of sea-q x-value
12894                   IF (AMVSQ2.GT.AMCHK2) THEN
12895                      XTSQTH      = AMCHK2/(XPVD(IPVAL)*ECM**2)
12896 **sr 8.4.98 (1/sqrt(x))
12897 C                    XTSQXX      = DT_SAMPEX(XTSQTH,XTSQ(J))
12898 C                    XTSQXX      = DT_SAMSQX(XTSQTH,XTSQ(J))
12899                      XTSQXX      = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
12900 **
12901                      XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
12902                      XTSQ(J)     = XTSQXX
12903 *         chain mass below minimum - reset sea-q x-value and correct
12904 *                                    diquark-x of the same nucleon
12905                   ELSEIF (AMVSQ2.LT.AMCHK2) THEN
12906                      XTSQW       = AMCHK2/(XPVD(IPVAL)*ECM**2)
12907                      DXTSQ       = XTSQW-XTSQ(J)
12908                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12909                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12910                         XTSQ(J)     = XTSQW
12911                      ENDIF
12912                   ENDIF
12913 *>>>end of chain mass correction
12914
12915                   GOTO 290
12916                ENDIF
12917   280       CONTINUE
12918          ENDIF
12919   290    CONTINUE
12920   300 CONTINUE
12921
12922 * (7) get sea-sea chains
12923 *-----------------------------------------------------------------------
12924
12925       NSS = 0
12926       NDS = 0
12927       NSD = 0
12928       DO 420 I=1,NN
12929          IF (INTLO(I)) THEN
12930             IPVAL = ITOVP(INTER1(I))
12931             ITVAL = ITOVT(INTER2(I))
12932 *   loop over target partons not yet matched
12933             DO 400 J=1,IXTS
12934                IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
12935 *   loop over projectile partons not yet matched
12936                   DO 390 JJ=1,IXPS
12937                      IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
12938                         ZUOSP(JJ)     = .FALSE.
12939                         ZUOST(J)      = .FALSE.
12940                         INTLO(I)      = .FALSE.
12941                         NSS           = NSS+1
12942                         ISKPCH(1,NSS) = 0
12943                         INTSS1(NSS)   = JJ
12944                         INTSS2(NSS)   = J
12945
12946 *---->chain recombination option
12947                         VALFRA        = DBLE(NVV/(NVV+IXPS+IXTS))
12948                         IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
12949      &                                                             THEN
12950 *       sea-sea chains may recombine with valence-valence chains
12951 *       only if they have the same projectile or target nucleon
12952                            DO 4201 IVV=1,NVV
12953                               IF (ISKPCH(8,IVV).NE.99) THEN
12954                                  IXVPR = INTVV1(IVV)
12955                                  IXVTA = INTVV2(IVV)
12956                                  IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
12957      &                               (INTER2(I).EQ.IFROVT(IXVTA))) THEN
12958 *         recombination possible, drop old v-v and s-s chains
12959                                     ISKPCH(1,NSS) = 99
12960                                     ISKPCH(8,IVV) = 99
12961
12962 *         (a) assign new s-v chains
12963 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
12964                                     IF (LSEADI.AND.
12965      &                                  (DT_RNDM(VALFRA).GT.FRCDIQ))
12966      &                                                             THEN
12967 *           sample sea-diquark pair
12968                                        CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
12969      &                                                      IREJ1)
12970                                        IF (IREJ1.EQ.0) GOTO 4202
12971                                     ENDIF
12972                                     NSV           = NSV+1
12973                                     ISKPCH(4,NSV) = 0
12974                                     INTSV1(NSV)   = JJ
12975                                     INTSV2(NSV)   = IXVTA
12976 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12977 *           the actual chain masses
12978                                     AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
12979      &                                                     *ECM**2
12980                                     AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
12981      &                                                     *ECM**2
12982 *           get lower mass cuts
12983                                     IF (IPSQ(JJ).EQ.3) THEN
12984 *             q being s-quark
12985                                        AMCHK1 = AMAS
12986                                        AMCHK2 = AMIS
12987                                     ELSE
12988 *             q being u/d-quark
12989                                        AMCHK1 = AMAU
12990                                        AMCHK2 = AMIU
12991                                     ENDIF
12992 *           q-qq chain
12993 *             chain mass above minimum - resampling of sea-q x-value
12994                                     IF (AMSVQ1.GT.AMCHK1) THEN
12995                                        XPSQTH      =
12996      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
12997 **sr 8.4.98 (1/sqrt(x))
12998                                        XPSQXX      =
12999      &                                    DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
13000 C    &                                    DT_SAMSQX(XPSQTH,XPSQ(JJ))
13001 C    &                                    DT_SAMPEX(XPSQTH,XPSQ(JJ))
13002 **
13003                                        XPVD(IPVAL) =
13004      &                                    XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
13005                                        XPSQ(JJ)    = XPSQXX
13006 *             chain mass below minimum - reset sea-q x-value and correct
13007 *                                        diquark-x of the same nucleon
13008                                     ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13009                                        XPSQW =
13010      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
13011                                        DXPSQ = XPSQW-XPSQ(JJ)
13012                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13013      &                                                            THEN
13014                                           XPVD(IPVAL) =
13015      &                                       XPVD(IPVAL)-DXPSQ
13016                                           XPSQ(JJ)    = XPSQW
13017                                        ENDIF
13018                                     ENDIF
13019 *           aq-q chain
13020 *             chain mass below minimum - reset sea-aq x-value and correct
13021 *                                        diquark-x of the same nucleon
13022                                     IF (AMSVQ2.LT.AMCHK2) THEN
13023                                        XPSQW =
13024      &                                    AMCHK2/(XTVQ(IXVTA)*ECM**2)
13025                                        DXPSQ = XPSQW-XPSAQ(JJ)
13026                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13027      &                                                            THEN
13028                                           XPVD(IPVAL) =
13029      &                                       XPVD(IPVAL)-DXPSQ
13030                                           XPSAQ(JJ)   = XPSQW
13031                                        ENDIF
13032                                     ENDIF
13033 *>>>>>>>>>>>end of chain mass correction
13034  4202                               CONTINUE
13035
13036 *         (b) assign new v-s chains
13037 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
13038                                     IF (LSEADI.AND.(
13039      &                                  DT_RNDM(AMSVQ2).GT.FRCDIQ))
13040      &                                                             THEN
13041 *           sample sea-diquark pair
13042                                        CALL DT_SAMSDQ(ECM,IXVPR,J,1,
13043      &                                                      IREJ1)
13044                                        IF (IREJ1.EQ.0) GOTO 4203
13045                                     ENDIF
13046                                     NVS           = NVS+1
13047                                     ISKPCH(6,NVS) = 0
13048                                     INTVS1(NVS)   = IXVPR
13049                                     INTVS2(NVS)   = J
13050 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13051 *           the actual chain masses
13052                                     AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
13053                                     AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
13054 *           get lower mass cuts
13055                                     IF (ITSQ(J).EQ.3) THEN
13056 *             q being s-quark
13057                                        AMCHK1 = AMIS
13058                                        AMCHK2 = AMAS
13059                                     ELSE
13060 *             q being u/d-quark
13061                                        AMCHK1 = AMIU
13062                                        AMCHK2 = AMAU
13063                                     ENDIF
13064 *           q-aq chain
13065 *             chain mass below minimum - reset sea-aq x-value and correct
13066 *                                        diquark-x of the same nucleon
13067                                     IF (AMVSQ1.LT.AMCHK1) THEN
13068                                        XTSQW =
13069      &                                    AMCHK1/(XPVQ(IXVPR)*ECM**2)
13070                                        DXTSQ = XTSQW-XTSAQ(J)
13071                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13072      &                                                            THEN
13073                                           XTVD(ITVAL) =
13074      &                                       XTVD(ITVAL)-DXTSQ
13075                                           XTSAQ(J)    = XTSQW
13076                                        ENDIF
13077                                     ENDIF
13078                                     IF (AMVSQ2.GT.AMCHK2) THEN
13079                                        XTSQTH      =
13080      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
13081 **sr 8.4.98 (1/sqrt(x))
13082                                        XTSQXX      =
13083      &                                    DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13084 C    &                                    DT_SAMSQX(XTSQTH,XTSQ(J))
13085 C    &                                    DT_SAMPEX(XTSQTH,XTSQ(J))
13086 **
13087                                        XTVD(ITVAL) =
13088      &                                    XTVD(ITVAL)+XTSQ(J)-XTSQXX
13089                                        XTSQ(J)     = XTSQXX
13090                                     ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13091                                        XTSQW =
13092      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
13093                                        DXTSQ = XTSQW-XTSQ(J)
13094                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13095      &                                                            THEN
13096                                           XTVD(ITVAL) =
13097      &                                       XTVD(ITVAL)-DXTSQ
13098                                           XTSQ(J)     = XTSQW
13099                                        ENDIF
13100                                     ENDIF
13101 *>>>>>>>>>end of chain mass correction
13102  4203                               CONTINUE
13103 *       jump out of s-s chain loop
13104                                     GOTO 420
13105                                  ENDIF
13106                               ENDIF
13107  4201                      CONTINUE
13108                         ENDIF
13109 *---->end of chain recombination option
13110
13111 *     sample sea-diquark pair (projectile)
13112                         IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13113                            CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13114                            IF (IREJ1.EQ.0) THEN
13115                               ISKPCH(1,NSS) = 99
13116                               GOTO 410
13117                            ENDIF
13118                         ENDIF
13119 *     sample sea-diquark pair (target)
13120                         IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13121                            CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13122                            IF (IREJ1.EQ.0) THEN
13123                               ISKPCH(1,NSS) = 99
13124                               GOTO 410
13125                            ENDIF
13126                         ENDIF
13127 *>>>>>correct chain kinematics according to minimum chain masses
13128 *     the actual chain masses
13129                         SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13130                         SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13131 *     check for lower mass cuts
13132                         IF ((SSMA1Q.LT.SSMIMQ).OR.
13133      &                      (SSMA2Q.LT.SSMIMQ)) THEN
13134                            IPVAL = ITOVP(INTER1(I))
13135                            ITVAL = ITOVT(INTER2(I))
13136                            IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13137      &                         (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13138 *       maximum allowed x values for sea quarks
13139                               XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13140      &                                           1.2D0*XSSTHR
13141                               XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13142      &                                           1.2D0*XSSTHR
13143 *       resampling of x values not possible - skip sea-sea chains
13144                               IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13145      &                            (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13146 *       resampling of x for projectile sea quark pair
13147                               ICOUS = 0
13148   310                         CONTINUE
13149                               ICOUS = ICOUS+1
13150                               IF (XSSTHR.GT.0.05D0) THEN
13151                                  XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13152      &                                                         XSPMAX)
13153                                  XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13154      &                                                         XSPMAX)
13155                               ELSE
13156   320                            CONTINUE
13157                                  XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13158                                  IF ((XPSQI.LT.XSSTHR).OR.
13159      &                               (XPSQI.GT.XSPMAX))  GOTO 320
13160   330                            CONTINUE
13161                                  XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13162                                  IF ((XPSAQI.LT.XSSTHR).OR.
13163      &                               (XPSAQI.GT.XSPMAX)) GOTO 330
13164                               ENDIF
13165 *       final test of remaining x for projectile diquark
13166                               XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13167      &                                            +XPSQ(JJ)+XPSAQ(JJ)
13168                               IF (XPVDCO.LE.XDTHR) THEN
13169 *!!!
13170 C                                IF (ICOUS.LT.5) GOTO 310
13171                                  IF (ICOUS.LT.0.5D0) GOTO 310
13172                                  GOTO 380
13173                               ENDIF
13174 *       resampling of x for target sea quark pair
13175                               ICOUS = 0
13176   350                         CONTINUE
13177                               ICOUS = ICOUS+1
13178                               IF (XSSTHR.GT.0.05D0) THEN
13179                                  XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13180      &                                                         XSTMAX)
13181                                  XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13182      &                                                         XSTMAX)
13183                               ELSE
13184   360                            CONTINUE
13185                                  XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13186                                  IF ((XTSQI.LT.XSSTHR).OR.
13187      &                               (XTSQI.GT.XSTMAX))  GOTO 360
13188   370                            CONTINUE
13189                                  XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13190                                  IF ((XTSAQI.LT.XSSTHR).OR.
13191      &                               (XTSAQI.GT.XSTMAX)) GOTO 370
13192                               ENDIF
13193 *       final test of remaining x for target diquark
13194                               XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13195      &                                            +XTSQ(J)+XTSAQ(J)
13196                               IF (XTVDCO.LT.XDTHR) THEN
13197                                  IF (ICOUS.LT.5) GOTO 350
13198                                  GOTO 380
13199                               ENDIF
13200                               XPVD(IPVAL) = XPVDCO
13201                               XTVD(ITVAL) = XTVDCO
13202                               XPSQ(JJ)    = XPSQI
13203                               XPSAQ(JJ)   = XPSAQI
13204                               XTSQ(J)     = XTSQI
13205                               XTSAQ(J)    = XTSAQI
13206 *>>>>>end of chain mass correction
13207                               GOTO 410
13208                            ENDIF
13209 *     come here to discard s-s interaction
13210 *     resampling of x values not allowed or unsuccessful
13211   380                      CONTINUE
13212                            INTLO(I)  = .FALSE.
13213                            ZUOST(J)  = .TRUE.
13214                            ZUOSP(JJ) = .TRUE.
13215                            NSS       = NSS-1
13216                         ENDIF
13217 *   consider next s-s interaction
13218                         GOTO 410
13219                      ENDIF
13220   390             CONTINUE
13221                ENDIF
13222   400       CONTINUE
13223          ENDIF
13224   410    CONTINUE
13225   420 CONTINUE
13226
13227 * correct x-values of valence quarks for non-matching sea quarks
13228       DO 430 I=1,IXPS
13229          IF (ZUOSP(I)) THEN
13230             IPVAL       = ITOVP(IFROSP(I))
13231             XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13232             XPSQ(I)     = ZERO
13233             XPSAQ(I)    = ZERO
13234             ZUOSP(I)    = .FALSE.
13235          ENDIF
13236   430 CONTINUE
13237       DO 440 I=1,IXTS
13238          IF (ZUOST(I)) THEN
13239             ITVAL       = ITOVT(IFROST(I))
13240             XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13241             XTSQ(I)     = ZERO
13242             XTSAQ(I)    = ZERO
13243             ZUOST(I)    = .FALSE.
13244          ENDIF
13245   440 CONTINUE
13246       DO 450 I=1,IXPV
13247          IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13248   450 CONTINUE
13249       DO 460 I=1,IXTV
13250          IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13251   460 CONTINUE
13252
13253       RETURN
13254       END
13255 *
13256 *===samsdq=============================================================*
13257 *
13258 CDECK  ID>, DT_SAMSDQ
13259       SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13260
13261 ************************************************************************
13262 * SAMpling of Sea-DiQuarks                                             *
13263 *              ECM        cm-energy of the nucleon-nucleon system      *
13264 *              IDX1,2     indices of x-values of the participating     *
13265 *                         partons (IDX2 is always the sea-q-pair to be *
13266 *                         changed to sea-qq-pair)                      *
13267 *              MODE       = 1  valence-q - sea-diq                     *
13268 *                         = 2  sea-diq   - valence-q                   *
13269 *                         = 3  sea-q     - sea-diq                     *
13270 *                         = 4  sea-diq   - sea-q                       *
13271 * Based on DIQVS, DIQSV, DIQSSD, DIQDSS.                               *
13272 * This version dated 17.10.95 is written by S. Roesler                 *
13273 ************************************************************************
13274
13275       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13276       SAVE
13277
13278       PARAMETER (ZERO=0.0D0)
13279
13280 * threshold values for x-sampling (DTUNUC 1.x)
13281       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13282      &                SSMIMQ,VVMTHR
13283 * various options for treatment of partons (DTUNUC 1.x)
13284 * (chain recombination, Cronin,..)
13285       LOGICAL LCO2CR,LINTPT
13286       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13287      &                LCO2CR,LINTPT
13288
13289       PARAMETER ( MAXNCL = 260,
13290
13291      &            MAXVQU = MAXNCL,
13292      &            MAXSQU = 20*MAXVQU,
13293      &            MAXINT = MAXVQU+MAXSQU)
13294 * x-values of partons (DTUNUC 1.x)
13295       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13296      &                XTVQ(MAXVQU),XTVD(MAXVQU),
13297      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
13298      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
13299 * flavors of partons (DTUNUC 1.x)
13300       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13301      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13302      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
13303      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13304      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
13305      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13306      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
13307 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13308       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13309      &                IXPV,IXPS,IXTV,IXTS,
13310      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
13311      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
13312      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
13313      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
13314      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
13315      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
13316      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
13317      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
13318 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13319       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13320      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13321 * auxiliary common for chain system storage (DTUNUC 1.x)
13322       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13323
13324       IREJ = 0
13325 *  threshold-x for valence diquarks
13326       XDTHR = CDQ/ECM
13327
13328       GOTO (1,2,3,4) MODE
13329
13330 *---------------------------------------------------------------------
13331 * proj. valence partons - targ. sea partons
13332 * get x-values and flavors for target sea-diquark pair
13333
13334     1 CONTINUE
13335       IDXVP = IDX1
13336       IDXST = IDX2
13337
13338 *  index of corr. val-diquark-x in target nucleon
13339       IDXVT = ITOVT(IFROST(IDXST))
13340 *  available x above diquark thresholds for valence- and sea-diquarks
13341       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13342
13343       IF (XXD.GE.ZERO) THEN
13344 *  x-values for the three diquarks of the target nucleon
13345          RR1    = DT_RNDM(XXD)
13346          RR2    = DT_RNDM(RR1)
13347          RR3    = DT_RNDM(RR2)
13348          SR123  = RR1+RR2+RR3
13349          XXTV   = XDTHR+RR1*XXD/SR123
13350          XXTSQ  = XDTHR+RR2*XXD/SR123
13351          XXTSAQ = XDTHR+RR3*XXD/SR123
13352       ELSE
13353          XXTV   = XTVD(IDXVT)
13354          XXTSQ  = XTSQ(IDXST)
13355          XXTSAQ = XTSAQ(IDXST)
13356       ENDIF
13357 *  flavor of the second quarks in the sea-diquark pair
13358       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13359       ITSAQ2(IDXST) = -ITSQ2(IDXST)
13360 *  check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13361       AM1    = XXTSQ *XPVQ(IDXVP)*ECM**2
13362       AM2    = XXTSAQ*XPVD(IDXVP)*ECM**2
13363       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13364 *    ss-asas pair
13365      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13366          IREJ = 1
13367          RETURN
13368       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13369 *    at least one strange quark
13370      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13371          IREJ = 1
13372          RETURN
13373       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13374          IREJ = 1
13375          RETURN
13376       ENDIF
13377 *  accept the new sea-diquark
13378       XTVD(IDXVT)   = XXTV
13379       XTSQ(IDXST)   = XXTSQ
13380       XTSAQ(IDXST)  = XXTSAQ
13381       NVD           = NVD+1
13382       INTVD1(NVD)   = IDXVP
13383       INTVD2(NVD)   = IDXST
13384       ISKPCH(7,NVD) = 0
13385       RETURN
13386
13387 *---------------------------------------------------------------------
13388 * proj. sea partons - targ. valence partons
13389 * get x-values and flavors for projectile sea-diquark pair
13390
13391     2 CONTINUE
13392       IDXSP = IDX2
13393       IDXVT = IDX1
13394
13395 *  index of corr. val-diquark-x in projectile nucleon
13396       IDXVP = ITOVP(IFROSP(IDXSP))
13397 *  available x above diquark thresholds for valence- and sea-diquarks
13398       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13399
13400       IF (XXD.GE.ZERO) THEN
13401 *  x-values for the three diquarks of the projectile nucleon
13402          RR1    = DT_RNDM(XXD)
13403          RR2    = DT_RNDM(RR1)
13404          RR3    = DT_RNDM(RR2)
13405          SR123  = RR1+RR2+RR3
13406          XXPV   = XDTHR+RR1*XXD/SR123
13407          XXPSQ  = XDTHR+RR2*XXD/SR123
13408          XXPSAQ = XDTHR+RR3*XXD/SR123
13409       ELSE
13410          XXPV   = XPVD(IDXVP)
13411          XXPSQ  = XPSQ(IDXSP)
13412          XXPSAQ = XPSAQ(IDXSP)
13413       ENDIF
13414 *  flavor of the second quarks in the sea-diquark pair
13415       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13416       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13417 *  check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13418       AM1    = XXPSQ *XTVQ(IDXVT)*ECM**2
13419       AM2    = XXPSAQ*XTVD(IDXVT)*ECM**2
13420       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13421 *    ss-asas pair
13422      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13423          IREJ = 1
13424          RETURN
13425       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13426 *    at least one strange quark
13427      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13428          IREJ = 1
13429          RETURN
13430       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13431          IREJ = 1
13432          RETURN
13433       ENDIF
13434 *  accept the new sea-diquark
13435       XPVD(IDXVP)   = XXPV
13436       XPSQ(IDXSP)   = XXPSQ
13437       XPSAQ(IDXSP)  = XXPSAQ
13438       NDV           = NDV+1
13439       INTDV1(NDV)   = IDXSP
13440       INTDV2(NDV)   = IDXVT
13441       ISKPCH(5,NDV) = 0
13442       RETURN
13443
13444 *---------------------------------------------------------------------
13445 * proj. sea partons - targ. sea partons
13446 * get x-values and flavors for target sea-diquark pair
13447
13448     3 CONTINUE
13449       IDXSP = IDX1
13450       IDXST = IDX2
13451
13452 *  index of corr. val-diquark-x in target nucleon
13453       IDXVT = ITOVT(IFROST(IDXST))
13454 *  available x above diquark thresholds for valence- and sea-diquarks
13455       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13456
13457       IF (XXD.GE.ZERO) THEN
13458 *  x-values for the three diquarks of the target nucleon
13459          RR1    = DT_RNDM(XXD)
13460          RR2    = DT_RNDM(RR1)
13461          RR3    = DT_RNDM(RR2)
13462          SR123  = RR1+RR2+RR3
13463          XXTV   = XDTHR+RR1*XXD/SR123
13464          XXTSQ  = XDTHR+RR2*XXD/SR123
13465          XXTSAQ = XDTHR+RR3*XXD/SR123
13466       ELSE
13467          XXTV   = XTVD(IDXVT)
13468          XXTSQ  = XTSQ(IDXST)
13469          XXTSAQ = XTSAQ(IDXST)
13470       ENDIF
13471 *  flavor of the second quarks in the sea-diquark pair
13472       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13473       ITSAQ2(IDXST) = -ITSQ2(IDXST)
13474 *  check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
13475       AM1    = XXTSQ *XPSQ(IDXSP)*ECM**2
13476       AM2    = XXTSAQ*XPSAQ(IDXSP)*ECM**2
13477       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13478 *    ss-asas pair
13479      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
13480          IREJ = 1
13481          RETURN
13482       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13483 *    at least one strange quark
13484      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
13485          IREJ = 1
13486          RETURN
13487       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13488          IREJ = 1
13489          RETURN
13490       ENDIF
13491 *  accept the new sea-diquark
13492       XTVD(IDXVT)   = XXTV
13493       XTSQ(IDXST)   = XXTSQ
13494       XTSAQ(IDXST)  = XXTSAQ
13495       NSD           = NSD+1
13496       INTSD1(NSD)   = IDXSP
13497       INTSD2(NSD)   = IDXST
13498       ISKPCH(3,NSD) = 0
13499       RETURN
13500
13501 *---------------------------------------------------------------------
13502 * proj. sea partons - targ. sea partons
13503 * get x-values and flavors for projectile sea-diquark pair
13504
13505     4 CONTINUE
13506       IDXSP = IDX2
13507       IDXST = IDX1
13508
13509 *  index of corr. val-diquark-x in projectile nucleon
13510       IDXVP = ITOVP(IFROSP(IDXSP))
13511 *  available x above diquark thresholds for valence- and sea-diquarks
13512       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13513
13514       IF (XXD.GE.ZERO) THEN
13515 *  x-values for the three diquarks of the projectile nucleon
13516          RR1    = DT_RNDM(XXD)
13517          RR2    = DT_RNDM(RR1)
13518          RR3    = DT_RNDM(RR2)
13519          SR123  = RR1+RR2+RR3
13520          XXPV   = XDTHR+RR1*XXD/SR123
13521          XXPSQ  = XDTHR+RR2*XXD/SR123
13522          XXPSAQ = XDTHR+RR3*XXD/SR123
13523       ELSE
13524          XXPV   = XPVD(IDXVP)
13525          XXPSQ  = XPSQ(IDXSP)
13526          XXPSAQ = XPSAQ(IDXSP)
13527       ENDIF
13528 *  flavor of the second quarks in the sea-diquark pair
13529       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13530       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13531 *  check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
13532       AM1    = XXPSQ *XTSQ(IDXST)*ECM**2
13533       AM2    = XXPSAQ*XTSAQ(IDXST)*ECM**2
13534       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13535 *    ss-asas pair
13536      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
13537          IREJ = 1
13538          RETURN
13539       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13540 *    at least one strange quark
13541      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
13542          IREJ = 1
13543          RETURN
13544       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13545          IREJ = 1
13546          RETURN
13547       ENDIF
13548 *  accept the new sea-diquark
13549       XPVD(IDXVP)   = XXPV
13550       XPSQ(IDXSP)   = XXPSQ
13551       XPSAQ(IDXSP)  = XXPSAQ
13552       NDS           = NDS+1
13553       INTDS1(NDS)   = IDXSP
13554       INTDS2(NDS)   = IDXST
13555       ISKPCH(2,NDS) = 0
13556       RETURN
13557       END
13558 *
13559 *===difevt=============================================================*
13560 *
13561 CDECK  ID>, DT_DIFEVT
13562       SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
13563      &                  IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
13564
13565 ************************************************************************
13566 * Interface to treatment of diffractive interactions.                  *
13567 *  (input)          IFP1/2        PDG-indizes of projectile partons    *
13568 *                                 (baryon: IFP2 - adiquark)            *
13569 *                   PP(4)         projectile 4-momentum                *
13570 *                   IFT1/2        PDG-indizes of target partons        *
13571 *                                 (baryon: IFT1 - adiquark)            *
13572 *                   PT(4)         target 4-momentum                    *
13573 *  (output)         JDIFF = 0     no diffraction                       *
13574 *                         = 1/-1  LMSD/LMDD                            *
13575 *                         = 2/-2  HMSD/HMDD                            *
13576 *                   NCSY          counter for two-chain systems        *
13577 *                                 dumped to DTEVT1                     *
13578 * This version dated 14.02.95 is written by S. Roesler                 *
13579 ************************************************************************
13580
13581       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13582       SAVE
13583
13584       PARAMETER ( LINP = 5 ,
13585      &            LOUT = 6 ,
13586      &            LDAT = 9 )
13587
13588       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
13589      &           OHALF=0.5D0)
13590
13591 * event history
13592
13593       PARAMETER (NMXHKK=200000)
13594
13595       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
13596      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
13597      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
13598 * extended event history
13599       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
13600      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
13601      &                IHIST(2,NMXHKK)
13602 * flags for diffractive interactions (DTUNUC 1.x)
13603       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
13604
13605       DIMENSION PP(4),PT(4)
13606
13607       LOGICAL LFIRST
13608       DATA LFIRST /.TRUE./
13609
13610       IREJ   = 0
13611       JDIFF  = 0
13612       IFLAGD = JDIFF
13613
13614 * cm. energy
13615       XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
13616      &          (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
13617 * identities of projectile hadron / target nucleon
13618       KPROJ = IDT_ICIHAD(IDHKK(MOP))
13619       KTARG = IDT_ICIHAD(IDHKK(MOT))
13620
13621 * single diffractive xsections
13622       CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
13623 * double diffractive xsections
13624 **!! no double diff yet
13625 C     CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
13626       DDTOT = 0.0D0
13627       DDHM  = 0.0D0
13628 **!!
13629 * total inelastic xsection
13630 C     SIGIN  = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
13631       DUMZER = ZERO
13632       CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
13633       SIGIN  = MAX(SIGTO-SIGEL,ZERO)
13634
13635 * fraction of diffractive processes
13636       FRADIF = (SDTOT+DDTOT)/SIGIN
13637
13638       IF (LFIRST) THEN
13639          WRITE(LOUT,1000) XM,SDTOT,SIGIN
13640  1000    FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
13641      &          F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
13642      &          F5.1,' mb',/)
13643          LFIRST = .FALSE.
13644       ENDIF
13645
13646       IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
13647      &    (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
13648 * diffractive interaction requested by x-section or by user
13649          FRASD  = SDTOT/(SDTOT+DDTOT)
13650          FRASDH = SDHM/SDTOT
13651 **sr needs to be specified!!
13652 C        FRADDH = DDHM/DDTOT
13653          FRADDH = 1.0D0
13654 **
13655          IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
13656 *   single diffraction
13657             KDIFF = 1
13658             IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
13659                KP = 2
13660                KT = 0
13661                IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
13662      &               ISINGD.NE.3) THEN
13663                   KP = 0
13664                   KT = 2
13665                ENDIF
13666             ELSE
13667                KP = 1
13668                KT = 0
13669                IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
13670      &               ISINGD.NE.3) THEN
13671                   KP = 0
13672                   KT = 1
13673                ENDIF
13674             ENDIF
13675          ELSE
13676 *   double diffraction
13677             KDIFF = -1
13678             IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
13679                KP = 2
13680                KT = 2
13681             ELSE
13682                KP = 1
13683                KT = 1
13684             ENDIF
13685          ENDIF
13686          CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13687      &               IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13688          IF (IREJ1.EQ.0) THEN
13689             IFLAGD = 2*KDIFF
13690             IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
13691          ELSE
13692             GOTO 9999
13693          ENDIF
13694       ENDIF
13695       JDIFF = IFLAGD
13696
13697       RETURN
13698
13699  9999 CONTINUE
13700       IREJ  = 1
13701       RETURN
13702       END
13703 *
13704 *===difkin=============================================================*
13705 *
13706 CDECK  ID>, DT_DIFFKI
13707       SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13708      &                  IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
13709
13710 ************************************************************************
13711 * Kinematics of diffractive nucleon-nucleon interaction.               *
13712 *          IFP1/2   PDG-indizes of projectile partons                  *
13713 *                   (baryon: IFP2 - adiquark)                          *
13714 *          PP(4)    projectile 4-momentum                              *
13715 *          IFT1/2   PDG-indizes of target partons                      *
13716 *                   (baryon: IFT1 - adiquark)                          *
13717 *          PT(4)    target 4-momentum                                  *
13718 *          KP   = 0 projectile quasi-elastically scattered             *
13719 *               = 1            excited to low-mass diff. state         *
13720 *               = 2            excited to high-mass diff. state        *
13721 *          KT   = 0 target     quasi-elastically scattered             *
13722 *               = 1            excited to low-mass diff. state         *
13723 *               = 2            excited to high-mass diff. state        *
13724 * This version dated 12.02.95 is written by S. Roesler                 *
13725 ************************************************************************
13726
13727       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13728       SAVE
13729
13730       PARAMETER ( LINP = 5 ,
13731      &            LOUT = 6 ,
13732      &            LDAT = 9 )
13733
13734       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
13735
13736       LOGICAL LSTART
13737
13738 * particle properties (BAMJET index convention)
13739       CHARACTER*8  ANAME
13740       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
13741      &                IICH(210),IIBAR(210),K1(210),K2(210)
13742 * flags for input different options
13743       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
13744       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
13745      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
13746 * rejection counter
13747       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
13748      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
13749      &                IREXCI(3),IRDIFF(2),IRINC
13750 * kinematics of diffractive interactions (DTUNUC 1.x)
13751       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13752      &                PPF(4),PTF(4),
13753      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13754      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13755
13756       DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
13757      &          PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
13758
13759       DATA LSTART /.TRUE./
13760
13761       IF (LSTART) THEN
13762          WRITE(LOUT,2000)
13763  2000    FORMAT(/,1X,'DIFEVT:  diffractive interactions treated ')
13764          LSTART = .FALSE.
13765       ENDIF
13766
13767       IREJ = 0
13768
13769 * initialize common /DTDIKI/
13770       CALL DT_DIFINI
13771 * store momenta of initial incoming particles for emc-check
13772       IF (LEMCCK) THEN
13773          CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
13774          CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
13775       ENDIF
13776
13777 * masses of initial particles
13778       XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
13779       XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
13780       IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
13781       XMP  = SQRT(XMP2)
13782       XMT  = SQRT(XMT2)
13783 * check quark-input (used to adjust coherence cond. for M-selection)
13784       IBP  = 0
13785       IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
13786       IBT  = 0
13787       IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
13788
13789 * parameter for Lorentz-transformation into nucleon-nucleon cms
13790       DO 3 K=1,4
13791          PITOT(K) = PP(K)+PT(K)
13792     3 CONTINUE
13793       XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
13794       IF (XMTOT2.LE.ZERO) THEN
13795          WRITE(LOUT,1000) XMTOT2
13796  1000    FORMAT(1X,'DIFEVT:   negative cm. energy!  ',
13797      &          'XMTOT2 = ',E12.3)
13798          GOTO 9999
13799       ENDIF
13800       XMTOT = SQRT(XMTOT2)
13801       DO 4 K=1,4
13802          BGTOT(K) = PITOT(K)/XMTOT
13803     4 CONTINUE
13804 * transformation of nucleons into cms
13805       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
13806      &            PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
13807       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
13808      &            PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
13809 * rotation angles
13810       COD = PP1(3)/PPTOT
13811 C     SID = SQRT((ONE-COD)*(ONE+COD))
13812       PPT = SQRT(PP1(1)**2+PP1(2)**2)
13813       SID = PPT/PPTOT
13814       COF = ONE
13815       SIF = ZERO
13816       IF(PPTOT*SID.GT.TINY10) THEN
13817          COF   = PP1(1)/(SID*PPTOT)
13818          SIF   = PP1(2)/(SID*PPTOT)
13819          ANORF = SQRT(COF*COF+SIF*SIF)
13820          COF   = COF/ANORF
13821          SIF   = SIF/ANORF
13822       ENDIF
13823 * check consistency
13824       DO 5 K=1,4
13825          DEV1(K) = ABS(PP1(K)+PT1(K))
13826     5 CONTINUE
13827       DEV1(4) = ABS(DEV1(4)-XMTOT)
13828       IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
13829      &    (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10))     THEN
13830          WRITE(LOUT,1001) DEV1
13831  1001    FORMAT(1X,'DIFEVT:   inconsitent Lorentz-transformation! ',
13832      &          /,8X,4E12.3)
13833          GOTO 9999
13834       ENDIF
13835
13836 * select x-fractions in high-mass diff. interactions
13837       IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
13838
13839 * select diffractive masses
13840 * - projectile
13841       IF (KP.EQ.1) THEN
13842          XMPF = DT_XMLMD(XMTOT)
13843          CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
13844          IF (IREJ1.GT.0) GOTO 9999
13845       ELSEIF (KP.EQ.2) THEN
13846          XMPF = DT_XMHMD(XMTOT,IBP,1)
13847       ELSE
13848          XMPF = XMP
13849       ENDIF
13850 * - target
13851       IF (KT.EQ.1) THEN
13852          XMTF = DT_XMLMD(XMTOT)
13853          CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
13854          IF (IREJ1.GT.0) GOTO 9999
13855       ELSEIF (KT.EQ.2) THEN
13856          XMTF = DT_XMHMD(XMTOT,IBT,2)
13857       ELSE
13858          XMTF = XMT
13859       ENDIF
13860
13861 * kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
13862       XMPF2 = XMPF**2
13863       XMTF2 = XMTF**2
13864       PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
13865       PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
13866
13867 * select momentum transfer (all t-values used here are <0)
13868 *   minimum absolute value to produce diffractive masses
13869       TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
13870       TT   = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
13871       IF (IREJ1.GT.0) GOTO 9999
13872
13873 * longitudinal momentum of excited/elastically scattered projectile
13874       PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
13875 * total transverse momentum due to t-selection
13876       PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
13877       IF (PPBLT2.LT.ZERO) THEN
13878          WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
13879  1002    FORMAT(1X,'DIFEVT:   inconsistent transverse momentum! ',
13880      &          E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
13881          GOTO 9999
13882       ENDIF
13883       CALL DT_DSFECF(SINPHI,COSPHI)
13884       PPBLT     = SQRT(PPBLT2)
13885       PPBLOB(1) = COSPHI*PPBLT
13886       PPBLOB(2) = SINPHI*PPBLT
13887
13888 * rotate excited/elastically scattered projectile into n-n cms.
13889       CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
13890      &                                                    XX,YY,ZZ)
13891       PPBLOB(1) = XX
13892       PPBLOB(2) = YY
13893       PPBLOB(3) = ZZ
13894
13895 * 4-momentum of excited/elastically scattered target and of exchanged
13896 * Pomeron
13897       DO 6 K=1,4
13898          IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
13899          PPOM1(K) = PP1(K)-PPBLOB(K)
13900     6 CONTINUE
13901       PTBLOB(4) = XMTOT-PPBLOB(4)
13902
13903 * Lorentz-transformation back into system of initial diff. collision
13904       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13905      &            PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
13906      &            PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
13907       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13908      &            PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
13909      &            PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
13910       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13911      &            PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
13912      &            PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
13913
13914 * store 4-momentum of elastically scattered particle (in single diff.
13915 * events)
13916       IF (KP.EQ.0) THEN
13917          DO 7 K=1,4
13918             PSC(K) = PPF(K)
13919     7    CONTINUE
13920       ELSEIF (KT.EQ.0) THEN
13921          DO 8 K=1,4
13922             PSC(K) = PTF(K)
13923     8    CONTINUE
13924       ENDIF
13925
13926 * check consistency of kinematical treatment so far
13927       IF (LEMCCK) THEN
13928          CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
13929          CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
13930          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
13931          IF (IREJ1.NE.0) GOTO 9999
13932       ENDIF
13933       DO 9 K=1,4
13934          DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
13935          DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
13936     9 CONTINUE
13937       IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
13938      &    (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
13939      &    (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
13940      &    (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5))     THEN
13941          WRITE(LOUT,1003) DEV1,DEV2
13942  1003    FORMAT(1X,'DIFEVT:   inconsitent kinematical treatment!  ',
13943      &          2(/,8X,4E12.3))
13944          GOTO 9999
13945       ENDIF
13946
13947 * kinematical treatment for low-mass diffraction
13948       CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
13949       IF (IREJ1.NE.0) GOTO 9999
13950
13951 * dump diffractive chains into DTEVT1
13952       CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13953       IF (IREJ1.NE.0) GOTO 9999
13954
13955       RETURN
13956
13957  9999 CONTINUE
13958       IRDIFF(1) = IRDIFF(1)+1
13959       IREJ      = 1
13960       RETURN
13961       END
13962 *
13963 *===xmhmd==============================================================*
13964 *
13965 CDECK  ID>, DT_XMHMD
13966       DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
13967
13968 ************************************************************************
13969 * Diffractive mass in high mass single/double diffractive events.      *
13970 * This version dated 11.02.95 is written by S. Roesler                 *
13971 ************************************************************************
13972
13973       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13974       SAVE
13975
13976       PARAMETER ( LINP = 5 ,
13977      &            LOUT = 6 ,
13978      &            LDAT = 9 )
13979
13980       PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
13981
13982 * kinematics of diffractive interactions (DTUNUC 1.x)
13983       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13984      &                PPF(4),PTF(4),
13985      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13986      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13987
13988 C     DATA XCOLOW /0.05D0/
13989       DATA XCOLOW /0.15D0/
13990
13991       DT_XMHMD = ZERO
13992       XH = XPH(2)
13993       IF (MODE.EQ.2) XH = XTH(2)
13994
13995 * minimum Pomeron-x for high-mass diffraction
13996 * (adjusted to get a smooth transition between HM and LM component)
13997       R = DT_RNDM(XH)
13998       XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
13999       IF (ECM.LE.300.0D0) THEN
14000          RR     = (1.0D0-EXP(-((ECM/140.0D0)**4)))
14001          XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
14002       ENDIF
14003 * maximum Pomeron-x for high-mass diffraction
14004 * (coherence condition, adjusted to fit to experimental data)
14005       IF (IB.NE.0) THEN
14006 *   baryon-diffraction
14007          XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
14008       ELSE
14009 *   meson-diffraction
14010          XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
14011       ENDIF
14012 * check boundaries
14013       IF (XDIMIN.GE.XDIMAX) THEN
14014          XDIMIN = OHALF*XDIMAX
14015       ENDIF
14016
14017       KLOOP = 0
14018     1 CONTINUE
14019       KLOOP = KLOOP+1
14020       IF (KLOOP.GT.20) RETURN
14021 * sample Pomeron-x from 1/x-distribution (critical Pomeron)
14022       XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
14023 * corr. diffr. mass
14024       DT_XMHMD = ECM*SQRT(XDIFF)
14025       IF (DT_XMHMD.LT.2.5D0) GOTO 1
14026
14027       RETURN
14028       END
14029 *
14030 *===xmlmd==============================================================*
14031 *
14032 CDECK  ID>, DT_XMLMD
14033       DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
14034
14035 ************************************************************************
14036 * Diffractive mass in high mass single/double diffractive events.      *
14037 * This version dated 11.02.95 is written by S. Roesler                 *
14038 ************************************************************************
14039
14040       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14041       SAVE
14042
14043       PARAMETER ( LINP = 5 ,
14044      &            LOUT = 6 ,
14045      &            LDAT = 9 )
14046
14047 * minimum Pomeron-x for low-mass diffraction
14048 C     AMO = 1.5D0
14049       AMO = 2.0D0
14050 * maximum Pomeron-x for low-mass diffraction
14051 * (adjusted to get a smooth transition between HM and LM component)
14052       R   = DT_RNDM(AMO)
14053       SAM = 1.0D0
14054       IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
14055       R   = DT_RNDM(AMO)*SAM
14056       AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
14057       AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
14058
14059 * selection of diffractive mass
14060 * (adjusted to get a smooth transition between HM and LM component)
14061       R   = DT_RNDM(AMU)
14062       IF (ECM.LE.50.0D0) THEN
14063          DT_XMLMD = AMO*(AMU/AMO)**R
14064       ELSE
14065          A = 0.7D0
14066          IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
14067          DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
14068       ENDIF
14069
14070       RETURN
14071       END
14072 *
14073 *===tdiff==============================================================*
14074 *
14075 CDECK  ID>, DT_TDIFF
14076       DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
14077
14078 ************************************************************************
14079 * t-selection for single/double diffractive interactions.              *
14080 *          ECM      cm. energy                                         *
14081 *          TMIN     minimum momentum transfer to produce diff. masses  *
14082 *          XM1/XM2  diffractively produced masses                      *
14083 *                   (for single diffraction XM2 is obsolete)           *
14084 *          K1/K2= 0 not excited                                        *
14085 *               = 1 low-mass excitation                                *
14086 *               = 2 high-mass excitation                               *
14087 * This version dated 11.02.95 is written by S. Roesler                 *
14088 ************************************************************************
14089
14090       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14091       SAVE
14092
14093       PARAMETER ( LINP = 5 ,
14094      &            LOUT = 6 ,
14095      &            LDAT = 9 )
14096
14097       PARAMETER (ZERO=0.0D0)
14098
14099       PARAMETER ( BTP0   = 3.7D0,
14100      &            ALPHAP = 0.24D0 )
14101
14102       IREJ   = 0
14103       NCLOOP = 0
14104       DT_TDIFF  = ZERO
14105
14106       IF (K1.GT.0) THEN
14107          XM1 = XM1I
14108          XM2 = XM2I
14109       ELSE
14110          XM1 = XM2I
14111       ENDIF
14112       XDI = (XM1/ECM)**2
14113       IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14114 * slope for single diffraction
14115          SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14116       ELSE
14117 * slope for double diffraction
14118          SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14119       ENDIF
14120
14121     1 CONTINUE
14122       NCLOOP = NCLOOP+1
14123       IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14124       Y = DT_RNDM(XDI)
14125       T = -LOG(1.0D0-Y)/SLOPE
14126       IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14127       DT_TDIFF = -ABS(T)
14128
14129       RETURN
14130
14131  9999 CONTINUE
14132       WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14133  1000 FORMAT(1X,'DT_TDIFF:   t-selection rejected!',/,
14134      &       1X,'ECM  = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14135      &       E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14136       IREJ = 1
14137       RETURN
14138       END
14139 *
14140 *===xvalhm=============================================================*
14141 *
14142 CDECK  ID>, DT_XVALHM
14143       SUBROUTINE DT_XVALHM(KP,KT)
14144
14145 ************************************************************************
14146 * Sampling of parton x-values in high-mass diffractive interactions.   *
14147 * This version dated 12.02.95 is written by S. Roesler                 *
14148 ************************************************************************
14149
14150       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14151       SAVE
14152
14153       PARAMETER ( LINP = 5 ,
14154      &            LOUT = 6 ,
14155      &            LDAT = 9 )
14156
14157       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14158
14159 * kinematics of diffractive interactions (DTUNUC 1.x)
14160       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14161      &                PPF(4),PTF(4),
14162      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14163      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14164 * various options for treatment of partons (DTUNUC 1.x)
14165 * (chain recombination, Cronin,..)
14166       LOGICAL LCO2CR,LINTPT
14167       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14168      &                LCO2CR,LINTPT
14169
14170       DATA UNON,XVQTHR /2.0D0,0.8D0/
14171
14172       IF (KP.EQ.2) THEN
14173 * x-fractions of projectile valence partons
14174     1    CONTINUE
14175          XPH(1) = DT_DBETAR(OHALF,UNON)
14176          IF (XPH(1).GE.XVQTHR) GOTO 1
14177          XPH(2) = ONE-XPH(1)
14178 * x-fractions of Pomeron q-aq-pair
14179          XPOLO = TINY2
14180          XPOHI = ONE-TINY2
14181          XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14182          XPPO(2) = ONE-XPPO(1)
14183 * flavors of Pomeron q-aq-pair
14184          IFLAV    = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14185          IFPPO(1) = IFLAV
14186          IFPPO(2) = -IFLAV
14187          IF (DT_RNDM(UNON).GT.OHALF) THEN
14188             IFPPO(1) = -IFLAV
14189             IFPPO(2) = IFLAV
14190          ENDIF
14191       ENDIF
14192
14193       IF (KT.EQ.2) THEN
14194 * x-fractions of projectile target partons
14195     2    CONTINUE
14196          XTH(1) = DT_DBETAR(OHALF,UNON)
14197          IF (XTH(1).GE.XVQTHR) GOTO 2
14198          XTH(2) = ONE-XTH(1)
14199 * x-fractions of Pomeron q-aq-pair
14200          XPOLO = TINY2
14201          XPOHI = ONE-TINY2
14202          XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14203          XTPO(2) = ONE-XTPO(1)
14204 * flavors of Pomeron q-aq-pair
14205          IFLAV    = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14206          IFTPO(1) = IFLAV
14207          IFTPO(2) = -IFLAV
14208          IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14209             IFTPO(1) = -IFLAV
14210             IFTPO(2) = IFLAV
14211          ENDIF
14212       ENDIF
14213
14214       RETURN
14215       END
14216 *
14217 *===lm2res=============================================================*
14218 *
14219 CDECK  ID>, DT_LM2RES
14220       SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14221
14222 ************************************************************************
14223 * Check low-mass diffractive excitation for resonance mass.            *
14224 *   (input)   IF1/2    PDG-indizes of valence partons                  *
14225 *   (in/out)  XM       diffractive mass requested/corrected            *
14226 *   (output)  IDR/IDXR id./BAMJET-index of resonance                   *
14227 * This version dated 12.02.95 is written by S. Roesler                 *
14228 ************************************************************************
14229
14230       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14231       SAVE
14232
14233       PARAMETER ( LINP = 5 ,
14234      &            LOUT = 6 ,
14235      &            LDAT = 9 )
14236
14237       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14238
14239 * kinematics of diffractive interactions (DTUNUC 1.x)
14240       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14241      &                PPF(4),PTF(4),
14242      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14243      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14244
14245       IREJ = 0
14246       IF1B = 0
14247       IF2B = 0
14248       XMI  = XM
14249
14250 * BAMJET indices of partons
14251       IF1A = IDT_IPDG2B(IF1,1,2)
14252       IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14253       IF2A = IDT_IPDG2B(IF2,1,2)
14254       IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14255
14256 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14257       IDCH = 2
14258       IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14259
14260 * check for resonance mass
14261       CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14262       IF (IREJ1.NE.0) GOTO 9999
14263
14264       XM = XMN
14265       RETURN
14266
14267  9999 CONTINUE
14268       IREJ = 1
14269       RETURN
14270       END
14271 *
14272 *===lmkine=============================================================*
14273 *
14274 CDECK  ID>, DT_LMKINE
14275       SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14276
14277 ************************************************************************
14278 * Kinematical treatment of low-mass excitations.                       *
14279 * This version dated 12.02.95 is written by S. Roesler                 *
14280 ************************************************************************
14281
14282       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14283       SAVE
14284
14285       PARAMETER ( LINP = 5 ,
14286      &            LOUT = 6 ,
14287      &            LDAT = 9 )
14288
14289       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14290
14291 * flags for input different options
14292       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14293       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14294      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14295 * kinematics of diffractive interactions (DTUNUC 1.x)
14296       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14297      &                PPF(4),PTF(4),
14298      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14299      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14300
14301       DIMENSION P1(4),P2(4)
14302
14303       IREJ = 0
14304
14305       IF (KP.EQ.1) THEN
14306          PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14307          POE  = PPF(4)/PABS
14308          FAC1 = OHALF*(POE+ONE)
14309          FAC2 = -OHALF*(POE-ONE)
14310          DO 1 K=1,3
14311             PPLM1(K) = FAC1*PPF(K)
14312             PPLM2(K) = FAC2*PPF(K)
14313     1    CONTINUE
14314          PPLM1(4) = FAC1*PABS
14315          PPLM2(4) = -FAC2*PABS
14316          IF (IMSHL.EQ.1) THEN
14317
14318             XM1 = PYMASS(IFP1)
14319             XM2 = PYMASS(IFP2)
14320
14321             CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14322             IF (IREJ1.NE.0) GOTO 9999
14323             DO 2 K=1,4
14324                PPLM1(K) = P1(K)
14325                PPLM2(K) = P2(K)
14326     2       CONTINUE
14327          ENDIF
14328       ENDIF
14329
14330       IF (KT.EQ.1) THEN
14331          PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14332          POE  = PTF(4)/PABS
14333          FAC1 = OHALF*(POE+ONE)
14334          FAC2 = -OHALF*(POE-ONE)
14335          DO 3 K=1,3
14336             PTLM2(K) = FAC1*PTF(K)
14337             PTLM1(K) = FAC2*PTF(K)
14338     3    CONTINUE
14339          PTLM2(4) = FAC1*PABS
14340          PTLM1(4) = -FAC2*PABS
14341          IF (IMSHL.EQ.1) THEN
14342
14343             XM1 = PYMASS(IFT1)
14344             XM2 = PYMASS(IFT2)
14345
14346             CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14347             IF (IREJ1.NE.0) GOTO 9999
14348             DO 4 K=1,4
14349                PTLM1(K) = P1(K)
14350                PTLM2(K) = P2(K)
14351     4       CONTINUE
14352          ENDIF
14353       ENDIF
14354
14355       RETURN
14356
14357  9999 CONTINUE
14358       WRITE(LOUT,'(A)') 'LMKINE:   kinematical treatment rejected'
14359       IREJ = 1
14360       RETURN
14361       END
14362 *
14363 *===difini=============================================================*
14364 *
14365 CDECK  ID>, DT_DIFINI
14366       SUBROUTINE DT_DIFINI
14367
14368 ************************************************************************
14369 * Initialization of common /DTDIKI/                                    *
14370 * This version dated 12.02.95 is written by S. Roesler                 *
14371 ************************************************************************
14372
14373       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14374       SAVE
14375
14376       PARAMETER ( LINP = 5 ,
14377      &            LOUT = 6 ,
14378      &            LDAT = 9 )
14379
14380       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14381
14382 * kinematics of diffractive interactions (DTUNUC 1.x)
14383       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14384      &                PPF(4),PTF(4),
14385      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14386      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14387
14388       DO 1 K=1,4
14389          PPOM(K)  = ZERO
14390          PSC(K)   = ZERO
14391          PPF(K)   = ZERO
14392          PTF(K)   = ZERO
14393          PPLM1(K) = ZERO
14394          PPLM2(K) = ZERO
14395          PTLM1(K) = ZERO
14396          PTLM2(K) = ZERO
14397     1 CONTINUE
14398       DO 2 K=1,2
14399          XPH(K)   = ZERO
14400          XPPO(K)  = ZERO
14401          XTH(K)   = ZERO
14402          XTPO(K)  = ZERO
14403          IFPPO(K) = 0
14404          IFTPO(K) = 0
14405     2 CONTINUE
14406       IDPR  = 0
14407       IDXPR = 0
14408       IDTR  = 0
14409       IDXTR = 0
14410
14411       RETURN
14412       END
14413 *
14414 *===difput=============================================================*
14415 *
14416 CDECK  ID>, DT_DIFPUT
14417       SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14418      &                                                          IREJ)
14419
14420 ************************************************************************
14421 * Dump diffractive chains into DTEVT1                                  *
14422 * This version dated 12.02.95 is written by S. Roesler                 *
14423 ************************************************************************
14424
14425       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14426       SAVE
14427
14428       PARAMETER ( LINP = 5 ,
14429      &            LOUT = 6 ,
14430      &            LDAT = 9 )
14431
14432       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14433
14434       LOGICAL LCHK
14435
14436 * kinematics of diffractive interactions (DTUNUC 1.x)
14437       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14438      &                PPF(4),PTF(4),
14439      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14440      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14441 * event history
14442
14443       PARAMETER (NMXHKK=200000)
14444
14445       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14446      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14447      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14448 * extended event history
14449       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14450      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14451      &                IHIST(2,NMXHKK)
14452 * rejection counter
14453       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14454      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14455      &                IREXCI(3),IRDIFF(2),IRINC
14456
14457       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
14458      &          P1(4),P2(4),P3(4),P4(4)
14459
14460       IREJ = 0
14461
14462       IF (KP.EQ.1) THEN
14463          DO 1 K=1,4
14464             PCH(K) = PPLM1(K)+PPLM2(K)
14465     1    CONTINUE
14466          ID1 = IFP1
14467          ID2 = IFP2
14468          IF (DT_RNDM(PT).GT.OHALF) THEN
14469             ID1 = IFP2
14470             ID2 = IFP1
14471          ENDIF
14472          CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
14473      &                                        PPLM1(4),0,0,0)
14474          CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
14475      &                                        PPLM2(4),0,0,0)
14476          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14477      &                                              IDPR,IDXPR,8)
14478       ELSEIF (KP.EQ.2) THEN
14479          DO 2 K=1,4
14480             PP1(K) = XPH(1)*PP(K)
14481             PP2(K) = XPH(2)*PP(K)
14482             PT1(K) = -XPPO(1)*PPOM(K)
14483             PT2(K) = -XPPO(2)*PPOM(K)
14484     2    CONTINUE
14485          CALL  DT_CHKCSY(IFP1,IFPPO(1),LCHK)
14486          XM1 = ZERO
14487          XM2 = ZERO
14488          IF (LCHK) THEN
14489             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14490             IF (IREJ1.NE.0) GOTO 9999
14491             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14492             IF (IREJ1.NE.0) GOTO 9999
14493             DO 3 K=1,4
14494                PP1(K) = P1(K)
14495                PT1(K) = P2(K)
14496                PP2(K) = P3(K)
14497                PT2(K) = P4(K)
14498     3       CONTINUE
14499             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14500      &                                                       0,0,8)
14501             CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14502      &                                             PT1(4),0,0,8)
14503             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14504      &                                                       0,0,8)
14505             CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14506      &                                             PT2(4),0,0,8)
14507          ELSE
14508             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14509             IF (IREJ1.NE.0) GOTO 9999
14510             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14511             IF (IREJ1.NE.0) GOTO 9999
14512             DO 4 K=1,4
14513                PP1(K) = P1(K)
14514                PT2(K) = P2(K)
14515                PP2(K) = P3(K)
14516                PT1(K) = P4(K)
14517     4       CONTINUE
14518             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14519      &                                                       0,0,8)
14520             CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14521      &                                                PT2(4),0,0,8)
14522             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14523      &                                                       0,0,8)
14524             CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14525      &                                                PT1(4),0,0,8)
14526          ENDIF
14527          NCSY = NCSY+1
14528       ELSE
14529          CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
14530      &                                                        0,0,0)
14531       ENDIF
14532
14533       IF (KT.EQ.1) THEN
14534          DO 5 K=1,4
14535             PCH(K) = PTLM1(K)+PTLM2(K)
14536     5    CONTINUE
14537          ID1 = IFT1
14538          ID2 = IFT2
14539          IF (DT_RNDM(PT).GT.OHALF) THEN
14540             ID1 = IFT2
14541             ID2 = IFT1
14542          ENDIF
14543          CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
14544      &                                              PTLM1(4),0,0,0)
14545          CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
14546      &                                              PTLM2(4),0,0,0)
14547          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14548      &                                              IDTR,IDXTR,8)
14549       ELSEIF (KT.EQ.2) THEN
14550          DO 6 K=1,4
14551             PP1(K) = XTPO(1)*PPOM(K)
14552             PP2(K) = XTPO(2)*PPOM(K)
14553             PT1(K) = XTH(2)*PT(K)
14554             PT2(K) = XTH(1)*PT(K)
14555     6    CONTINUE
14556          CALL  DT_CHKCSY(IFTPO(1),IFT1,LCHK)
14557          XM1 = ZERO
14558          XM2 = ZERO
14559          IF (LCHK) THEN
14560             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14561             IF (IREJ1.NE.0) GOTO 9999
14562             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14563             IF (IREJ1.NE.0) GOTO 9999
14564             DO 7 K=1,4
14565                PP1(K) = P1(K)
14566                PT1(K) = P2(K)
14567                PP2(K) = P3(K)
14568                PT2(K) = P4(K)
14569     7       CONTINUE
14570             CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14571      &                                                PP1(4),0,0,8)
14572             CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14573      &                                                       0,0,8)
14574             CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14575      &                                                PP2(4),0,0,8)
14576             CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14577      &                                                       0,0,8)
14578          ELSE
14579             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14580             IF (IREJ1.NE.0) GOTO 9999
14581             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14582             IF (IREJ1.NE.0) GOTO 9999
14583             DO 8 K=1,4
14584                PP1(K) = P1(K)
14585                PT2(K) = P2(K)
14586                PP2(K) = P3(K)
14587                PT1(K) = P4(K)
14588     8       CONTINUE
14589             CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14590      &                                                PP1(4),0,0,8)
14591             CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14592      &                                                       0,0,8)
14593             CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14594      &                                                PP2(4),0,0,8)
14595             CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14596      &                                                       0,0,8)
14597          ENDIF
14598          NCSY = NCSY+1
14599       ELSE
14600          CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
14601      &                                                        0,0,0)
14602       ENDIF
14603
14604       RETURN
14605
14606  9999 CONTINUE
14607       IRDIFF(2) = IRDIFF(2)+1
14608       IREJ      = 1
14609       RETURN
14610       END
14611 *
14612 *===evtfrg=============================================================*
14613 *
14614 CDECK  ID>, DT_EVTFRG
14615       SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
14616
14617 ************************************************************************
14618 * Hadronization of chains in DTEVT1.                                   *
14619 *                                                                      *
14620 * Input:                                                               *
14621 *   KMODE = 1   hadronization of PHOJET-chains (id=77xxx)              *
14622 *         = 2   hadronization of DTUNUC-chains (id=88xxx)              *
14623 *   NFRG  if KMODE = 1 : upper index of PHOJET-scatterings to be       *
14624 *                        hadronized with one PYEXEC call               *
14625 *         if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
14626 *                        with one PYEXEC call                          *
14627 * Output:                                                              *
14628 *   NPYMEM      number of entries in JETSET-common after hadronization *
14629 *   IREJ        rejection flag                                         *
14630 *                                                                      *
14631 * This version dated 17.09.00 is written by S. Roesler                 *
14632 ************************************************************************
14633
14634       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14635       SAVE
14636
14637       PARAMETER ( LINP = 5 ,
14638      &            LOUT = 6 ,
14639      &            LDAT = 9 )
14640
14641       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
14642       PARAMETER (ONE=1.0D0,ZERO=0.0D0)
14643
14644       LOGICAL LACCEP
14645
14646       PARAMETER (MXJOIN=200)
14647
14648 * event history
14649
14650       PARAMETER (NMXHKK=200000)
14651
14652       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14653      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14654      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14655 * extended event history
14656       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14657      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14658      &                IHIST(2,NMXHKK)
14659 * flags for input different options
14660       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14661       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14662      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14663 * statistics
14664       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
14665      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
14666      &                ICEVTG(8,0:30)
14667 * flags for diffractive interactions (DTUNUC 1.x)
14668       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14669 * nucleon-nucleon event-generator
14670       CHARACTER*8 CMODEL
14671       LOGICAL LPHOIN
14672       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
14673 * phojet
14674 C  model switches and parameters
14675       CHARACTER*8 MDLNA
14676       INTEGER ISWMDL,IPAMDL
14677       DOUBLE PRECISION PARMDL
14678       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14679 * jetset
14680
14681       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14682
14683       PARAMETER (MAXLND=4000)
14684       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
14685
14686       INTEGER PYK
14687
14688       DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
14689
14690       MODE = KMODE
14691       ISTSTG = 7
14692       IF (MODE.NE.1) ISTSTG = 8
14693       IREJ = 0
14694
14695       IP     = 0
14696       ISH    = 0
14697       INIEMC = 1
14698       NEND   = NHKK
14699       NACCEP = 0
14700       IFRG   = 0
14701       IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
14702       DO 10 I=NPOINT(3),NEND
14703 * sr 14.02.00: seems to be not necessary anymore, commented
14704 C        LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
14705 C    &            ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
14706          LACCEP = .TRUE.
14707 * pick up chains from dtevt1
14708          IDCHK = IDHKK(I)/10000
14709          IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
14710             IF (IDCHK.EQ.7) THEN
14711                IPJE = IDHKK(I)-IDCHK*10000
14712                IF (IPJE.NE.IFRG) THEN
14713                   IFRG = IPJE
14714                   IF (IFRG.GT.NFRG) GOTO 16
14715                ENDIF
14716             ELSE
14717                IPJE = 1
14718                IFRG = IFRG+1
14719                IF (IFRG.GT.NFRG) THEN
14720                   NFRG = -1
14721                   GOTO 16
14722                ENDIF
14723             ENDIF
14724 *   statistics counter
14725 c           IF (IDCH(I).LE.8)
14726 c    &         ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
14727 c           IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
14728 * special treatment for small chains already corrected to hadrons
14729             IF (IDRES(I).NE.0) THEN
14730                IF (IDRES(I).EQ.11) THEN
14731                   ID = IDXRES(I)
14732                ELSE
14733                   ID = IDT_IPDGHA(IDXRES(I))
14734                ENDIF
14735                IF (LEMCCK) THEN
14736                   CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
14737      &                              PHKK(4,I),INIEMC,IDUM,IDUM)
14738                   INIEMC = 2
14739                ENDIF
14740                IP = IP+1
14741                IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
14742                P(IP,1) = PHKK(1,I)
14743                P(IP,2) = PHKK(2,I)
14744                P(IP,3) = PHKK(3,I)
14745                P(IP,4) = PHKK(4,I)
14746                P(IP,5) = PHKK(5,I)
14747                K(IP,1) = 1
14748                K(IP,2) = ID
14749                K(IP,3) = 0
14750                K(IP,4) = 0
14751                K(IP,5) = 0
14752                IHIST(2,I) = 10000*IPJE+IP
14753                IF (IHIST(1,I).LE.-100) THEN
14754                   ISH = ISH+1
14755                   IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14756                   ISJOIN(ISH) = I
14757                ENDIF
14758                N = IP
14759                IHISMO(IP) = I
14760             ELSE
14761                IJ  = 0
14762                DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
14763                   IF (LEMCCK) THEN
14764                      CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
14765      &                                   PHKK(4,KK),INIEMC,IDUM,IDUM)
14766                      CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
14767                      INIEMC = 2
14768                   ENDIF
14769                   ID = IDHKK(KK)
14770                   IF (ID.EQ.0) ID = 21
14771 c                  PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
14772 c                  AM0  = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
14773
14774 c                  AMRQ   = PYMASS(ID)
14775
14776 c                  AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
14777 c                  IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
14778 c     &                (ABS(IDIFF).EQ.0)) THEN
14779 cC                    WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
14780 c                     DELTA      = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
14781 c                     PHKK(4,KK) = PHKK(4,KK)+DELTA
14782 c                     PTOT1      = PTOT-DELTA
14783 c                     PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
14784 c                     PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
14785 c                     PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
14786 c                     PHKK(5,KK) = AMRQ
14787 c                  ENDIF
14788                   IP = IP+1
14789                   IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
14790                   P(IP,1) = PHKK(1,KK)
14791                   P(IP,2) = PHKK(2,KK)
14792                   P(IP,3) = PHKK(3,KK)
14793                   P(IP,4) = PHKK(4,KK)
14794                   P(IP,5) = PHKK(5,KK)
14795                   K(IP,1) = 1
14796                   K(IP,2) = ID
14797                   K(IP,3) = 0
14798                   K(IP,4) = 0
14799                   K(IP,5) = 0
14800                   IHIST(2,KK) = 10000*IPJE+IP
14801                   IF (IHIST(1,KK).LE.-100) THEN
14802                      ISH = ISH+1
14803                      IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14804                      ISJOIN(ISH) = KK
14805                   ENDIF
14806                   IJ = IJ+1
14807                   IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
14808                   IJOIN(IJ)  = IP
14809                   IHISMO(IP) = I
14810    11          CONTINUE
14811                N = IP
14812 * join the two-parton system
14813
14814                CALL PYJOIN(IJ,IJOIN)
14815
14816             ENDIF
14817             IDHKK(I) = 99999
14818          ENDIF
14819    10 CONTINUE
14820    16 CONTINUE
14821       N = IP
14822
14823       IF (IP.GT.0) THEN
14824
14825 * final state parton shower
14826          DO 136 NPJE=1,IPJE
14827             IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
14828                IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
14829                   DO 130 K1=1,ISH
14830                      IF (ISJOIN(K1).EQ.0) GOTO 130
14831                      I = ISJOIN(K1)
14832                      IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
14833      &                                                       GOTO 130
14834                      IH1 = IHIST(2,I)/10000
14835                      IF (IH1.NE.NPJE) GOTO 130
14836                      IH1 = IHIST(2,I)-IH1*10000
14837                      DO 135 K2=K1+1,ISH
14838                         IF (ISJOIN(K2).EQ.0) GOTO 135
14839                         II = ISJOIN(K2)
14840                         IH2 = IHIST(2,II)/10000
14841                         IF (IH2.NE.NPJE) GOTO 135
14842                         IH2 = IHIST(2,II)-IH2*10000
14843                         IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
14844                            PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
14845                            PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
14846
14847                            RQLUN = MIN(PT1,PT2)
14848                            CALL PYSHOW(IH1,IH2,RQLUN)
14849
14850                            ISJOIN(K1) = 0
14851                            ISJOIN(K2) = 0
14852                            GOTO 130
14853                         ENDIF
14854  135                 CONTINUE
14855  130              CONTINUE
14856                ENDIF
14857             ENDIF
14858  136     CONTINUE
14859
14860          CALL DT_INITJS(MODE)
14861 * hadronization
14862
14863          CALL PYEXEC
14864
14865          IF (MSTU(24).NE.0) THEN
14866             WRITE(LOUT,*) ' JETSET-reject at event',
14867      &                    NEVHKK,MSTU(24),KMODE
14868 C           CALL DT_EVTOUT(4)
14869
14870 C           CALL PYLIST(2)
14871
14872             GOTO 9999
14873          ENDIF
14874
14875 *   number of entries in LUJETS
14876
14877          NLINES = PYK(0,1)
14878
14879          NPYMEM = NLINES
14880
14881          DO 12 I=1,NLINES
14882             IFLG(I) = 0
14883    12    CONTINUE
14884
14885          DO 13 II=1,NLINES
14886
14887             IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
14888
14889 *  pick up mother resonance if possible and put it together with
14890 *  their decay-products into the common
14891                IDXMOR = K(II,3)
14892                IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
14893                   KFMOR = K(IDXMOR,2)
14894                   ISMOR = K(IDXMOR,1)
14895                ELSE
14896                   KFMOR = 91
14897                   ISMOR = 1
14898                ENDIF
14899                IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
14900      &             (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
14901                   ID = K(IDXMOR,2)
14902
14903                   MO = IHISMO(PYK(IDXMOR,15))
14904                   PX = PYP(IDXMOR,1)
14905                   PY = PYP(IDXMOR,2)
14906                   PZ = PYP(IDXMOR,3)
14907                   PE = PYP(IDXMOR,4)
14908
14909                   CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14910                   IFLG(IDXMOR) = 1
14911                   MO = NHKK
14912                   DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
14913
14914                      IF (PYK(JDAUG,7).EQ.1) THEN
14915                         ID = PYK(JDAUG,8)
14916                         PX = PYP(JDAUG,1)
14917                         PY = PYP(JDAUG,2)
14918                         PZ = PYP(JDAUG,3)
14919                         PE = PYP(JDAUG,4)
14920
14921                         CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14922                         IF (LEMCCK) THEN
14923
14924                            PX = -PYP(JDAUG,1)
14925                            PY = -PYP(JDAUG,2)
14926                            PZ = -PYP(JDAUG,3)
14927                            PE = -PYP(JDAUG,4)
14928
14929                            CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14930                         ENDIF
14931                         IFLG(JDAUG) = 1
14932                      ENDIF
14933    15             CONTINUE
14934                ELSE
14935 *  there was no mother resonance
14936
14937                   MO = IHISMO(PYK(II,15))
14938                   ID = PYK(II,8)
14939                   PX = PYP(II,1)
14940                   PY = PYP(II,2)
14941                   PZ = PYP(II,3)
14942                   PE = PYP(II,4)
14943
14944                   CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14945                   IF (LEMCCK) THEN
14946
14947                      PX = -PYP(II,1)
14948                      PY = -PYP(II,2)
14949                      PZ = -PYP(II,3)
14950                      PE = -PYP(II,4)
14951
14952                      CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14953                   ENDIF
14954                ENDIF
14955             ENDIF
14956    13    CONTINUE
14957          IF (LEMCCK) THEN
14958             CHKLEV = TINY1
14959             CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
14960 C           IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
14961          ENDIF
14962
14963 * global energy-momentum & flavor conservation check
14964 **sr 16.5. this check is skipped in case of phojet-treatment
14965          IF (MCGENE.EQ.1)
14966      &      CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
14967
14968 * update statistics-counter for diffraction
14969 c        IF (IFLAGD.NE.0) THEN
14970 c           ICDIFF(1) = ICDIFF(1)+1
14971 c           IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
14972 c           IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
14973 c           IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
14974 c           IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
14975 c        ENDIF
14976
14977       ENDIF
14978
14979       RETURN
14980
14981  9999 CONTINUE
14982       IREJ = 1
14983       RETURN
14984       END
14985 *
14986 *===decay==============================================================*
14987 *
14988 CDECK  ID>, DT_DECAYS
14989       SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
14990
14991 ************************************************************************
14992 * Resonance-decay.                                                     *
14993 * This subroutine replaces DDECAY/DECHKK.                              *
14994 *             PIN(4)      4-momentum of resonance          (input)     *
14995 *             IDXIN       BAMJET-index of resonance        (input)     *
14996 *             POUT(20,4)  4-momenta of decay-products      (output)    *
14997 *             IDXOUT(20)  BAMJET-indices of decay-products (output)    *
14998 *             NSEC        number of secondaries            (output)    *
14999 * Adopted from the original version DECHKK.                            *
15000 * This version dated 09.01.95 is written by S. Roesler                 *
15001 ************************************************************************
15002
15003       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15004       SAVE
15005
15006       PARAMETER ( LINP = 5 ,
15007      &            LOUT = 6 ,
15008      &            LDAT = 9 )
15009
15010       PARAMETER (TINY17=1.0D-17)
15011
15012 * HADRIN: decay channel information
15013       PARAMETER (IDMAX9=602)
15014       CHARACTER*8 ZKNAME
15015       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15016 * particle properties (BAMJET index convention)
15017       CHARACTER*8  ANAME
15018       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15019      &                IICH(210),IIBAR(210),K1(210),K2(210)
15020 * flags for input different options
15021       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15022       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15023      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15024
15025       DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
15026      &          EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
15027      &          CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
15028
15029 * ISTAB = 1 strong and weak decays
15030 *       = 2 strong decays only
15031 *       = 3 strong decays, weak decays for charmed particles and tau
15032 *           leptons only
15033       DATA ISTAB /2/
15034
15035       IREJ = 0
15036       NSEC = 0
15037 * put initial resonance to stack
15038       NSTK = 1
15039       IDXSTK(NSTK) = IDXIN
15040       DO 5 I=1,4
15041          PI(NSTK,I) = PIN(I)
15042     5 CONTINUE
15043
15044 * store initial configuration for energy-momentum cons. check
15045       IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
15046      &                                   PI(NSTK,4),1,IDUM,IDUM)
15047
15048   100 CONTINUE
15049 * get particle from stack
15050       IDXI = IDXSTK(NSTK)
15051 * skip stable particles
15052       IF (ISTAB.EQ.1) THEN
15053          IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
15054          IF ((IDXI.GE.  1).AND.(IDXI.LE.  7)) GOTO 10
15055       ELSEIF (ISTAB.EQ.2) THEN
15056          IF ((IDXI.GE.  1).AND.(IDXI.LE. 30)) GOTO 10
15057          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15058          IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
15059          IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
15060          IF ( IDXI.EQ.109)                    GOTO 10
15061          IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
15062       ELSEIF (ISTAB.EQ.3) THEN
15063          IF ((IDXI.GE.  1).AND.(IDXI.LE. 23)) GOTO 10
15064          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15065          IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
15066          IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
15067       ENDIF
15068
15069 * calculate direction cosines and Lorentz-parameter of decaying part.
15070       PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
15071       PTOT = MAX(PTOT,TINY17)
15072       DO 1 I=1,3
15073          DCOS(I) = PI(NSTK,I)/PTOT
15074     1 CONTINUE
15075       GAM  = PI(NSTK,4)/AAM(IDXI)
15076       BGAM = PTOT/AAM(IDXI)
15077
15078 * get decay-channel
15079       KCHAN = K1(IDXI)-1
15080     2 CONTINUE
15081       KCHAN = KCHAN+1
15082       IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
15083
15084 * identities of secondaries
15085       IDX(1) = NZK(KCHAN,1)
15086       IDX(2) = NZK(KCHAN,2)
15087       IF (IDX(2).LT.1) GOTO 9999
15088       IDX(3) = NZK(KCHAN,3)
15089
15090 * handle decay in rest system of decaying particle
15091       IF (IDX(3).EQ.0) THEN
15092 *   two-particle decay
15093          NDEC = 2
15094          CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
15095      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15096      &               AAM(IDX(1)),AAM(IDX(2)))
15097       ELSE
15098 *   three-particle decay
15099          NDEC = 3
15100          CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
15101      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15102      &               CODF(3),COFF(3),SIFF(3),
15103      &               AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
15104       ENDIF
15105       NSTK = NSTK-1
15106
15107 * transform decay products back
15108       DO 3 I=1,NDEC
15109          NSTK = NSTK+1
15110          CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
15111      &               CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
15112      &               PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
15113 * add particle to stack
15114          IDXSTK(NSTK) = IDX(I)
15115          DO 4 J=1,3
15116             PI(NSTK,J) = DCOSF(J)*PFF(I)
15117     4    CONTINUE
15118     3 CONTINUE
15119       GOTO 100
15120
15121    10 CONTINUE
15122 * stable particle, put to output-arrays
15123       NSEC = NSEC+1
15124       DO 6 I=1,4
15125          POUT(NSEC,I) = PI(NSTK,I)
15126     6 CONTINUE
15127       IDXOUT(NSEC) = IDXSTK(NSTK)
15128 * store secondaries for energy-momentum conservation check
15129       IF (LEMCCK)
15130      &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15131      &            -POUT(NSEC,4),2,IDUM,IDUM)
15132       NSTK = NSTK-1
15133       IF (NSTK.GT.0) GOTO 100
15134
15135 * check energy-momentum conservation
15136       IF (LEMCCK) THEN
15137          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15138          IF (IREJ1.NE.0) GOTO 9999
15139       ENDIF
15140
15141       RETURN
15142
15143  9999 CONTINUE
15144       IREJ = 1
15145       RETURN
15146       END
15147 *
15148 *===decay1=============================================================*
15149 *
15150 CDECK  ID>, DT_DECAY1
15151       SUBROUTINE DT_DECAY1
15152
15153 ************************************************************************
15154 * Decay of resonances stored in DTEVT1.                                *
15155 * This version dated 20.01.95 is written by S. Roesler                 *
15156 ************************************************************************
15157
15158       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15159       SAVE
15160
15161       PARAMETER ( LINP = 5 ,
15162      &            LOUT = 6 ,
15163      &            LDAT = 9 )
15164
15165 * event history
15166
15167       PARAMETER (NMXHKK=200000)
15168
15169       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15170      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15171      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15172 * extended event history
15173       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15174      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15175      &                IHIST(2,NMXHKK)
15176
15177       DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15178
15179       NEND = NHKK
15180 C     DO 1 I=NPOINT(5),NEND
15181       DO 1 I=NPOINT(4),NEND
15182          IF (ABS(ISTHKK(I)).EQ.1) THEN
15183             DO 2 K=1,4
15184                PIN(K) = PHKK(K,I)
15185     2       CONTINUE
15186             IDXIN = IDBAM(I)
15187             CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15188             IF (NSEC.GT.1) THEN
15189                DO 3 N=1,NSEC
15190                   IDHAD = IDT_IPDGHA(IDXOUT(N))
15191                   CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15192      &                               POUT(N,3),POUT(N,4),0,0,0)
15193     3          CONTINUE
15194             ENDIF
15195          ENDIF
15196     1 CONTINUE
15197
15198       RETURN
15199       END
15200 *
15201 *===decpi0=============================================================*
15202 *
15203 CDECK  ID>, DT_DECPI0
15204       SUBROUTINE DT_DECPI0
15205
15206 ************************************************************************
15207 * Decay of pi0 handled with JETSET.                                    *
15208 * This version dated 18.02.96 is written by S. Roesler                 *
15209 ************************************************************************
15210
15211       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15212       SAVE
15213
15214       PARAMETER ( LINP = 5 ,
15215      &            LOUT = 6 ,
15216      &            LDAT = 9 )
15217
15218       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15219
15220 * event history
15221
15222       PARAMETER (NMXHKK=200000)
15223
15224       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15225      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15226      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15227 * extended event history
15228       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15229      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15230      &                IHIST(2,NMXHKK)
15231
15232       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15233
15234       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15235
15236       PARAMETER (MAXLND=4000)
15237       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15238
15239 * flags for input different options
15240       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15241       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15242      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15243
15244       INTEGER PYCOMP,PYK
15245
15246       DIMENSION IHISMO(NMXHKK),P1(4)
15247
15248       TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15249
15250       CALL DT_INITJS(2)
15251 * allow pi0 decay
15252
15253       KC = PYCOMP(111)
15254
15255       MDCY(KC,1) = 1
15256
15257       NN  = 0
15258       INI = 0
15259       DO 1 I=1,NHKK
15260          IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15261             IF (INI.EQ.0) THEN
15262                INI = 1
15263             ELSE
15264                INI = 2
15265             ENDIF
15266             IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15267      &                                    PHKK(4,I),INI,IDUM,IDUM)
15268             PT    = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15269             PTOT  = SQRT(PT**2+PHKK(3,I)**2)
15270             COSTH = PHKK(3,I)/(PTOT+TINY10)
15271             IF (COSTH.GT.ONE) THEN
15272                THETA = ZERO
15273             ELSEIF (COSTH.LT.-ONE) THEN
15274                THETA = TWOPI/2.0D0
15275             ELSE
15276                THETA = ACOS(COSTH)
15277             ENDIF
15278             PHI     = ASIN(PHKK(2,I)/(PT  +TINY10))
15279             IF (PHKK(1,I).LT.0.0D0)
15280
15281      &         PHI  = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15282
15283             ENER    = PHKK(4,I)
15284             NN      = NN+1
15285             KTEMP   = MSTU(10)
15286             MSTU(10)= 1
15287             P(NN,5) = PHKK(5,I)
15288
15289             CALL PY1ENT(NN,111,ENER,THETA,PHI)
15290
15291             MSTU(10)  = KTEMP
15292             IHISMO(NN)= I
15293          ENDIF
15294     1 CONTINUE
15295       IF (NN.GT.0) THEN
15296
15297          CALL PYEXEC
15298
15299          NLINES = PYK(0,1)
15300
15301          DO 2 II=1,NLINES
15302
15303             IF (PYK(II,7).EQ.1) THEN
15304
15305                DO 3 KK=1,4
15306
15307                   P1(KK) = PYP(II,KK)
15308
15309     3          CONTINUE
15310
15311                ID = PYK(II,8)
15312                MO = IHISMO(PYK(II,15))
15313
15314                CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15315                IF (LEMCCK)
15316      &            CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15317      &                                            IDUM,IDUM)
15318 *sr: flag with neg. sign (for HELIOS p/A-W jobs)
15319                ISTHKK(MO) = -2
15320             ENDIF
15321     2    CONTINUE
15322          IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15323       ENDIF
15324       MDCY(KC,1) = 0
15325
15326       RETURN
15327       END
15328 *
15329 *===dtwopd=============================================================*
15330 *
15331 CDECK  ID>, DT_DTWOPD
15332       SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15333      &                                            COF2,SIF2,AM1,AM2)
15334
15335 ************************************************************************
15336 * Two-particle decay.                                                  *
15337 *  UMO                 cm-energy of the decaying system       (input)  *
15338 *  AM1/AM2             masses of the decay products           (input)  *
15339 *  ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15340 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15341 * Revised by S. Roesler, 20.11.95                                      *
15342 ************************************************************************
15343
15344       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15345       SAVE
15346
15347       PARAMETER ( LINP = 5 ,
15348      &            LOUT = 6 ,
15349      &            LDAT = 9 )
15350
15351       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15352
15353       IF (UMO.LT.(AM1+AM2)) THEN
15354          WRITE(LOUT,1000) UMO,AM1,AM2
15355  1000    FORMAT(1X,'DTWOPD:    inconsistent kinematics - UMO,AM1,AM2 ',
15356      &          3E12.3)
15357          STOP
15358       ENDIF
15359
15360       ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15361       ECM2 = UMO-ECM1
15362       PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15363       PCM2 = PCM1
15364       CALL DT_DSFECF(SIF1,COF1)
15365       COD1 = TWO*DT_RNDM(PCM2)-ONE
15366       COD2 = -COD1
15367       COF2 = -COF1
15368       SIF2 = -SIF1
15369
15370       RETURN
15371       END
15372 *
15373 *===dthrep=============================================================*
15374 *
15375 CDECK  ID>, DT_DTHREP
15376       SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15377      &                  SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15378
15379 ************************************************************************
15380 * Three-particle decay.                                                *
15381 *  UMO                 cm-energy of the decaying system       (input)  *
15382 *  AM1/2/3             masses of the decay products           (input)  *
15383 *  ECM1/2/2,PCM1/2/3   cm-energies/momenta of the decay prod. (output) *
15384 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15385 *                                                                      *
15386 * Threpd89: slight revision by A. Ferrari                              *
15387 * Last change on   11-oct-93   by    Alfredo Ferrari, INFN - Milan     *
15388 * Revised by S. Roesler, 20.11.95                                      *
15389 ************************************************************************
15390
15391       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15392       SAVE
15393
15394       PARAMETER ( LINP = 5 ,
15395      &            LOUT = 6 ,
15396      &            LDAT = 9 )
15397
15398       PARAMETER ( ANGLSQ = 2.5D-31 )
15399       PARAMETER ( AZRZRZ = 1.0D-30 )
15400       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
15401       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
15402       PARAMETER ( ONEONE = 1.D+00 )
15403       PARAMETER ( TWOTWO = 2.D+00 )
15404       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15405
15406       COMMON /HNGAMR/ REDU,AMO,AMM(15)
15407 * flags for input different options
15408       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15409       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15410      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15411
15412       DIMENSION F(5),XX(5)
15413       DATA EPS /AZRZRZ/
15414
15415       UMOO=UMO+UMO
15416 C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
15417 C***J. VON NEUMANN - RANDOM - SELECTION OF S2
15418 C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
15419       UUMO=UMO
15420       AAM1=AM1
15421       AAM2=AM2
15422       AAM3=AM3
15423       GU=(AM2+AM3)**2
15424       GO=(UMO-AM1)**2
15425 *     UFAK=1.0000000000001D0
15426 *     IF (GU.GT.GO) UFAK=0.9999999999999D0
15427       IF (GU.GT.GO) THEN
15428          UFAK=ONEMNS
15429       ELSE
15430          UFAK=ONEPLS
15431       END IF
15432       OFAK=2.D0-UFAK
15433       GU=GU*UFAK
15434       GO=GO*OFAK
15435       DS2=(GO-GU)/99.D0
15436       AM11=AM1*AM1
15437       AM22=AM2*AM2
15438       AM33=AM3*AM3
15439       UMO2=UMO*UMO
15440       RHO2=0.D0
15441       S22=GU
15442       DO 124 I=1,100
15443          S21=S22
15444          S22=GU+(I-1.D0)*DS2
15445          RHO1=RHO2
15446          RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
15447      *                                             (S22+EPS)
15448          IF(RHO2.LT.RHO1) GO TO 125
15449   124 CONTINUE
15450   125 S2SUP=(S22-S21)*.5D0+S21
15451       SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
15452      *                                           (S2SUP+EPS)
15453       SUPRHO=SUPRHO*1.05D0
15454       XO=S21-DS2
15455       IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
15456       IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
15457       XX(1)=XO
15458       XX(3)=S22
15459       X1=(XO+S22)*0.5D0
15460       XX(2)=X1
15461       F(3)=RHO2
15462       F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
15463       F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
15464       DO 126 I=1,16
15465          X4=(XX(1)+XX(2))*0.5D0
15466          X5=(XX(2)+XX(3))*0.5D0
15467          F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
15468      *                                               (X4+EPS)
15469          F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
15470      *                                               (X5+EPS)
15471          XX(4)=X4
15472          XX(5)=X5
15473          DO 128 II=1,5
15474             IA=II
15475             DO 128 III=IA,5
15476                IF (F (II).GE.F (III)) GO TO 128
15477                FH=F(II)
15478                F(II)=F(III)
15479                F(III)=FH
15480                FH=XX(II)
15481                XX(II)=XX(III)
15482                XX(III)=FH
15483 128      CONTINUE
15484          SUPRHO=F(1)
15485          S2SUP=XX(1)
15486          DO 129 II=1,3
15487             IA=II
15488             DO 129 III=IA,3
15489                IF (XX(II).GE.XX(III)) GO TO 129
15490                FH=F(II)
15491                F(II)=F(III)
15492                F(III)=FH
15493                FH=XX(II)
15494                XX(II)=XX(III)
15495                XX(III)=FH
15496 129      CONTINUE
15497 126   CONTINUE
15498       AM23=(AM2+AM3)**2
15499       ITH=0
15500       REDU=2.D0
15501     1 CONTINUE
15502       ITH=ITH+1
15503       IF (ITH.GT.200) REDU=-9.D0
15504       IF (ITH.GT.200) GO TO 400
15505       C=DT_RNDM(REDU)
15506 *     S2=AM23+C*((UMO-AM1)**2-AM23)
15507       S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
15508       Y=DT_RNDM(S2)
15509       Y=Y*SUPRHO
15510       RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
15511       IF(Y.GT.RHO) GO TO 1
15512 C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
15513       S1=DT_RNDM(S2)
15514       S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
15515      &RHO*.5D0
15516       S3=UMO2+AM11+AM22+AM33-S1-S2
15517       ECM1=(UMO2+AM11-S2)/UMOO
15518       ECM2=(UMO2+AM22-S3)/UMOO
15519       ECM3=(UMO2+AM33-S1)/UMOO
15520       PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
15521       PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
15522       PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
15523       CALL DT_DSFECF(SFE,CFE)
15524 C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
15525 C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
15526       PCM12 = PCM1 * PCM2
15527       IF ( PCM12 .LT. ANGLSQ ) GO TO 200
15528       COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
15529       GO TO 300
15530  200  CONTINUE
15531          UW=DT_RNDM(S1)
15532          COSTH=(UW-0.5D+00)*2.D+00
15533  300  CONTINUE
15534 *     IF(ABS(COSTH).GT.0.9999999999999999D0)
15535 *    &COSTH=SIGN(0.9999999999999999D0,COSTH)
15536       IF(ABS(COSTH).GT.ONEONE)
15537      &COSTH=SIGN(ONEONE,COSTH)
15538       IF (REDU.LT.1.D+00) RETURN
15539       COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
15540 *     IF(ABS(COSTH2).GT.0.9999999999999999D0)
15541 *    &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
15542       IF(ABS(COSTH2).GT.ONEONE)
15543      &COSTH2=SIGN(ONEONE,COSTH2)
15544       SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
15545       SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
15546       SINTH1=COSTH2*SINTH-COSTH*SINTH2
15547       COSTH1=COSTH*COSTH2+SINTH2*SINTH
15548 C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
15549 C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
15550 C***THE DIRECTION OF PARTICLE 3
15551 C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
15552       CX11=-COSTH1
15553       CY11=SINTH1*CFE
15554       CZ11=SINTH1*SFE
15555       CX22=-COSTH2
15556       CY22=-SINTH2*CFE
15557       CZ22=-SINTH2*SFE
15558       CALL DT_DSFECF(SIF3,COF3)
15559       COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
15560       SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
15561     2 FORMAT(5F20.15)
15562       COD1=CX11*COD3+CZ11*SID3
15563       CHLP=(ONEONE-COD1)*(ONEONE+COD1)
15564       IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
15565      &CX11,CZ11
15566       SID1=SQRT(CHLP)
15567       COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
15568       SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
15569       COD2=CX22*COD3+CZ22*SID3
15570       SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
15571       COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
15572       SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
15573  400  CONTINUE
15574 * === Energy conservation check: === *
15575       EOCHCK = UMO - ECM1 - ECM2 - ECM3
15576 *     SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
15577 *     SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
15578 *     SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
15579       PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
15580       PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
15581      &       + PCM3 * COF3 * SID3
15582       PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
15583      &       + PCM3 * SIF3 * SID3
15584       EOCMPR = 1.D-12 * UMO
15585       IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
15586      &     .GT. EOCMPR ) THEN
15587 **sr 5.5.95 output-unit changed
15588          IF (IOULEV(1).GT.0) THEN
15589             WRITE(LOUT,*)
15590      &      ' *** Threpd: energy/momentum conservation failure! ***',
15591      &      EOCHCK,PXCHCK,PYCHCK,PZCHCK
15592             WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
15593          ENDIF
15594 **
15595       END IF
15596       RETURN
15597       END
15598 *
15599 *===dbklas=============================================================*
15600 *
15601 CDECK  ID>, DT_DBKLAS
15602       SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
15603
15604       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15605       SAVE
15606
15607       PARAMETER ( LINP = 5 ,
15608      &            LOUT = 6 ,
15609      &            LDAT = 9 )
15610
15611 * quark-content to particle index conversion (DTUNUC 1.x)
15612       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15613      &                IA08(6,21),IA10(6,21)
15614
15615       IF (I) 20,20,10
15616 * baryons
15617    10 CONTINUE
15618       CALL DT_INDEXD(J,K,IND)
15619       I8  = IB08(I,IND)
15620       I10 = IB10(I,IND)
15621       IF (I8.LE.0) I8 = I10
15622       RETURN
15623 * antibaryons
15624    20 CONTINUE
15625       II = IABS(I)
15626       JJ = IABS(J)
15627       KK = IABS(K)
15628       CALL DT_INDEXD(JJ,KK,IND)
15629       I8  = IA08(II,IND)
15630       I10 = IA10(II,IND)
15631       IF (I8.LE.0) I8 = I10
15632
15633       RETURN
15634       END
15635 *
15636 *===indexd=============================================================*
15637 *
15638 CDECK  ID>, DT_INDEXD
15639       SUBROUTINE DT_INDEXD(KA,KB,IND)
15640
15641       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15642       SAVE
15643
15644       PARAMETER ( LINP = 5 ,
15645      &            LOUT = 6 ,
15646      &            LDAT = 9 )
15647
15648       KP = KA*KB
15649       KS = KA+KB
15650       IF (KP.EQ.1) IND=1
15651       IF (KP.EQ.2) IND=2
15652       IF (KP.EQ.3) IND=3
15653       IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
15654       IF (KP.EQ.5) IND=5
15655       IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
15656       IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
15657       IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
15658       IF (KP.EQ.8)  IND=9
15659       IF (KP.EQ.10) IND=10
15660       IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
15661       IF (KP.EQ.9)  IND=12
15662       IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
15663       IF (KP.EQ.15) IND=14
15664       IF (KP.EQ.18) IND=15
15665       IF (KP.EQ.16) IND=16
15666       IF (KP.EQ.20) IND=17
15667       IF (KP.EQ.24) IND=18
15668       IF (KP.EQ.25) IND=19
15669       IF (KP.EQ.30) IND=20
15670       IF (KP.EQ.36) IND=21
15671
15672       RETURN
15673       END
15674 *
15675 *===dchant=============================================================*
15676 *
15677 CDECK  ID>, DT_DCHANT
15678       SUBROUTINE DT_DCHANT
15679
15680       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15681       SAVE
15682
15683       PARAMETER ( LINP = 5 ,
15684      &            LOUT = 6 ,
15685      &            LDAT = 9 )
15686
15687       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15688
15689 * HADRIN: decay channel information
15690       PARAMETER (IDMAX9=602)
15691       CHARACTER*8 ZKNAME
15692       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15693 * particle properties (BAMJET index convention)
15694       CHARACTER*8  ANAME
15695       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15696      &                IICH(210),IIBAR(210),K1(210),K2(210)
15697
15698       DIMENSION HWT(IDMAX9)
15699
15700 * change of weights wt from absolut values into the sum of wt of a dec.
15701       DO 10 J=1,IDMAX9
15702          HWT(J) = ZERO
15703    10 CONTINUE
15704 C     DO 999 KKK=1,210
15705 C        WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
15706 C    &      ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
15707 C    &      K1(KKK),K2(KKK)
15708 C 999 CONTINUE
15709 C     STOP
15710       DO 30 I=1,210
15711          IK1 = K1(I)
15712          IK2 = K2(I)
15713          HV  = ZERO
15714          DO 20 J=IK1,IK2
15715             HV     = HV+WT(J)
15716             HWT(J) = HV
15717 **sr 13.1.95
15718             IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
15719  1000       FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
15720    20    CONTINUE
15721    30 CONTINUE
15722       DO 40 J=1,IDMAX9
15723          WT(J) = HWT(J)
15724    40 CONTINUE
15725
15726       RETURN
15727       END
15728 *
15729 *===ddatar=============================================================*
15730 *
15731 CDECK  ID>, DT_DDATAR
15732       SUBROUTINE DT_DDATAR
15733
15734       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15735       SAVE
15736
15737       PARAMETER ( LINP = 5 ,
15738      &            LOUT = 6 ,
15739      &            LDAT = 9 )
15740
15741       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15742
15743 * quark-content to particle index conversion (DTUNUC 1.x)
15744       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15745      &                IA08(6,21),IA10(6,21)
15746
15747       DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
15748
15749       DATA IV/ 33, 34, 38,123,  0,  0, 32, 33, 39,124,
15750      &          0,  0, 36, 37, 96,127,  0,  0,126,125,
15751      &        128,129,14*0/
15752       DATA IP/ 23, 14, 16,116,  0,  0, 13, 23, 25,117,
15753      &          0,  0, 15, 24, 31,120,  0,  0,119,118,
15754      &        121,122,14*0/
15755       DATA IB/  0,  1, 21,140,  0,  0,  8, 22,137,  0,
15756      &          0, 97,138,  0,  0,146,  0,  0,  0,  0,
15757      &          0,  1,  8, 22,137,  0,  0,  0, 20,142,
15758      &          0,  0, 98,139,  0,  0,147,  0,  0,  0,
15759      &          0,  0, 21, 22, 97,138,  0,  0, 20, 98,
15760      &        139,  0,  0,  0,145,  0,  0,148,  0,  0,
15761      &          0,  0,  0,140,137,138,146,  0,  0,142,
15762      &        139,147,  0,  0,145,148,           50*0/
15763       DATA IBB/53, 54,104,161,  0,  0, 55,105,162,  0,
15764      &          0,107,164,  0,  0,167,  0,  0,  0,  0,
15765      &          0, 54, 55,105,162,  0,  0, 56,106,163,
15766      &          0,  0,108,165,  0,  0,168,  0,  0,  0,
15767      &          0,  0,104,105,107,164,  0,  0,106,108,
15768      &        165,  0,  0,109,166,  0,  0,169,  0,  0,
15769      &          0,  0,  0,161,162,164,167,  0,  0,163,
15770      &        165,168,  0,  0,166,169,  0,  0,170,47*0/
15771       DATA IA/  0,  2, 99,152,  0,  0,  9,100,149,  0,
15772      &          0,102,150,  0,  0,158,  0,  0,  0,  0,
15773      &          0,  2,  9,100,149,  0,  0,  0,101,154,
15774      &          0,  0,103,151,  0,  0,159,  0,  0,  0,
15775      &          0,  0, 99,100,102,150,  0,  0,101,103,
15776      &        151,  0,  0,  0,157,  0,  0,160,  0,  0,
15777      &          0,  0,  0,152,149,150,158,  0,  0,154,
15778      &        151,159,  0,  0,157,160,           50*0/
15779       DATA IAA/67, 68,110,171,  0,  0, 69,111,172,  0,
15780      &          0,113,174,  0,  0,177,  0,  0,  0,  0,
15781      &          0, 68, 69,111,172,  0,  0, 70,112,173,
15782      &          0,  0,114,175,  0,  0,178,  0,  0,  0,
15783      &          0,  0,110,111,113,174,  0,  0,112,114,
15784      &        175,  0,  0,115,176,  0,  0,179,  0,  0,
15785      &          0,  0,  0,171,172,174,177,  0,  0,173,
15786      &        175,178,  0,  0,176,179,  0,  0,180,47*0/
15787
15788       L=0
15789       DO 2 I=1,6
15790          DO 1 J=1,6
15791             L = L+1
15792             IMPS(I,J) = IP(L)
15793             IMVE(I,J) = IV(L)
15794     1    CONTINUE
15795     2 CONTINUE
15796       L=0
15797       DO 4 I=1,6
15798          DO 3 J=1,21
15799             L = L+1
15800             IB08(I,J) = IB(L)
15801             IB10(I,J) = IBB(L)
15802             IA08(I,J) = IA(L)
15803             IA10(I,J) = IAA(L)
15804     3    CONTINUE
15805     4 CONTINUE
15806 C     A1  = 0.88D0
15807 C     B1  = 3.0D0
15808 C     B2  = 3.0D0
15809 C     B3  = 8.0D0
15810 C     LT  = 0
15811 C     LB  = 0
15812 C     BET = 12.0D0
15813 C     AS  = 0.25D0
15814 C     B8  = 0.33D0
15815 C     AME = 0.95D0
15816 C     DIQ = 0.375D0
15817 C     ISU = 4
15818
15819       RETURN
15820       END
15821 *
15822 *===initjs=============================================================*
15823 *
15824 CDECK  ID>, DT_INITJS
15825       SUBROUTINE DT_INITJS(MODE)
15826
15827 ************************************************************************
15828 * Initialize JETSET paramters.                                         *
15829 *           MODE = 0 default settings                                  *
15830 *                = 1 PHOJET settings                                   *
15831 *                = 2 DTUNUC settings                                   *
15832 * This version dated 16.02.96 is written by S. Roesler                 *
15833 ************************************************************************
15834
15835       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15836       SAVE
15837
15838       PARAMETER ( LINP = 5 ,
15839      &            LOUT = 6 ,
15840      &            LDAT = 9 )
15841
15842       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15843
15844       LOGICAL LFIRST,LFIRDT,LFIRPH
15845
15846       INCLUDE './flukapro/(DIMPAR)'
15847       INCLUDE './flukapro/(PART)'
15848
15849       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15850
15851       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15852
15853       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15854
15855 * flags for particle decays
15856       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
15857      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
15858      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
15859 * flags for input different options
15860       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15861       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15862      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15863
15864       INTEGER PYCOMP
15865
15866       DIMENSION IDXSTA(40)
15867       DATA IDXSTA
15868 *          K0s   pi0  lam   alam  sig+  asig+ sig-  asig- tet0  atet0
15869      &  /  310,  111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
15870 *          tet- atet-  om-  aom-   D+    D-    D0    aD0   Ds+   aDs+
15871      &    3312,-3312, 3334,-3334,  411, -411,  421, -421,  431, -431,
15872 *          etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
15873      &     441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
15874 *         Ksic0 aKsic+aKsic0 sig0 asig0
15875      &    4132,-4232,-4132, 3212,-3212, 5*0/
15876
15877       DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
15878
15879       IF (LFIRST) THEN
15880 * save default settings
15881          PDEF1  = PARJ(1)
15882          PDEF2  = PARJ(2)
15883          PDEF3  = PARJ(3)
15884          PDEF5  = PARJ(5)
15885          PDEF6  = PARJ(6)
15886          PDEF7  = PARJ(7)
15887          PDEF18 = PARJ(18)
15888          PDEF19 = PARJ(19)
15889          PDEF21 = PARJ(21)
15890          PDEF42 = PARJ(42)
15891          MDEF12 = MSTJ(12)
15892 * LUJETS / PYJETS array-dimensions
15893
15894          MSTU(4) = 4000
15895
15896 * increase maximum number of JETSET-error prints
15897          MSTU(22) = 50000
15898 * prevent particles decaying
15899          DO 1 I=1,35
15900             IF (I.LT.34) THEN
15901
15902                KC = PYCOMP(IDXSTA(I))
15903
15904                IF (I.EQ.2) THEN
15905 *  pi0 decay
15906 C                 MDCY(KC,1) = 1
15907                   MDCY(KC,1) = 0
15908 **cr mode
15909 C              ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
15910 C   &                 (I.EQ.8).OR.(I.EQ.10)) THEN
15911 C              ELSEIF (I.EQ.4) THEN
15912 C                 MDCY(KC,1) = 1
15913 **
15914                ELSE
15915                   MDCY(KC,1) = 0
15916                ENDIF
15917             ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
15918
15919                KC = PYCOMP(IDXSTA(I))
15920
15921                MDCY(KC,1) = 0
15922             ENDIF
15923     1    CONTINUE
15924 *
15925
15926 * as Fluka event-generator: allow only paprop particles to be stable
15927 * and let all other particles decay (i.e. those with strong decays)
15928          IF (ITRSPT.EQ.1) THEN
15929             DO 5 I=1,IDMAXP
15930                IF (KPTOIP(I).NE.0) THEN
15931                   IDPDG = MPDGHA(I)
15932
15933                   KC    = PYCOMP(IDPDG)
15934
15935                   IF (MDCY(KC,1).EQ.1) THEN
15936                      WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-',
15937      &                             'transport : particle should not ',
15938      &                             'decay : ',IDPDG,'  ',ANAME(I)
15939                      MDCY(KC,1) = 0
15940                   ENDIF
15941                ENDIF
15942     5       CONTINUE
15943             DO 6 KC=1,500
15944                IDPDG = KCHG(KC,4)
15945                KP    = MCIHAD(IDPDG)
15946                IF (KP.GT.0) THEN
15947                   IF ((MDCY(KC,1).EQ.0).AND.(KPTOIP(KP).EQ.0).AND.
15948      &                (ANAME(KP).NE.'BLANK   ').AND.
15949      &                (ANAME(KP).NE.'RNDFLV  ')) THEN
15950                      WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-',
15951      &                             'transport: particle should decay ',
15952      &                             ': ',IDPDG,' ',ANAME(KP)
15953                      MDCY(KC,1) = 1
15954                   ENDIF
15955                ENDIF
15956     6       CONTINUE
15957          ENDIF
15958
15959 *
15960 * popcorn:
15961          IF (PDB.LE.ZERO) THEN
15962 *   no popcorn-mechanism
15963             MSTJ(12) = 1
15964          ELSE
15965             MSTJ(12) = 3
15966             PARJ(5)  = PDB
15967          ENDIF
15968 * set JETSET-parameter requested by input cards
15969          IF (NMSTU.GT.0) THEN
15970             DO 2 I=1,NMSTU
15971                MSTU(IMSTU(I)) = MSTUX(I)
15972     2       CONTINUE
15973          ENDIF
15974          IF (NMSTJ.GT.0) THEN
15975             DO 3 I=1,NMSTJ
15976                MSTJ(IMSTJ(I)) = MSTJX(I)
15977     3       CONTINUE
15978          ENDIF
15979          IF (NPARU.GT.0) THEN
15980             DO 4 I=1,NPARU
15981                PARU(IPARU(I)) = PARUX(I)
15982     4       CONTINUE
15983          ENDIF
15984          LFIRST = .FALSE.
15985       ENDIF
15986 *
15987 * PARJ(1)  suppression of qq-aqaq pair prod. compared to
15988 *          q-aq pair prod.                      (default: 0.1)
15989 * PARJ(2)  strangeness suppression               (default: 0.3)
15990 * PARJ(3)  extra suppression of strange diquarks (default: 0.4)
15991 * PARJ(6)  extra suppression of sas-pair shared by B and
15992 *          aB in BMaB                           (default: 0.5)
15993 * PARJ(7)  extra suppression of strange meson M in BMaB
15994 *          configuration                        (default: 0.5)
15995 * PARJ(18) spin 3/2 baryon suppression           (default: 1.0)
15996 * PARJ(21) width sigma in Gaussian p_x, p_y transverse
15997 *          momentum distrib. for prim. hadrons  (default: 0.35)
15998 * PARJ(42) b-parameter for symmetric Lund-fragmentation
15999 *          function                             (default: 0.9 GeV^-2)
16000 *
16001 * PHOJET settings
16002       IF (MODE.EQ.1) THEN
16003 *   JETSET default
16004 C        PARJ(1)  = PDEF1
16005 C        PARJ(2)  = PDEF2
16006 C        PARJ(3)  = PDEF3
16007 C        PARJ(6)  = PDEF6
16008 C        PARJ(7)  = PDEF7
16009 C        PARJ(18) = PDEF18
16010 C        PARJ(21) = PDEF21
16011 C        PARJ(42) = PDEF42
16012 **sr 18.11.98 parameter tuning
16013 C        PARJ(1)  = 0.092D0
16014 C        PARJ(2)  = 0.25D0
16015 C        PARJ(3)  = 0.45D0
16016 C        PARJ(19) = 0.3D0
16017 C        PARJ(21) = 0.45D0
16018 C        PARJ(42) = 1.0D0
16019 **sr 28.04.99 parameter tuning (May 99 minor modifications)
16020          PARJ(1)  = 0.085D0
16021          PARJ(2)  = 0.26D0
16022          PARJ(3)  = 0.8D0
16023          PARJ(11) = 0.38D0
16024          PARJ(18) = 0.3D0
16025          PARJ(19) = 0.4D0
16026          PARJ(21) = 0.36D0
16027          PARJ(41) = 0.3D0
16028          PARJ(42) = 0.86D0
16029          IF (NPARJ.GT.0) THEN
16030             DO 10 I=1,NPARJ
16031                IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
16032    10       CONTINUE
16033          ENDIF
16034          IF (LFIRPH) THEN
16035 C *** Commented by Chiara
16036 C            WRITE(LOUT,'(1X,A)')
16037 C     &         'DT_INITJS: JETSET-parameter for PHOJET'
16038             CALL DT_JSPARA(0)
16039             LFIRPH = .FALSE.
16040          ENDIF
16041 * DTUNUC settings
16042       ELSEIF (MODE.EQ.2) THEN
16043          IF (IFRAG(2).EQ.1) THEN
16044 **sr parameters before 9.3.96
16045 C           PARJ(2)  = 0.27D0
16046 C           PARJ(3)  = 0.6D0
16047 C           PARJ(6)  = 0.75D0
16048 C           PARJ(7)  = 0.75D0
16049 C           PARJ(21) = 0.55D0
16050 C           PARJ(42) = 1.3D0
16051 **sr 18.11.98 parameter tuning
16052 C           PARJ(1)  = 0.05D0
16053 C           PARJ(2)  = 0.27D0
16054 C           PARJ(3)  = 0.4D0
16055 C           PARJ(19) = 0.2D0
16056 C           PARJ(21) = 0.45D0
16057 C           PARJ(42) = 1.0D0
16058 **sr 28.04.99 parameter tuning
16059             PARJ(1)  = 0.11D0
16060             PARJ(2)  = 0.36D0
16061             PARJ(3)  = 0.8D0
16062             PARJ(19) = 0.2D0
16063             PARJ(21) = 0.3D0
16064             PARJ(41) = 0.3D0
16065             PARJ(42) = 0.58D0
16066             IF (NPARJ.GT.0) THEN
16067                DO 20 I=1,NPARJ
16068                   IF (IPARJ(I).LT.0) THEN
16069                      IDX = ABS(IPARJ(I))
16070                      PARJ(IDX) = PARJX(I)
16071                   ENDIF
16072    20          CONTINUE
16073             ENDIF
16074             IF (LFIRDT) THEN
16075                WRITE(LOUT,'(1X,A)')
16076      &           'DT_INITJS: JETSET-parameter for DTUNUC'
16077                CALL DT_JSPARA(0)
16078                LFIRDT = .FALSE.
16079             ENDIF
16080          ELSEIF (IFRAG(2).EQ.2) THEN
16081             PARJ(1)  = 0.11D0
16082             PARJ(2)  = 0.27D0
16083             PARJ(3)  = 0.3D0
16084             PARJ(6)  = 0.35D0
16085             PARJ(7)  = 0.45D0
16086             PARJ(18) = 0.66D0
16087 C           PARJ(21) = 0.55D0
16088 C           PARJ(42) = 1.0D0
16089             PARJ(21) = 0.60D0
16090             PARJ(42) = 1.3D0
16091          ELSE
16092             PARJ(1)  = PDEF1
16093             PARJ(2)  = PDEF2
16094             PARJ(3)  = PDEF3
16095             PARJ(6)  = PDEF6
16096             PARJ(7)  = PDEF7
16097             PARJ(18) = PDEF18
16098             PARJ(21) = PDEF21
16099             PARJ(42) = PDEF42
16100          ENDIF
16101       ELSE
16102          PARJ(1)  = PDEF1
16103          PARJ(2)  = PDEF2
16104          PARJ(3)  = PDEF3
16105          PARJ(5)  = PDEF5
16106          PARJ(6)  = PDEF6
16107          PARJ(7)  = PDEF7
16108          PARJ(18) = PDEF18
16109          PARJ(19) = PDEF19
16110          PARJ(21) = PDEF21
16111          PARJ(42) = PDEF42
16112          MSTJ(12) = MDEF12
16113       ENDIF
16114
16115       RETURN
16116       END
16117 *
16118 *===jspara=============================================================*
16119 *
16120 CDECK  ID>, DT_JSPARA
16121       SUBROUTINE DT_JSPARA(MODE)
16122
16123       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16124       SAVE
16125
16126       PARAMETER ( LINP = 5 ,
16127      &            LOUT = 6 ,
16128      &            LDAT = 9 )
16129
16130       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
16131      &           ONE=1.0D0,ZERO=0.0D0)
16132
16133       LOGICAL LFIRST
16134
16135       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16136
16137       DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
16138
16139       DATA LFIRST /.TRUE./
16140
16141 * save the default JETSET-parameter on the first call
16142       IF (LFIRST) THEN
16143          DO 1 I=1,200
16144             ISTU(I) = MSTU(I)
16145             QARU(I) = PARU(I)
16146             ISTJ(I) = MSTJ(I)
16147             QARJ(I) = PARJ(I)
16148     1    CONTINUE
16149          LFIRST = .FALSE.
16150       ENDIF
16151
16152 C *** Commented by Chiara
16153 C      WRITE(LOUT,1000)
16154 C 1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
16155
16156 * compare the default JETSET-parameter with the present values
16157       DO 2 I=1,200
16158 C *** Commented by Chiara
16159 C         IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
16160 C            WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
16161 CC           ISTU(I) = MSTU(I)
16162 C         ENDIF
16163          DIFF = ABS(PARU(I)-QARU(I))
16164 C *** Commented by Chiara
16165 C         IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
16166 C            WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
16167 CC           QARU(I) = PARU(I)
16168 C         ENDIF
16169 C *** Commented by Chiara
16170 C         IF (MSTJ(I).NE.ISTJ(I)) THEN
16171 C            WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16172 CC           ISTJ(I) = MSTJ(I)
16173 C         ENDIF
16174          DIFF = ABS(PARJ(I)-QARJ(I))
16175 C *** Commented by Chiara
16176 C         IF (DIFF.GE.1.0D-5) THEN
16177 C            WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16178 CC           QARJ(I) = PARJ(I)
16179 C         ENDIF
16180     2 CONTINUE
16181  1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16182  1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16183
16184       RETURN
16185       END
16186 *
16187 *===fozoca=============================================================*
16188 *
16189 CDECK  ID>, DT_FOZOCA
16190       SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16191
16192 ************************************************************************
16193 * This subroutine treats the complete FOrmation ZOne supressed intra-  *
16194 * nuclear CAscade.                                                     *
16195 *               LFZC = .true.  cascade has been treated                *
16196 *                    = .false. cascade skipped                         *
16197 * This is a completely revised version of the original FOZOKL.         *
16198 * This version dated 18.11.95 is written by S. Roesler                 *
16199 ************************************************************************
16200
16201       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16202       SAVE
16203
16204       PARAMETER ( LINP = 5 ,
16205      &            LOUT = 6 ,
16206      &            LDAT = 9 )
16207
16208       PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16209       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16210
16211       LOGICAL LSTART,LCAS,LFZC
16212
16213 * event history
16214
16215       PARAMETER (NMXHKK=200000)
16216
16217       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16218      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16219      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16220 * extended event history
16221       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16222      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16223      &                IHIST(2,NMXHKK)
16224 * rejection counter
16225       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16226      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16227      &                IREXCI(3),IRDIFF(2),IRINC
16228 * properties of interacting particles
16229       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16230 * Glauber formalism: collision properties
16231       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16232      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16233 * flags for input different options
16234       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16235       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16236      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16237 * final state after intranuclear cascade step
16238       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16239 * parameter for intranuclear cascade
16240       LOGICAL LPAULI
16241       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16242
16243       DIMENSION NCWOUN(2)
16244
16245       DATA LSTART /.TRUE./
16246
16247       LFZC = .TRUE.
16248       IREJ = 0
16249
16250 * skip cascade if hadron-hadron interaction or if supressed by user
16251       IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16252 * skip cascade if not all possible chains systems are hadronized
16253       DO 1 I=1,8
16254          IF (.NOT.LHADRO(I)) GOTO 9999
16255     1 CONTINUE
16256
16257       IF (LSTART) THEN
16258          WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16259  1000    FORMAT(/,1X,'FOZOCA:  intranuclear cascade treated for a ',
16260      &          'maximum of',I4,' generations',/,10X,'formation time ',
16261      &          'parameter:',F5.1,'  fm/c',9X,'modus:',I2)
16262          IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16263          IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16264  1001    FORMAT(10X,'p_t dependent formation zone',/)
16265  1002    FORMAT(10X,'constant formation zone',/)
16266          LSTART = .FALSE.
16267       ENDIF
16268
16269 * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16270 * which may interact with final state particles are stored in a seperate
16271 * array - here all proj./target nucleon-indices (just for simplicity)
16272       NOINC = 0
16273       DO 9 I=1,NPOINT(1)-1
16274          NOINC = NOINC+1
16275          IDXINC(NOINC) = I
16276     9 CONTINUE
16277
16278 * initialize Pauli-principle treatment (find wounded nucleons)
16279       NWOUND(1) = 0
16280       NWOUND(2) = 0
16281       NCWOUN(1) = 0
16282       NCWOUN(2) = 0
16283       DO 2 J=1,NPOINT(1)
16284          DO 3 I=1,2
16285             IF (ISTHKK(J).EQ.10+I) THEN
16286                NWOUND(I) = NWOUND(I)+1
16287                EWOUND(I,NWOUND(I)) = PHKK(4,J)
16288                IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16289             ENDIF
16290     3    CONTINUE
16291     2 CONTINUE
16292
16293 * modify nuclear potential for wounded nucleons
16294       IPRCL  = IP -NWOUND(1)
16295       IPZRCL = IPZ-NCWOUN(1)
16296       ITRCL  = IT -NWOUND(2)
16297       ITZRCL = ITZ-NCWOUN(2)
16298       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16299
16300       NSTART = NPOINT(4)
16301       NEND   = NHKK
16302
16303     7 CONTINUE
16304       DO 8 I=NSTART,NEND
16305
16306          IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16307 * select nucleus the cascade starts first (proj. - 1, target - -1)
16308             NCAS   = 1
16309 *   projectile/target with probab. 1/2
16310             IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16311                IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16312 *   in the nucleus with highest mass
16313             ELSEIF (INCMOD.EQ.2) THEN
16314                IF (IP.GT.IT) THEN
16315                   NCAS = -NCAS
16316                ELSEIF (IP.EQ.IT) THEN
16317                   IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16318                ENDIF
16319 * the nucleus the cascade starts first is requested to be the one
16320 * moving in the direction of the secondary
16321             ELSEIF (INCMOD.EQ.3) THEN
16322                NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
16323             ENDIF
16324 * check that the selected "nucleus" is not a hadron
16325             IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
16326      &          ((NCAS.EQ.-1).AND.(IT.LE.1)))    NCAS = -NCAS
16327
16328 * treat intranuclear cascade in the nucleus selected first
16329             LCAS = .FALSE.
16330             CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16331             IF (IREJ1.NE.0) GOTO 9998
16332 * treat intranuclear cascade in the other nucleus if this isn't a had.
16333             NCAS = -NCAS
16334             IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
16335      &          ((NCAS.EQ.-1).AND.(IT.GT.1)))    THEN
16336                IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16337                IF (IREJ1.NE.0) GOTO 9998
16338             ENDIF
16339
16340          ENDIF
16341
16342     8 CONTINUE
16343       NSTART = NEND+1
16344       NEND   = NHKK
16345       IF (NSTART.LE.NEND) GOTO 7
16346
16347       RETURN
16348
16349  9998 CONTINUE
16350 * reject this event
16351       IRINC = IRINC+1
16352       IREJ = 1
16353
16354  9999 CONTINUE
16355 * intranucl. cascade not treated because of interaction properties or
16356 * it is supressed by user or it was rejected or...
16357       LFZC = .FALSE.
16358 * reset flag characterizing direction of motion in n-n-cms
16359 **sr14-11-95
16360 C     DO 9990 I=NPOINT(5),NHKK
16361 C        IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
16362 C9990 CONTINUE
16363
16364       RETURN
16365       END
16366 *
16367 *===inucas=============================================================*
16368 *
16369 CDECK  ID>, DT_INUCAS
16370       SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
16371
16372 ************************************************************************
16373 * Formation zone supressed IntraNUclear CAScade for one final state    *
16374 * particle.                                                            *
16375 *           IT, IP    mass numbers of target, projectile nuclei        *
16376 *           IDXCAS    index of final state particle in DTEVT1          *
16377 *           NCAS =  1 intranuclear cascade in projectile               *
16378 *                = -1 intranuclear cascade in target                   *
16379 * This version dated 18.11.95 is written by S. Roesler                 *
16380 ************************************************************************
16381
16382       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16383       SAVE
16384
16385       PARAMETER ( LINP = 5 ,
16386      &            LOUT = 6 ,
16387      &            LDAT = 9 )
16388
16389       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
16390      &           OHALF=0.5D0,ONE=1.0D0)
16391       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16392       PARAMETER (TWOPI=6.283185307179586454D+00)
16393       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
16394
16395       LOGICAL LABSOR,LCAS
16396
16397 * event history
16398
16399       PARAMETER (NMXHKK=200000)
16400
16401       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16402      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16403      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16404 * extended event history
16405       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16406      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16407      &                IHIST(2,NMXHKK)
16408 * final state after inc step
16409       PARAMETER (MAXFSP=10)
16410       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
16411 * flags for input different options
16412       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16413       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16414      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16415 * particle properties (BAMJET index convention)
16416       CHARACTER*8  ANAME
16417       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16418      &                IICH(210),IIBAR(210),K1(210),K2(210)
16419 * Glauber formalism: collision properties
16420       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16421      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16422 * nuclear potential
16423       LOGICAL LFERMI
16424       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
16425      &                EBINDP(2),EBINDN(2),EPOT(2,210),
16426      &                ETACOU(2),ICOUL,LFERMI
16427 * parameter for intranuclear cascade
16428       LOGICAL LPAULI
16429       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16430 * final state after intranuclear cascade step
16431       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16432 * nucleon-nucleon event-generator
16433       CHARACTER*8 CMODEL
16434       LOGICAL LPHOIN
16435       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
16436 * statistics: residual nuclei
16437       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
16438      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
16439      &                NINCST(2,4),NINCEV(2),
16440      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
16441      &                NRESPB(2),NRESCH(2),NRESEV(4),
16442      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
16443      &                NEVAFI(2,2)
16444
16445       DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
16446      &          PCAS1(5),PNUC(5),BGTA(4),
16447      &          BGCAS(2),GACAS(2),BECAS(2),
16448      &          RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
16449
16450       DATA PDIF /0.545D0/
16451
16452       IREJ = 0
16453
16454 * update counter
16455       IF (NINCEV(1).NE.NEVHKK) THEN
16456          NINCEV(1) = NEVHKK
16457          NINCEV(2) = NINCEV(2)+1
16458       ENDIF
16459
16460 * "BAMJET-index" of this hadron
16461       IDCAS = IDBAM(IDXCAS)
16462       IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
16463
16464 * skip gammas, electrons, etc..
16465       IF (AAM(IDCAS).LT.TINY2) RETURN
16466
16467 * Lorentz-trsf. into projectile rest system
16468       IF (IP.GT.1) THEN
16469          CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16470      &               PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
16471      &               PCAS(1,4),IDCAS,-2)
16472          PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
16473          PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
16474          IF (PCAS(1,5).GT.ZERO) THEN
16475             PCAS(1,5) = SQRT(PCAS(1,5))
16476          ELSE
16477             PCAS(1,5) = AAM(IDCAS)
16478          ENDIF
16479          DO 20 K=1,3
16480             COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
16481    20    CONTINUE
16482 * Lorentz-parameters
16483 *   particle rest system --> projectile rest system
16484          BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
16485          GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
16486          BECAS(1) = BGCAS(1)/GACAS(1)
16487       ELSE
16488          DO 21 K=1,5
16489             PCAS(1,K) = ZERO
16490             IF (K.LE.3) COSCAS(1,K) = ZERO
16491    21    CONTINUE
16492          PTOCAS(1) = ZERO
16493          BGCAS(1)  = ZERO
16494          GACAS(1)  = ZERO
16495          BECAS(1)  = ZERO
16496       ENDIF
16497 * Lorentz-trsf. into target rest system
16498       IF (IT.GT.1) THEN
16499 * LEPTO: final state particles are already in target rest frame
16500 C        IF (MCGENE.EQ.3) THEN
16501 C           PCAS(2,1) = PHKK(1,IDXCAS)
16502 C           PCAS(2,2) = PHKK(2,IDXCAS)
16503 C           PCAS(2,3) = PHKK(3,IDXCAS)
16504 C           PCAS(2,4) = PHKK(4,IDXCAS)
16505 C        ELSE
16506             CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16507      &                  PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
16508      &                  PCAS(2,4),IDCAS,-3)
16509 C        ENDIF
16510          PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
16511          PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
16512          IF (PCAS(2,5).GT.ZERO) THEN
16513             PCAS(2,5) = SQRT(PCAS(2,5))
16514          ELSE
16515             PCAS(2,5) = AAM(IDCAS)
16516          ENDIF
16517          DO 22 K=1,3
16518             COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
16519    22    CONTINUE
16520 * Lorentz-parameters
16521 *   particle rest system --> target rest system
16522          BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
16523          GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
16524          BECAS(2) = BGCAS(2)/GACAS(2)
16525       ELSE
16526          DO 23 K=1,5
16527             PCAS(2,K) = ZERO
16528             IF (K.LE.3) COSCAS(2,K) = ZERO
16529    23    CONTINUE
16530          PTOCAS(2) = ZERO
16531          BGCAS(2)  = ZERO
16532          GACAS(2)  = ZERO
16533          BECAS(2)  = ZERO
16534       ENDIF
16535
16536 * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
16537 * potential (see CONUCL)
16538       RNUC(1)  = (RPROJ+4.605D0*PDIF)*FM2MM
16539       RNUC(2)  = (RTARG+4.605D0*PDIF)*FM2MM
16540 * impact parameter (the projectile moving along z)
16541       BIMPC(1) = ZERO
16542       BIMPC(2) = BIMPAC*FM2MM
16543
16544 * get position of initial hadron in projectile/target rest-syst.
16545       DO 3 K=1,4
16546          VTXCAS(1,K) = WHKK(K,IDXCAS)
16547          VTXCAS(2,K) = VHKK(K,IDXCAS)
16548     3 CONTINUE
16549
16550       ICAS = 1
16551       I2   = 2
16552       IF (NCAS.EQ.-1) THEN
16553          ICAS = 2
16554          I2   = 1
16555       ENDIF
16556
16557       IF (PTOCAS(ICAS).LT.TINY10) THEN
16558          WRITE(LOUT,1000) PTOCAS
16559  1000    FORMAT(1X,'INUCAS:   warning! zero momentum of initial',
16560      &          '  hadron ',/,20X,2E12.4)
16561          GOTO 9999
16562       ENDIF
16563
16564 * reset spectator flags
16565       NSPE = 0
16566       IDXSPE(1) = 0
16567       IDXSPE(2) = 0
16568       IDSPE(1)  = 0
16569       IDSPE(2)  = 0
16570
16571 * formation length (in fm)
16572 C     IF (LCAS) THEN
16573 C        DEL0 = ZERO
16574 C     ELSE
16575          DEL0 = TAUFOR*BGCAS(ICAS)
16576          IF (ITAUVE.EQ.1) THEN
16577             AMT  = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
16578             DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
16579          ENDIF
16580 C     ENDIF
16581 *   sample from exp(-del/del0)
16582       DEL1   = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
16583 * save formation time
16584       TAUSA1 = DEL1/BGCAS(ICAS)
16585       REL1   = TAUSA1*BGCAS(I2)
16586
16587       DEL    = DEL1
16588       TAUSAM = DEL/BGCAS(ICAS)
16589       REL    = TAUSAM*BGCAS(I2)
16590
16591 * special treatment for negative particles unable to escape
16592 * nuclear potential (implemented for ap, pi-, K- only)
16593       LABSOR = .FALSE.
16594       IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
16595 *   threshold energy = nuclear potential + Coulomb potential
16596 *   (nuclear potential for hadron-nucleus interactions only)
16597          ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
16598          IF (PCAS(ICAS,4).LT.ETHR) THEN
16599             DO 4 K=1,5
16600                PCAS1(K) = PCAS(ICAS,K)
16601     4       CONTINUE
16602 *   "absorb" negative particle in nucleus
16603             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
16604             IF (IREJ1.NE.0) GOTO 9999
16605             IF (NSPE.GE.1) LABSOR = .TRUE.
16606          ENDIF
16607       ENDIF
16608
16609 * if the initial particle has not been absorbed proceed with
16610 * "normal" cascade
16611       IF (.NOT.LABSOR) THEN
16612
16613 *   calculate coordinates of hadron at the end of the formation zone
16614 *   transport-time and -step in the rest system where this step is
16615 *   treated
16616          DSTEP  = DEL*FM2MM
16617          DTIME  = DSTEP/BECAS(ICAS)
16618          RSTEP  = REL*FM2MM
16619          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16620             RTIME = RSTEP/BECAS(I2)
16621          ELSE
16622             RTIME = ZERO
16623          ENDIF
16624 *   save step whithout considering the overlapping region
16625          DSTEP1 = DEL1*FM2MM
16626          DTIME1 = DSTEP1/BECAS(ICAS)
16627          RSTEP1 = REL1*FM2MM
16628          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16629             RTIME1 = RSTEP1/BECAS(I2)
16630          ELSE
16631             RTIME1 = ZERO
16632          ENDIF
16633 *   transport to the end of the formation zone in this system
16634          DO 5 K=1,3
16635             VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
16636             VTXCA1(I2,K)   = VTXCAS(I2,K)  +RSTEP1*COSCAS(I2,K)
16637             VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
16638             VTXCAS(I2,K)   = VTXCAS(I2,K)  +RSTEP*COSCAS(I2,K)
16639     5    CONTINUE
16640          VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
16641          VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME1
16642          VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16643          VTXCAS(I2,4)   = VTXCAS(I2,4)  +RTIME
16644
16645          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16646             XCAS   = VTXCAS(ICAS,1)
16647             YCAS   = VTXCAS(ICAS,2)
16648             XNCLTA = BIMPAC*FM2MM
16649             RNCLPR = (RPROJ+RNUCLE)*FM2MM
16650             RNCLTA = (RTARG+RNUCLE)*FM2MM
16651 C           RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
16652 C           RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
16653 C           RNCLPR = (RPROJ)*FM2MM
16654 C           RNCLTA = (RTARG)*FM2MM
16655             RCASPR = SQRT( XCAS**2        +YCAS**2)
16656             RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
16657             IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
16658                IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
16659             ENDIF
16660          ENDIF
16661
16662 *   check if particle is already outside of the corresp. nucleus
16663          RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
16664      &                VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
16665          IF (RDIST.GE.RNUC(ICAS)) THEN
16666 *   here: IDCH is the generation of the final state part. starting
16667 *   with zero for hadronization products
16668 *   flag particles of generation 0 being outside the nuclei after
16669 *   formation time (to be used for excitation energy calculation)
16670             IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
16671      &         NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
16672             GOTO 9997
16673          ENDIF
16674          DIST   = DLARGE
16675          DISTP  = DLARGE
16676          DISTN  = DLARGE
16677          IDXP   = 0
16678          IDXN   = 0
16679
16680 *   already here: skip particles being outside HADRIN "energy-window"
16681 *   to avoid wasting of time
16682          NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
16683          IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
16684             NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
16685 C           WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
16686 C1002       FORMAT(1X,'INUCAS:   warning! momentum of particle with ',
16687 C    &             'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
16688 C    &             E12.4,', above or below HADRIN-thresholds',I6)
16689             NSPE = 0
16690             GOTO 9997
16691          ENDIF
16692
16693          DO 7 IDXHKK=1,NOINC
16694             I = IDXINC(IDXHKK)
16695 *   scan DTEVT1 for unwounded or excited nucleons
16696             IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
16697                DO 8 K=1,3
16698                   IF (ICAS.EQ.1) THEN
16699                      VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
16700                   ELSEIF (ICAS.EQ.2) THEN
16701                      VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
16702                   ENDIF
16703     8          CONTINUE
16704                POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
16705      &                  VTXDST(2)*COSCAS(ICAS,2)+
16706      &                  VTXDST(3)*COSCAS(ICAS,3)
16707 *   check if nucleon is situated in forward direction
16708                IF (POSNUC.GT.ZERO) THEN
16709 *   distance between hadron and this nucleon
16710                   DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16711      &                          VTXDST(3)**2)
16712 *   impact parameter
16713                   BIMNU2 = DISTNU**2-POSNUC**2
16714                   IF (BIMNU2.LT.ZERO) THEN
16715                      WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
16716  1001                FORMAT(1X,'INUCAS:   warning! inconsistent impact',
16717      &                      '  parameter ',/,20X,3E12.4)
16718                      GOTO 7
16719                   ENDIF
16720                   BIMNU  = SQRT(BIMNU2)
16721 *   maximum impact parameter to have interaction
16722                   IDNUC  = IDT_ICIHAD(IDHKK(I))
16723                   IDNUC1 = IDT_MCHAD(IDNUC)
16724                   IDCAS1 = IDT_MCHAD(IDCAS)
16725                   DO 19 K=1,5
16726                      PCAS1(K) = PCAS(ICAS,K)
16727                      PNUC(K)  = PHKK(K,I)
16728    19             CONTINUE
16729 * Lorentz-parameter for trafo into rest-system of target
16730                   DO 18 K=1,4
16731                      BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
16732    18             CONTINUE
16733 * transformation of projectile into rest-system of target
16734                   CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
16735      &                        PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
16736      &                        PPTOT,PX,PY,PZ,PE)
16737 **
16738 C                 CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
16739 C                 CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
16740                   DUMZER = ZERO
16741                   CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
16742                   CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
16743                   IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
16744      &                (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
16745                   SIGIN = SIGTOT-SIGEL-SIGAB
16746 C                 SIGTOT = SIGIN+SIGEL+SIGAB
16747 **
16748                   BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
16749 *   check if interaction is possible
16750                   IF (BIMNU.LE.BIMMAX) THEN
16751 *   get nucleon with smallest distance and kind of interaction
16752 *   (elastic/inelastic)
16753                      IF (DISTNU.LT.DIST) THEN
16754                         DIST      = DISTNU
16755                         BINT      = BIMNU
16756                         IF (IDNUC.NE.IDSPE(1)) THEN
16757                            IDSPE(2)  = IDSPE(1)
16758                            IDXSPE(2) = IDXSPE(1)
16759                            IDSPE(1)  = IDNUC
16760                         ENDIF
16761                         IDXSPE(1) = I
16762                         NSPE      = 1
16763 **sr
16764                         SELA = SIGEL
16765                         SABS = SIGAB
16766                         STOT = SIGTOT
16767 C                       IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
16768 C                          SELA = SIGEL
16769 C                          STOT = SIGIN+SIGEL
16770 C                       ELSE
16771 C                          SELA = SIGEL+0.75D0*SIGIN
16772 C                          STOT = 0.25D0*SIGIN+SELA
16773 C                       ENDIF
16774 **
16775                      ENDIF
16776                   ENDIf
16777                ENDIF
16778                DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16779      &                       VTXDST(3)**2)
16780                IDNUC  = IDT_ICIHAD(IDHKK(I))
16781                IF (IDNUC.EQ.1) THEN
16782                   IF (DISTNU.LT.DISTP) THEN
16783                      DISTP = DISTNU
16784                      IDXP  = I
16785                      POSP  = POSNUC
16786                   ENDIF
16787                ELSEIF (IDNUC.EQ.8) THEN
16788                   IF (DISTNU.LT.DISTN) THEN
16789                      DISTN = DISTNU
16790                      IDXN  = I
16791                      POSN  = POSNUC
16792                   ENDIF
16793                ENDIF
16794             ENDIF
16795     7    CONTINUE
16796
16797 * there is no nucleon for a secondary interaction
16798          IF (NSPE.EQ.0) GOTO 9997
16799
16800 C        IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
16801 C    &      WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
16802          IF (IDXSPE(2).EQ.0) THEN
16803             IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
16804 C              DO 80 K=1,3
16805 C                 IF (ICAS.EQ.1) THEN
16806 C                    VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
16807 C                 ELSEIF (ICAS.EQ.2) THEN
16808 C                    VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
16809 C                 ENDIF
16810 C  80          CONTINUE
16811 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16812 C    &                       VTXDST(3)**2)
16813 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
16814                   IDXSPE(2) = IDXN
16815                   IDSPE(2)  = 8
16816 C              ELSE
16817 C                 STOT = STOT-SABS
16818 C                 SABS = ZERO
16819 C              ENDIF
16820             ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
16821 C              DO 81 K=1,3
16822 C                 IF (ICAS.EQ.1) THEN
16823 C                    VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
16824 C                 ELSEIF (ICAS.EQ.2) THEN
16825 C                    VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
16826 C                 ENDIF
16827 C  81          CONTINUE
16828 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16829 C    &                       VTXDST(3)**2)
16830 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
16831                   IDXSPE(2) = IDXP
16832                   IDSPE(2)  = 1
16833 C              ELSE
16834 C                 STOT = STOT-SABS
16835 C                 SABS = ZERO
16836 C              ENDIF
16837             ELSE
16838                STOT = STOT-SABS
16839                SABS = ZERO
16840             ENDIF
16841          ENDIF
16842          RR = DT_RNDM(DIST)
16843          IF (RR.LT.SELA/STOT) THEN
16844             IPROC = 2
16845          ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
16846             IPROC = 3
16847          ELSE
16848             IPROC = 1
16849          ENDIF
16850
16851          DO 9 K=1,5
16852             PCAS1(K) = PCAS(ICAS,K)
16853             PNUC(K)  = PHKK(K,IDXSPE(1))
16854     9    CONTINUE
16855          IF (IPROC.EQ.3) THEN
16856 * 2-nucleon absorption of pion
16857             NSPE = 2
16858             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
16859             IF (IREJ1.NE.0) GOTO 9999
16860             IF (NSPE.GE.1) LABSOR = .TRUE.
16861          ELSE
16862 * sample secondary interaction
16863             IDNUC = IDBAM(IDXSPE(1))
16864             CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
16865             IF (IREJ1.EQ.1) GOTO 9999
16866             IF (IREJ1.GT.1) GOTO 9998
16867          ENDIF
16868       ENDIF
16869
16870 * update arrays to include Pauli-principle
16871       DO 10 I=1,NSPE
16872          IF (NWOUND(ICAS).LE.299) THEN
16873             NWOUND(ICAS) = NWOUND(ICAS)+1
16874             EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
16875          ENDIF
16876    10 CONTINUE
16877
16878 * dump initial hadron for energy-momentum conservation check
16879       IF (LEMCCK)
16880      &   CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
16881      &               PCAS(ICAS,4),1,IDUM,IDUM)
16882
16883 * dump final state particles into DTEVT1
16884
16885 *   check if Pauli-principle is fulfilled
16886       NPAULI = 0
16887       NWTMP(1) = NWOUND(1)
16888       NWTMP(2) = NWOUND(2)
16889       DO 111 I=1,NFSP
16890          NPAULI = 0
16891          J1 = 2
16892          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16893      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
16894          DO 117 J=1,J1
16895             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
16896             IF (J.EQ.1) THEN
16897                IDX = ICAS
16898                PE  = PFSP(4,I)
16899             ELSE
16900                IDX  = I2
16901                MODE = 1
16902                IF (IDX.EQ.1) MODE = -1
16903                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
16904             ENDIF
16905 * first check if cascade step is forbidden due to Pauli-principle
16906 * (in case of absorpion this step is forced)
16907             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16908      &          (IDFSP(I).EQ.8))) THEN
16909 *   get nuclear potential barrier
16910                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16911                IF (IDFSP(I).EQ.1) THEN
16912                   POTLOW = POT-EBINDP(IDX)
16913                ELSE
16914                   POTLOW = POT-EBINDN(IDX)
16915                ENDIF
16916 *   final state particle not able to escape nucleus
16917                IF (PE.LE.POTLOW) THEN
16918 *     check if there are wounded nucleons
16919                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16920      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
16921                      NPAULI      = NPAULI+1
16922                      NWOUND(IDX) = NWOUND(IDX)-1
16923                   ELSE
16924 *     interaction prohibited by Pauli-principle
16925                      NWOUND(1) = NWTMP(1)
16926                      NWOUND(2) = NWTMP(2)
16927                      GOTO 9997
16928                   ENDIF
16929                ENDIF
16930             ENDIF
16931   117    CONTINUE
16932   111 CONTINUE
16933
16934       NPAULI = 0
16935       NWOUND(1) = NWTMP(1)
16936       NWOUND(2) = NWTMP(2)
16937
16938       DO 11 I=1,NFSP
16939
16940          IST = ISTHKK(IDXCAS)
16941
16942          NPAULI = 0
16943          J1 = 2
16944          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16945      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
16946          DO 17 J=1,J1
16947             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
16948             IDX = ICAS
16949             PE  = PFSP(4,I)
16950             IF (J.EQ.2) THEN
16951                IDX = I2
16952                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
16953             ENDIF
16954 * first check if cascade step is forbidden due to Pauli-principle
16955 * (in case of absorpion this step is forced)
16956             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16957      &          (IDFSP(I).EQ.8))) THEN
16958 *   get nuclear potential barrier
16959                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16960                IF (IDFSP(I).EQ.1) THEN
16961                   POTLOW = POT-EBINDP(IDX)
16962                ELSE
16963                   POTLOW = POT-EBINDN(IDX)
16964                ENDIF
16965 *   final state particle not able to escape nucleus
16966                IF (PE.LE.POTLOW) THEN
16967 *     check if there are wounded nucleons
16968                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16969      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
16970                      NWOUND(IDX) = NWOUND(IDX)-1
16971                      NPAULI = NPAULI+1
16972                      IST    = 14+IDX
16973                   ELSE
16974 *     interaction prohibited by Pauli-principle
16975                      NWOUND(1) = NWTMP(1)
16976                      NWOUND(2) = NWTMP(2)
16977                      GOTO 9997
16978                   ENDIF
16979 **sr
16980 c               ELSEIF (PE.LE.POT) THEN
16981 cC              ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
16982 cC                 NWOUND(IDX) = NWOUND(IDX)-1
16983 c**
16984 c                  NPAULI = NPAULI+1
16985 c                  IST    = 14+IDX
16986                ENDIF
16987             ENDIF
16988    17    CONTINUE
16989
16990 * dump final state particles for energy-momentum conservation check
16991          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
16992      &                           -PFSP(4,I),2,IDUM,IDUM)
16993
16994          PX = PFSP(1,I)
16995          PY = PFSP(2,I)
16996          PZ = PFSP(3,I)
16997          PE = PFSP(4,I)
16998          IF (ABS(IST).EQ.1) THEN
16999 * transform particles back into n-n cms
17000 * LEPTO: leave final state particles in target rest frame
17001 C           IF (MCGENE.EQ.3) THEN
17002 C              PFSP(1,I) = PX
17003 C              PFSP(2,I) = PY
17004 C              PFSP(3,I) = PZ
17005 C              PFSP(4,I) = PE
17006 C           ELSE
17007                IMODE = ICAS+1
17008                CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17009      &                     PFSP(4,I),IDFSP(I),IMODE)
17010 C           ENDIF
17011          ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
17012 * target cascade but fsp got stuck in proj. --> transform it into
17013 * proj. rest system
17014             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17015      &                  PFSP(4,I),IDFSP(I),-1)
17016          ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
17017 * proj. cascade but fsp got stuck in target --> transform it into
17018 * target rest system
17019             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17020      &                  PFSP(4,I),IDFSP(I),1)
17021          ENDIF
17022
17023 * dump final state particles into DTEVT1
17024          IGEN = IDCH(IDXCAS)+1
17025          ID   = IDT_IPDGHA(IDFSP(I))
17026          IXR  = 0
17027          IF (LABSOR) IXR = 99
17028          CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
17029      &               PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
17030
17031 * update the counter for particles which got stuck inside the nucleus
17032          IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
17033             NOINC = NOINC+1
17034             IDXINC(NOINC) = NHKK
17035          ENDIF
17036          IF (LABSOR) THEN
17037 *   in case of absorption the spatial treatment is an approximate
17038 *   solution anyway (the positions of the nucleons which "absorb" the
17039 *   cascade particle are not taken into consideration) therefore the
17040 *   particles are produced at the position of the cascade particle
17041             DO 12 K=1,4
17042                WHKK(K,NHKK) = WHKK(K,IDXCAS)
17043                VHKK(K,NHKK) = VHKK(K,IDXCAS)
17044    12       CONTINUE
17045          ELSE
17046 *   DDISTL - distance the cascade particle moves to the intera. point
17047 *   (the position where impact-parameter = distance to the interacting
17048 *   nucleon), DIST - distance to the interacting nucleon at the time of
17049 *   formation of the cascade particle, BINT - impact-parameter of this
17050 *   cascade-interaction
17051             DDISTL = SQRT(DIST**2-BINT**2)
17052             DTIME  = DDISTL/BECAS(ICAS)
17053             DTIMEL = DDISTL/BGCAS(ICAS)
17054             RDISTL = DTIMEL*BGCAS(I2)
17055             IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17056                RTIME = RDISTL/BECAS(I2)
17057             ELSE
17058                RTIME = ZERO
17059             ENDIF
17060 *   RDISTL, RTIME are this step and time in the rest system of the other
17061 *   nucleus
17062             DO 13 K=1,3
17063                VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
17064                VTXCA1(I2,K)   = VTXCAS(I2,K)  +COSCAS(I2,K)  *RDISTL
17065    13       CONTINUE
17066             VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17067             VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME
17068 *   position of particle production is half the impact-parameter to
17069 *   the interacting nucleon
17070             DO 14 K=1,3
17071                WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
17072                VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
17073    14       CONTINUE
17074 *   time of production of secondary = time of interaction
17075             WHKK(4,NHKK) = VTXCA1(1,4)
17076             VHKK(4,NHKK) = VTXCA1(2,4)
17077          ENDIF
17078
17079    11 CONTINUE
17080
17081 * modify status and position of cascade particle (the latter for
17082 * statistics reasons only)
17083       ISTHKK(IDXCAS) = 2
17084       IF (LABSOR) ISTHKK(IDXCAS) = 19
17085       IF (.NOT.LABSOR) THEN
17086          DO 15 K=1,4
17087             WHKK(K,IDXCAS) = VTXCA1(1,K)
17088             VHKK(K,IDXCAS) = VTXCA1(2,K)
17089    15    CONTINUE
17090       ENDIF
17091
17092       DO 16 I=1,NSPE
17093          IS = IDXSPE(I)
17094 * dump interacting nucleons for energy-momentum conservation check
17095          IF (LEMCCK)
17096      &      CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
17097      &                                                  2,IDUM,IDUM)
17098 * modify entry for interacting nucleons
17099          IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
17100          IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
17101          IF (I.GE.2) THEN
17102             JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
17103             JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
17104          ENDIF
17105    16 CONTINUE
17106
17107 * check energy-momentum conservation
17108       IF (LEMCCK) THEN
17109          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
17110          IF (IREJ1.NE.0) GOTO 9999
17111       ENDIF
17112
17113 * update counter
17114       IF (LABSOR) THEN
17115          NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
17116       ELSE
17117          IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
17118          IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
17119       ENDIF
17120
17121       RETURN
17122
17123  9997 CONTINUE
17124  9998 CONTINUE
17125 * transport-step but no cascade step due to configuration (i.e. there
17126 * is no nucleon for interaction etc.)
17127       IF (LCAS) THEN
17128          DO 100 K=1,4
17129 C           WHKK(K,IDXCAS) = VTXCAS(1,K)
17130 C           VHKK(K,IDXCAS) = VTXCAS(2,K)
17131             WHKK(K,IDXCAS) = VTXCA1(1,K)
17132             VHKK(K,IDXCAS) = VTXCA1(2,K)
17133   100    CONTINUE
17134       ENDIF
17135
17136 C9998 CONTINUE
17137 * no cascade-step because of configuration
17138 * (i.e. hadron outside nucleus etc.)
17139       LCAS = .TRUE.
17140       RETURN
17141
17142  9999 CONTINUE
17143 * rejection
17144       IREJ = 1
17145       RETURN
17146       END
17147 *
17148 *===absorp=============================================================*
17149 *
17150 CDECK  ID>, DT_ABSORP
17151       SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
17152
17153 ************************************************************************
17154 * Two-nucleon absorption of antiprotons, pi-, and K-.                  *
17155 * Antiproton absorption is handled by HADRIN.                          *
17156 * The following channels for meson-absorption are considered:          *
17157 *          pi- + p + p ---> n + p                                      *
17158 *          pi- + p + n ---> n + n                                      *
17159 *          K-  + p + p ---> sigma+ + n / Lam + p / sigma0 + p          *
17160 *          K-  + p + n ---> sigma- + n / Lam + n / sigma0 + n          *
17161 *          K-  + p + p ---> sigma- + n                                 *
17162 *      IDCAS, PCAS   identity, momentum of particle to be absorbed     *
17163 *      NCAS =  1     intranuclear cascade in projectile                *
17164 *           = -1     intranuclear cascade in target                    *
17165 *      NSPE          number of spectator nucleons involved             *
17166 *      IDXSPE(2)     DTEVT1-indices of spectator nucleons involved     *
17167 * Revised version of the original STOPIK written by HJM and J. Ranft.  *
17168 * This version dated 24.02.95 is written by S. Roesler                 *
17169 ************************************************************************
17170
17171       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17172       SAVE
17173
17174       PARAMETER ( LINP = 5 ,
17175      &            LOUT = 6 ,
17176      &            LDAT = 9 )
17177
17178       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17179      &           ONETHI=0.3333D0,TWOTHI=0.6666D0)
17180
17181 * event history
17182
17183       PARAMETER (NMXHKK=200000)
17184
17185       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17186      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17187      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17188 * extended event history
17189       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17190      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17191      &                IHIST(2,NMXHKK)
17192 * flags for input different options
17193       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17194       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17195      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17196 * final state after inc step
17197       PARAMETER (MAXFSP=10)
17198       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17199 * particle properties (BAMJET index convention)
17200       CHARACTER*8  ANAME
17201       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17202      &                IICH(210),IIBAR(210),K1(210),K2(210)
17203
17204       DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17205      &          PTOT3P(4),BG3P(4),
17206      &          ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17207
17208       IREJ = 0
17209       NFSP = 0
17210
17211 * skip particles others than ap, pi-, K- for mode=0
17212       IF ((MODE.EQ.0).AND.
17213      &    (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17214 * skip particles others than pions for mode=1
17215 * (2-nucleon absorption in intranuclear cascade)
17216       IF ((MODE.EQ.1).AND.
17217      &    (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17218
17219       NUCAS = NCAS
17220       IF (NUCAS.EQ.-1) NUCAS = 2
17221
17222       IF (MODE.EQ.0) THEN
17223 * scan spectator nucleons for nucleons being able to "absorb"
17224          NSPE      = 0
17225          IDXSPE(1) = 0
17226          IDXSPE(2) = 0
17227          DO 1 I=1,NHKK
17228             IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17229                NSPE         = NSPE+1
17230                IDXSPE(NSPE) = I
17231                IDSPE(NSPE)  = IDBAM(I)
17232                IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17233                IF (NSPE.EQ.2) THEN
17234                   IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17235      &                                  (IDSPE(2).EQ.8)) THEN
17236 *    there is no pi-+n+n channel
17237                      NSPE = 1
17238                      GOTO 1
17239                   ELSE
17240                      GOTO 2
17241                   ENDIF
17242                ENDIF
17243             ENDIF
17244     1    CONTINUE
17245
17246     2    CONTINUE
17247       ENDIF
17248 * transform excited projectile nucleons (status=15) into proj. rest s.
17249       DO 3 I=1,NSPE
17250          DO 4 K=1,5
17251             PSPE(I,K) = PHKK(K,IDXSPE(I))
17252     4    CONTINUE
17253     3 CONTINUE
17254
17255 * antiproton absorption
17256       IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17257          DO 5 K=1,5
17258             PSPE1(K) = PSPE(1,K)
17259     5    CONTINUE
17260          CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17261          IF (IREJ1.NE.0) GOTO 9999
17262
17263 * meson absorption
17264       ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17265      &                      .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17266          IF (IDCAS.EQ.14) THEN
17267 *   pi- absorption
17268             IDFSP(1) = 8
17269             IDFSP(2) = 8
17270             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17271          ELSEIF (IDCAS.EQ.13) THEN
17272 *   pi+ absorption
17273             IDFSP(1) = 1
17274             IDFSP(2) = 1
17275             IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17276          ELSEIF (IDCAS.EQ.23) THEN
17277 *   pi0 absorption
17278             IDFSP(1) = IDSPE(1)
17279             IDFSP(2) = IDSPE(2)
17280          ELSEIF (IDCAS.EQ.16) THEN
17281 *   K- absorption
17282             R = DT_RNDM(PCAS)
17283             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17284                IF (R.LT.ONETHI) THEN
17285                   IDFSP(1) = 21
17286                   IDFSP(2) = 8
17287                ELSEIF (R.LT.TWOTHI) THEN
17288                   IDFSP(1) = 17
17289                   IDFSP(2) = 1
17290                ELSE
17291                   IDFSP(1) = 22
17292                   IDFSP(2) = 1
17293                ENDIF
17294             ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17295                IDFSP(1) = 20
17296                IDFSP(2) = 8
17297             ELSE
17298                IF (R.LT.ONETHI) THEN
17299                   IDFSP(1) = 20
17300                   IDFSP(2) = 1
17301                ELSEIF (R.LT.TWOTHI) THEN
17302                   IDFSP(1) = 17
17303                   IDFSP(2) = 8
17304                ELSE
17305                   IDFSP(1) = 22
17306                   IDFSP(2) = 8
17307                ENDIF
17308             ENDIF
17309          ENDIF
17310 *   dump initial particles for energy-momentum cons. check
17311          IF (LEMCCK) THEN
17312             CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
17313             CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
17314      &                                                    IDUM,IDUM)
17315             CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
17316      &                                                    IDUM,IDUM)
17317          ENDIF
17318 *   get Lorentz-parameter of 3 particle initial state
17319          DO 6 K=1,4
17320             PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
17321     6    CONTINUE
17322          P3P  = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
17323          AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
17324          DO 7 K=1,4
17325             BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
17326     7    CONTINUE
17327 *   2-particle decay of the 3-particle compound system
17328          CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
17329      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
17330      &               AAM(IDFSP(1)),AAM(IDFSP(2)))
17331          DO 8 I=1,2
17332             SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
17333             PX  = PCMF(I)*COFF(I)*SDF
17334             PY  = PCMF(I)*SIFF(I)*SDF
17335             PZ  = PCMF(I)*CODF(I)
17336             CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
17337      &                  ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17338      &                  PFSP(4,I))
17339             PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
17340 *   check consistency of kinematics
17341             IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
17342                WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
17343  1001          FORMAT(1X,'ABSORP:   warning! inconsistent',
17344      &                ' tree-particle kinematics',/,20X,'id: ',I3,
17345      &                ' AAM = ',E10.4,' MFSP = ',E10.4)
17346             ENDIF
17347 *   dump final state particles for energy-momentum cons. check
17348             IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17349      &                              -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17350     8    CONTINUE
17351          NFSP = 2
17352          IF (LEMCCK) THEN
17353             CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
17354             IF (IREJ1.NE.0) THEN
17355                WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
17356      &                      AM3P
17357                GOTO 9999
17358             ENDIF
17359          ENDIF
17360       ELSE
17361          IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
17362  1000    FORMAT(1X,'ABSORP:   warning! absorption for particle ',I3,
17363      &          ' impossible',/,20X,'too few spectators (',I2,')')
17364          NSPE = 0
17365       ENDIF
17366
17367       RETURN
17368
17369  9999 CONTINUE
17370       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
17371       IREJ = 1
17372       RETURN
17373       END
17374 *
17375 *===hadrin=============================================================*
17376 *
17377 CDECK  ID>, DT_HADRIN
17378       SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
17379
17380 ************************************************************************
17381 * Interface to the HADRIN-routines for inelastic and elastic           *
17382 * scattering.                                                          *
17383 *      IDPR,PPR(5)   identity, momentum of projectile                  *
17384 *      IDTA,PTA(5)   identity, momentum of target                      *
17385 *      MODE  = 1     inelastic interaction                             *
17386 *            = 2     elastic   interaction                             *
17387 * Revised version of the original FHAD.                                *
17388 * This version dated 27.10.95 is written by S. Roesler                 *
17389 ************************************************************************
17390
17391       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17392       SAVE
17393
17394       PARAMETER ( LINP = 5 ,
17395      &            LOUT = 6 ,
17396      &            LDAT = 9 )
17397
17398       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
17399      &           TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
17400
17401       LOGICAL LCORR,LMSSG
17402
17403 * flags for input different options
17404       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17405       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17406      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17407 * final state after inc step
17408       PARAMETER (MAXFSP=10)
17409       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17410 * particle properties (BAMJET index convention)
17411       CHARACTER*8  ANAME
17412       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17413      &                IICH(210),IIBAR(210),K1(210),K2(210)
17414 * output-common for DHADRI/ELHAIN
17415 * final state from HADRIN interaction
17416       PARAMETER (MAXFIN=10)
17417       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
17418      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
17419
17420       DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
17421      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
17422
17423       DATA LMSSG /.TRUE./
17424
17425       IREJ  = 0
17426       NFSP  = 0
17427       KCORR = 0
17428       IMCORR(1) = 0
17429       IMCORR(2) = 0
17430       LCORR = .FALSE.
17431
17432 *   dump initial particles for energy-momentum cons. check
17433       IF (LEMCCK) THEN
17434          CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
17435          CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
17436       ENDIF
17437
17438       AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
17439       AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
17440       IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
17441      &    (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
17442      &    (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
17443          IF (LMSSG.AND.(IOULEV(3).GT.0))
17444      &   WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
17445  1000    FORMAT(1X,'HADRIN:   warning! inconsistent projectile/target',
17446      &          ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
17447      &          E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
17448          LMSSG = .FALSE.
17449          LCORR = .TRUE.
17450       ENDIF
17451
17452 * convert initial state particles into particles which can be
17453 * handled by HADRIN
17454       IDHPR = IDPR
17455       IDHTA = IDTA
17456       IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
17457          IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
17458          DO 1 K=1,4
17459             P1IN(K) = PPR(K)
17460             P2IN(K) = PTA(K)
17461     1    CONTINUE
17462          XM1 = AAM(IDHPR)
17463          XM2 = AAM(IDHTA)
17464          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17465          IF (IREJ1.GT.0) THEN
17466             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
17467             GOTO 9999
17468          ENDIF
17469          DO 2 K=1,4
17470             PPR(K) = P1OUT(K)
17471             PTA(K) = P2OUT(K)
17472     2    CONTINUE
17473          PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
17474          PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
17475       ENDIF
17476
17477 * Lorentz-parameter for trafo into rest-system of target
17478       DO 3 K=1,4
17479          BGTA(K) = PTA(K)/PTA(5)
17480     3 CONTINUE
17481 * transformation of projectile into rest-system of target
17482       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
17483      &            PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
17484      &            PPR1(4))
17485
17486 * direction cosines of projectile in target rest system
17487       CX = PPR1(1)/PPRTO1
17488       CY = PPR1(2)/PPRTO1
17489       CZ = PPR1(3)/PPRTO1
17490
17491 * sample inelastic interaction
17492       IF (MODE.EQ.1) THEN
17493          CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
17494          IF (IRH.EQ.1) GOTO 9998
17495 * sample elastic interaction
17496       ELSEIF (MODE.EQ.2) THEN
17497          CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
17498          IF (IREJ1.NE.0) THEN
17499             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
17500             GOTO 9999
17501          ENDIF
17502          IF (IRH.EQ.1) GOTO 9998
17503       ELSE
17504          WRITE(LOUT,1001) MODE,INTHAD
17505  1001    FORMAT(1X,'HADRIN:   warning! inconsistent interaction mode',
17506      &          I4,' (INTHAD =',I4,')')
17507          GOTO 9999
17508       ENDIF
17509
17510 * transform final state particles back into Lab.
17511       DO 4 I=1,IRH
17512          NFSP = NFSP+1
17513          PX   = CXRH(I)*PLRH(I)
17514          PY   = CYRH(I)*PLRH(I)
17515          PZ   = CZRH(I)*PLRH(I)
17516          CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
17517      &               PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
17518      &               PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
17519          IDFSP(NFSP) = ITRH(I)
17520          AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
17521      &                                            PFSP(3,NFSP)**2
17522          IF (AMFSP2.LT.-TINY3) THEN
17523             WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
17524      &                       PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
17525  1002       FORMAT(1X,'HADRIN:   warning! final state particle (id = ',
17526      &             I2,') with negative mass^2',/,1X,5E12.4)
17527             GOTO 9999
17528          ELSE
17529             PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
17530             IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
17531                WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
17532      &                          PFSP(5,NFSP)
17533  1003          FORMAT(1X,'HADRIN:   warning! final state particle',
17534      &                ' (id = ',I2,') with inconsistent mass',/,1X,
17535      &                2E12.4)
17536                KCORR         = KCORR+1
17537                IF (KCORR.GT.2) GOTO 9999
17538                IMCORR(KCORR) = NFSP
17539             ENDIF
17540          ENDIF
17541 *   dump final state particles for energy-momentum cons. check
17542          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17543      &                           -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17544     4 CONTINUE
17545
17546 * transform momenta on mass shell in case of inconsistencies in
17547 * HADRIN
17548       IF (KCORR.GT.0) THEN
17549          IF (KCORR.EQ.2) THEN
17550             I1 = IMCORR(1)
17551             I2 = IMCORR(2)
17552          ELSE
17553             IF (IMCORR(1).EQ.1) THEN
17554                I1 = 1
17555                I2 = 2
17556             ELSE
17557                I1 = 1
17558                I2 = IMCORR(1)
17559             ENDIF
17560          ENDIF
17561          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
17562      &                           PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
17563          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
17564      &                           PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
17565          DO 5 K=1,4
17566             P1IN(K) = PFSP(K,I1)
17567             P2IN(K) = PFSP(K,I2)
17568     5    CONTINUE
17569          XM1 = AAM(IDFSP(I1))
17570          XM2 = AAM(IDFSP(I2))
17571          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17572          IF (IREJ1.GT.0) THEN
17573             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
17574 C           GOTO 9999
17575          ENDIF
17576          DO 6 K=1,4
17577             PFSP(K,I1) = P1OUT(K)
17578             PFSP(K,I2) = P2OUT(K)
17579     6    CONTINUE
17580          PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
17581      &                    -PFSP(2,I1)**2-PFSP(3,I1)**2)
17582          PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
17583      &                    -PFSP(2,I2)**2-PFSP(3,I2)**2)
17584 *   dump final state particles for energy-momentum cons. check
17585          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
17586      &                           -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
17587          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
17588      &                           -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
17589       ENDIF
17590
17591 * check energy-momentum conservation
17592       IF (LEMCCK) THEN
17593          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
17594          IF (IREJ1.NE.0) GOTO 9999
17595       ENDIF
17596
17597       RETURN
17598
17599  9998 CONTINUE
17600       IREJ = 2
17601       RETURN
17602
17603  9999 CONTINUE
17604       IREJ = 1
17605       RETURN
17606       END
17607 *
17608 *===hadcol=============================================================*
17609 *
17610 CDECK  ID>, DT_HADCOL
17611       SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
17612
17613 ************************************************************************
17614 * Interface to the HADRIN-routines for inelastic and elastic           *
17615 * scattering. This subroutine samples hadron-nucleus interactions      *
17616 * below DPM-threshold.                                                 *
17617 *      IDPROJ        BAMJET-index of projectile hadron                 *
17618 *      PPN           projectile momentum in target rest frame          *
17619 *      IDXTAR        DTEVT1-index of target nucleon undergoing         *
17620 *                    interaction with projectile hadron                *
17621 * This subroutine replaces HADHAD.                                     *
17622 * This version dated 5.5.95 is written by S. Roesler                   *
17623 ************************************************************************
17624
17625       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17626       SAVE
17627
17628       PARAMETER ( LINP = 5 ,
17629      &            LOUT = 6 ,
17630      &            LDAT = 9 )
17631
17632       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
17633
17634       LOGICAL LSTART
17635
17636 * event history
17637
17638       PARAMETER (NMXHKK=200000)
17639
17640       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17641      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17642      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17643 * extended event history
17644       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17645      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17646      &                IHIST(2,NMXHKK)
17647 * nuclear potential
17648       LOGICAL LFERMI
17649       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17650      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17651      &                ETACOU(2),ICOUL,LFERMI
17652 * interface HADRIN-DPM
17653       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
17654 * parameter for intranuclear cascade
17655       LOGICAL LPAULI
17656       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17657 * final state after inc step
17658       PARAMETER (MAXFSP=10)
17659       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17660 * particle properties (BAMJET index convention)
17661       CHARACTER*8  ANAME
17662       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17663      &                IICH(210),IIBAR(210),K1(210),K2(210)
17664
17665       DIMENSION PPROJ(5),PNUC(5)
17666
17667       DATA LSTART /.TRUE./
17668
17669       IREJ   = 0
17670
17671       NPOINT(1) = NHKK+1
17672
17673       TAUSAV = TAUFOR
17674 **sr 6/9/01 commented
17675 C     TAUFOR = TAUFOR/2.0D0
17676 **
17677       IF (LSTART) THEN
17678          WRITE(LOUT,1000)
17679  1000    FORMAT(/,1X,'HADCOL:  Scattering handled by HADRIN')
17680          WRITE(LOUT,1001) TAUFOR
17681  1001    FORMAT(/,1X,'HADCOL:  Formation zone parameter set to ',
17682      &          F5.1,' fm/c')
17683          LSTART = .FALSE.
17684       ENDIF
17685
17686       IDNUC  = IDBAM(IDXTAR)
17687       IDNUC1 = IDT_MCHAD(IDNUC)
17688       IDPRO1 = IDT_MCHAD(IDPROJ)
17689
17690       IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
17691          IPROC = INTHAD
17692       ELSE
17693 **
17694 C        CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
17695 C        CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
17696          DUMZER = ZERO
17697          CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
17698          SIGIN = SIGTOT-SIGEL
17699 C        SIGTOT = SIGIN+SIGEL
17700 **
17701          IPROC  = 1
17702          IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
17703       ENDIF
17704
17705       PPROJ(1) = ZERO
17706       PPROJ(2) = ZERO
17707       PPROJ(3) = PPN
17708       PPROJ(5) = AAM(IDPROJ)
17709       PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
17710       DO 1 K=1,5
17711          PNUC(K)  = PHKK(K,IDXTAR)
17712     1 CONTINUE
17713
17714       ILOOP = 0
17715     2 CONTINUE
17716       ILOOP = ILOOP+1
17717       IF (ILOOP.GT.100) GOTO 9999
17718
17719       CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
17720       IF (IREJ1.EQ.1) GOTO 9999
17721
17722       IF (IREJ1.GT.1) THEN
17723 * no interaction possible
17724 *   require Pauli blocking
17725          IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
17726          IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
17727          IF ((IIBAR(IDPROJ).NE.1).AND.
17728      &       (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5)))              GOTO 2
17729 *   store incoming particle as final state particle
17730          CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
17731          CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
17732          NPOINT(4) = NHKK
17733       ELSE
17734 * require Pauli blocking for final state nucleons
17735          DO 4 I=1,NFSP
17736             IF ((IDFSP(I).EQ.1).AND.
17737      &          (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I))))       GOTO 2
17738             IF ((IDFSP(I).EQ.8).AND.
17739      &          (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I))))       GOTO 2
17740             IF ((IIBAR(IDFSP(I)).NE.1).AND.
17741      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
17742     4    CONTINUE
17743 * store final state particles
17744          DO 5 I=1,NFSP
17745             IST = 1
17746             IF ((IIBAR(IDFSP(I)).EQ.1).AND.
17747      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
17748             IDHAD = IDT_IPDGHA(IDFSP(I))
17749             CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
17750             CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
17751      &                                        PCMS,ECMS,0,0,0)
17752             IF (I.EQ.1) NPOINT(4) = NHKK
17753             VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
17754             VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
17755             VHKK(3,NHKK) = VHKK(3,IDXTAR)
17756             VHKK(4,NHKK) = VHKK(4,IDXTAR)
17757             WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
17758             WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
17759             WHKK(3,NHKK) = WHKK(3,1)
17760             WHKK(4,NHKK) = WHKK(4,1)
17761     5    CONTINUE
17762       ENDIF
17763       TAUFOR = TAUSAV
17764       RETURN
17765
17766  9999 CONTINUE
17767       IREJ = 1
17768       TAUFOR = TAUSAV
17769       RETURN
17770       END
17771 *
17772 *===getemu=============================================================*
17773 *
17774 CDECK  ID>, DT_GETEMU
17775       SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
17776
17777 ************************************************************************
17778 * Sampling of emulsion component to be considered as target-nucleus.   *
17779 * This version dated 6.5.95   is written by S. Roesler.                *
17780 ************************************************************************
17781
17782       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17783       SAVE
17784
17785       PARAMETER ( LINP = 5 ,
17786      &            LOUT = 6 ,
17787      &            LDAT = 9 )
17788
17789       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
17790
17791       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
17792
17793 * emulsion treatment
17794       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
17795      &                NCOMPO,IEMUL
17796 * Glauber formalism: flags and parameters for statistics
17797       LOGICAL LPROD
17798       CHARACTER*8 CGLB
17799       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
17800
17801       IF (MODE.EQ.0) THEN
17802          SUMFRA = ZERO
17803          RR = DT_RNDM(SUMFRA)
17804          IT  = 0
17805          ITZ = 0
17806          DO 1 ICOMP=1,NCOMPO
17807             SUMFRA = SUMFRA+EMUFRA(ICOMP)
17808             IF (SUMFRA.GT.RR) THEN
17809                IT    = IEMUMA(ICOMP)
17810                ITZ   = IEMUCH(ICOMP)
17811                KKMAT = ICOMP
17812                GOTO 2
17813             ENDIF
17814     1    CONTINUE
17815     2    CONTINUE
17816          IF (IT.LE.0) THEN
17817             WRITE(LOUT,'(1X,A,E12.3)')
17818      &       'Warning!  norm. failure within emulsion fractions',
17819      &       SUMFRA
17820             STOP
17821          ENDIF
17822       ELSEIF (MODE.EQ.1) THEN
17823          NDIFF = 10000
17824          DO 3 I=1,NCOMPO
17825             IDIFF = ABS(IT-IEMUMA(I))
17826             IF (IDIFF.LT.NDIFF) THEN
17827                KKMAT = I
17828                NDIFF = IDIFF
17829             ENDIF
17830     3    CONTINUE
17831       ELSE
17832          STOP 'DT_GETEMU'
17833       ENDIF
17834
17835 * bypass for variable projectile/target/energy runs: the correct
17836 * Glauber data will be always loaded on kkmat=1
17837       IF (IOGLB.EQ.100) THEN
17838          KKMAT = 1
17839       ENDIF
17840
17841       RETURN
17842       END
17843 *
17844 *===nclpot=============================================================*
17845 *
17846 CDECK  ID>, DT_NCLPOT
17847       SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
17848
17849 ************************************************************************
17850 * Calculation of Coulomb and nuclear potential for a given configurat. *
17851 *               IPZ, IP       charge/mass number of proj.              *
17852 *               ITZ, IT       charge/mass number of targ.              *
17853 *               AFERP,AFERT   factors modifying proj./target pot.      *
17854 *                             if =0, FERMOD is used                    *
17855 *               MODE = 0      calculation of binding energy            *
17856 *                    = 1      pre-calculated binding energy is used    *
17857 * This version dated 16.11.95  is written by S. Roesler.               *
17858 ************************************************************************
17859
17860       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17861       SAVE
17862
17863       PARAMETER ( LINP = 5 ,
17864      &            LOUT = 6 ,
17865      &            LDAT = 9 )
17866
17867       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
17868      &           TINY10=1.0D-10)
17869
17870       LOGICAL LSTART
17871
17872 * particle properties (BAMJET index convention)
17873       CHARACTER*8  ANAME
17874       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17875      &                IICH(210),IIBAR(210),K1(210),K2(210)
17876 * nuclear potential
17877       LOGICAL LFERMI
17878       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17879      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17880      &                ETACOU(2),ICOUL,LFERMI
17881
17882       DIMENSION IDXPOT(14)
17883 *                   ap   an  lam  alam sig- sig+ sig0 tet0 tet- asig-
17884       DATA IDXPOT /   2,   9,  17,  18,  20,  21,  22,  97,  98,  99,
17885 *                 asig0 asig+ atet0 atet+
17886      &              100, 101, 102, 103/
17887
17888       DATA AN     /0.4D0/
17889       DATA LSTART /.TRUE./
17890
17891       IF (MODE.EQ.0) THEN
17892          EBINDP(1) = ZERO
17893          EBINDN(1) = ZERO
17894          EBINDP(2) = ZERO
17895          EBINDN(2) = ZERO
17896       ENDIF
17897       AIP  = DBLE(IP)
17898       AIPZ = DBLE(IPZ)
17899       AIT  = DBLE(IT)
17900       AITZ = DBLE(ITZ)
17901
17902       FERMIP = AFERP
17903       IF (AFERP.LE.ZERO) FERMIP = FERMOD
17904       FERMIT = AFERT
17905       IF (AFERT.LE.ZERO) FERMIT = FERMOD
17906
17907 * Fermi momenta and binding energy for projectile
17908       IF ((IP.GT.1).AND.LFERMI) THEN
17909          IF (MODE.EQ.0) THEN
17910 C           EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
17911 C           EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
17912             BIP  = AIP -ONE
17913             BIPZ = AIPZ-ONE
17914
17915             EBINDP(1) = 1.0D-3*ABS(ENERGY(AIP,AIPZ)
17916      &                            -ENERGY(BIP,BIPZ))
17917
17918             IF (AIP.LE.AIPZ) THEN
17919                EBINDN(1) = EBINDP(1)
17920                WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
17921             ELSE
17922
17923                EBINDN(1) = 1.0D-3*ABS(ENERGY(AIP,AIPZ)
17924      &                               -ENERGY(BIP,AIPZ))
17925
17926             ENDIF
17927          ENDIF
17928          PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
17929          PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
17930       ELSE
17931          PFERMP(1) = ZERO
17932          PFERMN(1) = ZERO
17933       ENDIF
17934 * effective nuclear potential for projectile
17935 C     EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
17936 C     EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
17937       EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
17938       EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
17939
17940 * Fermi momenta and binding energy for target
17941       IF ((IT.GT.1).AND.LFERMI) THEN
17942          IF (MODE.EQ.0) THEN
17943 C           EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
17944 C           EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
17945             BIT  = AIT -ONE
17946             BITZ = AITZ-ONE
17947
17948             EBINDP(2) = 1.0D-3*ABS(ENERGY(AIT,AITZ)
17949      &                            -ENERGY(BIT,BITZ))
17950
17951             IF (AIT.LE.AITZ) THEN
17952                EBINDN(2) = EBINDP(2)
17953                WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
17954             ELSE
17955
17956                EBINDN(2) = 1.0D-3*ABS(ENERGY(AIT,AITZ)
17957      &                               -ENERGY(BIT,AITZ))
17958
17959             ENDIF
17960          ENDIF
17961          PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
17962          PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
17963       ELSE
17964          PFERMP(2) = ZERO
17965          PFERMN(2) = ZERO
17966       ENDIF
17967 * effective nuclear potential for target
17968 C     EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
17969 C     EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
17970       EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
17971       EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
17972
17973       DO 2 I=1,14
17974          EPOT(1,IDXPOT(I)) = EPOT(1,8)
17975          EPOT(2,IDXPOT(I)) = EPOT(2,8)
17976     2 CONTINUE
17977
17978 * Coulomb energy
17979       ETACOU(1) = ZERO
17980       ETACOU(2) = ZERO
17981       IF (ICOUL.EQ.1) THEN
17982          IF (IP.GT.1)
17983      &   ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
17984          IF (IT.GT.1)
17985      &   ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
17986       ENDIF
17987
17988       IF (LSTART) THEN
17989          WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
17990      &                    EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
17991      &                    EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
17992      &                    FERMOD,ETACOU
17993  1000    FORMAT(/,/,1X,'NCLPOT:    quantities for inclusion of nuclear'
17994      &           ,' effects',/,12X,'---------------------------',
17995      &           '----------------',/,/,38X,'projectile',
17996      &           '      target',/,/,1X,'Mass number / charge',
17997      &           17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy  -',
17998      &           ' proton   (GeV) ',2E14.4,/,17X,'- neutron  (GeV)'
17999      &          ,1X,2E14.4,/,1X,'Fermi-potential - proton   (GeV)',
18000      &           1X,2E14.4,/,17X,'- neutron  (GeV) ',2E14.4,/,/,
18001      &           1X,'Scale factor for Fermi-momentum    ',F4.2,/,
18002      &           /,1X,'Coulomb-energy ',2(E14.4,' GeV  '),/,/)
18003          LSTART = .FALSE.
18004       ENDIF
18005
18006       RETURN
18007       END
18008 *
18009 *===resncl=============================================================*
18010 *
18011 CDECK  ID>, DT_RESNCL
18012       SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
18013
18014 ************************************************************************
18015 * Treatment of residual nuclei and nuclear effects.                    *
18016 *         MODE = 1     initializations                                 *
18017 *              = 2     treatment of final state                        *
18018 * This version dated 16.11.95 is written by S. Roesler.                *
18019 ************************************************************************
18020
18021       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18022       SAVE
18023
18024       PARAMETER ( LINP = 5 ,
18025      &            LOUT = 6 ,
18026      &            LDAT = 9 )
18027
18028       PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
18029      &           TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
18030      &           ONETHI=ONE/THREE)
18031       PARAMETER (AMUAMU = 0.93149432D0,
18032      &           FM2MM  = 1.0D-12,
18033      &           RNUCLE = 1.12D0)
18034
18035 * event history
18036
18037       PARAMETER (NMXHKK=200000)
18038
18039       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18040      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18041      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18042 * extended event history
18043       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18044      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18045      &                IHIST(2,NMXHKK)
18046 * particle properties (BAMJET index convention)
18047       CHARACTER*8  ANAME
18048       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18049      &                IICH(210),IIBAR(210),K1(210),K2(210)
18050 * flags for input different options
18051       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18052       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18053      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18054 * nuclear potential
18055       LOGICAL LFERMI
18056       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18057      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18058      &                ETACOU(2),ICOUL,LFERMI
18059 * properties of interacting particles
18060       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18061 * properties of photon/lepton projectiles
18062       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
18063 * Lorentz-parameters of the current interaction
18064       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
18065      &                UMO,PPCM,EPROJ,PPROJ
18066 * treatment of residual nuclei: wounded nucleons
18067       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18068 * treatment of residual nuclei: 4-momenta
18069       LOGICAL LRCLPR,LRCLTA
18070       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18071      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18072
18073       DIMENSION PFSP(4),PSEC(4),PSEC0(4)
18074       DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
18075      &          IDXCOR(15000),IDXOTH(NMXHKK)
18076
18077       GOTO (1,2) MODE
18078
18079 *------- initializations
18080     1 CONTINUE
18081
18082 * initialize arrays for residual nuclei
18083       DO 10 K=1,5
18084          IF (K.LE.4) THEN
18085             PFSP(K)     = ZERO
18086          ENDIF
18087          PINIPR(K) = ZERO
18088          PINITA(K) = ZERO
18089          PRCLPR(K) = ZERO
18090          PRCLTA(K) = ZERO
18091          TRCLPR(K) = ZERO
18092          TRCLTA(K) = ZERO
18093    10 CONTINUE
18094       SCPOT = ONE
18095       NLOOP = 0
18096
18097 * correction of projectile 4-momentum for effective target pot.
18098 * and Coulomb-energy (in case of hadron-nucleus interaction only)
18099       IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18100          EPNI = EPN
18101 *   Coulomb-energy:
18102 *     positively charged hadron - check energy for Coloumb pot.
18103          IF (IICH(IJPROJ).EQ.1) THEN
18104             THRESH = ETACOU(2)+AAM(IJPROJ)
18105             IF (EPNI.LE.THRESH) THEN
18106                WRITE(LOUT,1000)
18107  1000          FORMAT(/,1X,'KKINC:  WARNING!  projectile energy',
18108      &                ' below Coulomb threshold - event rejected',/)
18109                ISTHKK(1) = 1
18110                RETURN
18111             ENDIF
18112 *     negatively charged hadron - increase energy by Coulomb energy
18113          ELSEIF (IICH(IJPROJ).EQ.-1) THEN
18114             EPNI = EPNI+ETACOU(2)
18115          ENDIF
18116          IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
18117 *   Effective target potential
18118 *sr 6.6. binding energy only (to avoid negative exc. energies)
18119 C           EPNI = EPNI+EPOT(2,IJPROJ)
18120             EBIPOT = EBINDP(2)
18121             IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
18122      &         EBIPOT = EBINDN(2)
18123             EPNI = EPNI+ABS(EBIPOT)
18124 * re-initialization of DTLTRA
18125             DUM1 = ZERO
18126             DUM2 = ZERO
18127             CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
18128          ENDIF
18129       ENDIF
18130
18131 * projectile in n-n cms
18132       IF ((IP.LE.1).AND.(IT.GT.1)) THEN
18133          PMASS1 = AAM(IJPROJ)
18134 C* VDM assumption
18135 C         IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
18136          IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
18137          PMASS2 = AAM(1)
18138          PM1 = SIGN(PMASS1**2,PMASS1)
18139          PM2 = SIGN(PMASS2**2,PMASS2)
18140          PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
18141          PINIPR(5) = PMASS1
18142          IF (PMASS1.GT.ZERO) THEN
18143             PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
18144      &                      *(PINIPR(4)+PINIPR(5)))
18145          ELSE
18146             PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
18147          ENDIF
18148          AIT  = DBLE(IT)
18149          AITZ = DBLE(ITZ)
18150
18151          PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18152
18153          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18154       ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
18155          PMASS1 = AAM(1)
18156          PMASS2 = AAM(IJTARG)
18157          PM1 = SIGN(PMASS1**2,PMASS1)
18158          PM2 = SIGN(PMASS2**2,PMASS2)
18159          PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
18160          PINITA(5) = PMASS2
18161          PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
18162      &                    *(PINITA(4)+PINITA(5)))
18163          AIP  = DBLE(IP)
18164          AIPZ = DBLE(IPZ)
18165
18166          PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18167
18168          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18169       ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
18170          AIP  = DBLE(IP)
18171          AIPZ = DBLE(IPZ)
18172
18173          PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18174
18175          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18176          AIT  = DBLE(IT)
18177          AITZ = DBLE(ITZ)
18178
18179          PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18180
18181          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18182       ENDIF
18183
18184       RETURN
18185
18186 *------- treatment of final state
18187     2 CONTINUE
18188
18189       NLOOP = NLOOP+1
18190       IF (NLOOP.GT.1) SCPOT = 0.10D0
18191 C     WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18192
18193       JPW  = NPW
18194       JPCW = NPCW
18195       JTW  = NTW
18196       JTCW = NTCW
18197       DO 40 K=1,4
18198          PFSP(K)   = ZERO
18199    40 CONTINUE
18200
18201       NOB = 0
18202       NOM = 0
18203       DO 900 I=NPOINT(4),NHKK
18204          IDXOTH(I) = -1
18205          IF (ISTHKK(I).EQ.1) THEN
18206             IF (IDBAM(I).EQ.7) GOTO 900
18207             IPOT = 0
18208             IOTHER = 0
18209 * particle moving into forward direction
18210             IF (PHKK(3,I).GE.ZERO) THEN
18211 *   most likely to be effected by projectile potential
18212                IPOT = 1
18213 *     there is no projectile nucleus, try target
18214                IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18215                   IPOT   = 2
18216                   IF (IP.GT.1) IOTHER = 1
18217 *       there is no target nucleus --> skip
18218                   IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18219                ENDIF
18220 * particle moving into backward direction
18221             ELSE
18222 *   most likely to be effected by target potential
18223                IPOT = 2
18224 *     there is no target nucleus, try projectile
18225                IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18226                   IPOT   = 1
18227                   IF (IT.GT.1) IOTHER = 1
18228 *       there is no projectile nucleus --> skip
18229                   IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18230                ENDIF
18231             ENDIF
18232             IFLG = -IPOT
18233 * nobam=3: particle is in overlap-region or neither inside proj. nor target
18234 *      =1: particle is not in overlap-region AND is inside target (2)
18235 *      =2: particle is not in overlap-region AND is inside projectile (1)
18236 * flag particles which are inside the nucleus ipot but not in its
18237 * overlap region
18238             IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
18239 * baryons: keep all nucleons and all others where flag is set
18240             IF (IIBAR(IDBAM(I)).NE.0) THEN
18241                IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
18242      &                                                           THEN
18243                   NOB = NOB+1
18244                   PMOMB(NOB) = PHKK(3,I)
18245                   IDXB(NOB)  = SIGN(1000000*IABS(IFLG)
18246      &                        +100000*IOTHER+I,IFLG)
18247                ENDIF
18248 * mesons: keep only those mesons where flag is set
18249             ELSE
18250                IF (IFLG.GT.0) THEN
18251                   NOM = NOM+1
18252                   PMOMM(NOM) = PHKK(3,I)
18253                   IDXM(NOM)  = 1000000*IFLG+100000*IOTHER+I
18254                ENDIF
18255             ENDIF
18256          ENDIF
18257   900 CONTINUE
18258 *
18259 * sort particles in the arrays according to increasing long. momentum
18260       CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
18261       CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
18262 *
18263 * shuffle indices into one and the same array according to the later
18264 * sequence of correction
18265       NCOR = 0
18266       IF (IT.GT.1) THEN
18267          DO 910 I=1,NOB
18268             IF (PMOMB(I).GT.ZERO) GOTO 911
18269             NCOR = NCOR+1
18270             IDXCOR(NCOR) = IDXB(I)
18271   910    CONTINUE
18272   911    CONTINUE
18273          IF (IP.GT.1) THEN
18274             DO 912 J=1,NOB
18275                I = NOB+1-J
18276                IF (PMOMB(I).LT.ZERO) GOTO 913
18277                NCOR = NCOR+1
18278                IDXCOR(NCOR) = IDXB(I)
18279   912       CONTINUE
18280   913       CONTINUE
18281          ELSE
18282             DO 914 I=1,NOB
18283                IF (PMOMB(I).GT.ZERO) THEN
18284                   NCOR = NCOR+1
18285                   IDXCOR(NCOR) = IDXB(I)
18286                ENDIF
18287   914       CONTINUE
18288          ENDIF
18289       ELSE
18290          DO 915 J=1,NOB
18291             I = NOB+1-J
18292             NCOR = NCOR+1
18293             IDXCOR(NCOR) = IDXB(I)
18294   915    CONTINUE
18295       ENDIF
18296       DO 925 I=1,NOM
18297          IF (PMOMM(I).GT.ZERO) GOTO 926
18298          NCOR = NCOR+1
18299          IDXCOR(NCOR) = IDXM(I)
18300   925 CONTINUE
18301   926 CONTINUE
18302       DO 927 J=1,NOM
18303          I = NOM+1-J
18304          IF (PMOMM(I).LT.ZERO) GOTO 928
18305          NCOR = NCOR+1
18306          IDXCOR(NCOR) = IDXM(I)
18307   927 CONTINUE
18308   928 CONTINUE
18309 *
18310 C      IF (NEVHKK.EQ.484) THEN
18311 C         WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
18312 C 9000    FORMAT(1X,'wounded nucleons (proj.-p,n  targ.-p,n)',/,4I10)
18313 C         WRITE(LOUT,9001) NOB,NOM,NCOR
18314 C 9001    FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
18315 C         WRITE(LOUT,'(/,A)') ' baryons '
18316 C         DO 950 I=1,NOB
18317 CC           J     = IABS(IDXB(I))
18318 CC           INDEX = J-IABS(J/1000000)*1000000
18319 C            IPOT   = IABS(IDXB(I))/1000000
18320 C            IOTHER = IABS(IDXB(I))/100000-IPOT*10
18321 C            INDEX = IABS(IDXB(I))-IPOT*1000000-IOTHER*100000
18322 C            WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
18323 C  950    CONTINUE
18324 C         WRITE(LOUT,'(/,A)') ' mesons '
18325 C         DO 951 I=1,NOM
18326 CC           INDEX = IDXM(I)-IABS(IDXM(I)/1000000)*1000000
18327 C            IPOT   = IABS(IDXM(I))/1000000
18328 C            IOTHER = IABS(IDXM(I))/100000-IPOT*10
18329 C            INDEX = IABS(IDXM(I))-IPOT*1000000-IOTHER*100000
18330 C            WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
18331 C  951    CONTINUE
18332 C 9002    FORMAT(1X,4I14,E14.5)
18333 C         WRITE(LOUT,'(/,A)') ' all '
18334 C         DO 952 I=1,NCOR
18335 CC           J     = IABS(IDXCOR(I))
18336 CC           INDEX = J-IABS(J/1000000)*1000000
18337 CC            IPOT   = IABS(IDXCOR(I))/1000000
18338 C            IOTHER = IABS(IDXCOR(I))/100000-IPOT*10
18339 C            INDEX = IABS(IDXCOR(I))-IPOT*1000000-IOTHER*100000
18340 C            WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
18341 C  952    CONTINUE
18342 C 9003    FORMAT(1X,4I14)
18343 C      ENDIF
18344 *
18345       DO 20 ICOR=1,NCOR
18346          IPOT   = IABS(IDXCOR(ICOR))/1000000
18347          IOTHER = IABS(IDXCOR(ICOR))/100000-IPOT*10
18348          I = IABS(IDXCOR(ICOR))-IPOT*1000000-IOTHER*100000
18349          IDXOTH(I) = 1
18350
18351          IDSEC  = IDBAM(I)
18352
18353 * reduction of particle momentum by corresponding nuclear potential
18354 * (this applies only if Fermi-momenta are requested)
18355
18356          IF (LFERMI) THEN
18357
18358 *   Lorentz-transformation into the rest system of the selected nucleus
18359             IMODE = -IPOT-1
18360             CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18361      &                  PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
18362             PSECO  = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
18363             AMSEC  = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
18364             JPMOD  = 0
18365
18366             CHKLEV = TINY3
18367             IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
18368             IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
18369             IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
18370                IF (IOULEV(3).GT.0)
18371      &            WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
18372  2000          FORMAT(1X,'RESNCL: inconsistent mass of particle',
18373      &                ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
18374      &                I4,'   AMSEC: ',E12.3,'  AAM(IDSEC): ',E12.3,/)
18375                GOTO 23
18376             ENDIF
18377
18378             DO 21 K=1,4
18379                PSEC0(K) = PSEC(K)
18380    21       CONTINUE
18381
18382 *   the correction for nuclear potential effects is applied to as many
18383 *   p/n as many nucleons were wounded; the momenta of other final state
18384 *   particles are corrected only if they materialize inside the corresp.
18385 *   nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
18386 *   = 3 part. outside proj. and targ., >=10 in overlapping region)
18387             IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
18388                IF (IPOT.EQ.1) THEN
18389                   IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
18390 *      this is most likely a wounded nucleon
18391 **test
18392 C                    RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
18393 C    &                           +(VHKK(2,IPW(JPW))/FM2MM)**2
18394 C    &                           +(VHKK(3,IPW(JPW))/FM2MM)**2)
18395 C                    RAD   = RNUCLE*DBLE(IP)**ONETHI
18396 C                    FDEN  = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
18397 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18398 **
18399                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18400                      JPW = JPW-1
18401                      JPMOD = 1
18402                   ELSE
18403 *      correct only if part. was materialized inside nucleus
18404 *      and if it is ouside the overlapping region
18405                      IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
18406                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18407                         JPMOD = 1
18408                      ENDIF
18409                   ENDIF
18410                ELSEIF (IPOT.EQ.2) THEN
18411                   IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
18412 *      this is most likely a wounded nucleon
18413 **test
18414 C                    RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
18415 C    &                           +(VHKK(2,ITW(JTW))/FM2MM)**2
18416 C    &                           +(VHKK(3,ITW(JTW))/FM2MM)**2)
18417 C                    RAD   = RNUCLE*DBLE(IT)**ONETHI
18418 C                    FDEN  = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
18419 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18420 **
18421                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18422                      JTW = JTW-1
18423                      JPMOD = 1
18424                   ELSE
18425 *      correct only if part. was materialized inside nucleus
18426                      IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
18427                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18428                         JPMOD = 1
18429                      ENDIF
18430                   ENDIF
18431                ENDIF
18432             ELSE
18433                IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
18434                   PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18435                   JPMOD = 1
18436                ENDIF
18437             ENDIF
18438
18439             IF (NLOOP.EQ.1) THEN
18440 * Coulomb energy correction:
18441 * the treatment of Coulomb potential correction is similar to the
18442 * one for nuclear potential
18443                IF (IDSEC.EQ.1) THEN
18444                   IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
18445                      JPCW = JPCW-1
18446                   ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
18447                      JTCW = JTCW-1
18448                   ELSE
18449                      IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18450                   ENDIF
18451                ELSE
18452                   IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18453                ENDIF
18454                IF (IICH(IDSEC).EQ.1) THEN
18455 *    pos. particles: check if they are able to escape Coulomb potential
18456                   IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
18457                      ISTHKK(I) = 14+IPOT
18458                      IF (ISTHKK(I).EQ.15) THEN
18459                         DO 26 K=1,4
18460                            PHKK(K,I) = PSEC0(K)
18461                            TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18462    26                CONTINUE
18463                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18464                         IF (IDSEC.EQ.1) NPCW = NPCW-1
18465                      ELSEIF (ISTHKK(I).EQ.16) THEN
18466                         DO 27 K=1,4
18467                            PHKK(K,I) = PSEC0(K)
18468                            TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18469    27                   CONTINUE
18470                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18471                         IF (IDSEC.EQ.1) NTCW = NTCW-1
18472                      ENDIF
18473                      GOTO 20
18474                   ENDIF
18475                ELSEIF (IICH(IDSEC).EQ.-1) THEN
18476 *    neg. particles: decrease energy by Coulomb-potential
18477                   PSEC(4) = PSEC(4)-ETACOU(IPOT)
18478                   JPMOD = 1
18479                ENDIF
18480             ENDIF
18481
18482    25       CONTINUE
18483
18484             IF (PSEC(4).LT.AMSEC) THEN
18485                IF (IOULEV(6).GT.0)
18486      &            WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
18487  2001          FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
18488      &                ' is not allowed to escape nucleus',/,
18489      &                8X,'id : ',I3,'   reduced energy: ',E15.4,
18490      &                '   mass: ',E12.3)
18491                ISTHKK(I) = 14+IPOT
18492                IF (ISTHKK(I).EQ.15) THEN
18493                   DO 28 K=1,4
18494                      PHKK(K,I) = PSEC0(K)
18495                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18496    28             CONTINUE
18497                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18498                   IF (IDSEC.EQ.1) NPCW = NPCW-1
18499                ELSEIF (ISTHKK(I).EQ.16) THEN
18500                   DO 29 K=1,4
18501                      PHKK(K,I) = PSEC0(K)
18502                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18503    29             CONTINUE
18504                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18505                   IF (IDSEC.EQ.1) NTCW = NTCW-1
18506                ENDIF
18507                GOTO 20
18508             ENDIF
18509
18510             IF (JPMOD.EQ.1) THEN
18511                PSECN  = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
18512 * 4-momentum after correction for nuclear potential
18513                DO 22 K=1,3
18514                   PSEC(K) = PSEC(K)*PSECN/PSECO
18515    22          CONTINUE
18516
18517 * store recoil momentum from particles escaping the nuclear potentials
18518                DO 30 K=1,4
18519                   IF (IPOT.EQ.1) THEN
18520                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
18521                   ELSEIF (IPOT.EQ.2) THEN
18522                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
18523                   ENDIF
18524    30          CONTINUE
18525
18526 * transform momentum back into n-n cms
18527                IMODE = IPOT+1
18528                CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
18529      &                     PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18530      &                     IDSEC,IMODE)
18531             ENDIF
18532
18533          ENDIF
18534
18535    23    CONTINUE
18536          DO 31 K=1,4
18537             PFSP(K) = PFSP(K)+PHKK(K,I)
18538    31    CONTINUE
18539
18540    20 CONTINUE
18541
18542       DO 33 I=NPOINT(4),NHKK
18543          IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
18544             PFSP(1) = PFSP(1)+PHKK(1,I)
18545             PFSP(2) = PFSP(2)+PHKK(2,I)
18546             PFSP(3) = PFSP(3)+PHKK(3,I)
18547             PFSP(4) = PFSP(4)+PHKK(4,I)
18548          ENDIF
18549    33 CONTINUE
18550
18551       DO 34 K=1,5
18552          PRCLPR(K) = TRCLPR(K)
18553          PRCLTA(K) = TRCLTA(K)
18554    34 CONTINUE
18555
18556       IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18557 * hadron-nucleus interactions: get residual momentum from energy-
18558 * momentum conservation
18559          DO 32 K=1,4
18560             PRCLPR(K) = ZERO
18561             PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
18562    32    CONTINUE
18563       ELSE
18564 * nucleus-hadron, nucleus-nucleus: get residual momentum from
18565 * accumulated recoil momenta of particles leaving the spectators
18566 *   transform accumulated recoil momenta of residual nuclei into
18567 *   n-n cms
18568          PZI = PRCLPR(3)
18569          PEI = PRCLPR(4)
18570          CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
18571          PZI = PRCLTA(3)
18572          PEI = PRCLTA(4)
18573          CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
18574 C        IF (IP.GT.1) THEN
18575             PRCLPR(3) = PRCLPR(3)+PINIPR(3)
18576             PRCLPR(4) = PRCLPR(4)+PINIPR(4)
18577 C        ENDIF
18578          IF (IT.GT.1) THEN
18579             PRCLTA(3) = PRCLTA(3)+PINITA(3)
18580             PRCLTA(4) = PRCLTA(4)+PINITA(4)
18581          ENDIF
18582       ENDIF
18583
18584 * check momenta of residual nuclei
18585       IF (LEMCCK) THEN
18586          CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
18587      &               1,IDUM,IDUM)
18588          CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
18589      &               2,IDUM,IDUM)
18590          CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
18591      &               2,IDUM,IDUM)
18592          CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
18593      &               2,IDUM,IDUM)
18594          CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
18595 **sr 19.12. changed to avoid output when used with phojet
18596 C        CHKLEV = TINY3
18597          CHKLEV = TINY1
18598          CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
18599 C        IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
18600 C    &      CALL DT_EVTOUT(4)
18601          IF (IREJ1.GT.0) RETURN
18602       ENDIF
18603
18604       RETURN
18605       END
18606 *
18607 *===scn4ba=============================================================*
18608 *
18609 CDECK  ID>, DT_SCN4BA
18610       SUBROUTINE DT_SCN4BA
18611
18612 ************************************************************************
18613 * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot.    *
18614 * This version dated 12.12.95 is written by S. Roesler.                *
18615 ************************************************************************
18616
18617       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18618       SAVE
18619
18620       PARAMETER ( LINP = 5 ,
18621      &            LOUT = 6 ,
18622      &            LDAT = 9 )
18623
18624       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18625      &           TINY10=1.0D-10)
18626
18627 * event history
18628
18629       PARAMETER (NMXHKK=200000)
18630
18631       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18632      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18633      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18634 * extended event history
18635       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18636      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18637      &                IHIST(2,NMXHKK)
18638 * particle properties (BAMJET index convention)
18639       CHARACTER*8  ANAME
18640       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18641      &                IICH(210),IIBAR(210),K1(210),K2(210)
18642 * properties of interacting particles
18643       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18644 * nuclear potential
18645       LOGICAL LFERMI
18646       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18647      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18648      &                ETACOU(2),ICOUL,LFERMI
18649 * treatment of residual nuclei: wounded nucleons
18650       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18651 * treatment of residual nuclei: 4-momenta
18652       LOGICAL LRCLPR,LRCLTA
18653       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18654      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18655
18656       DIMENSION PLAB(2,5),PCMS(4)
18657
18658       IREJ = 0
18659
18660 * get number of wounded nucleons
18661       NPW    = 0
18662       NPW0   = 0
18663       NPCW   = 0
18664       NPSTCK = 0
18665       NTW    = 0
18666       NTW0   = 0
18667       NTCW   = 0
18668       NTSTCK = 0
18669
18670       ISGLPR = 0
18671       ISGLTA = 0
18672       LRCLPR = .FALSE.
18673       LRCLTA = .FALSE.
18674
18675 C     DO 2 I=1,NHKK
18676       DO 2 I=1,NPOINT(1)
18677 * projectile nucleons wounded in primary interaction and in fzc
18678          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
18679             NPW      = NPW+1
18680             IPW(NPW) = I
18681             NPSTCK   = NPSTCK+1
18682             IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
18683             IF (ISTHKK(I).EQ.11)  NPW0 = NPW0+1
18684 C           IF (IP.GT.1) THEN
18685                DO 5 K=1,4
18686                   TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
18687     5          CONTINUE
18688 C           ENDIF
18689 * target nucleons wounded in primary interaction and in fzc
18690          ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
18691             NTW      = NTW+1
18692             ITW(NTW) = I
18693             NTSTCK   = NTSTCK+1
18694             IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
18695             IF (ISTHKK(I).EQ.12)  NTW0 = NTW0+1
18696             IF (IT.GT.1) THEN
18697                DO 6 K=1,4
18698                   TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
18699     6          CONTINUE
18700             ENDIF
18701          ELSEIF (ISTHKK(I).EQ.13) THEN
18702             ISGLPR = I
18703          ELSEIF (ISTHKK(I).EQ.14) THEN
18704             ISGLTA = I
18705          ENDIF
18706     2 CONTINUE
18707
18708       DO 11 I=NPOINT(4),NHKK
18709 * baryons which are unable to escape the nuclear potential of proj.
18710          IF (ISTHKK(I).EQ.15) THEN
18711             ISGLPR = I
18712             NPSTCK = NPSTCK-1
18713             IF (IIBAR(IDBAM(I)).NE.0) THEN
18714                NPW    = NPW-1
18715                IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
18716             ENDIF
18717             DO 7 K=1,4
18718                TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18719     7       CONTINUE
18720 * baryons which are unable to escape the nuclear potential of targ.
18721          ELSEIF (ISTHKK(I).EQ.16) THEN
18722             ISGLTA = I
18723             NTSTCK = NTSTCK-1
18724             IF (IIBAR(IDBAM(I)).NE.0) THEN
18725                NTW    = NTW-1
18726                IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
18727             ENDIF
18728             DO 8 K=1,4
18729                TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18730     8       CONTINUE
18731          ENDIF
18732    11 CONTINUE
18733
18734 * residual nuclei so far
18735       IRESP = IP-NPSTCK
18736       IREST = IT-NTSTCK
18737
18738 * ckeck for "residual nuclei" consisting of one nucleon only
18739 * treat it as final state particle
18740       IF (IRESP.EQ.1) THEN
18741          ID  = IDBAM(ISGLPR)
18742          IST = ISTHKK(ISGLPR)
18743          CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
18744      &               PHKK(3,ISGLPR),PHKK(4,ISGLPR),
18745      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
18746          IF (IST.EQ.13) THEN
18747             ISTHKK(ISGLPR) = 11
18748          ELSE
18749             ISTHKK(ISGLPR) = 2
18750          ENDIF
18751          CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
18752      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18753      &               IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
18754          NOBAM(NHKK)      = NOBAM(ISGLPR)
18755          JDAHKK(1,ISGLPR) = NHKK
18756          DO 21 K=1,4
18757             TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
18758    21    CONTINUE
18759       ENDIF
18760       IF (IREST.EQ.1) THEN
18761          ID  = IDBAM(ISGLTA)
18762          IST = ISTHKK(ISGLTA)
18763          CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
18764      &               PHKK(3,ISGLTA),PHKK(4,ISGLTA),
18765      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
18766          IF (IST.EQ.14) THEN
18767             ISTHKK(ISGLTA) = 12
18768          ELSE
18769             ISTHKK(ISGLTA) = 2
18770          ENDIF
18771          CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
18772      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18773      &               IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
18774          NOBAM(NHKK)      = NOBAM(ISGLTA)
18775          JDAHKK(1,ISGLTA) = NHKK
18776          DO 22 K=1,4
18777             TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
18778    22    CONTINUE
18779       ENDIF
18780
18781 * get nuclear potential corresp. to the residual nucleus
18782       IPRCL  = IP -NPW
18783       IPZRCL = IPZ-NPCW
18784       ITRCL  = IT -NTW
18785       ITZRCL = ITZ-NTCW
18786       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
18787
18788 * baryons unable to escape the nuclear potential are treated as
18789 * excited nucleons (ISTHKK=15,16)
18790       DO 3 I=NPOINT(4),NHKK
18791          IF (ISTHKK(I).EQ.1) THEN
18792             ID  = IDBAM(I)
18793             IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
18794 *   final state n and p not being outside of both nuclei are considered
18795                NPOTP = 1
18796                NPOTT = 1
18797                IF ( (IP.GT.1)      .AND.(IRESP.GT.1).AND.
18798      &              (NOBAM(I).NE.1).AND.(NPW.GT.0)        ) THEN
18799 *     Lorentz-trsf. into proj. rest sys. for those being inside proj.
18800                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18801      &                        PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
18802      &                        PLAB(1,4),ID,-2)
18803                   PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
18804                   PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
18805      &                                  (PLAB(1,4)+PLABT) ))
18806                   EKIN = PLAB(1,4)-PLAB(1,5)
18807                   IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
18808                   IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
18809                ENDIF
18810                IF ( (IT.GT.1)      .AND.(IREST.GT.1).AND.
18811      &              (NOBAM(I).NE.2).AND.(NTW.GT.0)        ) THEN
18812 *     Lorentz-trsf. into targ. rest sys. for those being inside targ.
18813                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18814      &                        PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
18815      &                        PLAB(2,4),ID,-3)
18816                   PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
18817                   PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
18818      &                                  (PLAB(2,4)+PLABT) ))
18819                   EKIN = PLAB(2,4)-PLAB(2,5)
18820                   IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
18821                   IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
18822                ENDIF
18823                IF (PHKK(3,I).GE.ZERO) THEN
18824                   ISTHKK(I) = NPOTT
18825                   IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
18826                ELSE
18827                   ISTHKK(I) = NPOTP
18828                   IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
18829                ENDIF
18830                IF (ISTHKK(I).NE.1) THEN
18831                   J = ISTHKK(I)-14
18832                   DO 4 K=1,5
18833                      PHKK(K,I) = PLAB(J,K)
18834     4             CONTINUE
18835                   IF (ISTHKK(I).EQ.15) THEN
18836                      NPW = NPW-1
18837                      IF (ID.EQ.1) NPCW = NPCW-1
18838                      DO 9 K=1,4
18839                         TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18840     9                CONTINUE
18841                   ELSEIF (ISTHKK(I).EQ.16) THEN
18842                      NTW = NTW-1
18843                      IF (ID.EQ.1) NTCW = NTCW-1
18844                      DO 10 K=1,4
18845                         TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18846    10                CONTINUE
18847                   ENDIF
18848                ENDIF
18849             ENDIF
18850          ENDIF
18851     3 CONTINUE
18852
18853 * again: get nuclear potential corresp. to the residual nucleus
18854       IPRCL  = IP -NPW
18855       IPZRCL = IPZ-NPCW
18856       ITRCL  = IT -NTW
18857       ITZRCL = ITZ-NTCW
18858 c      AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
18859 cC     AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
18860 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
18861 C     AFERP = 0.0D0
18862 c      AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
18863 cC     AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
18864 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
18865 C     AFERT = 0.0D0
18866 C     IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
18867 C     IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
18868 C     IF (AFERP.GT.0.85D0) AFERP = 0.85D0
18869 C     IF (AFERT.GT.0.85D0) AFERT = 0.85D0
18870       AFERP = FERMOD+0.1D0
18871       AFERT = FERMOD+0.1D0
18872
18873       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
18874
18875       RETURN
18876       END
18877 *
18878 *===ficonf=============================================================*
18879 *
18880 CDECK  ID>, DT_FICONF
18881       SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
18882
18883 ************************************************************************
18884 * Treatment of FInal CONFiguration including evaporation, fission and  *
18885 * Fermi-break-up (for light nuclei only).                              *
18886 * Adopted from the original routine FINALE and extended to residual    *
18887 * projectile nuclei.                                                   *
18888 * This version dated 12.12.95 is written by S. Roesler.                *
18889 ************************************************************************
18890
18891       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18892       SAVE
18893
18894       PARAMETER ( LINP = 5 ,
18895      &            LOUT = 6 ,
18896      &            LDAT = 9 )
18897
18898       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18899       PARAMETER (ANGLGB=5.0D-16)
18900
18901 * event history
18902
18903       PARAMETER (NMXHKK=200000)
18904
18905       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18906      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18907      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18908 * extended event history
18909       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18910      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18911      &                IHIST(2,NMXHKK)
18912 * rejection counter
18913       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
18914      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
18915      &                IREXCI(3),IRDIFF(2),IRINC
18916 * central particle production, impact parameter biasing
18917       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
18918 * particle properties (BAMJET index convention)
18919       CHARACTER*8  ANAME
18920       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18921      &                IICH(210),IIBAR(210),K1(210),K2(210)
18922 * treatment of residual nuclei: 4-momenta
18923       LOGICAL LRCLPR,LRCLTA
18924       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18925      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18926 * treatment of residual nuclei: properties of residual nuclei
18927       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
18928      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
18929      &                NTOTFI(2),NPROFI(2)
18930 * statistics: residual nuclei
18931       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
18932      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
18933      &                NINCST(2,4),NINCEV(2),
18934      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
18935      &                NRESPB(2),NRESCH(2),NRESEV(4),
18936      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
18937      &                NEVAFI(2,2)
18938 * flags for input different options
18939       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18940       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18941      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18942
18943       INCLUDE './flukapro/(DIMPAR)'
18944       INCLUDE './flukapro/(FINUC)'
18945       INCLUDE './flukapro/(RESNUC)'
18946       PARAMETER ( EMVGEV = 1.0                D-03 )
18947       PARAMETER ( AMUGEV = 0.93149432         D+00 )
18948       PARAMETER ( AMPRTN = 0.93827231         D+00 )
18949       PARAMETER ( AMNTRN = 0.93956563         D+00 )
18950       PARAMETER ( AMELCT = 0.51099906         D-03 )
18951       PARAMETER ( ELCCGS = 4.8032068          D-10 )
18952       PARAMETER ( ELCMKS = 1.60217733         D-19 )
18953       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
18954      &                   * 1.D-09 )
18955       PARAMETER ( HLFHLF = 0.5D+00 )
18956       PARAMETER ( FERTHO = 14.33       D-09 )
18957       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
18958       PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
18959       PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
18960       INCLUDE './flukapro/(NUCDAT)'
18961       INCLUDE './flukapro/(PAREVT)'
18962       INCLUDE './flukapro/(FHEAVY)'
18963
18964 * event flag
18965       COMMON /DTEVNO/ NEVENT,ICASCA
18966
18967       DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
18968      &          PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
18969      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
18970
18971       DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
18972       DATA EXC,NEXC /520*ZERO,520*0/
18973       DATA EXPNUC /4.0D-3,4.0D-3/
18974
18975       IREJ   = 0
18976       LRCLPR = .FALSE.
18977       LRCLTA = .FALSE.
18978
18979 * skip residual nucleus treatment if not requested or in case
18980 * of central collisions
18981       IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
18982
18983       DO 1 K=1,2
18984          IDPAR(K) = 0
18985          IDXPAR(K)= 0
18986          NTOT(K)  = 0
18987          NTOTFI(K)= 0
18988          NPRO(K)  = 0
18989          NPROFI(K)= 0
18990          NN(K)    = 0
18991          NH(K)    = 0
18992          NHPOS(K) = 0
18993          NQ(K)    = 0
18994          EEXC(K)  = ZERO
18995          MO1(K)   = 0
18996          MO2(K)   = 0
18997          DO 2 I=1,4
18998             VRCL(K,I) = ZERO
18999             WRCL(K,I) = ZERO
19000     2    CONTINUE
19001     1 CONTINUE
19002       NFSP = 0
19003       INUC(1) = IP
19004       INUC(2) = IT
19005
19006       DO 3 I=1,NHKK
19007
19008 * number of final state particles
19009          IF (ABS(ISTHKK(I)).EQ.1) THEN
19010             NFSP  = NFSP+1
19011             IDFSP = IDBAM(I)
19012          ENDIF
19013
19014 * properties of remaining nucleon configurations
19015          KF = 0
19016          IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
19017          IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
19018          IF (KF.GT.0) THEN
19019             IF (MO1(KF).EQ.0) MO1(KF) = I
19020             MO2(KF)  = I
19021 *   position of residual nucleus = average position of nucleons
19022             DO 4 K=1,4
19023                VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
19024                WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
19025     4       CONTINUE
19026 *   total number of particles contributing to each residual nucleus
19027             NTOT(KF)  = NTOT(KF)+1
19028             IDTMP     = IDBAM(I)
19029             IDXTMP    = I
19030 *   total charge of residual nuclei
19031             NQ(KF) = NQ(KF)+IICH(IDTMP)
19032 *   number of protons
19033             IF (IDHKK(I).EQ.2212) THEN
19034                NPRO(KF) = NPRO(KF)+1
19035 *   number of neutrons
19036             ELSEIF (IDHKK(I).EQ.2112) THEN
19037                NN(KF) = NN(KF)+1
19038             ELSE
19039 *   number of baryons other than n, p
19040                IF (IIBAR(IDTMP).EQ.1) THEN
19041                   NH(KF) = NH(KF)+1
19042                   IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
19043                ELSE
19044 *   any other mesons (status set to 1)
19045 C                 WRITE(LOUT,1002) KF,IDTMP
19046 C1002             FORMAT(1X,'FICONF:   residual nucleus ',I2,
19047 C    &                   ' containing meson ',I4,', status set to 1')
19048                   ISTHKK(I) = 1
19049                   IDTMP     = IDPAR(KF)
19050                   IDXTMP    = IDXPAR(KF)
19051                   NTOT(KF)  = NTOT(KF)-1
19052                ENDIF
19053             ENDIF
19054             IDPAR(KF)  = IDTMP
19055             IDXPAR(KF) = IDXTMP
19056          ENDIF
19057     3 CONTINUE
19058
19059 * reject elastic events (def: one final state particle = projectile)
19060       IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
19061          IREXCI(3) = IREXCI(3)+1
19062          GOTO 9999
19063 C        RETURN
19064       ENDIF
19065
19066 * check if one nucleus disappeared..
19067 C     IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
19068 C        DO 5 K=1,4
19069 C           PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
19070 C           PRCLPR(K) = ZERO
19071 C   5    CONTINUE
19072 C     ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
19073 C        DO 6 K=1,4
19074 C           PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
19075 C           PRCLTA(K) = ZERO
19076 C   6    CONTINUE
19077 C     ENDIF
19078
19079       ICOR   = 0
19080       INORCL = 0
19081       DO 7 I=1,2
19082          DO 8 K=1,4
19083 * get the average of the nucleon positions
19084             VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
19085             WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
19086             IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
19087             IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
19088     8    CONTINUE
19089 * mass number and charge of residual nuclei
19090          AIF(I)  = DBLE(NTOT(I))
19091          AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
19092          IF (NTOT(I).GT.1) THEN
19093 * masses of residual nuclei in ground state
19094
19095 C           AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*ENERGY(AIF(I),AIZF(I))
19096             AMRCL0(I) = AIF(I)*AMUC12
19097      &                  +EMVGEV*EXMSAZ(AIF(I),AIZF(I),.TRUE.,IZDUM)
19098
19099 * masses of residual nuclei
19100             PTORCL   = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
19101             AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
19102             IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
19103             IF (AMRCL(I).LE.ZERO) THEN
19104                IF (IOULEV(3).GT.0)
19105      &            WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
19106      &                             PRCL(I,4),NTOT
19107  1000          FORMAT(1X,'warning! negative excitation energy',/,
19108      &                I4,4E15.4,2I4)
19109                AMRCL(I) = ZERO
19110                EEXC(I)  = ZERO
19111                IF (NLOOP.LE.500) THEN
19112                   GOTO 9998
19113                ELSE
19114                   IREXCI(2) = IREXCI(2)+1
19115                   GOTO 9999
19116                ENDIF
19117             ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
19118      &                                                         THEN
19119 **sr
19120 C              WRITE(6,*) NEVHKK,I,NTOT(1),NTOT(2),AMRCL(I),AMRCL0(I)
19121 **
19122 **sr 3.3
19123 C              AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
19124                M = MIN(NTOT(I),260)
19125                IF (NEXC(I,M).GT.0) THEN
19126                   AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
19127                ELSE
19128    70             CONTINUE
19129                   M = M+1
19130                   IF (M.GE.INUC(I)) THEN
19131                      AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
19132                   ELSE
19133                      IF (NEXC(I,M).GT.0) THEN
19134                         AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
19135                      ELSE
19136                         GOTO 70
19137                      ENDIF
19138                   ENDIF
19139                ENDIF
19140 **
19141                EEXC(I)  = AMRCL(I)-AMRCL0(I)
19142                ICOR     = ICOR+I
19143             ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
19144                IF (IOULEV(3).GT.0)
19145 &                 WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
19146  1004          FORMAT(1X,'warning! too high excitation energy',/,
19147      &                I4,1P,2E15.4,3I5)
19148                AMRCL(I) = ZERO
19149                EEXC(I)  = ZERO
19150                IF (NLOOP.LE.500) THEN
19151                   GOTO 9998
19152                ELSE
19153                   IREXCI(2) = IREXCI(2)+1
19154                   GOTO 9999
19155                ENDIF
19156             ELSE
19157 * excitation energies of residual nuclei
19158                EEXC(I)   = AMRCL(I)-AMRCL0(I)
19159                IF (ICASCA.EQ.0) THEN
19160 **sr 15.1.
19161 C                 EXPNUC(I) = EEXC(I)/DBLE(NTOT(I))
19162                   EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
19163                   M = MIN(NTOT(I),260)
19164                   EXC(I,M)  = EXC(I,M)+EEXC(I)
19165                   NEXC(I,M) = NEXC(I,M)+1
19166                ENDIF
19167             ENDIF
19168          ELSEIF (NTOT(I).EQ.1) THEN
19169             WRITE(LOUT,1003) I
19170  1003       FORMAT(1X,'FICONF:   warning! NTOT(I)=1? (I=',I3,')')
19171             GOTO 9999
19172          ELSE
19173             AMRCL0(I) = ZERO
19174             AMRCL(I)  = ZERO
19175             EEXC(I)   = ZERO
19176             INORCL    = INORCL+I
19177          ENDIF
19178     7 CONTINUE
19179
19180       PRCLPR(5) = AMRCL(1)
19181       PRCLTA(5) = AMRCL(2)
19182
19183       IF (ICOR.GT.0) THEN
19184          IF (INORCL.EQ.0) THEN
19185 * one or both residual nuclei consist of one nucleon only, transform
19186 * this nucleon on mass shell
19187             DO 9 K=1,4
19188                P1IN(K) = PRCL(1,K)
19189                P2IN(K) = PRCL(2,K)
19190     9       CONTINUE
19191             XM1 = AMRCL(1)
19192             XM2 = AMRCL(2)
19193             CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
19194             IF (IREJ1.GT.0) THEN
19195                WRITE(LOUT,*) 'ficonf-mashel rejection'
19196                GOTO 9999
19197             ENDIF
19198             DO 10 K=1,4
19199                PRCL(1,K) = P1OUT(K)
19200                PRCL(2,K) = P2OUT(K)
19201                PRCLPR(K) = P1OUT(K)
19202                PRCLTA(K) = P2OUT(K)
19203    10       CONTINUE
19204             PRCLPR(5) = AMRCL(1)
19205             PRCLTA(5) = AMRCL(2)
19206          ELSE
19207             IF (IOULEV(3).GT.0)
19208      &      WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
19209      &                       INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
19210      &                       AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
19211      &                       AMRCL(2),AMRCL(2)-AMRCL0(2)
19212  1001       FORMAT(1X,'FICONF:   warning! no residual nucleus for',
19213      &             ' correction',/,11X,'at event',I8,
19214      &             ',  nucleon config. 1:',2I4,' 2:',2I4,
19215      &             2(/,11X,3E12.3))
19216             IF (NLOOP.LE.500) THEN
19217                GOTO 9998
19218             ELSE
19219                IREXCI(1) = IREXCI(1)+1
19220             ENDIF
19221          ENDIF
19222       ENDIF
19223
19224 * update counter
19225 C     IF (NRESEV(1).NE.NEVHKK) THEN
19226 C        NRESEV(1) = NEVHKK
19227 C        NRESEV(2) = NRESEV(2)+1
19228 C     ENDIF
19229       NRESEV(2) = NRESEV(2)+1
19230       DO 15 I=1,2
19231          EXCDPM(I)   = EXCDPM(I)+EEXC(I)
19232          EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
19233          NRESTO(I) = NRESTO(I)+NTOT(I)
19234          NRESPR(I) = NRESPR(I)+NPRO(I)
19235          NRESNU(I) = NRESNU(I)+NN(I)
19236          NRESBA(I) = NRESBA(I)+NH(I)
19237          NRESPB(I) = NRESPB(I)+NHPOS(I)
19238          NRESCH(I) = NRESCH(I)+NQ(I)
19239    15 CONTINUE
19240
19241 * evaporation
19242       IF (LEVPRT) THEN
19243          DO 13 I=1,2
19244 * initialize evaporation counter
19245             NP = 0
19246             EEXCFI(I) = ZERO
19247             IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
19248      &          (EEXC(I).GT.ZERO)) THEN
19249 * put residual nuclei into DTEVT1
19250                IDRCL = 80000
19251                JMASS = INT( AIF(I))
19252                JCHAR = INT(AIZF(I))
19253 *  the following patch is required to transmit the correct excitation
19254 *   energy to Eventd
19255                IF (ITRSPT.EQ.1) THEN
19256                   PRCL0 = PRCL(I,4)
19257                   PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
19258      &                                                    +PRCL(I,3)**2)
19259                   IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
19260                      WRITE(LOUT,*)
19261      &                  ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
19262                   ENDIF
19263                ENDIF
19264                CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
19265      &              PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
19266 **sr 22.6.97
19267                NOBAM(NHKK) = I
19268 **
19269                DO 14 J=1,4
19270                   VHKK(J,NHKK) = VRCL(I,J)
19271                   WHKK(J,NHKK) = WRCL(I,J)
19272    14          CONTINUE
19273 *  interface to evaporation module - fill final residual nucleus into
19274 *  common FKRESN
19275 *   fill resnuc only if code is not used as event generator in Fluka
19276                IF (ITRSPT.NE.1) THEN
19277                   PXRES  = PRCL(I,1)
19278                   PYRES  = PRCL(I,2)
19279                   PZRES  = PRCL(I,3)
19280                   IBRES  = NPRO(I)+NN(I)+NH(I)
19281                   ICRES  = NPRO(I)+NHPOS(I)
19282                   ANOW   = DBLE(IBRES)
19283                   ZNOW   = DBLE(ICRES)
19284                   PTRES  = SQRT(PXRES**2+PYRES**2+PZRES**2)
19285 *   ground state mass of the residual nucleus (should be equal to AM0T)
19286
19287                   AMNRES = AMRCL0(I)
19288                   AMMRES = AMNAMA ( AMNRES, IBRES, ICRES )
19289
19290 *  common FKFINU
19291                   TV = ZERO
19292 *   kinetic energy of residual nucleus
19293                   TVRECL = PRCL(I,4)-AMRCL(I)
19294 *   excitation energy of residual nucleus
19295                   TVCMS  = EEXC(I)
19296                   PTOLD  = PTRES
19297                   PTRES  = SQRT(ABS(TVRECL*(TVRECL+
19298      &                          2.0D0*(AMMRES+TVCMS))))
19299                   IF (PTOLD.LT.ANGLGB) THEN
19300                      CALL DT_RACO(PXRES,PYRES,PZRES)
19301                      PTOLD = ONE
19302                   ENDIF
19303                   PXRES = PXRES*PTRES/PTOLD
19304                   PYRES = PYRES*PTRES/PTOLD
19305                   PZRES = PZRES*PTRES/PTOLD
19306 * evaporation
19307                   WE = ONE
19308
19309                   NPHEAV = 0
19310                   LRNFSS = .FALSE.
19311                   LFRAGM = .FALSE.
19312                   CALL EVEVAP(WE)
19313
19314 * put evaporated particles and residual nuclei to DTEVT1
19315                   MO = NHKK
19316                   CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
19317                ENDIF
19318                EEXCFI(I) = EXCITF
19319                EXCEVA(I) = EXCEVA(I)+EXCITF
19320             ENDIF
19321    13    CONTINUE
19322       ENDIF
19323
19324       RETURN
19325
19326 C9998 IREXCI(1) = IREXCI(1)+1
19327  9998 IREJ   = IREJ+1
19328  9999 CONTINUE
19329       LRCLPR = .TRUE.
19330       LRCLTA = .TRUE.
19331       IREJ   = IREJ+1
19332       RETURN
19333       END
19334 *                                                                      *
19335 *====eva2he============================================================*
19336 *                                                                      *
19337 CDECK  ID>, DT_EVA2HE
19338       SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
19339
19340 ************************************************************************
19341 * Interface between common's of evaporation module (FKFINU,FKFHVY)     *
19342 * and DTEVT1.                                                          *
19343 *    MO    DTEVT1-index of "mother" (residual) nucleus before evap.    *
19344 *    EEXCF exitation energy of residual nucleus after evaporation      *
19345 *    IRCL  = 1 projectile residual nucleus                             *
19346 *          = 2 target     residual nucleus                             *
19347 * This version dated 19.04.95 is written by S. Roesler.                *
19348 ************************************************************************
19349
19350       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19351       SAVE
19352
19353       PARAMETER ( LINP = 5 ,
19354      &            LOUT = 6 ,
19355      &            LDAT = 9 )
19356
19357       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
19358
19359 * event history
19360
19361       PARAMETER (NMXHKK=200000)
19362
19363       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19364      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19365      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19366 * Note: DTEVT2 - special use for heavy fragments !
19367 *       (IDRES(I) = mass number, IDXRES(I) = charge)
19368 * extended event history
19369       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19370      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19371      &                IHIST(2,NMXHKK)
19372 * particle properties (BAMJET index convention)
19373       CHARACTER*8  ANAME
19374       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19375      &                IICH(210),IIBAR(210),K1(210),K2(210)
19376 * flags for input different options
19377       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19378       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19379      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19380 * statistics: residual nuclei
19381       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19382      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19383      &                NINCST(2,4),NINCEV(2),
19384      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19385      &                NRESPB(2),NRESCH(2),NRESEV(4),
19386      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19387      &                NEVAFI(2,2)
19388 * treatment of residual nuclei: properties of residual nuclei
19389       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19390      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19391      &                NTOTFI(2),NPROFI(2)
19392
19393       INCLUDE './flukapro/(DIMPAR)'
19394       INCLUDE './flukapro/(FINUC)'
19395       INCLUDE './flukapro/(RESNUC)'
19396       INCLUDE './flukapro/(FHEAVY)'
19397
19398       DIMENSION IPTOKP(39)
19399       DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
19400      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
19401      & 100, 101, 97, 102, 98, 103, 109, 115 /
19402
19403       IREJ = 0
19404
19405 * skip if evaporation package is not included
19406       IF (.NOT.LEVAPO) RETURN
19407
19408 * update counter
19409       IF (NRESEV(3).NE.NEVHKK) THEN
19410          NRESEV(3) = NEVHKK
19411          NRESEV(4) = NRESEV(4)+1
19412       ENDIF
19413
19414       IF (LEMCCK)
19415      &   CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
19416      &                                                   IDUM,IDUM)
19417 * mass number/charge of residual nucleus before evaporation
19418       IBTOT = IDRES(MO)
19419       IZTOT = IDXRES(MO)
19420
19421 * protons/neutrons/gammas
19422       DO 1 I=1,NP
19423          PX    = CXR(I)*PLR(I)
19424          PY    = CYR(I)*PLR(I)
19425          PZ    = CZR(I)*PLR(I)
19426          ID    = IPTOKP(KPART(I))
19427          IDPDG = IDT_IPDGHA(ID)
19428          AM    = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
19429      &           (2.0D0*MAX(TKI(I),TINY10))
19430          IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
19431             WRITE(LOUT,1000) ID,AM,AAM(ID)
19432  1000       FORMAT(1X,'EVA2HE:  inconsistent mass of evap. ',
19433      &             'particle',I3,2E10.3)
19434          ENDIF
19435          PE = TKI(I)+AM
19436          CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
19437          NOBAM(NHKK) = IRCL
19438          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19439          IBTOT = IBTOT-IIBAR(ID)
19440          IZTOT = IZTOT-IICH(ID)
19441     1 CONTINUE
19442
19443 * heavy fragments
19444       DO 2 I=1,NPHEAV
19445          PX     = CXHEAV(I)*PHEAVY(I)
19446          PY     = CYHEAV(I)*PHEAVY(I)
19447          PZ     = CZHEAV(I)*PHEAVY(I)
19448          IDHEAV = 80000
19449          AM     = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
19450      &            (2.0D0*MAX(TKHEAV(I),TINY10))
19451          PE     = TKHEAV(I)+AM
19452          CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
19453      &                  IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
19454          NOBAM(NHKK) = IRCL
19455          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19456          IBTOT = IBTOT-IBHEAV(KHEAVY(I))
19457          IZTOT = IZTOT-ICHEAV(KHEAVY(I))
19458     2 CONTINUE
19459
19460       IF (IBRES.GT.0) THEN
19461 * residual nucleus after evaporation
19462          IDNUC = 80000
19463          CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
19464      &                                        IBRES,ICRES,0)
19465          NOBAM(NHKK) = IRCL
19466       ENDIF
19467       EEXCF = TVCMS
19468       NTOTFI(IRCL) = IBRES
19469       NPROFI(IRCL) = ICRES
19470       IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
19471       IBTOT = IBTOT-IBRES
19472       IZTOT = IZTOT-ICRES
19473
19474 * count events with fission
19475       NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
19476       IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
19477
19478 * energy-momentum conservation check
19479       IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
19480 C     IF (IREJ.GT.0) THEN
19481 C        CALL DT_EVTOUT(4)
19482 C        WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
19483 C     ENDIF
19484 * baryon-number/charge conservation check
19485       IF (IBTOT+IZTOT.NE.0) THEN
19486          WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
19487  1001    FORMAT(1X,'EVA2HE:   baryon-number/charge conservation ',
19488      &          'failure at event ',I8,' :  IBTOT,IZTOT = ',2I3)
19489       ENDIF
19490
19491       RETURN
19492       END
19493 *
19494 *===ebind==============================================================*
19495 *
19496 CDECK  ID>, DT_EBIND
19497       DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
19498
19499 ************************************************************************
19500 * Binding energy for nuclei.                                           *
19501 * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972)                  *
19502 *                 IA        mass number                                *
19503 *                 IZ        atomic number                              *
19504 * This version dated 5.5.95   is updated by S. Roesler.                *
19505 ************************************************************************
19506
19507       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19508       SAVE
19509
19510       PARAMETER ( LINP = 5 ,
19511      &            LOUT = 6 ,
19512      &            LDAT = 9 )
19513
19514       PARAMETER (ZERO=0.0D0)
19515
19516       DATA       A1,       A2,        A3,        A4,      A5
19517      &     / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
19518
19519       IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
19520          WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0.  ',IA,IZ
19521          DT_EBIND = ZERO
19522          RETURN
19523       ENDIF
19524       AA = IA
19525       DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
19526      &        -A4*(IA-2*IZ)**2/AA
19527       IF (MOD(IA,2).EQ.1) THEN
19528          IA5 = 0
19529       ELSEIF (MOD(IZ,2).EQ.1) THEN
19530          IA5 = 1
19531       ELSE
19532          IA5 = -1
19533       ENDIF
19534       DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
19535
19536       RETURN
19537       END
19538
19539 ************************************************************************
19540 *                                                                      *
19541 *  DPMJET 3.0:   cross section routines                                *
19542 *                                                                      *
19543 ************************************************************************
19544 *
19545 *
19546 *     SUBROUTINE DT_SHNDIF
19547 *         diffractive cross sections (all energies)
19548 *     SUBROUTINE DT_PHOXS
19549 *         total and inel. cross sections from PHOJET interpol. tables
19550 *     SUBROUTINE DT_XSHN
19551 *         total and el. cross sections for all energies
19552 *     SUBROUTINE DT_SIHNAB
19553 *         pion 2-nucleon absorption cross sections
19554 *     SUBROUTINE DT_SIGEMU
19555 *         cross section for target "compounds"
19556 *     SUBROUTINE DT_SIGGA
19557 *         photon nucleus cross sections
19558 *     SUBROUTINE DT_SIGGAT
19559 *         photon nucleus cross sections from tables
19560 *     SUBROUTINE DT_SANO
19561 *         anomalous hard photon-nucleon cross sections from tables
19562 *     SUBROUTINE DT_SIGGP
19563 *         photon nucleon cross sections
19564 *     SUBROUTINE DT_SIGVEL
19565 *         quasi-elastic vector meson prod. cross sections
19566 *     DOUBLE PRECISION FUNCTION DT_SIGVP
19567 *         sigma_VN(tilde)
19568 *     DOUBLE PRECISION FUNCTION DT_RRM2
19569 *     DOUBLE PRECISION FUNCTION DT_RM2
19570 *     DOUBLE PRECISION FUNCTION DT_SAM2
19571 *     SUBROUTINE DT_CKMT
19572 *     SUBROUTINE DT_CKMTX
19573 *     SUBROUTINE DT_PDF0
19574 *     SUBROUTINE DT_CKMTQ0
19575 *     SUBROUTINE DT_CKMTDE
19576 *     SUBROUTINE DT_CKMTPR
19577 *     FUNCTION DT_CKMTFF
19578 *
19579 *     SUBROUTINE DT_FLUINI
19580 *         total nucleon cross section fluctuation treatment
19581 *
19582 *     SUBROUTINE DT_SIGTBL
19583 *         pre-tabulation of low-energy elastic x-sec. using SIHNEL
19584 *     SUBROUTINE DT_XSTABL
19585 *         service routines
19586 *
19587 *
19588 *
19589 *===shndif===============================================================*
19590 *
19591 CDECK  ID>, DT_SHNDIF
19592       SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
19593
19594 **********************************************************************
19595 *   Single diffractive hadron-nucleon cross sections                 *
19596 *                                              S.Roesler 14/1/93     *
19597 *                                                                    *
19598 *   The cross sections are calculated from extrapolated single       *
19599 *   diffractive antiproton-proton cross sections (DTUJET92) using    *
19600 *   scaling relations between total and single diffractive cross     *
19601 *   sections.                                                        *
19602 **********************************************************************
19603
19604       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19605       SAVE
19606       PARAMETER (ZERO=0.0D0)
19607
19608 * particle properties (BAMJET index convention)
19609       CHARACTER*8  ANAME
19610       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19611      &                IICH(210),IIBAR(210),K1(210),K2(210)
19612 *
19613       CSD1   =   4.201483727D0
19614       CSD4   = -0.4763103556D-02
19615       CSD5   =  0.4324148297D0
19616 *
19617       CHMSD1 =  0.8519297242D0
19618       CHMSD4 = -0.1443076599D-01
19619       CHMSD5 =  0.4014954567D0
19620 *
19621       EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
19622       PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
19623 *
19624       SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
19625       SHMSD  = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
19626       FRAC   = SHMSD/SDIAPP
19627 *
19628       GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
19629      &     999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
19630      &      10, 10, 20, 20, 20) KPROJ
19631 *
19632    10 CONTINUE
19633 *---------------------------- p - p , n - p , sigma0+- - p ,
19634 *                             Lambda - p
19635       CSD1   =  6.004476070D0
19636       CSD4   = -0.1257784606D-03
19637       CSD5   =  0.2447335720D0
19638       SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
19639       SIGDIH = FRAC*SIGDIF
19640       RETURN
19641 *
19642    20 CONTINUE
19643 *
19644       KPSCAL = 2
19645       KTSCAL = 1
19646 C     F      = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
19647       DUMZER = ZERO
19648       CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
19649       F      = SDIAPP/SIGTO
19650       KT     = 1
19651 C     SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
19652       CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
19653       SIGDIF = SIGTO*F
19654       SIGDIH = FRAC*SIGDIF
19655       RETURN
19656 *
19657   999 CONTINUE
19658 *-------------------------- leptons..
19659       SIGDIF = 1.D-10
19660       SIGDIH = 1.D-10
19661       RETURN
19662       END
19663 *
19664 *===phoxs================================================================*
19665 *
19666 CDECK  ID>, DT_PHOXS
19667       SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
19668
19669 ************************************************************************
19670 * Total/inelastic proton-nucleon cross sections taken from PHOJET-     *
19671 * interpolation tables.                                                *
19672 * This version dated 05.11.97 is written by S. Roesler                 *
19673 ************************************************************************
19674
19675       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19676       SAVE
19677
19678       PARAMETER ( LINP = 5 ,
19679      &            LOUT = 6 ,
19680      &            LDAT = 9 )
19681
19682       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
19683       PARAMETER (TWOPI  = 6.283185307179586454D+00,
19684      &           PI     = TWOPI/TWO,
19685      &           GEV2MB = 0.38938D0)
19686
19687       LOGICAL LFIRST
19688       DATA LFIRST /.TRUE./
19689
19690 * nucleon-nucleon event-generator
19691       CHARACTER*8 CMODEL
19692       LOGICAL LPHOIN
19693       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
19694 * particle properties (BAMJET index convention)
19695       CHARACTER*8  ANAME
19696       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19697      &                IICH(210),IIBAR(210),K1(210),K2(210)
19698
19699 **PHOJET105a
19700 C     PARAMETER (IEETAB=10)
19701 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
19702 **PHOJET110
19703 C  energy-interpolation table
19704       INTEGER IEETA2
19705       PARAMETER ( IEETA2 = 20 )
19706       INTEGER ISIMAX
19707       DOUBLE PRECISION SIGTAB,SIGECM
19708       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
19709 **
19710
19711       IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
19712          WRITE(LOUT,*) MCGENE
19713  1000    FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
19714          STOP
19715       ENDIF
19716
19717       IF (ECM.LE.ZERO) THEN
19718          EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
19719          ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
19720       ENDIF
19721
19722       IF (MODE.EQ.1) THEN
19723 * DL
19724          DELDL = 0.0808D0
19725          EPSDL = -0.4525D0
19726          S     = ECM*ECM
19727          STOT  = 21.7D0*S**DELDL+56.08D0*S**EPSDL
19728          ALPHAP= 0.25D0
19729          BEL   = 8.5D0+2.D0*ALPHAP*LOG(S)
19730          SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
19731          SINE  = STOT-SIGEL
19732          SDIF1 = ZERO
19733       ELSE
19734 * Phojet
19735          IP = 1
19736          IF(ECM.LE.SIGECM(IP,1)) THEN
19737            I1 = 1
19738            I2 = 1
19739          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
19740            DO 1 I=2,ISIMAX
19741               IF (ECM.LE.SIGECM(IP,I)) GOTO 2
19742     1      CONTINUE
19743     2      CONTINUE
19744            I1 = I-1
19745            I2 = I
19746          ELSE
19747            IF (LFIRST) THEN
19748               WRITE(LOUT,'(/1X,A,2E12.3)')
19749      &          'PHOXS: warning! energy above initialization limit (',
19750      &          ECM,SIGECM(IP,ISIMAX)
19751              LFIRST = .FALSE.
19752            ENDIF
19753            I1 = ISIMAX
19754            I2 = ISIMAX
19755          ENDIF
19756          FAC2 = ZERO
19757          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
19758      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
19759          FAC1  = ONE-FAC2
19760          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
19761          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
19762          SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
19763      &           FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
19764          BEL   = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
19765       ENDIF
19766
19767       RETURN
19768       END
19769 *
19770 *===xshn===============================================================*
19771 *
19772 CDECK  ID>, DT_XSHN
19773       SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
19774
19775 ************************************************************************
19776 * Total and elastic hadron-nucleon cross section.                      *
19777 * Below 500GeV cross sections are based on the '98 data compilation    *
19778 * of the PDG. At higher energies PHOJET results are used (patched to   *
19779 * the low energy data at 500GeV).                                      *
19780 *     IP      projectile index (BAMJET numbering scheme)               *
19781 *             (should be in the range 1..25)                           *
19782 *     IT      target index (BAMJET numbering scheme)                   *
19783 *             (1 = proton, 8 = neutron)                                *
19784 *     PL      laboratory momentum                                      *
19785 *     ECM     cm. energy (ignored if PL>0)                             *
19786 *     STOT    total cross section                                      *
19787 *     SELA    elastic cross section                                    *
19788 * Last change: 24.4.99 by S. Roesler                                   *
19789 ************************************************************************
19790
19791       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19792       SAVE
19793
19794       PARAMETER ( LINP = 5 ,
19795      &            LOUT = 6 ,
19796      &            LDAT = 9 )
19797
19798       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
19799
19800       PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
19801      &           PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
19802       PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
19803
19804       LOGICAL LFIRST
19805 * particle properties (BAMJET index convention)
19806       CHARACTER*8  ANAME
19807       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19808      &                IICH(210),IIBAR(210),K1(210),K2(210)
19809 * nucleon-nucleon event-generator
19810       CHARACTER*8 CMODEL
19811       LOGICAL LPHOIN
19812       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
19813 **PHOJET105a
19814 C     PARAMETER (IEETAB=10)
19815 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
19816 **PHOJET110
19817 C  energy-interpolation table
19818       INTEGER IEETA2
19819       PARAMETER ( IEETA2 = 20 )
19820       INTEGER ISIMAX
19821       DOUBLE PRECISION SIGTAB,SIGECM
19822       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
19823
19824       DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
19825       DIMENSION IDXDAT(25,2)
19826 *
19827       DATA APL /
19828      &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
19829      &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
19830      &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
19831      &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
19832      & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
19833      & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
19834      & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
19835 *
19836 * total cross sections:
19837 * p p
19838       DATA (ASIGTO(1,K),K=1,NPOINT) /
19839      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
19840      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
19841      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
19842      & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
19843      & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
19844      & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
19845      & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
19846 * pbar p
19847       DATA (ASIGTO(2,K),K=1,NPOINT) /
19848      & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
19849      & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
19850      & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
19851      & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
19852      & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
19853      & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
19854      & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
19855 * n p
19856       DATA (ASIGTO(3,K),K=1,NPOINT) /
19857      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
19858      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
19859      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
19860      & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
19861      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
19862      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
19863      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
19864 * pi+ p
19865       DATA (ASIGTO(4,K),K=1,NPOINT) /
19866      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
19867      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
19868      & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
19869      & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
19870      & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
19871      & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
19872      & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
19873 * pi- p
19874       DATA (ASIGTO(5,K),K=1,NPOINT) /
19875      & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
19876      & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
19877      & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
19878      & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
19879      & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
19880      & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
19881      & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
19882 * K+ p
19883       DATA (ASIGTO(6,K),K=1,NPOINT) /
19884      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
19885      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
19886      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
19887      & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
19888      & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
19889      & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
19890      & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
19891 * K- p
19892       DATA (ASIGTO(7,K),K=1,NPOINT) /
19893      & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
19894      & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
19895      & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
19896      & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
19897      & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
19898      & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
19899      & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
19900 * K+ n
19901       DATA (ASIGTO(8,K),K=1,NPOINT) /
19902      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
19903      & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
19904      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
19905      & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
19906      & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
19907      & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
19908      & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
19909 * K- n
19910       DATA (ASIGTO(9,K),K=1,NPOINT) /
19911      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
19912      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
19913      & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
19914      & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
19915      & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
19916      & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
19917      & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
19918 * Lambda p
19919       DATA (ASIGTO(10,K),K=1,NPOINT) /
19920      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
19921      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
19922      & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
19923      & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
19924      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
19925      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
19926      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
19927 *
19928 * elastic cross sections:
19929 * p p
19930       DATA (ASIGEL(1,K),K=1,NPOINT) /
19931      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
19932      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
19933      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
19934      & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
19935      & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
19936      & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
19937      & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
19938 * pbar p
19939       DATA (ASIGEL(2,K),K=1,NPOINT) /
19940      & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
19941      & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
19942      & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
19943      & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
19944      & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
19945      & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
19946      & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
19947 * n p
19948       DATA (ASIGEL(3,K),K=1,NPOINT) /
19949      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
19950      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
19951      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
19952      & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
19953      & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
19954      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
19955      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
19956 * pi+ p
19957       DATA (ASIGEL(4,K),K=1,NPOINT) /
19958      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
19959      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
19960      & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
19961      & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
19962      & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
19963      & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
19964      & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
19965 * pi- p
19966       DATA (ASIGEL(5,K),K=1,NPOINT) /
19967      & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
19968      & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
19969      & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
19970      & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
19971      & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
19972      & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
19973      & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
19974 * K+ p
19975       DATA (ASIGEL(6,K),K=1,NPOINT) /
19976      & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
19977      & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
19978      & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
19979      & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
19980      & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
19981      & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
19982      & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
19983 * K- p
19984       DATA (ASIGEL(7,K),K=1,NPOINT) /
19985      & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
19986      & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
19987      & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
19988      & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
19989      & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
19990      & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
19991      & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
19992 * K+ n
19993       DATA (ASIGEL(8,K),K=1,NPOINT) /
19994      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
19995      & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
19996      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
19997      & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
19998      & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
19999      & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
20000      & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
20001 * K- n
20002       DATA (ASIGEL(9,K),K=1,NPOINT) /
20003      & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
20004      & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
20005      & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
20006      & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
20007      & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
20008      & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
20009      & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
20010 * Lambda p
20011       DATA (ASIGEL(10,K),K=1,NPOINT) /
20012      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
20013      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
20014      & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
20015      & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
20016      & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
20017      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
20018      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
20019
20020       DATA (IDXDAT(K,1),K=1,25) /
20021      &  1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
20022      &  1, 3,45, 8, 9/
20023       DATA (IDXDAT(K,2),K=1,25) /
20024      &  3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
20025      &  3, 1,45, 6, 7/
20026
20027       DATA LFIRST /.TRUE./
20028
20029       IF (LFIRST) THEN
20030          APLABL = LOG10(PLABLO)
20031          APLABH = LOG10(PLABHI)
20032          APTHRE = LOG10(PTHRE)
20033          ADP1   = (APTHRE-APLABL)/DBLE(NPOIN1)
20034          ADP2   = (APLABH-APTHRE)/DBLE(NPOIN2)
20035          DUM0   = ZERO
20036          PHOPLA = PLABHI
20037          PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
20038          ECMS   = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
20039          IF (MCGENE.EQ.2) THEN
20040             IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
20041                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
20042             ELSE
20043                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
20044             ENDIF
20045          ELSE
20046             CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
20047          ENDIF
20048          PHOSEL = PHOSTO-PHOSIN
20049          APHOST = LOG10(PHOSTO)
20050          APHOSE = LOG10(PHOSEL)
20051          LFIRST = .FALSE.
20052       ENDIF
20053       STOT = ZERO
20054       SELA = ZERO
20055       PLAB = PL
20056       ECMS = ECM
20057       IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
20058          WRITE(LOUT,1000) IP,IT
20059  1000    FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
20060      &          'proj/target',2I4)
20061          STOP
20062       ENDIF
20063
20064       IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
20065          ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
20066          PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
20067       ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
20068          WRITE(LOUT,1001) PLAB,ECMS
20069  1001    FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
20070          STOP
20071       ENDIF
20072
20073 * index of spectrum
20074       IDXP = IP
20075       IF (IP.GT.25) THEN
20076          IF (AAM(IP).GT.ZERO) THEN
20077             IF (ABS(IIBAR(IP)).GT.0) THEN
20078                IDXP = 1
20079             ELSE
20080                IDXP = 13
20081             ENDIF
20082          ELSE
20083             IDXP = 7
20084          ENDIF
20085       ENDIF
20086       IDXT = 1
20087       IF (IT.EQ.8) IDXT = 2
20088       IDXS = IDXDAT(IDXP,IDXT)
20089       IF (IDXS.EQ.0) RETURN
20090
20091 * compute momentum bin indices
20092       IF (PLAB.LT.PLABLO) THEN
20093          IDX0 = 1
20094          IDX1 = 1
20095       ELSEIF (PLAB.GE.PLABHI) THEN
20096          IDX0 = NPOINT
20097          IDX1 = NPOINT
20098       ELSE
20099          APLAB = LOG10(PLAB)
20100          IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
20101             IDX0 = INT((APLAB-APLABL)/ADP1)+1
20102          ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
20103             IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
20104          ENDIF
20105          IDX1 = IDX0+1
20106       ENDIF
20107
20108 * interpolate cross section
20109       IF (IDXS.GT.10) THEN
20110          IDXS1 = IDXS/10
20111          IDXS2 = IDXS-10*IDXS1
20112          IF (IDX0.EQ.IDX1) THEN
20113             IF (IDX0.EQ.1) THEN
20114                ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
20115                ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
20116             ELSE
20117                DUM0   = ZERO
20118                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
20119                PHOSEL = PHOSTO-PHOSIN
20120                ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
20121                ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
20122                ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
20123                ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
20124                ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
20125                ASELA  = 0.5D0*(ASELA1+ASELA2)
20126             ENDIF
20127          ELSE
20128             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
20129             ASTOT1 = ASIGTO(IDXS1,IDX0)+
20130      &               FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
20131             ASTOT2 = ASIGTO(IDXS2,IDX0)+
20132      &               FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
20133             ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
20134             ASELA1 = ASIGEL(IDXS1,IDX0)+
20135      &               FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
20136             ASELA2 = ASIGEL(IDXS2,IDX0)+
20137      &               FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
20138             ASELA  = 0.5D0*(ASELA1+ASELA2)
20139          ENDIF
20140       ELSE
20141          IF (IDX0.EQ.IDX1) THEN
20142             IF (IDX0.EQ.1) THEN
20143                ASTOT = ASIGTO(IDXS,IDX0)
20144                ASELA = ASIGEL(IDXS,IDX0)
20145             ELSE
20146                DUM0   = ZERO
20147                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
20148                PHOSEL = PHOSTO-PHOSIN
20149                ASTOT  = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
20150                ASELA  = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
20151             ENDIF
20152          ELSE
20153             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
20154             ASTOT = ASIGTO(IDXS,IDX0)+
20155      &              FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
20156             ASELA = ASIGEL(IDXS,IDX0)+
20157      &              FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
20158          ENDIF
20159       ENDIF
20160       STOT = 10.0D0**ASTOT
20161       SELA = 10.0D0**ASELA
20162
20163       RETURN
20164       END
20165 *
20166 *===sihnab===============================================================*
20167 *
20168 CDECK  ID>, DT_SIHNAB
20169       SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
20170
20171 **********************************************************************
20172 * Pion 2-nucleon absorption cross sections.                          *
20173 * (sigma_tot for pi+ d --> p p, pi- d --> n n                        *
20174 *  taken from Ritchie PRC 28 (1983) 926 )                            *
20175 * This version dated 18.05.96 is written by S. Roesler               *
20176 **********************************************************************
20177
20178       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20179       SAVE
20180       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
20181       PARAMETER (AMPR = 938.0D0,
20182      &           AMPI = 140.0D0,
20183      &           AMDE = TWO*AMPR,
20184      &           A    = -1.2D0,
20185      &           B    = 3.5D0,
20186      &           C    = 7.4D0,
20187      &           D    = 5600.0D0,
20188      &           ER   = 2136.0D0)
20189
20190       SIGABS = ZERO
20191       IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
20192      &                   .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
20193       PTOT = PLAB*1.0D3
20194       EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
20195       IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
20196       ECM  = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
20197       SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
20198 * approximate 3N-abs., I=1-abs. etc.
20199       SIGABS = SIGABS/0.40D0
20200 * pi0-absorption (rough approximation!!)
20201       IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
20202
20203       RETURN
20204       END
20205 *
20206 *===sigemu=============================================================*
20207 *
20208 CDECK  ID>, DT_SIGEMU
20209       SUBROUTINE DT_SIGEMU
20210
20211 ************************************************************************
20212 * Combined cross section for target compounds.                         *
20213 * This version dated 6.4.98   is written by S. Roesler                 *
20214 ************************************************************************
20215
20216       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20217       SAVE
20218
20219       PARAMETER ( LINP = 5 ,
20220      &            LOUT = 6 ,
20221      &            LDAT = 9 )
20222
20223       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
20224      &           OHALF=0.5D0,ONE=1.0D0)
20225
20226       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
20227
20228 * Glauber formalism: cross sections
20229       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
20230      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
20231      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
20232      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
20233      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
20234      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
20235      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
20236      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
20237      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
20238      &                BSLOPE,NEBINI,NQBINI
20239 * emulsion treatment
20240       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
20241      &                NCOMPO,IEMUL
20242 * nucleon-nucleon event-generator
20243       CHARACTER*8 CMODEL
20244       LOGICAL LPHOIN
20245       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20246
20247       IF (MCGENE.NE.4) THEN
20248          WRITE(LOUT,'(A)') ' DT_SIGEMU:    Combined cross sections'
20249          WRITE(LOUT,'(15X,A)') '-----------------------'
20250       ENDIF
20251       DO 1 IE=1,NEBINI
20252          DO 2 IQ=1,NQBINI
20253             SIGTOT = ZERO
20254             SIGELA = ZERO
20255             SIGQEP = ZERO
20256             SIGQET = ZERO
20257             SIGQE2 = ZERO
20258             SIGPRO = ZERO
20259             SIGDEL = ZERO
20260             SIGDQE = ZERO
20261             ERRTOT = ZERO
20262             ERRELA = ZERO
20263             ERRQEP = ZERO
20264             ERRQET = ZERO
20265             ERRQE2 = ZERO
20266             ERRPRO = ZERO
20267             ERRDEL = ZERO
20268             ERRDQE = ZERO
20269             IF (NCOMPO.GT.0) THEN
20270                DO 3 IC=1,NCOMPO
20271                   SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
20272                   SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
20273                   SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
20274                   SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
20275                   SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
20276                   SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
20277                   SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
20278                   SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
20279                   ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
20280                   ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
20281                   ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
20282                   ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
20283                   ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
20284                   ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
20285                   ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
20286                   ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
20287     3          CONTINUE
20288                ERRTOT = SQRT(ERRTOT)
20289                ERRELA = SQRT(ERRELA)
20290                ERRQEP = SQRT(ERRQEP)
20291                ERRQET = SQRT(ERRQET)
20292                ERRQE2 = SQRT(ERRQE2)
20293                ERRPRO = SQRT(ERRPRO)
20294                ERRDEL = SQRT(ERRDEL)
20295                ERRDQE = SQRT(ERRDQE)
20296             ELSE
20297                SIGTOT = XSTOT(IE,IQ,1)
20298                SIGELA = XSELA(IE,IQ,1)
20299                SIGQEP = XSQEP(IE,IQ,1)
20300                SIGQET = XSQET(IE,IQ,1)
20301                SIGQE2 = XSQE2(IE,IQ,1)
20302                SIGPRO = XSPRO(IE,IQ,1)
20303                SIGDEL = XSDEL(IE,IQ,1)
20304                SIGDQE = XSDQE(IE,IQ,1)
20305                ERRTOT = XETOT(IE,IQ,1)
20306                ERRELA = XEELA(IE,IQ,1)
20307                ERRQEP = XEQEP(IE,IQ,1)
20308                ERRQET = XEQET(IE,IQ,1)
20309                ERRQE2 = XEQE2(IE,IQ,1)
20310                ERRPRO = XEPRO(IE,IQ,1)
20311                ERRDEL = XEDEL(IE,IQ,1)
20312                ERRDQE = XEDQE(IE,IQ,1)
20313             ENDIF
20314             IF (MCGENE.NE.4) THEN
20315                WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
20316  1000         FORMAT(/,1X,'E_cm =',F9.1,' GeV  Q^2 =',F6.1,' GeV^2 :',/)
20317                WRITE(LOUT,1001) SIGTOT,ERRTOT
20318  1001          FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
20319                WRITE(LOUT,1002) SIGELA,ERRELA
20320  1002          FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
20321                WRITE(LOUT,1003) SIGQEP,ERRQEP
20322  1003          FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
20323      &                F11.5,' mb')
20324                WRITE(LOUT,1004) SIGQET,ERRQET
20325  1004          FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
20326      &                F11.5,' mb')
20327                WRITE(LOUT,1005) SIGQE2,ERRQE2
20328  1005          FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
20329      &                ' +-',F11.5,' mb')
20330                WRITE(LOUT,1006) SIGPRO,ERRPRO
20331  1006          FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
20332                WRITE(LOUT,1007) SIGDEL,ERRDEL
20333  1007          FORMAT(1X,'diff-el   ',27X,F10.4,' +-',F11.5,' mb')
20334                WRITE(LOUT,1008) SIGDQE,ERRDQE
20335  1008          FORMAT(1X,'diff-qel  ',27X,F10.4,' +-',F11.5,' mb')
20336             ENDIF
20337
20338     2    CONTINUE
20339     1 CONTINUE
20340
20341       RETURN
20342       END
20343 *
20344 *===sigga==============================================================*
20345 *
20346 CDECK  ID>, DT_SIGGA
20347       SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
20348
20349 ************************************************************************
20350 * Total/inelastic photon-nucleus cross sections.                       *
20351 *     !!!! Overwrites SHMAKI-initialization. Do not use it during      *
20352 *          production runs !!!!                                        *
20353 * This version dated 27.03.96 is written by S. Roesler                 *
20354 ************************************************************************
20355
20356       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20357       SAVE
20358
20359       PARAMETER ( LINP = 5 ,
20360      &            LOUT = 6 ,
20361      &            LDAT = 9 )
20362
20363       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
20364      &           OHALF=0.5D0,ONE=1.0D0)
20365       PARAMETER (AMPROT = 0.938D0)
20366
20367       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
20368
20369 * Glauber formalism: cross sections
20370       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
20371      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
20372      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
20373      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
20374      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
20375      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
20376      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
20377      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
20378      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
20379      &                BSLOPE,NEBINI,NQBINI
20380
20381       NT  = NTI
20382       X   = XI
20383       Q2  = Q2I
20384       ECM = ECMI
20385       XNU = XNUI
20386       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
20387      &   ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
20388       CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
20389       STOT  = XSTOT(1,1,1)
20390       ETOT  = XETOT(1,1,1)
20391       SIN   = XSPRO(1,1,1)
20392       EIN   = XEPRO(1,1,1)
20393
20394       RETURN
20395       END
20396 *
20397 *===siggat=============================================================*
20398 *
20399 CDECK  ID>, DT_SIGGAT
20400       SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
20401
20402 ************************************************************************
20403 * Total/inelastic photon-nucleus cross sections.                       *
20404 * Uses pre-tabulated cross section.                                    *
20405 * This version dated 29.07.96 is written by S. Roesler                 *
20406 ************************************************************************
20407
20408       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20409       SAVE
20410
20411       PARAMETER ( LINP = 5 ,
20412      &            LOUT = 6 ,
20413      &            LDAT = 9 )
20414
20415       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
20416      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
20417
20418       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
20419
20420 * Glauber formalism: cross sections
20421       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
20422      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
20423      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
20424      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
20425      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
20426      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
20427      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
20428      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
20429      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
20430      &                BSLOPE,NEBINI,NQBINI
20431
20432       NTARG = ABS(NT)
20433       I1   = 1
20434       I2   = 1
20435       RATE = ONE
20436       IF (NEBINI.GT.1) THEN
20437          IF (ECMI.GE.ECMNN(NEBINI)) THEN
20438             I1   = NEBINI
20439             I2   = NEBINI
20440             RATE = ONE
20441          ELSEIF (ECMI.GT.ECMNN(1)) THEN
20442             DO 1 I=2,NEBINI
20443                IF (ECMI.LT.ECMNN(I)) THEN
20444                   I1   = I-1
20445                   I2   = I
20446                   RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
20447                   GOTO 2
20448                ENDIF
20449     1       CONTINUE
20450     2       CONTINUE
20451          ENDIF
20452       ENDIF
20453       J1   = 1
20454       J2   = 1
20455       RATQ = ONE
20456       IF (NQBINI.GT.1) THEN
20457          IF (Q2I.GE.Q2G(NQBINI)) THEN
20458             J1   = NQBINI
20459             J2   = NQBINI
20460             RATQ = ONE
20461          ELSEIF (Q2I.GT.Q2G(1)) THEN
20462             DO 3 I=2,NQBINI
20463                IF (Q2I.LT.Q2G(I)) THEN
20464                   J1   = I-1
20465                   J2   = I
20466                   RATQ = LOG10(    Q2I/MAX(Q2G(J1),TINY14))/
20467      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
20468 C                 RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
20469                   GOTO 4
20470                ENDIF
20471     3       CONTINUE
20472     4       CONTINUE
20473          ENDIF
20474       ENDIF
20475
20476       STOT = XSTOT(I1,J1,NTARG)+
20477      &   RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
20478      &   RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
20479      &   RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
20480      &              XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
20481
20482       RETURN
20483       END
20484 *
20485 *===sigano=============================================================*
20486 *
20487 CDECK  ID>, DT_SANO
20488       DOUBLE PRECISION FUNCTION DT_SANO(ECM)
20489
20490 ************************************************************************
20491 * This version dated 31.07.96 is written by S. Roesler                 *
20492 ************************************************************************
20493
20494       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20495       SAVE
20496
20497       PARAMETER ( LINP = 5 ,
20498      &            LOUT = 6 ,
20499      &            LDAT = 9 )
20500
20501       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
20502      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
20503       PARAMETER (NE = 8)
20504
20505 * VDM parameter for photon-nucleus interactions
20506       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20507 * properties of interacting particles
20508       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
20509
20510       DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
20511       DATA ECMANO /
20512      &             0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
20513      &             0.100D+04,0.200D+04,0.500D+04
20514      &            /
20515 * fixed cut (3 GeV/c)
20516       DATA FRAANO /
20517      &             0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
20518      &             0.062D+00,0.054D+00,0.042D+00
20519      &            /
20520       DATA SIGHRD /
20521      &           4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
20522      &           3.3086D-01,7.6255D-01,2.1319D+00
20523      &            /
20524 * running cut (based on obsolete Phojet-caluclations, bugs..)
20525 C     DATA FRAANO /
20526 C    &             0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
20527 C    &             0.167E+00,0.150E+00,0.131E+00
20528 C    &            /
20529 C     DATA SIGHRD /
20530 C    &           6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
20531 C    &           2.5736E-01,4.5593E-01,8.2550E-01
20532 C    &            /
20533
20534       DT_SANO = ZERO
20535       IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
20536       J1   = 0
20537       J2   = 0
20538       RATE = ONE
20539       IF (ECM.GE.ECMANO(NE)) THEN
20540          J1 = NE
20541          J2 = NE
20542       ELSEIF (ECM.GT.ECMANO(1)) THEN
20543          DO 1 IE=2,NE
20544             IF (ECM.LT.ECMANO(IE)) THEN
20545                J1   = IE-1
20546                J2   = IE
20547                RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
20548                GOTO 2
20549             ENDIF
20550     1    CONTINUE
20551     2    CONTINUE
20552       ENDIF
20553       IF ((J1.GT.0).AND.(J2.GT.0)) THEN
20554          AFRA1  = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
20555          AFRA2  = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
20556          DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
20557       ENDIF
20558
20559       RETURN
20560       END
20561 *
20562 *===siggp==============================================================*
20563 *
20564 CDECK  ID>, DT_SIGGP
20565       SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
20566
20567 ************************************************************************
20568 * Total/inelastic photon-nucleon cross sections.                       *
20569 * This version dated 30.04.96 is written by S. Roesler                 *
20570 ************************************************************************
20571
20572       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20573       SAVE
20574
20575       PARAMETER ( LINP = 5 ,
20576      &            LOUT = 6 ,
20577      &            LDAT = 9 )
20578
20579       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
20580       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
20581      &           PI     = TWOPI/TWO,
20582      &           GEV2MB = 0.38938D0,
20583      &           ALPHEM = ONE/137.0D0)
20584
20585 * particle properties (BAMJET index convention)
20586       CHARACTER*8  ANAME
20587       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20588      &                IICH(210),IIBAR(210),K1(210),K2(210)
20589 * VDM parameter for photon-nucleus interactions
20590       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20591
20592 **PHOJET105a
20593 C     CHARACTER*8 MDLNA
20594 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
20595 C     PARAMETER (IEETAB=10)
20596 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20597 **PHOJET110
20598 C  model switches and parameters
20599       CHARACTER*8 MDLNA
20600       INTEGER ISWMDL,IPAMDL
20601       DOUBLE PRECISION PARMDL
20602       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
20603 C  energy-interpolation table
20604       INTEGER IEETA2
20605       PARAMETER ( IEETA2 = 20 )
20606       INTEGER ISIMAX
20607       DOUBLE PRECISION SIGTAB,SIGECM
20608       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20609 **
20610
20611 C     PARAMETER (NPOINT=80)
20612       PARAMETER (NPOINT=16)
20613       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
20614
20615       STOT = ZERO
20616       SINE = ZERO
20617       SDIR = ZERO
20618
20619       W2 = ECMI**2
20620       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
20621      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
20622       Q2 = Q2I
20623       X  = XI
20624 * photoprod.
20625       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
20626          Q2 = 0.0001D0
20627          X  = Q2/(W2+Q2-AAM(1)**2)
20628 * DIS
20629       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
20630          X  = Q2/(W2+Q2-AAM(1)**2)
20631       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
20632          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
20633       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
20634          W2 = Q2*(ONE-X)/X+AAM(1)**2
20635       ELSE
20636          WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
20637          STOP
20638       ENDIF
20639       ECM = SQRT(W2)
20640
20641       IF (MODEGA.EQ.1) THEN
20642          SCALE = SQRT(Q2)
20643          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
20644      &                                                       IDPDF)
20645 C        W = SQRT(W2)
20646
20647 C        ALLMF2 = PHO_ALLM97(Q2,W)
20648
20649 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
20650          STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
20651          SINE = ZERO
20652          SDIR = ZERO
20653       ELSEIF (MODEGA.EQ.2) THEN
20654          IF (INTRGE(1).EQ.1) THEN
20655             AMLO2 = (3.0D0*AAM(13))**2
20656          ELSEIF (INTRGE(1).EQ.2) THEN
20657             AMLO2 = AAM(33)**2
20658          ELSE
20659             AMLO2 = AAM(96)**2
20660          ENDIF
20661          IF (INTRGE(2).EQ.1) THEN
20662             AMHI2 = W2/TWO
20663          ELSEIF (INTRGE(2).EQ.2) THEN
20664             AMHI2 = W2/4.0D0
20665          ELSE
20666             AMHI2 = W2
20667          ENDIF
20668          AMHI20 = (ECM-AAM(1))**2
20669          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
20670          XAMLO  = LOG( AMLO2+Q2 )
20671          XAMHI  = LOG( AMHI2+Q2 )
20672 **PHOJET105a
20673 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
20674 **PHOJET112
20675
20676          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
20677
20678 **
20679          SUM  = ZERO
20680          DO 1 J=1,NPOINT
20681             AM2 = EXP(ABSZX(J))-Q2
20682             IF (AM2.LT.16.0D0) THEN
20683                R = TWO
20684             ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
20685                R = 10.0D0/3.0D0
20686             ELSE
20687                R = 11.0D0/3.0D0
20688             ENDIF
20689 C           FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
20690             FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
20691      &            * (ONE+EPSPOL*Q2/AM2)
20692             SUM = SUM+WEIGHT(J)*FAC
20693     1    CONTINUE
20694          SINE = SUM
20695          SDIR = DT_SIGVP(X,Q2)
20696          STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
20697          SDIR = SDIR/(0.588D0+RL2+Q2)
20698 C        STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
20699       ELSEIF (MODEGA.EQ.3) THEN
20700          CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
20701       ELSEIF (MODEGA.EQ.4) THEN
20702 *  load cross sections from PHOJET interpolation table
20703          IP = 1
20704          IF(ECM.LE.SIGECM(IP,1)) THEN
20705            I1 = 1
20706            I2 = 1
20707          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
20708            DO 2 I=2,ISIMAX
20709               IF (ECM.LE.SIGECM(IP,I)) GOTO 3
20710     2      CONTINUE
20711     3      CONTINUE
20712            I1 = I-1
20713            I2 = I
20714          ELSE
20715            WRITE(LOUT,'(/1X,A,2E12.3)')
20716      &       'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
20717            I1 = ISIMAX
20718            I2 = ISIMAX
20719          ENDIF
20720          FAC2 = ZERO
20721          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
20722      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
20723          FAC1 = ONE-FAC2
20724 *  cross section dependence on photon virtuality
20725          FSUP1 = ZERO
20726          DO 4 I=1,3
20727             FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
20728      &                                /(1.D0+Q2/PARMDL(30+I))**2
20729     4    CONTINUE
20730          FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
20731          FAC1  = FAC1*FSUP1
20732          FAC2  = FAC2*FSUP1
20733          FSUP2 = 1.0D0
20734          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
20735          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
20736          SDIR  = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
20737 **re:
20738          STOT  = STOT-SDIR
20739 **
20740          SDIR  = SDIR/(FSUP1*FSUP2)
20741 **re:
20742          STOT  = STOT+SDIR
20743 **
20744       ENDIF
20745
20746       RETURN
20747       END
20748 *
20749 *===sigvel=============================================================*
20750 *
20751 CDECK  ID>, DT_SIGVEL
20752       SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
20753
20754 ************************************************************************
20755 * Cross section for elastic vector meson production                    *
20756 * This version dated 10.05.96 is written by S. Roesler                 *
20757 ************************************************************************
20758
20759       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20760       SAVE
20761
20762       PARAMETER ( LINP = 5 ,
20763      &            LOUT = 6 ,
20764      &            LDAT = 9 )
20765
20766       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
20767       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
20768      &           PI     = TWOPI/TWO,
20769      &           GEV2MB = 0.38938D0,
20770      &           ALPHEM = ONE/137.0D0)
20771
20772 * particle properties (BAMJET index convention)
20773       CHARACTER*8  ANAME
20774       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20775      &                IICH(210),IIBAR(210),K1(210),K2(210)
20776 * VDM parameter for photon-nucleus interactions
20777       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20778
20779       W2 = ECMI**2
20780       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
20781      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
20782       Q2 = Q2I
20783       X  = XI
20784 * photoprod.
20785       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
20786          Q2 = 0.0001D0
20787          X  = Q2/(W2+Q2-AAM(1)**2)
20788 * DIS
20789       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
20790          X  = Q2/(W2+Q2-AAM(1)**2)
20791       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
20792          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
20793       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
20794          W2 = Q2*(ONE-X)/X+AAM(1)**2
20795       ELSE
20796          WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
20797          STOP
20798       ENDIF
20799       ECM = SQRT(W2)
20800
20801       AMV  = AAM(IDXV)
20802       AMV2 = AMV**2
20803
20804       BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
20805      &        +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
20806       ROSH   = 0.1D0
20807       STOVP  = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
20808       SELVP  = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
20809
20810       IF (IDXV.EQ.33) THEN
20811          COUPL = 0.00365D0
20812       ELSE
20813          STOP
20814       ENDIF
20815       SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
20816       SIG2 = SELVP
20817       SVEL  = COUPL * (AMV2/(AMV2+Q2))**2
20818      &              * (ONE+EPSPOL*Q2/AMV2) * SELVP
20819
20820       RETURN
20821       END
20822 *
20823 *===sigvp==============================================================*
20824 *
20825 CDECK  ID>, DT_SIGVP
20826       DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
20827
20828 ************************************************************************
20829 * sigma_Vp                                                             *
20830 ************************************************************************
20831
20832       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20833       SAVE
20834
20835       PARAMETER ( LINP = 5 ,
20836      &            LOUT = 6 ,
20837      &            LDAT = 9 )
20838
20839       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
20840       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
20841      &           PI    = TWOPI/TWO,
20842      &           GEV2MB = 0.38938D0,
20843      &           AMPROT = 0.938D0,
20844      &           ALPHEM = ONE/137.0D0)
20845 * VDM parameter for photon-nucleus interactions
20846       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20847
20848       X  = XI
20849       Q2 = Q2I
20850       IF (XI.LE.ZERO)  X  = 0.0001D0
20851       IF (Q2I.LE.ZERO) Q2 = 0.0001D0
20852
20853       ECM    = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
20854
20855       SCALE = SQRT(Q2)
20856       IF (MODEGA.EQ.1) THEN
20857          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
20858      &                                                       IDPDF)
20859 C        W = ECM
20860
20861 C        ALLMF2 = PHO_ALLM97(Q2,W)
20862
20863 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
20864 C        STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
20865 C        DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
20866          DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
20867       ELSEIF (MODEGA.EQ.4) THEN
20868          CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
20869 C        F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
20870          DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
20871       ELSE
20872          STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
20873       ENDIF
20874
20875       RETURN
20876
20877       END
20878 *
20879 *===RRM2===============================================================*
20880 *
20881 CDECK  ID>, DT_RRM2
20882       DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
20883
20884       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20885       SAVE
20886
20887       PARAMETER ( LINP = 5 ,
20888      &            LOUT = 6 ,
20889      &            LDAT = 9 )
20890
20891       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
20892       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
20893      &           PI    = TWOPI/TWO,
20894      &           GEV2MB = 0.38938D0)
20895
20896 * particle properties (BAMJET index convention)
20897       CHARACTER*8  ANAME
20898       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20899      &                IICH(210),IIBAR(210),K1(210),K2(210)
20900 * VDM parameter for photon-nucleus interactions
20901       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20902
20903       S   = Q2*(ONE-X)/X+AAM(1)**2
20904       ECM = SQRT(S)
20905
20906       IF (INTRGE(1).EQ.1) THEN
20907          AMLO2 = (3.0D0*AAM(13))**2
20908       ELSEIF (INTRGE(1).EQ.2) THEN
20909          AMLO2 = AAM(33)**2
20910       ELSE
20911          AMLO2 = AAM(96)**2
20912       ENDIF
20913       IF (INTRGE(2).EQ.1) THEN
20914          AMHI2 = S/TWO
20915       ELSEIF (INTRGE(2).EQ.2) THEN
20916          AMHI2 = S/4.0D0
20917       ELSE
20918          AMHI2 = S
20919       ENDIF
20920       AMHI20 = (ECM-AAM(1))**2
20921       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
20922
20923       AM1C2 = 16.0D0
20924       AM2C2 = 121.0D0
20925       IF (AMHI2.LE.AM1C2) THEN
20926          DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
20927       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
20928          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
20929      &          10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
20930       ELSE
20931          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
20932      &          10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
20933      &          11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
20934       ENDIF
20935
20936       RETURN
20937       END
20938 *
20939 *===RM2================================================================*
20940 *
20941 CDECK  ID>, DT_RM2
20942       DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
20943
20944       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20945       SAVE
20946
20947       PARAMETER ( LINP = 5 ,
20948      &            LOUT = 6 ,
20949      &            LDAT = 9 )
20950
20951       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
20952       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
20953      &           PI    = TWOPI/TWO,
20954      &           GEV2MB = 0.38938D0)
20955 * VDM parameter for photon-nucleus interactions
20956       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20957
20958       IF (RL2.LE.ZERO) THEN
20959          DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
20960      &        (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
20961      &         +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
20962       ELSE
20963          TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
20964          TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
20965          DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
20966      &       -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
20967      &       +EPSPOL*(
20968      &         -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
20969      &       -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
20970       ENDIF
20971
20972       RETURN
20973       END
20974 *
20975 *===SAM2===============================================================*
20976 *
20977 CDECK  ID>, DT_SAM2
20978       DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
20979
20980       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20981       SAVE
20982
20983       PARAMETER ( LINP = 5 ,
20984      &            LOUT = 6 ,
20985      &            LDAT = 9 )
20986
20987       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
20988      &           TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
20989       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
20990      &           PI    = TWOPI/TWO,
20991      &           GEV2MB = 0.38938D0)
20992
20993 * particle properties (BAMJET index convention)
20994       CHARACTER*8  ANAME
20995       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20996      &                IICH(210),IIBAR(210),K1(210),K2(210)
20997 * VDM parameter for photon-nucleus interactions
20998       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20999
21000       S = ECM**2
21001       IF (INTRGE(1).EQ.1) THEN
21002          AMLO2 = (3.0D0*AAM(13))**2
21003       ELSEIF (INTRGE(1).EQ.2) THEN
21004          AMLO2 = AAM(33)**2
21005       ELSE
21006          AMLO2 = AAM(96)**2
21007       ENDIF
21008       IF (INTRGE(2).EQ.1) THEN
21009          AMHI2 = S/TWO
21010       ELSEIF (INTRGE(2).EQ.2) THEN
21011          AMHI2 = S/4.0D0
21012       ELSE
21013          AMHI2 = S
21014       ENDIF
21015       AMHI20 = (ECM-AAM(1))**2
21016       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
21017
21018       AM1C2 = 16.0D0
21019       AM2C2 = 121.0D0
21020       YLO   = LOG(AMLO2+Q2)
21021       YC1   = LOG(AM1C2+Q2)
21022       YC2   = LOG(AM2C2+Q2)
21023       YHI   = LOG(AMHI2+Q2)
21024       IF (AMHI2.LE.AM1C2) THEN
21025          FACHI = TWO
21026       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
21027          FACHI = TENTRD
21028       ELSE
21029          FACHI = ELVTRD
21030       ENDIF
21031
21032     1 CONTINUE
21033       YSAM2  = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
21034       IF (YSAM2.LE.YC1) THEN
21035          FAC = TWO
21036       ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
21037          FAC = TENTRD
21038       ELSE
21039          FAC = ELVTRD
21040       ENDIF
21041       WEIGMX = FACHI*(ONE-Q2*EXP(  -YHI))
21042       XSAM2  = FAC  *(ONE-Q2*EXP(-YSAM2))
21043       IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
21044
21045       DT_SAM2   = EXP(YSAM2)-Q2
21046
21047       RETURN
21048       END
21049 *
21050 *===ckmt===============================================================*
21051 *
21052 CDECK  ID>, DT_CKMT
21053       SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
21054      &                F2,IPAR)
21055
21056 ************************************************************************
21057 * This version dated 31.01.96 is written by S. Roesler                 *
21058 ************************************************************************
21059
21060       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21061       SAVE
21062
21063       PARAMETER ( LINP = 5 ,
21064      &            LOUT = 6 ,
21065      &            LDAT = 9 )
21066
21067       PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
21068
21069       PARAMETER (Q02 = 2.0D0,
21070      &           DQ2 = 10.05D0,
21071      &           Q12 = Q02+DQ2)
21072
21073       DIMENSION PD(-6:6),SEA(3),VAL(2)
21074
21075       CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
21076       CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
21077       ADQ2 = LOG10(Q12)-LOG10(Q02)
21078       F2P  = (F2Q1-F2Q0)/ADQ2
21079       CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
21080       CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
21081       F2PP = (F2PQ1-F2PQ0)/ADQ2
21082       FX   = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
21083
21084       Q2     = MAX(SCALE**2.0D0,TINY10)
21085       SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
21086       IF (Q2.LT.Q02) THEN
21087          CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
21088          UPV  = VAL(1)
21089          DNV  = VAL(2)
21090          USEA = SEA(1)
21091          DSEA = SEA(2)
21092          STR  = SEA(3)
21093          CHM  = 0.0D0
21094          BOT  = 0.0D0
21095          TOP  = 0.0D0
21096          GL   = GLU
21097       ELSE
21098          CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
21099          F2 = F2*SMOOTH
21100          UPV  = PD(2)-PD(3)
21101          DNV  = PD(1)-PD(3)
21102          USEA = PD(3)
21103          DSEA = PD(3)
21104          STR  = PD(3)
21105          CHM  = PD(4)
21106          BOT  = PD(5)
21107          TOP  = PD(6)
21108          GL   = PD(0)
21109 C        UPV  = UPV*SMOOTH
21110 C        DNV  = DNV*SMOOTH
21111 C        USEA = USEA*SMOOTH
21112 C        DSEA = DSEA*SMOOTH
21113 C        STR  = STR*SMOOTH
21114 C        CHM  = CHM*SMOOTH
21115 C        GL   = GL*SMOOTH
21116       ENDIF
21117
21118       RETURN
21119       END
21120 C
21121 CDECK  ID>, DT_CKMTX
21122       SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
21123 C**********************************************************************
21124 C
21125 C     PDF based on Regge theory, evolved with .... by ....
21126 C
21127 C     input: IPAR     2212   proton (not installed)
21128 C                       45   Pomeron
21129 C                      100   Deuteron
21130 C
21131 C     output: PD(-6:6) x*f(x)  parton distribution functions
21132 C            (PDFLIB convention: d = PD(1), u = PD(2) )
21133 C
21134 C**********************************************************************
21135
21136       SAVE
21137       DOUBLE PRECISION  X,SCALE2,PD(-6:6),CDN,CUP,F2
21138
21139       PARAMETER ( LINP = 5 ,
21140      &            LOUT = 6 ,
21141      &            LDAT = 9 )
21142
21143       DIMENSION QQ(7)
21144 C
21145       Q2=SNGL(SCALE2)
21146       Q1S=Q2
21147       XX=SNGL(X)
21148 C  QCD lambda for evolution
21149       OWLAM = 0.23D0
21150       OWLAM2=OWLAM**2
21151 C  Q0**2 for evolution
21152       Q02 = 2.D0
21153 C
21154 C
21155 C  the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
21156 C                        q(6)=x*charm, q(7)=x*gluon
21157 C
21158       SB=0.
21159       IF(Q2-Q02) 1,1,2
21160     2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
21161     1 CONTINUE
21162       IF(IPAR.EQ.2212) THEN
21163         CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
21164         CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
21165         CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
21166         CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
21167         CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
21168         CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
21169         CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
21170 C     ELSEIF (IPAR.EQ.45) THEN
21171 C       CALL CKMTPO(1,0,XX,SB,QQ(1))
21172 C       CALL CKMTPO(2,0,XX,SB,QQ(2))
21173 C       CALL CKMTPO(3,0,XX,SB,QQ(3))
21174 C       CALL CKMTPO(4,0,XX,SB,QQ(4))
21175 C       CALL CKMTPO(5,0,XX,SB,QQ(5))
21176 C       CALL CKMTPO(8,0,XX,SB,QQ(6))
21177 C       CALL CKMTPO(7,0,XX,SB,QQ(7))
21178       ELSEIF (IPAR.EQ.100) THEN
21179         CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
21180         CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
21181         CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
21182         CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
21183         CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
21184         CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
21185         CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
21186       ELSE
21187         WRITE(LOUT,'(1X,A,I4,A)')
21188      &     'CKMTX:   IPAR =',IPAR,' not implemented!'
21189         STOP
21190       ENDIF
21191 C
21192       PD(-6) = 0.D0
21193       PD(-5) = 0.D0
21194       PD(-4) = DBLE(QQ(6))
21195       PD(-3) = DBLE(QQ(3))
21196       PD(-2) = DBLE(QQ(4))
21197       PD(-1) = DBLE(QQ(5))
21198       PD(0)  = DBLE(QQ(7))
21199       PD(1)  = DBLE(QQ(2))
21200       PD(2)  = DBLE(QQ(1))
21201       PD(3)  = DBLE(QQ(3))
21202       PD(4)  = DBLE(QQ(6))
21203       PD(5)  = 0.D0
21204       PD(6)  = 0.D0
21205       IF(IPAR.EQ.45) THEN
21206         CDN = (PD(1)-PD(-1))/2.D0
21207         CUP = (PD(2)-PD(-2))/2.D0
21208         PD(-1) = PD(-1) + CDN
21209         PD(-2) = PD(-2) + CUP
21210         PD(1) = PD(-1)
21211         PD(2) = PD(-2)
21212       ENDIF
21213       F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
21214      &     1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
21215      &     1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
21216       END
21217 C
21218 *
21219 *===pdf0===============================================================*
21220 *
21221 CDECK  ID>, DT_PDF0
21222       SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
21223
21224 ************************************************************************
21225 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
21226 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
21227 *                   IPAR  = 2212   proton                              *
21228 *                         =  100   deuteron                            *
21229 * This version dated 31.01.96 is written by S. Roesler                 *
21230 ************************************************************************
21231
21232       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21233       SAVE
21234
21235       PARAMETER ( LINP = 5 ,
21236      &            LOUT = 6 ,
21237      &            LDAT = 9 )
21238
21239       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
21240
21241       PARAMETER (
21242      &              AA     = 0.1502D0,
21243      &              BBDEU  = 1.2D0,
21244      &              BUD    = 0.754D0,
21245      &              BDD    = 0.4495D0,
21246      &              BUP    = 1.2064D0,
21247      &              BDP    = 0.1798D0,
21248      &              DELTA0 = 0.07684D0,
21249      &              D      = 1.117D0,
21250      &              C      = 3.5489D0,
21251      &              A      = 0.2631D0,
21252      &              B      = 0.6452D0,
21253      &              ALPHAR = 0.415D0,
21254      &              E      = 0.1D0
21255      &          )
21256
21257       PARAMETER (NPOINT=16)
21258 C     DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
21259       DIMENSION SEA(3),VAL(2)
21260
21261       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
21262       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
21263 * proton, deuteron
21264       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
21265          CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
21266          SEA(1) = 0.75D0*SEA0
21267          SEA(2) = SEA(1)
21268          SEA(3) = SEA(1)
21269          VAL(1) = 9.0D0/4.0D0*VALU0
21270          VAL(2) = 9.0D0*VALD0
21271          GLU0   = SEA(1)/(1.0D0-X)
21272          F2     = SEA0+VALU0+VALD0
21273          F2PDF  = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
21274      &            1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
21275      &            1.0D0/9.0D0*(2.0D0*SEA(3))
21276          IF (ABS(F2-F2PDF).GT.TINY9) THEN
21277             WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
21278             STOP
21279          ENDIF
21280 **PHOJET105a
21281 C        CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
21282 **PHOJET112
21283
21284 C        CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
21285
21286 **
21287 C        SUMQ = ZERO
21288 C        SUMG = ZERO
21289 C        DO 1 J=1,NPOINT
21290 C           CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
21291 C           VALU0 = 9.0D0/4.0D0*VALU0
21292 C           VALD0 = 9.0D0*VALD0
21293 C           SEA0  = 0.75D0*SEA0
21294 C           SUMQ  = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
21295 C           SUMG  = SUMG+ (SEA0/(1.0D0-ABSZX(J)))  *WEIGHT(J)
21296 C   1    CONTINUE
21297 C        GLU = GLU0*(1.0D0-SUMQ)/SUMG
21298       ELSE
21299          WRITE(LOUT,'(1X,A,I4,A)')
21300      &      'PDF0:   IPAR =',IPAR,' not implemented!'
21301          STOP
21302       ENDIF
21303
21304       RETURN
21305       END
21306 *
21307 *===ckmtq0=============================================================*
21308 *
21309 CDECK  ID>, DT_CKMTQ0
21310       SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
21311
21312 ************************************************************************
21313 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
21314 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
21315 *                   IPAR  = 2212   proton                              *
21316 *                         =  100   deuteron                            *
21317 * This version dated 31.01.96 is written by S. Roesler                 *
21318 ************************************************************************
21319
21320       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21321       SAVE
21322
21323       PARAMETER ( LINP = 5 ,
21324      &            LOUT = 6 ,
21325      &            LDAT = 9 )
21326
21327       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
21328
21329       PARAMETER (
21330      &              AA     = 0.1502D0,
21331      &              BBDEU  = 1.2D0,
21332      &              BUD    = 0.754D0,
21333      &              BDD    = 0.4495D0,
21334      &              BUP    = 1.2064D0,
21335      &              BDP    = 0.1798D0,
21336      &              DELTA0 = 0.07684D0,
21337      &              D      = 1.117D0,
21338      &              C      = 3.5489D0,
21339      &              A      = 0.2631D0,
21340      &              B      = 0.6452D0,
21341      &              ALPHAR = 0.415D0,
21342      &              E      = 0.1D0
21343      &          )
21344
21345       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
21346       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
21347 * proton, deuteron
21348       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
21349          IF (IPAR.EQ.2212) THEN
21350             BU = BUP
21351             BD = BDP
21352          ELSE
21353             BU = BUD
21354             BD = BDD
21355          ENDIF
21356          SEA0  = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
21357      &          (Q2/(Q2+A))**(1.0D0+DELTA)
21358          VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
21359      &           (Q2/(Q2+B))**(ALPHAR)
21360          VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
21361      &           (Q2/(Q2+B))**(ALPHAR)
21362       ELSE
21363          WRITE(LOUT,'(1X,A,I4,A)')
21364      &      'CKMTQ0: IPAR =',IPAR,' not implemented!'
21365          STOP
21366       ENDIF
21367       RETURN
21368       END
21369 C
21370 C
21371 CDECK  ID>, DT_CKMTDE
21372       SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
21373 C
21374 C**********************************************************************
21375 C    Deuteron - PDFs
21376 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
21377 C    ANS = PDF(I)
21378 C    This version by S. Roesler, 30.01.96
21379 C**********************************************************************
21380
21381       SAVE
21382       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
21383       EQUIVALENCE (GF(1,1,1),DL(1))
21384       DATA DELTA/.13/
21385 C
21386       DATA (DL(K),K=    1,   85) /
21387      &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
21388      &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
21389      &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
21390      &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
21391      &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
21392      &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
21393      &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
21394      &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
21395      &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
21396      &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
21397      &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
21398      &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
21399      &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
21400      &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
21401      &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
21402      &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
21403      &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
21404       DATA (DL(K),K=   86,  170) /
21405      &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
21406      &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
21407      &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
21408      &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
21409      &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
21410      &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
21411      &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
21412      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21413      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21414      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21415      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21416      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21417      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21418      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21419      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21420      &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
21421      &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
21422       DATA (DL(K),K=  171,  255) /
21423      &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
21424      &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
21425      &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
21426      &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
21427      &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
21428      &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
21429      &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
21430      &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
21431      &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
21432      &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
21433      &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
21434      &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
21435      &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
21436      &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
21437      &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
21438      &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
21439      &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
21440       DATA (DL(K),K=  256,  340) /
21441      &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
21442      &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
21443      &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
21444      &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
21445      &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
21446      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21447      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21448      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21449      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21450      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21451      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21452      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21453      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21454      &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
21455      &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
21456      &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
21457      &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
21458       DATA (DL(K),K=  341,  425) /
21459      &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
21460      &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
21461      &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
21462      &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
21463      &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
21464      &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
21465      &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
21466      &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
21467      &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
21468      &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
21469      &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
21470      &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
21471      &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
21472      &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
21473      &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
21474      &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
21475      &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
21476       DATA (DL(K),K=  426,  510) /
21477      &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
21478      &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
21479      &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
21480      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21481      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21482      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21483      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21484      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21485      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21486      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21487      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21488      &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
21489      &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
21490      &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
21491      &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
21492      &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
21493      &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
21494       DATA (DL(K),K=  511,  595) /
21495      &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
21496      &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
21497      &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
21498      &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
21499      &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
21500      &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
21501      &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
21502      &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
21503      &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
21504      &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
21505      &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
21506      &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
21507      &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
21508      &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
21509      &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
21510      &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
21511      &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
21512       DATA (DL(K),K=  596,  680) /
21513      &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
21514      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21515      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21516      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21517      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21518      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21519      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21520      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21521      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21522      &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
21523      &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
21524      &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
21525      &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
21526      &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
21527      &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
21528      &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
21529      &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
21530       DATA (DL(K),K=  681,  765) /
21531      &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
21532      &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
21533      &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
21534      &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
21535      &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
21536      &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
21537      &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
21538      &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
21539      &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
21540      &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
21541      &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
21542      &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
21543      &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
21544      &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
21545      &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
21546      &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
21547      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21548       DATA (DL(K),K=  766,  850) /
21549      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21550      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21551      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21552      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21553      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21554      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21555      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21556      &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
21557      &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
21558      &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
21559      &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
21560      &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
21561      &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
21562      &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
21563      &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
21564      &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
21565      &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
21566       DATA (DL(K),K=  851,  935) /
21567      &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
21568      &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
21569      &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
21570      &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
21571      &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
21572      &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
21573      &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
21574      &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
21575      &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
21576      &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
21577      &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
21578      &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
21579      &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
21580      &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
21581      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21582      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21583      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21584       DATA (DL(K),K=  936, 1020) /
21585      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21586      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21587      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21588      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21589      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21590      &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
21591      &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
21592      &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
21593      &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
21594      &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
21595      &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
21596      &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
21597      &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
21598      &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
21599      &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
21600      &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
21601      &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
21602       DATA (DL(K),K= 1021, 1105) /
21603      &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
21604      &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
21605      &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
21606      &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
21607      &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
21608      &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
21609      &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
21610      &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
21611      &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
21612      &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
21613      &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
21614      &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
21615      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21616      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21617      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21618      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21619      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21620       DATA (DL(K),K= 1106, 1190) /
21621      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21622      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21623      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21624      &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
21625      &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
21626      &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
21627      &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
21628      &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
21629      &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
21630      &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
21631      &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
21632      &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
21633      &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
21634      &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
21635      &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
21636      &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
21637      &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
21638       DATA (DL(K),K= 1191, 1275) /
21639      &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
21640      &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
21641      &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
21642      &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
21643      &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
21644      &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
21645      &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
21646      &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
21647      &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
21648      &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
21649      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21650      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21651      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21652      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21653      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21654      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21655      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21656       DATA (DL(K),K= 1276, 1360) /
21657      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21658      &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
21659      &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
21660      &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
21661      &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
21662      &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
21663      &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
21664      &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
21665      &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
21666      &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
21667      &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
21668      &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
21669      &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
21670      &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
21671      &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
21672      &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
21673      &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
21674       DATA (DL(K),K= 1361, 1445) /
21675      &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
21676      &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
21677      &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
21678      &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
21679      &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
21680      &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
21681      &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
21682      &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
21683      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21684      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21685      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21686      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21687      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21688      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21689      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21690      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21691      &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
21692       DATA (DL(K),K= 1446, 1530) /
21693      &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
21694      &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
21695      &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
21696      &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
21697      &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
21698      &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
21699      &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
21700      &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
21701      &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
21702      &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
21703      &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
21704      &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
21705      &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
21706      &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
21707      &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
21708      &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
21709      &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
21710       DATA (DL(K),K= 1531, 1615) /
21711      &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
21712      &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
21713      &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
21714      &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
21715      &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
21716      &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
21717      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21718      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21719      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21720      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21721      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21722      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21723      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21724      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21725      &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
21726      &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
21727      &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
21728       DATA (DL(K),K= 1616, 1700) /
21729      &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
21730      &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
21731      &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
21732      &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
21733      &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
21734      &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
21735      &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
21736      &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
21737      &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
21738      &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
21739      &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
21740      &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
21741      &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
21742      &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
21743      &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
21744      &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
21745      &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
21746       DATA (DL(K),K= 1701, 1785) /
21747      &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
21748      &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
21749      &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
21750      &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
21751      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21752      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21753      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21754      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21755      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21756      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21757      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21758      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21759      &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
21760      &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
21761      &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
21762      &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
21763      &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
21764       DATA (DL(K),K= 1786, 1870) /
21765      &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
21766      &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
21767      &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
21768      &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
21769      &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
21770      &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
21771      &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
21772      &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
21773      &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
21774      &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
21775      &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
21776      &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
21777      &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
21778      &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
21779      &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
21780      &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
21781      &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
21782       DATA (DL(K),K= 1871, 1955) /
21783      &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
21784      &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
21785      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21786      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21787      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21788      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21789      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21790      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21791      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21792      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21793      &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
21794      &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
21795      &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
21796      &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
21797      &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
21798      &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
21799      &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
21800       DATA (DL(K),K= 1956, 2040) /
21801      &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
21802      &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
21803      &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
21804      &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
21805      &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
21806      &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
21807      &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
21808      &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
21809      &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
21810      &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
21811      &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
21812      &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
21813      &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
21814      &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
21815      &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
21816      &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
21817      &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
21818       DATA (DL(K),K= 2041, 2125) /
21819      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21820      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21821      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21822      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21823      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21824      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21825      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21826      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21827      &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
21828      &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
21829      &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
21830      &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
21831      &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
21832      &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
21833      &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
21834      &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
21835      &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
21836       DATA (DL(K),K= 2126, 2210) /
21837      &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
21838      &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
21839      &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
21840      &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
21841      &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
21842      &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
21843      &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
21844      &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
21845      &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
21846      &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
21847      &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
21848      &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
21849      &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
21850      &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
21851      &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
21852      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21853      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21854       DATA (DL(K),K= 2211, 2295) /
21855      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21856      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21857      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21858      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21859      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21860      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21861      &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
21862      &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
21863      &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
21864      &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
21865      &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
21866      &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
21867      &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
21868      &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
21869      &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
21870      &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
21871      &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
21872       DATA (DL(K),K= 2296, 2380) /
21873      &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
21874      &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
21875      &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
21876      &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
21877      &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
21878      &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
21879      &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
21880      &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
21881      &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
21882      &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
21883      &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
21884      &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
21885      &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
21886      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21887      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21888      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21889      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21890       DATA (DL(K),K= 2381, 2465) /
21891      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21892      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21893      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21894      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21895      &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
21896      &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
21897      &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
21898      &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
21899      &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
21900      &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
21901      &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
21902      &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
21903      &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
21904      &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
21905      &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
21906      &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
21907      &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
21908       DATA (DL(K),K= 2466, 2550) /
21909      &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
21910      &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
21911      &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
21912      &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
21913      &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
21914      &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
21915      &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
21916      &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
21917      &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
21918      &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
21919      &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
21920      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21921      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21922      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21923      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21924      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21925      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21926       DATA (DL(K),K= 2551, 2635) /
21927      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21928      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21929      &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
21930      &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
21931      &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
21932      &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
21933      &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
21934      &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
21935      &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
21936      &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
21937      &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
21938      &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
21939      &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
21940      &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
21941      &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
21942      &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
21943      &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
21944       DATA (DL(K),K= 2636, 2720) /
21945      &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
21946      &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
21947      &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
21948      &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
21949      &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
21950      &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
21951      &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
21952      &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
21953      &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
21954      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21955      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21956      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21957      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21958      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21959      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21960      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21961      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21962       DATA (DL(K),K= 2721, 2805) /
21963      &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
21964      &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
21965      &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
21966      &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
21967      &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
21968      &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
21969      &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
21970      &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
21971      &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
21972      &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
21973      &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
21974      &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
21975      &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
21976      &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
21977      &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
21978      &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
21979      &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
21980       DATA (DL(K),K= 2806, 2890) /
21981      &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
21982      &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
21983      &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
21984      &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
21985      &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
21986      &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
21987      &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
21988      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21989      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21990      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21991      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21992      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21993      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21994      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21995      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21996      &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
21997      &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
21998       DATA (DL(K),K= 2891, 2975) /
21999      &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
22000      &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
22001      &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
22002      &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
22003      &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
22004      &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
22005      &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
22006      &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
22007      &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
22008      &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
22009      &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
22010      &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
22011      &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
22012      &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
22013      &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
22014      &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
22015      &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
22016       DATA (DL(K),K= 2976, 3060) /
22017      &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
22018      &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
22019      &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
22020      &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
22021      &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
22022      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22023      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22024      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22025      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22026      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22027      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22028      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22029      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22030      &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
22031      &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
22032      &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
22033      &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
22034       DATA (DL(K),K= 3061, 3145) /
22035      &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
22036      &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
22037      &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
22038      &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
22039      &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
22040      &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
22041      &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
22042      &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
22043      &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
22044      &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
22045      &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
22046      &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
22047      &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
22048      &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
22049      &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
22050      &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
22051      &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
22052       DATA (DL(K),K= 3146, 3230) /
22053      &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
22054      &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
22055      &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
22056      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22057      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22058      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22059      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22060      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22061      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22062      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22063      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22064      &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
22065      &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
22066      &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
22067      &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
22068      &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
22069      &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
22070       DATA (DL(K),K= 3231, 3315) /
22071      &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
22072      &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
22073      &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
22074      &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
22075      &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
22076      &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
22077      &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
22078      &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
22079      &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
22080      &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
22081      &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
22082      &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
22083      &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
22084      &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
22085      &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
22086      &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
22087      &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
22088       DATA (DL(K),K= 3316, 3400) /
22089      &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
22090      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22091      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22092      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22093      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22094      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22095      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22096      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22097      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22098      &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
22099      &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
22100      &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
22101      &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
22102      &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
22103      &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
22104      &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
22105      &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
22106       DATA (DL(K),K= 3401, 3485) /
22107      &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
22108      &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
22109      &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
22110      &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
22111      &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
22112      &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
22113      &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
22114      &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
22115      &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
22116      &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
22117      &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
22118      &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
22119      &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
22120      &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
22121      &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
22122      &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
22123      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22124       DATA (DL(K),K= 3486, 3570) /
22125      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22126      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22127      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22128      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22129      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22130      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22131      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22132      &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
22133      &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
22134      &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
22135      &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
22136      &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
22137      &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
22138      &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
22139      &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
22140      &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
22141      &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
22142       DATA (DL(K),K= 3571, 3655) /
22143      &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
22144      &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
22145      &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
22146      &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
22147      &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
22148      &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
22149      &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
22150      &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
22151      &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
22152      &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
22153      &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
22154      &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
22155      &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
22156      &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
22157      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22158      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22159      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22160       DATA (DL(K),K= 3656, 3740) /
22161      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22162      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22163      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22164      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22165      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22166      &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
22167      &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
22168      &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
22169      &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
22170      &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
22171      &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
22172      &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
22173      &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
22174      &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
22175      &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
22176      &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
22177      &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
22178       DATA (DL(K),K= 3741, 3825) /
22179      &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
22180      &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
22181      &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
22182      &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
22183      &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
22184      &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
22185      &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
22186      &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
22187      &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
22188      &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
22189      &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
22190      &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
22191      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22192      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22193      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22194      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22195      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22196       DATA (DL(K),K= 3826, 3910) /
22197      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22198      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22199      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22200      &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
22201      &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
22202      &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
22203      &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
22204      &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
22205      &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
22206      &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
22207      &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
22208      &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
22209      &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
22210      &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
22211      &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
22212      &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
22213      &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
22214       DATA (DL(K),K= 3911, 3995) /
22215      &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
22216      &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
22217      &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
22218      &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
22219      &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
22220      &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
22221      &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
22222      &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
22223      &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
22224      &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
22225      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22226      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22227      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22228      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22229      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22230      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22231      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22232       DATA (DL(K),K= 3996, 4000) /
22233      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22234 C
22235       ANS = 0.
22236       IF (X.GT.0.9985) RETURN
22237       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
22238 C
22239       IS  = S/DELTA+1
22240       IS1 = IS+1
22241       DO 1 L=1,25
22242          KL    = L+NDRV*25
22243          F1(L) = GF(I,IS,KL)
22244          F2(L) = GF(I,IS1,KL)
22245     1 CONTINUE
22246       A1 = DT_CKMTFF(X,F1)
22247       A2 = DT_CKMTFF(X,F2)
22248 C      A1=ALOG(A1)
22249 C      A2=ALOG(A2)
22250       S1  = (IS-1)*DELTA
22251       S2  = S1+DELTA
22252       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
22253 C      ANS=EXP(ANS)
22254       RETURN
22255       END
22256 C
22257 C
22258 CDECK  ID>, DT_CKMTPR
22259       SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
22260 C
22261 C**********************************************************************
22262 C    Proton   - PDFs
22263 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22264 C    ANS = PDF(I)
22265 C    This version by S. Roesler, 31.01.96
22266 C**********************************************************************
22267
22268       SAVE
22269       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22270       EQUIVALENCE (GF(1,1,1),DL(1))
22271       DATA DELTA/.10/
22272 C
22273       DATA (DL(K),K=    1,   85) /
22274      &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22275      &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
22276      &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
22277      &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
22278      &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
22279      &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
22280      &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
22281      &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
22282      &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
22283      &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
22284      &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
22285      &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
22286      &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
22287      &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
22288      &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
22289      &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
22290      &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
22291       DATA (DL(K),K=   86,  170) /
22292      &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
22293      &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
22294      &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
22295      &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
22296      &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
22297      &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
22298      &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
22299      &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
22300      &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
22301      &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
22302      &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
22303      &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
22304      &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
22305      &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
22306      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22307      &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22308      &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
22309       DATA (DL(K),K=  171,  255) /
22310      &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
22311      &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
22312      &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
22313      &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
22314      &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
22315      &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
22316      &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
22317      &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
22318      &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
22319      &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
22320      &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
22321      &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
22322      &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
22323      &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
22324      &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
22325      &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
22326      &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
22327       DATA (DL(K),K=  256,  340) /
22328      &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
22329      &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
22330      &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
22331      &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
22332      &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
22333      &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
22334      &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
22335      &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
22336      &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
22337      &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
22338      &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
22339      &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
22340      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22341      &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22342      &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
22343      &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
22344      &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
22345       DATA (DL(K),K=  341,  425) /
22346      &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
22347      &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
22348      &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
22349      &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
22350      &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
22351      &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
22352      &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
22353      &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
22354      &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
22355      &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
22356      &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
22357      &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
22358      &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
22359      &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
22360      &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
22361      &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
22362      &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
22363       DATA (DL(K),K=  426,  510) /
22364      &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
22365      &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
22366      &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
22367      &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
22368      &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
22369      &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
22370      &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
22371      &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
22372      &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
22373      &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22374      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22375      &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22376      &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
22377      &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
22378      &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
22379      &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
22380      &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
22381       DATA (DL(K),K=  511,  595) /
22382      &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
22383      &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
22384      &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
22385      &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
22386      &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
22387      &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
22388      &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
22389      &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
22390      &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
22391      &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
22392      &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
22393      &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
22394      &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
22395      &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
22396      &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
22397      &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
22398      &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
22399       DATA (DL(K),K=  596,  680) /
22400      &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
22401      &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
22402      &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
22403      &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
22404      &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
22405      &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
22406      &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
22407      &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22408      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22409      &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
22410      &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
22411      &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
22412      &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
22413      &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
22414      &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
22415      &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
22416      &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
22417       DATA (DL(K),K=  681,  765) /
22418      &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
22419      &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
22420      &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
22421      &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
22422      &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
22423      &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
22424      &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
22425      &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
22426      &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
22427      &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
22428      &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
22429      &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
22430      &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
22431      &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
22432      &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
22433      &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
22434      &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
22435       DATA (DL(K),K=  766,  850) /
22436      &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
22437      &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
22438      &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
22439      &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
22440      &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
22441      &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22442      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22443      &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
22444      &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
22445      &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
22446      &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
22447      &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
22448      &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
22449      &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
22450      &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
22451      &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
22452      &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
22453       DATA (DL(K),K=  851,  935) /
22454      &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
22455      &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
22456      &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
22457      &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
22458      &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
22459      &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
22460      &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
22461      &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
22462      &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
22463      &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
22464      &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
22465      &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
22466      &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
22467      &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
22468      &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
22469      &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
22470      &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
22471       DATA (DL(K),K=  936, 1020) /
22472      &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
22473      &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
22474      &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
22475      &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22476      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22477      &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
22478      &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
22479      &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
22480      &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
22481      &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
22482      &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
22483      &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
22484      &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
22485      &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
22486      &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
22487      &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
22488      &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
22489       DATA (DL(K),K= 1021, 1105) /
22490      &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
22491      &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
22492      &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
22493      &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
22494      &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
22495      &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
22496      &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
22497      &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
22498      &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
22499      &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
22500      &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
22501      &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
22502      &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
22503      &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
22504      &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
22505      &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
22506      &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
22507       DATA (DL(K),K= 1106, 1190) /
22508      &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
22509      &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
22510      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22511      &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
22512      &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
22513      &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
22514      &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
22515      &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
22516      &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
22517      &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
22518      &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
22519      &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
22520      &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
22521      &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
22522      &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
22523      &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
22524      &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
22525       DATA (DL(K),K= 1191, 1275) /
22526      &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
22527      &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
22528      &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
22529      &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
22530      &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
22531      &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
22532      &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
22533      &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
22534      &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
22535      &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
22536      &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
22537      &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
22538      &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
22539      &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
22540      &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
22541      &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
22542      &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
22543       DATA (DL(K),K= 1276, 1360) /
22544      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22545      &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
22546      &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
22547      &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
22548      &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
22549      &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
22550      &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
22551      &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
22552      &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
22553      &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
22554      &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
22555      &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
22556      &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
22557      &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
22558      &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
22559      &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
22560      &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
22561       DATA (DL(K),K= 1361, 1445) /
22562      &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
22563      &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
22564      &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
22565      &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
22566      &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
22567      &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
22568      &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
22569      &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
22570      &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
22571      &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
22572      &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
22573      &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
22574      &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
22575      &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
22576      &0.317005E+00,0.137130E-01,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.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
22579       DATA (DL(K),K= 1446, 1530) /
22580      &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
22581      &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
22582      &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
22583      &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
22584      &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
22585      &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
22586      &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
22587      &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
22588      &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
22589      &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
22590      &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
22591      &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
22592      &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
22593      &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
22594      &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
22595      &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
22596      &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
22597       DATA (DL(K),K= 1531, 1615) /
22598      &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
22599      &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
22600      &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
22601      &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
22602      &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
22603      &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
22604      &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
22605      &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
22606      &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
22607      &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
22608      &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
22609      &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
22610      &0.168600E+00,0.650389E-02,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.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
22613      &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
22614      &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
22615       DATA (DL(K),K= 1616, 1700) /
22616      &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
22617      &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
22618      &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
22619      &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
22620      &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
22621      &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
22622      &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
22623      &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
22624      &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
22625      &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
22626      &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
22627      &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
22628      &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
22629      &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
22630      &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
22631      &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
22632      &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
22633       DATA (DL(K),K= 1701, 1785) /
22634      &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
22635      &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
22636      &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
22637      &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
22638      &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
22639      &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
22640      &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
22641      &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
22642      &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
22643      &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
22644      &0.943886E-01,0.321106E-02,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.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
22647      &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
22648      &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
22649      &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
22650      &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
22651       DATA (DL(K),K= 1786, 1870) /
22652      &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
22653      &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
22654      &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
22655      &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
22656      &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
22657      &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
22658      &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
22659      &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
22660      &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
22661      &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
22662      &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
22663      &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
22664      &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
22665      &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
22666      &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
22667      &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
22668      &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
22669       DATA (DL(K),K= 1871, 1955) /
22670      &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
22671      &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
22672      &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
22673      &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
22674      &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
22675      &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
22676      &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
22677      &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
22678      &0.542848E-01,0.161174E-02,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.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
22681      &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
22682      &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
22683      &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
22684      &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
22685      &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
22686      &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
22687       DATA (DL(K),K= 1956, 2040) /
22688      &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
22689      &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
22690      &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
22691      &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
22692      &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
22693      &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
22694      &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
22695      &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
22696      &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
22697      &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
22698      &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
22699      &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
22700      &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
22701      &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
22702      &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
22703      &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
22704      &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
22705       DATA (DL(K),K= 2041, 2125) /
22706      &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
22707      &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
22708      &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
22709      &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
22710      &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
22711      &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
22712      &0.315960E-01,0.810432E-03,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.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
22715      &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
22716      &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
22717      &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
22718      &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
22719      &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
22720      &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
22721      &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
22722      &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
22723       DATA (DL(K),K= 2126, 2210) /
22724      &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
22725      &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
22726      &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
22727      &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
22728      &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
22729      &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
22730      &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
22731      &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
22732      &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
22733      &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
22734      &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
22735      &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
22736      &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
22737      &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
22738      &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
22739      &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
22740      &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
22741       DATA (DL(K),K= 2211, 2295) /
22742      &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
22743      &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
22744      &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
22745      &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
22746      &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
22747      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22748      &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
22749      &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
22750      &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
22751      &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
22752      &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
22753      &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
22754      &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
22755      &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
22756      &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
22757      &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
22758      &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
22759       DATA (DL(K),K= 2296, 2380) /
22760      &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
22761      &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
22762      &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
22763      &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
22764      &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
22765      &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
22766      &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
22767      &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
22768      &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
22769      &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
22770      &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
22771      &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
22772      &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
22773      &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
22774      &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
22775      &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
22776      &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
22777       DATA (DL(K),K= 2381, 2465) /
22778      &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
22779      &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
22780      &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
22781      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22782      &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
22783      &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
22784      &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
22785      &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
22786      &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
22787      &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
22788      &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
22789      &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
22790      &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
22791      &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
22792      &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
22793      &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
22794      &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
22795       DATA (DL(K),K= 2466, 2550) /
22796      &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
22797      &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
22798      &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
22799      &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
22800      &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
22801      &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
22802      &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
22803      &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
22804      &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
22805      &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
22806      &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
22807      &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
22808      &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
22809      &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
22810      &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
22811      &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
22812      &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
22813       DATA (DL(K),K= 2551, 2635) /
22814      &0.603390E-02,0.934295E-04,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.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
22817      &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
22818      &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
22819      &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
22820      &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
22821      &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
22822      &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
22823      &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
22824      &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
22825      &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
22826      &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
22827      &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
22828      &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
22829      &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
22830      &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
22831       DATA (DL(K),K= 2636, 2720) /
22832      &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
22833      &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
22834      &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
22835      &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
22836      &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
22837      &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
22838      &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
22839      &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
22840      &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
22841      &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
22842      &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
22843      &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
22844      &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
22845      &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
22846      &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
22847      &0.332897E-02,0.424179E-04,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       DATA (DL(K),K= 2721, 2805) /
22850      &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
22851      &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
22852      &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
22853      &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
22854      &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
22855      &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
22856      &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
22857      &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
22858      &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
22859      &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
22860      &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
22861      &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
22862      &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
22863      &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
22864      &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
22865      &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
22866      &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
22867       DATA (DL(K),K= 2806, 2890) /
22868      &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
22869      &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
22870      &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
22871      &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
22872      &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
22873      &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
22874      &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
22875      &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
22876      &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
22877      &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
22878      &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
22879      &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
22880      &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
22881      &0.176404E-02,0.181381E-04,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.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
22884      &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
22885       DATA (DL(K),K= 2891, 2975) /
22886      &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
22887      &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
22888      &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
22889      &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
22890      &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
22891      &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
22892      &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
22893      &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
22894      &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
22895      &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
22896      &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
22897      &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
22898      &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
22899      &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
22900      &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
22901      &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
22902      &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
22903       DATA (DL(K),K= 2976, 3060) /
22904      &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
22905      &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
22906      &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
22907      &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
22908      &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
22909      &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
22910      &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
22911      &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
22912      &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
22913      &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
22914      &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
22915      &0.883469E-03,0.711035E-05,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.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
22918      &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
22919      &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
22920      &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
22921       DATA (DL(K),K= 3061, 3145) /
22922      &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
22923      &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
22924      &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
22925      &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
22926      &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
22927      &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
22928      &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
22929      &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
22930      &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
22931      &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
22932      &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
22933      &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
22934      &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
22935      &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
22936      &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
22937      &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
22938      &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
22939       DATA (DL(K),K= 3146, 3230) /
22940      &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
22941      &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
22942      &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
22943      &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
22944      &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
22945      &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
22946      &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
22947      &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
22948      &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
22949      &0.409096E-03,0.244427E-05,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.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
22952      &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
22953      &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
22954      &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
22955      &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
22956      &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
22957       DATA (DL(K),K= 3231, 3315) /
22958      &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
22959      &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
22960      &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
22961      &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
22962      &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
22963      &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
22964      &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
22965      &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
22966      &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
22967      &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
22968      &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
22969      &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
22970      &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
22971      &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
22972      &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
22973      &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
22974      &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
22975       DATA (DL(K),K= 3316, 3400) /
22976      &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
22977      &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
22978      &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
22979      &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
22980      &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
22981      &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
22982      &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
22983      &0.169376E-03,0.676674E-06,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.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
22986      &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
22987      &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
22988      &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
22989      &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
22990      &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
22991      &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
22992      &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
22993       DATA (DL(K),K= 3401, 3485) /
22994      &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
22995      &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
22996      &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
22997      &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
22998      &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
22999      &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
23000      &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
23001      &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
23002      &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
23003      &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
23004      &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
23005      &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
23006      &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
23007      &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
23008      &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
23009      &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
23010      &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
23011       DATA (DL(K),K= 3486, 3570) /
23012      &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
23013      &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
23014      &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
23015      &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
23016      &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
23017      &0.593824E-04,0.126902E-06,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.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
23020      &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
23021      &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
23022      &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
23023      &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
23024      &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
23025      &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
23026      &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
23027      &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
23028      &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
23029       DATA (DL(K),K= 3571, 3655) /
23030      &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
23031      &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
23032      &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
23033      &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
23034      &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
23035      &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
23036      &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
23037      &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
23038      &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
23039      &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
23040      &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
23041      &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
23042      &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
23043      &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
23044      &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
23045      &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
23046      &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
23047       DATA (DL(K),K= 3656, 3740) /
23048      &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
23049      &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
23050      &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
23051      &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
23052      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23053      &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23054      &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
23055      &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
23056      &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
23057      &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
23058      &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
23059      &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
23060      &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
23061      &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
23062      &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
23063      &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
23064      &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
23065       DATA (DL(K),K= 3741, 3825) /
23066      &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
23067      &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
23068      &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
23069      &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
23070      &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
23071      &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
23072      &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
23073      &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
23074      &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
23075      &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
23076      &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
23077      &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
23078      &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
23079      &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
23080      &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
23081      &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
23082      &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
23083       DATA (DL(K),K= 3826, 3910) /
23084      &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
23085      &0.261981E-05,0.331859E-08,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.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23088      &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
23089      &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
23090      &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
23091      &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
23092      &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
23093      &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
23094      &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
23095      &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
23096      &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
23097      &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
23098      &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
23099      &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
23100      &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
23101       DATA (DL(K),K= 3911, 3995) /
23102      &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
23103      &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
23104      &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
23105      &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
23106      &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
23107      &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
23108      &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
23109      &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
23110      &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
23111      &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
23112      &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
23113      &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
23114      &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
23115      &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
23116      &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
23117      &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
23118      &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
23119       DATA (DL(K),K= 3996, 4000) /
23120      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23121 C
23122       ANS = 0.
23123       IF (X.GT.0.9985) RETURN
23124       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23125 C
23126       IS  = S/DELTA+1
23127       IS1 = IS+1
23128       DO 1 L=1,25
23129          KL    = L+NDRV*25
23130          F1(L) = GF(I,IS,KL)
23131          F2(L) = GF(I,IS1,KL)
23132     1 CONTINUE
23133       A1 = DT_CKMTFF(X,F1)
23134       A2 = DT_CKMTFF(X,F2)
23135 C      A1=ALOG(A1)
23136 C      A2=ALOG(A2)
23137       S1  = (IS-1)*DELTA
23138       S2  = S1+DELTA
23139       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23140 C      ANS=EXP(ANS)
23141       RETURN
23142       END
23143 C
23144 CDECK  ID>, DT_CKMTFF
23145       FUNCTION DT_CKMTFF(X,FVL)
23146 C**********************************************************************
23147 C
23148 C     LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
23149 C     FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
23150 C     NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
23151 C     IN MAIN ROUTINE.
23152 C
23153 C**********************************************************************
23154
23155       SAVE
23156       DIMENSION FVL(25),XGRID(25)
23157       DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
23158      *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
23159 C
23160       DT_CKMTFF=0.
23161       DO 1 I=1,NX
23162       IF(X.LT.XGRID(I)) GO TO 2
23163     1 CONTINUE
23164     2 I=I-1
23165       IF(I.EQ.0) THEN
23166          I=I+1
23167       ELSE IF(I.GT.23) THEN
23168          I=23
23169       ENDIF
23170       J=I+1
23171       K=J+1
23172       AXI=LOG(XGRID(I))
23173       BXI=LOG(1.-XGRID(I))
23174       AXJ=LOG(XGRID(J))
23175       BXJ=LOG(1.-XGRID(J))
23176       AXK=LOG(XGRID(K))
23177       BXK=LOG(1.-XGRID(K))
23178       FI=LOG(ABS(FVL(I)) +1.E-15)
23179       FJ=LOG(ABS(FVL(J)) +1.E-16)
23180       FK=LOG(ABS(FVL(K)) +1.E-17)
23181       DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
23182       ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
23183      $ BXI))/DET
23184       ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
23185       BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
23186       IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
23187      1RETURN
23188 C      IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
23189 C         WRITE(6,2001) X,FVL
23190 C 2001    FORMAT(8E12.4)
23191 C         WRITE(6,2001) ALPHA,BETA,ALOGA,DET
23192 C      ENDIF
23193       DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
23194       RETURN
23195       END
23196 *
23197 *===fluini=============================================================*
23198 *
23199 CDECK  ID>, DT_FLUINI
23200       SUBROUTINE DT_FLUINI
23201
23202 ************************************************************************
23203 * Initialisation of the nucleon-nucleon cross section fluctuation      *
23204 * treatment. The original version by J. Ranft.                         *
23205 * This version dated 21.04.95 is revised by S. Roesler.                *
23206 ************************************************************************
23207
23208       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23209       SAVE
23210
23211       PARAMETER ( LINP = 5 ,
23212      &            LOUT = 6 ,
23213      &            LDAT = 9 )
23214
23215       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
23216
23217       PARAMETER ( A     = 0.1D0,
23218      &            B     = 0.893D0,
23219      &            OM    = 1.1D0,
23220      &            N     = 6,
23221      &            DX    = 0.003D0)
23222
23223 * n-n cross section fluctuations
23224       PARAMETER (NBINS = 1000)
23225       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
23226       DIMENSION FLUSI(NBINS),FLUIX(NBINS)
23227
23228       WRITE(LOUT,1000)
23229  1000 FORMAT(/,1X,'FLUINI:  hadronic cross section fluctuations ',
23230      &       'treated')
23231
23232       FLUSU  = ZERO
23233       FLUSUU = ZERO
23234
23235       DO 1 I=1,NBINS
23236          X        = DBLE(I)*DX
23237          FLUIX(I) = X
23238          FLUS     = ((X-B)/(OM*B))**N
23239          IF (FLUS.LE.20.0D0) THEN
23240             FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
23241          ELSE
23242             FLUSI(I) = ZERO
23243          ENDIF
23244          FLUSU = FLUSU+FLUSI(I)
23245     1 CONTINUE
23246       DO 2 I=1,NBINS
23247          FLUSUU   = FLUSUU+FLUSI(I)/FLUSU
23248          FLUSI(I) = FLUSUU
23249     2 CONTINUE
23250
23251 C     WRITE(LOUT,1001)
23252 C1001 FORMAT(1X,'FLUCTUATIONS')
23253 C     CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
23254
23255       DO 3 I=1,NBINS
23256          AF = DBLE(I)*0.001D0
23257          DO 4 J=1,NBINS
23258             IF (AF.LE.FLUSI(J)) THEN
23259                FLUIXX(I) = FLUIX(J)
23260                GOTO 5
23261             ENDIF
23262     4    CONTINUE
23263     5    CONTINUE
23264     3 CONTINUE
23265       FLUIXX(1)     = FLUIX(1)
23266       FLUIXX(NBINS) = FLUIX(NBINS)
23267
23268       RETURN
23269       END
23270 *
23271 *===sigtab=============================================================*
23272 *
23273 CDECK  ID>, DT_SIGTBL
23274       SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
23275
23276 ************************************************************************
23277 * This version dated 18.11.95 is written by S. Roesler                 *
23278 ************************************************************************
23279
23280       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23281       SAVE
23282
23283       PARAMETER ( LINP = 5 ,
23284      &            LOUT = 6 ,
23285      &            LDAT = 9 )
23286
23287       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
23288      &           OHALF=0.5D0,ONE=1.0D0)
23289       PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
23290
23291       LOGICAL LINIT
23292
23293 * particle properties (BAMJET index convention)
23294       CHARACTER*8  ANAME
23295       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
23296      &                IICH(210),IIBAR(210),K1(210),K2(210)
23297
23298       DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
23299       DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
23300      &             0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
23301      &             0, 0, 5/
23302       DATA LINIT /.FALSE./
23303
23304 * precalculation and tabulation of elastic cross sections
23305       IF (ABS(MODE).EQ.1) THEN
23306          IF (MODE.EQ.1)
23307      &      OPEN(LDAT,FILE='sigtab.out',STATUS='UNKNOWN')
23308          PLABLX = LOG10(PLO)
23309          PLABHX = LOG10(PHI)
23310          DPLAB  = (PLABHX-PLABLX)/DBLE(NBINS)
23311          DO 1 I=1,NBINS+1
23312             PLAB = PLABLX+DBLE(I-1)*DPLAB
23313             PLAB = 10**PLAB
23314             DO 2 IPROJ=1,23
23315                IDX = IDSIG(IPROJ)
23316                IF (IDX.GT.0) THEN
23317 C                 CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
23318 C                 CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
23319                   DUMZER = ZERO
23320                   CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
23321                   CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
23322                ENDIF
23323     2       CONTINUE
23324             IF (MODE.EQ.1) THEN
23325                WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
23326      &                                (SIGEN(IDX,I),IDX=1,5)
23327  1000          FORMAT(F5.1,10F7.2)
23328             ENDIF
23329     1    CONTINUE
23330          IF (MODE.EQ.1) CLOSE(LDAT)
23331          LINIT = .TRUE.
23332       ELSE
23333          SIGE = -ONE
23334          IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
23335      &                           .AND.(PTOT.LE.PHI) ) THEN
23336             IDX = IDSIG(JP)
23337             IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
23338                PLABX = LOG10(PTOT)
23339                IF (PLABX.LE.PLABLX) THEN
23340                   I1 = 1
23341                   I2 = 1
23342                ELSEIF (PLABX.GE.PLABHX) THEN
23343                   I1 = NBINS+1
23344                   I2 = NBINS+1
23345                ELSE
23346                   I1 = INT((PLABX-PLABLX)/DPLAB)+1
23347                   I2 = I1+1
23348                ENDIF
23349                PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
23350                PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
23351                PBIN   = PLAB2X-PLAB1X
23352                IF (PBIN.GT.TINY10) THEN
23353                   RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
23354                ELSE
23355                   RATX = ZERO
23356                ENDIF
23357                IF (JT.EQ.1) THEN
23358                   SIG1 = SIGEP(IDX,I1)
23359                   SIG2 = SIGEP(IDX,I2)
23360                ELSE
23361                   SIG1 = SIGEN(IDX,I1)
23362                   SIG2 = SIGEN(IDX,I2)
23363                ENDIF
23364                SIGE = SIG1+RATX*(SIG2-SIG1)
23365             ENDIF
23366          ENDIF
23367       ENDIF
23368
23369       RETURN
23370       END
23371 *
23372 *===xstabl=============================================================*
23373 *
23374 CDECK  ID>, DT_XSTABL
23375       SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
23376
23377       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23378       SAVE
23379
23380       PARAMETER ( LINP = 5 ,
23381      &            LOUT = 6 ,
23382      &            LDAT = 9 )
23383
23384       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
23385      &           OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
23386       LOGICAL LLAB,LELOG,LQLOG
23387
23388 * particle properties (BAMJET index convention)
23389       CHARACTER*8  ANAME
23390       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
23391      &                IICH(210),IIBAR(210),K1(210),K2(210)
23392 * properties of interacting particles
23393       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
23394
23395       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
23396
23397 * Glauber formalism: cross sections
23398       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
23399      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
23400      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
23401      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
23402      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
23403      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
23404      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
23405      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
23406      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
23407      &                BSLOPE,NEBINI,NQBINI
23408 * emulsion treatment
23409       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
23410      &                NCOMPO,IEMUL
23411
23412       DIMENSION WHAT(6)
23413
23414       LLAB   = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
23415       ELO    = ABS(WHAT(1))
23416       EHI    = ABS(WHAT(2))
23417       IF (ELO.GT.EHI) ELO = EHI
23418       LELOG  = WHAT(3).LT.ZERO
23419       NEBINS = MAX(INT(ABS(WHAT(3))),1)
23420       DEBINS = (EHI-ELO)/DBLE(NEBINS)
23421       IF (LELOG) THEN
23422          AELO   = LOG10(ELO)
23423          AEHI   = LOG10(EHI)
23424          ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
23425       ENDIF
23426       Q2LO   = WHAT(4)
23427       Q2HI   = WHAT(5)
23428       IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
23429       LQLOG  = WHAT(6).LT.ZERO
23430       NQBINS = MAX(INT(ABS(WHAT(6))),1)
23431       DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
23432       IF (LQLOG) THEN
23433          AQ2LO  = LOG10(Q2LO)
23434          AQ2HI  = LOG10(Q2HI)
23435          ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
23436       ENDIF
23437
23438       IF ( ELO.EQ. EHI) NEBINS = 0
23439       IF (Q2LO.EQ.Q2HI) NQBINS = 0
23440
23441       WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
23442  1000 FORMAT(/,1X,'XSTABL:  E_lo  =',E10.3,' GeV  E_hi  =',E10.3,
23443      &       ' GeV     Lab = ',L1,'  qel: ',I2,/,10X,'Q2_lo =',F10.5,
23444      &       ' GeV^2  Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
23445      &       '   A_p = ',I3,'   A_t = ',I3,/)
23446
23447 C     IF (IJPROJ.NE.7) THEN
23448          WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
23449 * normalize fractions of emulsion components
23450          IF (NCOMPO.GT.0) THEN
23451             SUMFRA = ZERO
23452             DO 10 I=1,NCOMPO
23453                SUMFRA = SUMFRA+EMUFRA(I)
23454    10       CONTINUE
23455             IF (SUMFRA.GT.ZERO) THEN
23456                DO 11 I=1,NCOMPO
23457                   EMUFRA(I) = EMUFRA(I)/SUMFRA
23458    11          CONTINUE
23459             ENDIF
23460          ENDIF
23461 C     ELSE
23462 C        WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
23463 C     ENDIF
23464       DO 1 I=1,NEBINS+1
23465          IF (LELOG) THEN
23466             E = 10**(AELO+DBLE(I-1)*ADEBIN)
23467          ELSE
23468             E = ELO+DBLE(I-1)*DEBINS
23469          ENDIF
23470          DO 2 J=1,NQBINS+1
23471             IF (LQLOG) THEN
23472                Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
23473             ELSE
23474                Q2 = Q2LO+DBLE(J-1)*DQBINS
23475             ENDIF
23476 c            IF (IJPROJ.NE.7) THEN
23477                IF (LLAB) THEN
23478                   PLAB = ZERO
23479                   ECM  = ZERO
23480                   CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
23481                ELSE
23482                   ECM = E
23483                ENDIF
23484                XI  = ZERO
23485                Q2I = ZERO
23486                IF (IJPROJ.EQ.7) Q2I = Q2
23487                IF (NCOMPO.GT.0) THEN
23488                   DO 20 IC=1,NCOMPO
23489                      IIT = IEMUMA(IC)
23490                      CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
23491    20             CONTINUE
23492                ELSE
23493                   CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
23494 C                 CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
23495                ENDIF
23496                IF (NCOMPO.GT.0) THEN
23497                   XTOT = ZERO
23498                   ETOT = ZERO
23499                   XELA = ZERO
23500                   EELA = ZERO
23501                   XQEP = ZERO
23502                   EQEP = ZERO
23503                   XQET = ZERO
23504                   EQET = ZERO
23505                   XQE2 = ZERO
23506                   EQE2 = ZERO
23507                   XPRO = ZERO
23508                   EPRO = ZERO
23509                   XPRO1= ZERO
23510                   XDEL = ZERO
23511                   EDEL = ZERO
23512                   XDQE = ZERO
23513                   EDQE = ZERO
23514                   DO 21 IC=1,NCOMPO
23515                      XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
23516                      ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
23517                      XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
23518                      EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
23519                      XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
23520                      EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
23521                      XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
23522                      EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
23523                      XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
23524                      EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
23525                      XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
23526                      EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
23527                      XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
23528                      EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
23529                      XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
23530                      EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
23531                      YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
23532      &                     -XSQEP(1,1,IC)-XSQET(1,1,IC)
23533      &                     -XSQE2(1,1,IC)
23534                      XPRO1= XPRO1+EMUFRA(IC)*YPRO
23535    21             CONTINUE
23536                   ETOT = SQRT(ETOT)
23537                   EELA = SQRT(EELA)
23538                   EQEP = SQRT(EQEP)
23539                   EQET = SQRT(EQET)
23540                   EQE2 = SQRT(EQE2)
23541                   EPRO = SQRT(EPRO)
23542                   EDEL = SQRT(EDEL)
23543                   EDQE = SQRT(EDQE)
23544                   WRITE(LOUT,'(8E9.3)')
23545      &               E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
23546 C                 WRITE(LOUT,'(4E9.3)')
23547 C    &               E,XDEL,XDQE,XDEL+XDQE
23548                ELSE
23549                   WRITE(LOUT,'(11E10.3)')
23550      &              E,
23551      &              XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
23552      &              XSQE2(1,1,1),XSPRO(1,1,1),
23553      &              XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
23554      &             -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
23555      &              XSDEL(1,1,1)+XSDQE(1,1,1)
23556 C                 WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
23557 C    &                                    XSDEL(1,1,1)+XSDQE(1,1,1)
23558                ENDIF
23559 c            ELSE
23560 c               IF (LLAB) THEN
23561 c                  IF (IT.GT.1) THEN
23562 c                     IF (IXSQEL.EQ.0) THEN
23563 cC                       CALL DT_SIGGA(IT,  Q2, E,ZERO,ZERO,
23564 cC                       CALL DT_SIGGA(IT,   E,Q2,ZERO,ZERO,
23565 c                        CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
23566 c     &                             STOT,ETOT,SIN,EIN,STOT0)
23567 c                        IF (IRATIO.EQ.1) THEN
23568 c                           CALL DT_SIGGP(  Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
23569 cC                          CALL DT_SIGGP(   E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
23570 cC                          CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
23571 c*!! save cross sections
23572 c                           STOTA = STOT
23573 c                           ETOTA = ETOT
23574 c                           STOTP = STGP
23575 c*!!
23576 c                           STOT  = STOT/(DBLE(IT)*STGP)
23577 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
23578 c                           STOT0 = STGP
23579 c                           ETOT  = ZERO
23580 c                           EIN   = ZERO
23581 c                        ENDIF
23582 c                     ELSE
23583 c                        WRITE(LOUT,*)
23584 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
23585 c                        STOP
23586 c                     ENDIF
23587 c                  ELSE
23588 c                     ETOT = ZERO
23589 c                     EIN  = ZERO
23590 c                     STOT0= ZERO
23591 c                     IF (IXSQEL.EQ.0) THEN
23592 c                        CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
23593 c                     ELSE
23594 c                       SIN = ZERO
23595 c                       CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
23596 c                     ENDIF
23597 c                  ENDIF
23598 c               ELSE
23599 c                  IF (IT.GT.1) THEN
23600 c                     IF (IXSQEL.EQ.0) THEN
23601 c                        CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
23602 c     &                             STOT,ETOT,SIN,EIN,STOT0)
23603 c                        IF (IRATIO.EQ.1) THEN
23604 c                           CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
23605 c*!! save cross sections
23606 c                           STOTA = STOT
23607 c                           ETOTA = ETOT
23608 c                           STOTP = STGP
23609 c*!!
23610 c                           STOT  = STOT/(DBLE(IT)*STGP)
23611 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
23612 c                           STOT0 = STGP
23613 c                           ETOT  = ZERO
23614 c                           EIN   = ZERO
23615 c                        ENDIF
23616 c                     ELSE
23617 c                        WRITE(LOUT,*)
23618 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
23619 c                        STOP
23620 c                     ENDIF
23621 c                  ELSE
23622 c                     ETOT = ZERO
23623 c                     EIN  = ZERO
23624 c                     STOT0= ZERO
23625 c                     IF (IXSQEL.EQ.0) THEN
23626 c                        CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
23627 c                     ELSE
23628 c                       SIN = ZERO
23629 c                       CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
23630 c                     ENDIF
23631 c                  ENDIF
23632 c               ENDIF
23633 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
23634 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
23635 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
23636 c               WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
23637 c            ENDIF
23638     2    CONTINUE
23639     1 CONTINUE
23640
23641       RETURN
23642       END
23643 *
23644 *===testxs=============================================================*
23645 *
23646 CDECK  ID>, DT_TESTXS
23647       SUBROUTINE DT_TESTXS
23648
23649       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23650       SAVE
23651
23652       DIMENSION XSTOT(26,2),XSELA(26,2)
23653
23654       OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
23655       OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
23656       OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
23657       OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
23658       DUMECM = 0.0D0
23659       PLABL = 0.01D0
23660       PLABH = 10000.0D0
23661       NBINS = 120
23662       APLABL = LOG10(PLABL)
23663       APLABH = LOG10(PLABH)
23664       ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
23665       DO 1 I=1,NBINS+1
23666          ADP = APLABL+DBLE(I-1)*ADPLAB
23667          P = 10.0D0**ADP
23668          DO 2 J=1,26
23669             CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
23670             CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
23671     2    CONTINUE
23672          WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
23673          WRITE(11,1000) P,(XSELA(K,1),K=1,26)
23674          WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
23675          WRITE(13,1000) P,(XSELA(K,2),K=1,26)
23676     1 CONTINUE
23677  1000 FORMAT(F8.3,26F9.3)
23678
23679       RETURN
23680       END
23681 ************************************************************************
23682 *                                                                      *
23683 *  DTUNUC 2.0:   library routines                                      *
23684 *                                   processed by S. Roesler, 6.5.95    *
23685 *                                                                      *
23686 ************************************************************************
23687 *
23688 *     1) Handling of parton momenta
23689 *          SUBROUTINE MASHEL
23690 *          SUBROUTINE DFERMI
23691 *
23692 *     2) Handling of parton flavors and particle indices
23693 *          INTEGER FUNCTION IPDG2B
23694 *          INTEGER FUNCTION IB2PDG
23695 *          INTEGER FUNCTION IQUARK
23696 *          INTEGER FUNCTION IBJQUA
23697 *          INTEGER FUNCTION ICIHAD
23698 *          INTEGER FUNCTION IPDGHA
23699 *          INTEGER FUNCTION MCHAD
23700 *          SUBROUTINE FLAHAD
23701 *
23702 *     3) Energy-momentum and quantum number conservation check routines
23703 *          SUBROUTINE EMC1
23704 *          SUBROUTINE EMC2
23705 *          SUBROUTINE EVTEMC
23706 *          SUBROUTINE EVTFLC
23707 *          SUBROUTINE EVTCHG
23708 *
23709 *     4) Transformations
23710 *          SUBROUTINE LTINI
23711 *          SUBROUTINE LTRANS
23712 *          SUBROUTINE LTNUC
23713 *          SUBROUTINE DALTRA
23714 *          SUBROUTINE DTRAFO
23715 *          SUBROUTINE STTRAN
23716 *          SUBROUTINE MYTRAN
23717 *          SUBROUTINE LT2LAO
23718 *          SUBROUTINE LT2LAB
23719 *
23720 *     5) Sampling from distributions
23721 *          INTEGER FUNCTION NPOISS
23722 *          DOUBLE PRECISION FUNCTION SAMPXB
23723 *          DOUBLE PRECISION FUNCTION SAMPEX
23724 *          DOUBLE PRECISION FUNCTION SAMSQX
23725 *          DOUBLE PRECISION FUNCTION BETREJ
23726 *          DOUBLE PRECISION FUNCTION DGAMRN
23727 *          DOUBLE PRECISION FUNCTION DBETAR
23728 *          SUBROUTINE RANNOR
23729 *          SUBROUTINE DPOLI
23730 *          SUBROUTINE DSFECF
23731 *          SUBROUTINE RACO
23732 *
23733 *     6) Special functions, algorithms and service routines
23734 *          DOUBLE PRECISION FUNCTION YLAMB
23735 *          SUBROUTINE SORT
23736 *          SUBROUTINE SORT1
23737 *          SUBROUTINE DT_XTIME
23738 *
23739 *     7) Random number generator package
23740 *          DOUBLE PRECISION FUNCTION DT_RNDM
23741 *          SUBROUTINE DT_RNDMST
23742 *          SUBROUTINE DT_RNDMIN
23743 *          SUBROUTINE DT_RNDMOU
23744 *          SUBROUTINE DT_RNDMTE
23745 *
23746 ************************************************************************
23747 *                                                                      *
23748 *                 1) Handling of parton momenta                        *
23749 *                                                                      *
23750 ************************************************************************
23751 *
23752 *===mashel=============================================================*
23753 *
23754 CDECK  ID>, DT_MASHEL
23755       SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
23756
23757 ************************************************************************
23758 *                                                                      *
23759 *    rescaling of momenta of two partons to put both                   *
23760 *                                       on mass shell                  *
23761 *                                                                      *
23762 *    input:       PA1,PA2   input momentum vectors                     *
23763 *                 XM1,2     desired masses of particles afterwards     *
23764 *                 P1,P2     changed momentum vectors                   *
23765 *                                                                      *
23766 * The original version is written by R. Engel.                         *
23767 * This version dated 12.12.94 is modified by S. Roesler.               *
23768 ************************************************************************
23769
23770       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23771       SAVE
23772
23773       PARAMETER ( LINP = 5 ,
23774      &            LOUT = 6 ,
23775      &            LDAT = 9 )
23776
23777       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
23778
23779       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
23780
23781       IREJ = 0
23782
23783 * Lorentz transformation into system CMS
23784       PX  = PA1(1)+PA2(1)
23785       PY  = PA1(2)+PA2(2)
23786       PZ  = PA1(3)+PA2(3)
23787       EE  = PA1(4)+PA2(4)
23788       XPTOT = SQRT(PX**2+PY**2+PZ**2)
23789       XMS   = (EE-XPTOT)*(EE+XPTOT)
23790       IF(XMS.LT.(XM1+XM2)**2) THEN
23791 C        WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
23792          GOTO 9999
23793       ENDIF
23794       XMS = SQRT(XMS)
23795       BGX = PX/XMS
23796       BGY = PY/XMS
23797       BGZ = PZ/XMS
23798       GAM = EE/XMS
23799       CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
23800      &           PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
23801 * rotation angles
23802       COD = P1(3)/PTOT1
23803 C     SID = SQRT((ONE-COD)*(ONE+COD))
23804       PPT = SQRT(P1(1)**2+P1(2)**2)
23805       SID = PPT/PTOT1
23806       COF = ONE
23807       SIF = ZERO
23808       IF(PTOT1*SID.GT.TINY10) THEN
23809          COF   = P1(1)/(SID*PTOT1)
23810          SIF   = P1(2)/(SID*PTOT1)
23811          ANORF = SQRT(COF*COF+SIF*SIF)
23812          COF   = COF/ANORF
23813          SIF   = SIF/ANORF
23814       ENDIF
23815 * new CM momentum and energies (for masses XM1,XM2)
23816       XM12 = SIGN(XM1**2,XM1)
23817       XM22 = SIGN(XM2**2,XM2)
23818       SS   = XMS**2
23819       PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
23820       EE1  = SQRT(XM12+PCMP**2)
23821       EE2  = XMS-EE1
23822 * back rotation
23823       MODE = 1
23824       CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
23825       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
23826      &            PTOT1,P1(1),P1(2),P1(3),P1(4))
23827       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
23828      &            PTOT2,P2(1),P2(2),P2(3),P2(4))
23829 * check consistency
23830       DEL = XMS*0.0001D0
23831       IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
23832         IDEV = 1
23833       ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
23834         IDEV = 2
23835       ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
23836         IDEV = 3
23837       ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
23838         IDEV = 4
23839       ELSE
23840         IDEV = 0
23841       ENDIF
23842       IF (IDEV.NE.0) THEN
23843          WRITE(LOUT,'(/1X,A,I3)')
23844      &      'MASHEL: inconsistent transformation',IDEV
23845          WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
23846          WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
23847          WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
23848          WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
23849          WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
23850          WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
23851       ENDIF
23852       RETURN
23853
23854  9999 CONTINUE
23855       IREJ = 1
23856       RETURN
23857       END
23858 *
23859 *===dfermi=============================================================*
23860 *
23861 CDECK  ID>, DT_DFERMI
23862       SUBROUTINE DT_DFERMI(GPART)
23863
23864 ************************************************************************
23865 * Find largest of three random numbers.                                *
23866 ************************************************************************
23867
23868       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23869       SAVE
23870
23871       DIMENSION G(3)
23872
23873       DO 10 I=1,3
23874         G(I)=DT_RNDM(GPART)
23875    10 CONTINUE
23876       IF (G(3).LT.G(2)) GOTO 40
23877       IF (G(3).LT.G(1)) GOTO 30
23878       GPART = G(3)
23879    20 RETURN
23880    30 GPART = G(1)
23881       GOTO 20
23882    40 IF (G(2).LT.G(1)) GOTO 30
23883       GPART = G(2)
23884       GOTO 20
23885
23886       END
23887
23888 ************************************************************************
23889 *                                                                      *
23890 *         2) Handling of parton flavors and particle indices           *
23891 *                                                                      *
23892 ************************************************************************
23893 *
23894 *===ipdg2b=============================================================*
23895 *
23896 CDECK  ID>, IDT_IPDG2B
23897       INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
23898
23899 ************************************************************************
23900 *                                                                      *
23901 *     conversion of quark numbering scheme                             *
23902 *                                                                      *
23903 *     input:   PDG parton numbering                                    *
23904 *              for diquarks:  NN number of the constituent quark       *
23905 *                             (e.g. ID=2301,NN=1 -> ICONV2=1)          *
23906 *                                                                      *
23907 *     output:  BAMJET particle codes                                   *
23908 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
23909 *              2 d     8 a-d             -2 a-d                        *
23910 *              3 s     9 a-s             -3 a-s                        *
23911 *              4 c    10 a-c             -4 a-c                        *
23912 *                                                                      *
23913 * This is a modified version of ICONV2 written by R. Engel.            *
23914 * This version dated 13.12.94 is written by S. Roesler.                *
23915 ************************************************************************
23916
23917       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23918       SAVE
23919
23920       PARAMETER ( LINP = 5 ,
23921      &            LOUT = 6 ,
23922      &            LDAT = 9 )
23923
23924       IDA = ABS(ID)
23925 * diquarks
23926       IF (IDA.GT.6) THEN
23927         KF  = 3
23928         IF (IDA.GE.1000) KF = 4
23929         IDA = IDA/(10**(KF-NN))
23930         IDA = MOD(IDA,10)
23931       ENDIF
23932 * exchange up and dn quarks
23933       IF (IDA.EQ.1) THEN
23934         IDA = 2
23935       ELSEIF (IDA.EQ.2) THEN
23936         IDA = 1
23937       ENDIF
23938 * antiquarks
23939       IF (ID.LT.0) THEN
23940          IF (MODE.EQ.1) THEN
23941             IDA = IDA+6
23942          ELSE
23943             IDA = -IDA
23944          ENDIF
23945       ENDIF
23946       IDT_IPDG2B = IDA
23947
23948       RETURN
23949       END
23950 *
23951 *===ib2pdg=============================================================*
23952 *
23953 CDECK  ID>, IDT_IB2PDG
23954       INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
23955
23956 ************************************************************************
23957 *                                                                      *
23958 *     conversion of quark numbering scheme                             *
23959 *                                                                      *
23960 *     input:   BAMJET particle codes                                   *
23961 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
23962 *              2 d     8 a-d             -2 a-d                        *
23963 *              3 s     9 a-s             -3 a-s                        *
23964 *              4 c    10 a-c             -4 a-c                        *
23965 *                                                                      *
23966 *     output:  PDG parton numbering                                    *
23967 *                                                                      *
23968 * This version dated 13.12.94 is written by S. Roesler.                *
23969 ************************************************************************
23970
23971       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23972       SAVE
23973
23974       PARAMETER ( LINP = 5 ,
23975      &            LOUT = 6 ,
23976      &            LDAT = 9 )
23977
23978       DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
23979       DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
23980       DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
23981      &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
23982      &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
23983
23984       IDA = ID1
23985       IDB = ID2
23986       IF (MODE.EQ.1) THEN
23987          IF (ID1.GT.6) IDA = -(ID1-6)
23988          IF (ID2.GT.6) IDB = -(ID2-6)
23989       ENDIF
23990       IF (ID2.EQ.0) THEN
23991          IDT_IB2PDG = IHKKQ(IDA)
23992       ELSE
23993          IDT_IB2PDG = IHKKQQ(IDA,IDB)
23994       ENDIF
23995
23996       RETURN
23997       END
23998 *
23999 *===ipdgqu=============================================================*
24000 *
24001 CDECK  ID>, IDT_IQUARK
24002       INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
24003
24004 ************************************************************************
24005 *                                                                      *
24006 *     quark contents according to PDG conventions                      *
24007 *     (random selection in case of quark mixing)                       *
24008 *                                                                      *
24009 *     input:   IDBAMJ BAMJET particle code                             *
24010 *              K      1..3   quark number                              *
24011 *                                                                      *
24012 *     output:  1   d  (anti --> neg.)                                  *
24013 *              2   u                                                   *
24014 *              3   s                                                   *
24015 *              4   c                                                   *
24016 *                                                                      *
24017 * This version written by R. Engel.                                    *
24018 ************************************************************************
24019
24020       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24021       SAVE
24022
24023       IQ = IDT_IBJQUA(K,IDBAMJ)
24024 * quark-antiquark
24025       IF (IQ.GT.6) THEN
24026          IQ = 6-IQ
24027       ENDIF
24028 * exchange of up and down
24029       IF (ABS(IQ).EQ.1) THEN
24030          IQ = SIGN(2,IQ)
24031       ELSEIF (ABS(IQ).EQ.2) THEN
24032          IQ = SIGN(1,IQ)
24033       ENDIF
24034       IDT_IQUARK = IQ
24035
24036       RETURN
24037       END
24038 *
24039 *===ibamq==============================================================*
24040 *
24041 CDECK  ID>, IDT_IBJQUA
24042       INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
24043
24044 ************************************************************************
24045 *                                                                      *
24046 *     quark contents according to BAMJET conventions                   *
24047 *     (random selection in case of quark mixing)                       *
24048 *                                                                      *
24049 *     input:   IDBAMJ BAMJET particle code                             *
24050 *              K      1..3   quark number                              *
24051 *                                                                      *
24052 *     output:  1   u      7   u bar                                    *
24053 *              2   d      8   d bar                                    *
24054 *              3   s      9   s bar                                    *
24055 *              4   c     10   c bar                                    *
24056 *                                                                      *
24057 * This version written by R. Engel.                                    *
24058 ************************************************************************
24059
24060       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24061       SAVE
24062
24063       DIMENSION ITAB(3,210)
24064       DATA ((ITAB(I,K),I=1,3),K=1,30) /
24065      &    1,  1,  2,   7,  7,  8,   0,  0,  0,
24066      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24067      &    0,  0,  0,   1,  2,  2,   7,  8,  8,
24068 *sr 10.1.94
24069 C    &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24070      &    0,  0,  0,   0,  0,  0,   3,  8,  0,
24071 *
24072      &    1,  8,  0,   2,  7,  0,   1,  9,  0,
24073 *sr 10.1.94
24074 C    &    3,  7,  0,   0,  0,  0,   0,  0,  0,
24075      &    3,  7,  0,   3,  1,  2,   9,  7,  8,
24076 *sr 10.1.94
24077 C    &    0,  0,  0,   2,  2,  3,   1,  1,  3,
24078      &    2,  9,  0,   2,  2,  3,   1,  1,  3,
24079 *
24080      &    1,  2,  3, 201,202,  0,   2,  9,  0,
24081      &    3,  8,  0,   0,  0,  0,   0,  0,  0,
24082      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
24083       DATA ((ITAB(I,K),I=1,3),K=31,60) /
24084      &    3,  9,  0,   1,  8,  0, 203,204,  0,
24085      &    2,  7,  0,   0,  0,  0,   1,  9,  0,
24086      &    2,  9,  0,   3,  7,  0,   3,  8,  0,
24087      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24088      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24089      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24090      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24091      &    0,  0,  0,   1,  1,  1,   1,  1,  2,
24092      &    1,  2,  2,   2,  2,  2,   0,  0,  0,
24093      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
24094       DATA ((ITAB(I,K),I=1,3),K=61,90) /
24095      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24096      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24097      &    7,  7,  7,   7,  7,  8,   7,  8,  8,
24098      &    8,  8,  8,   0,  0,  0,   0,  0,  0,
24099      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24100      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24101      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24102      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24103      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24104      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
24105       DATA ((ITAB(I,K),I=1,3),K=91,120) /
24106      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24107      &    0,  0,  0,   0,  0,  0,   3,  9,  0,
24108      &    1,  3,  3,   2,  3,  3,   7,  7,  9,
24109      &    7,  8,  9,   8,  8,  9,   7,  9,  9,
24110      &    8,  9,  9,   1,  1,  3,   1,  2,  3,
24111      &    2,  2,  3,   1,  3,  3,   2,  3,  3,
24112      &    3,  3,  3,   7,  7,  9,   7,  8,  9,
24113      &    8,  8,  9,   7,  9,  9,   8,  9,  9,
24114      &    9,  9,  9,   4,  7,  0,   4,  8,  0,
24115      &    2, 10,  0,   1, 10,  0,   4,  9,  0 /
24116       DATA ((ITAB(I,K),I=1,3),K=121,150) /
24117      &    3, 10,  0,   4, 10,  0,   4,  7,  0,
24118      &    4,  8,  0,   2, 10,  0,   1, 10,  0,
24119      &    4,  9,  0,   3, 10,  0,   4, 10,  0,
24120      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24121      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24122      &    0,  0,  0,   1,  2,  4,   1,  3,  4,
24123      &    2,  3,  4,   1,  1,  4,   0,  0,  0,
24124      &    2,  2,  4,   0,  0,  0,   0,  0,  0,
24125      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
24126      &    3,  4,  4,   7,  8, 10,   7,  9, 10 /
24127       DATA ((ITAB(I,K),I=1,3),K=151,180) /
24128      &    8,  9, 10,   7,  7, 10,   0,  0,  0,
24129      &    8,  8, 10,   0,  0,  0,   0,  0,  0,
24130      &    9,  9, 10,   7, 10, 10,   8, 10, 10,
24131      &    9, 10, 10,   1,  1,  4,   1,  2,  4,
24132      &    2,  2,  4,   1,  3,  4,   2,  3,  4,
24133      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
24134      &    3,  4,  4,   4,  4,  4,   7,  7, 10,
24135      &    7,  8, 10,   8,  8, 10,   7,  9, 10,
24136      &    8,  9, 10,   9,  9, 10,   7, 10, 10,
24137      &    8, 10, 10,   9, 10, 10,  10, 10, 10 /
24138       DATA ((ITAB(I,K),I=1,3),K=181,210) /
24139      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24140      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24141      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24142      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24143      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24144      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24145      &    0,  0,  0,   0,  0,  0,   1,  7,  0,
24146      &    2,  8,  0,   1,  7,  0,   2,  8,  0,
24147      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24148      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
24149       DATA IDOLD /0/
24150
24151       ONE = 1.0D0
24152       IF (ITAB(1,IDBAMJ).LE.200) THEN
24153          ID = ITAB(K,IDBAMJ)
24154       ELSE
24155          IF(IDOLD.NE.IDBAMJ) THEN
24156             IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
24157      &           DT_RNDM(ONE)+ITAB(1,IDBAMJ))
24158         ELSE
24159            IDOLD = 0
24160         ENDIF
24161         ID = ITAB(K,IT)
24162       ENDIF
24163       IDOLD  = IDBAMJ
24164       IDT_IBJQUA = ID
24165
24166       RETURN
24167       END
24168 *
24169 *===icihad=============================================================*
24170 *
24171 CDECK  ID>, IDT_ICIHAD
24172       INTEGER FUNCTION IDT_ICIHAD(MCIND)
24173
24174 ************************************************************************
24175 * Conversion of particle index PDG proposal --> BAMJET-index scheme    *
24176 * This is a completely new version dated 25.10.95.                     *
24177 * Renamed to be not in conflict with the modified PHOJET-version       *
24178 ************************************************************************
24179
24180       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24181       SAVE
24182
24183 * hadron index conversion (BAMJET <--> PDG)
24184       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
24185      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
24186      &                IAMCIN(210)
24187
24188       IDT_ICIHAD = 0
24189       KPDG   = ABS(MCIND)
24190       IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
24191       IF (MCIND.LT.0) THEN
24192          JSIGN = 1
24193       ELSE
24194          JSIGN = 2
24195       ENDIF
24196       IF (KPDG.GE.10000) THEN
24197          DO 1 I=1,19
24198             IDT_ICIHAD = IBAM5(JSIGN,I)
24199             IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
24200             IDT_ICIHAD = 0
24201     1    CONTINUE
24202       ELSEIF (KPDG.GE.1000) THEN
24203          DO 2 I=1,29
24204             IDT_ICIHAD = IBAM4(JSIGN,I)
24205             IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
24206             IDT_ICIHAD = 0
24207     2    CONTINUE
24208       ELSEIF (KPDG.GE.100) THEN
24209          DO 3 I=1,22
24210             IDT_ICIHAD = IBAM3(JSIGN,I)
24211             IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
24212             IDT_ICIHAD = 0
24213     3    CONTINUE
24214       ELSEIF (KPDG.GE.10) THEN
24215          DO 4 I=1,7
24216             IDT_ICIHAD = IBAM2(JSIGN,I)
24217             IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
24218             IDT_ICIHAD = 0
24219     4    CONTINUE
24220       ENDIF
24221     5 CONTINUE
24222
24223       RETURN
24224       END
24225 *
24226 *===ipdgha=============================================================*
24227 *
24228 CDECK  ID>, IDT_IPDGHA
24229       INTEGER FUNCTION IDT_IPDGHA(MCIND)
24230
24231 ************************************************************************
24232 * Conversion of particle index BAMJET-index scheme --> PDG proposal    *
24233 * Adopted from the original by S. Roesler. This version dated 12.5.95  *
24234 * Renamed to be not in conflict with the modified PHOJET-version       *
24235 ************************************************************************
24236
24237       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24238       SAVE
24239
24240 * hadron index conversion (BAMJET <--> PDG)
24241       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
24242      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
24243      &                IAMCIN(210)
24244
24245       IDT_IPDGHA = IAMCIN(MCIND)
24246
24247       RETURN
24248       END
24249 *
24250 *===flahad=============================================================*
24251 *
24252 CDECK  ID>, DT_FLAHAD
24253       SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
24254
24255 ************************************************************************
24256 * sampling of FLAvor composition for HADrons/photons                   *
24257 *              ID         BAMJET-id of hadron                          *
24258 *              IF1,2,3    flavor content                               *
24259 *                         (u,d,s: 1,2,3;  au,ad,as: -1,-1,-3)          *
24260 * Note:  -  u,d numbering as in BAMJET                                 *
24261 *        -  ID .le. 30 !!                                              *
24262 * This version dated 12.03.96 is written by S. Roesler                 *
24263 ************************************************************************
24264
24265       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24266       SAVE
24267
24268 * auxiliary common for reggeon exchange (DTUNUC 1.x)
24269       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
24270      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
24271      &                IQTCHR(-6:6),MQUARK(3,39)
24272
24273       DIMENSION JSEL(3,6)
24274       DATA JSEL/ 1,2,3,  2,3,1,  3,1,2,  1,3,2,   2,1,3,   3,2,1/
24275
24276       ONE = 1.0D0
24277       IF (ID.EQ.7) THEN
24278 * photon (charge dependent flavour sampling)
24279          K = INT(DT_RNDM(ONE)*6.D0+1.D0)
24280          IF (K.LE.4) THEN
24281             IF1 = 2
24282             IF2 = -2
24283          ELSE IF(K.EQ.5) THEN
24284             IF1 = 1
24285             IF2 = -1
24286          ELSE
24287             IF1 = 3
24288             IF2 = -3
24289          ENDIF
24290          IF(DT_RNDM(ONE).LT.0.5D0) THEN
24291             K   = IF1
24292             IF1 = IF2
24293             IF2 = K
24294          ENDIF
24295          IF3 = 0
24296       ELSE
24297 * hadron
24298          IX  = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
24299          IF1 = MQUARK(JSEL(1,IX),ID)
24300          IF2 = MQUARK(JSEL(2,IX),ID)
24301          IF3 = MQUARK(JSEL(3,IX),ID)
24302          IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
24303             IF1 = IF3
24304             IF3 = 0
24305          ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
24306             IF2 = IF3
24307             IF3 = 0
24308          ENDIF
24309       ENDIF
24310
24311       RETURN
24312       END
24313 *
24314 *===mchad==============================================================*
24315 *
24316 CDECK  ID>, IDT_MCHAD
24317       INTEGER FUNCTION IDT_MCHAD(ITDTU)
24318
24319 ************************************************************************
24320 * Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
24321 * Adopted from the original by S. Roesler. This version dated 6.5.95   *
24322 ************************************************************************
24323
24324       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24325       SAVE
24326
24327       DIMENSION ITRANS(210)
24328       DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
24329      &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
24330      &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
24331      &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
24332      &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
24333      &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
24334      &9, 9, 9, 85*- 1,7*-1,1,8,-1/
24335
24336       IDT_MCHAD = ITRANS(ITDTU)
24337
24338       RETURN
24339       END
24340
24341 ************************************************************************
24342 *                                                                      *
24343 *   3) Energy-momentum and quantum number conservation check routines  *
24344 *                                                                      *
24345 ************************************************************************
24346 *
24347 *===emc1===============================================================*
24348 *
24349 CDECK  ID>, DT_EMC1
24350       SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
24351
24352 ************************************************************************
24353 * This version dated 15.12.94 is written by S. Roesler                 *
24354 ************************************************************************
24355
24356       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24357       SAVE
24358
24359       PARAMETER ( LINP = 5 ,
24360      &            LOUT = 6 ,
24361      &            LDAT = 9 )
24362
24363       PARAMETER (TINY10=1.0D-10)
24364
24365       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
24366
24367       IREJ = 0
24368
24369       IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
24370      &   WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
24371
24372       IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
24373          IF (MODE.EQ.1) THEN
24374             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
24375          ELSEIF (MODE.EQ.2) THEN
24376             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
24377          ENDIF
24378          CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
24379          CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
24380          CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
24381       ELSEIF (MODE.LT.0) THEN
24382          IF (MODE.EQ.-1) THEN
24383             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
24384          ELSEIF (MODE.EQ.-2) THEN
24385             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
24386          ENDIF
24387          CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
24388          CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
24389          CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
24390       ENDIF
24391
24392       IF (ABS(MODE).EQ.3) THEN
24393          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
24394          IF (IREJ1.NE.0) GOTO 9999
24395       ENDIF
24396       RETURN
24397
24398  9999 CONTINUE
24399       IREJ = 1
24400       RETURN
24401       END
24402 *
24403 *===emc2===============================================================*
24404 *
24405 CDECK  ID>, DT_EMC2
24406       SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
24407      &                                                MODE,IPOS,IREJ)
24408
24409 ************************************************************************
24410 *             MODE = 1   energy-momentum cons. check                   *
24411 *                  = 2   flavor-cons. check                            *
24412 *                  = 3   energy-momentum & flavor cons. check          *
24413 *                  = 4   energy-momentum & charge cons. check          *
24414 *                  = 5   energy-momentum & flavor & charge cons. check *
24415 * This version dated 16.01.95 is written by S. Roesler                 *
24416 ************************************************************************
24417
24418       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24419       SAVE
24420
24421       PARAMETER ( LINP = 5 ,
24422      &            LOUT = 6 ,
24423      &            LDAT = 9 )
24424
24425       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
24426
24427 * event history
24428
24429       PARAMETER (NMXHKK=200000)
24430
24431       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
24432      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
24433      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
24434 * extended event history
24435       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
24436      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
24437      &                IHIST(2,NMXHKK)
24438
24439       IREJ  = 0
24440       IREJ1 = 0
24441       IREJ2 = 0
24442       IREJ3 = 0
24443
24444       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
24445      &                CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
24446       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
24447      &                                CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
24448       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
24449       DO 1 I=1,NHKK
24450          IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
24451      &       (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
24452      &       (ISTHKK(I).EQ.IP5))                          THEN
24453             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
24454      &                                    .OR.(MODE.EQ.5))
24455      &      CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
24456      &                                               2,IDUM,IDUM)
24457             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
24458      &         CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
24459             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
24460      &                            CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
24461          ENDIF
24462          IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
24463      &       (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
24464      &       (ISTHKK(I).EQ.IN5))                          THEN
24465             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
24466      &                                    .OR.(MODE.EQ.5))
24467      &      CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
24468      &                                                   2,IDUM,IDUM)
24469             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
24470      &         CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
24471             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
24472      &                            CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
24473          ENDIF
24474     1 CONTINUE
24475       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
24476      &   CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
24477       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
24478      &   CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
24479       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
24480       IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
24481
24482       RETURN
24483
24484  9999 CONTINUE
24485       IREJ = 1
24486       RETURN
24487       END
24488 *
24489 *===evtemc=============================================================*
24490 *
24491 CDECK  ID>, DT_EVTEMC
24492       SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
24493
24494 ************************************************************************
24495 * This version dated 13.12.94 is written by S. Roesler                 *
24496 ************************************************************************
24497
24498       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24499       SAVE
24500
24501       PARAMETER ( LINP = 5 ,
24502      &            LOUT = 6 ,
24503      &            LDAT = 9 )
24504
24505       PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
24506      &           ZERO=0.0D0)
24507
24508 * event history
24509
24510       PARAMETER (NMXHKK=200000)
24511
24512       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
24513      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
24514      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
24515 * flags for input different options
24516       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
24517       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
24518      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
24519
24520       IREJ = 0
24521
24522       MODE = IMODE
24523       CHKLEV = TINY10
24524       IF (MODE.EQ.4) THEN
24525          CHKLEV = TINY2
24526          MODE   = 3
24527       ELSEIF (MODE.EQ.5) THEN
24528          CHKLEV = TINY1
24529          MODE   = 3
24530       ELSEIF (MODE.EQ.-1) THEN
24531          CHKLEV = EIO
24532          MODE   = 3
24533       ENDIF
24534
24535       IF (ABS(MODE).EQ.3) THEN
24536          PXDEV = PX
24537          PYDEV = PY
24538          PZDEV = PZ
24539          EDEV  = E
24540          IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
24541          IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
24542      &       (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
24543             IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
24544      &         'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
24545      &         '  event  ',NEVHKK,
24546      &         ' ! ',PXDEV,PYDEV,PZDEV,EDEV
24547             PX   = 0.0D0
24548             PY   = 0.0D0
24549             PZ   = 0.0D0
24550             E    = 0.0D0
24551             GOTO 9999
24552          ENDIF
24553          PX   = 0.0D0
24554          PY   = 0.0D0
24555          PZ   = 0.0D0
24556          E    = 0.0D0
24557          RETURN
24558       ENDIF
24559
24560       IF (MODE.EQ.1) THEN
24561          PX = 0.0D0
24562          PY = 0.0D0
24563          PZ = 0.0D0
24564          E  = 0.0D0
24565       ENDIF
24566
24567       PX = PX+PXIO
24568       PY = PY+PYIO
24569       PZ = PZ+PZIO
24570       E  = E+EIO
24571
24572       RETURN
24573
24574  9999 CONTINUE
24575       IREJ = 1
24576       RETURN
24577       END
24578 *
24579 *===evtflc=============================================================*
24580 *
24581 CDECK  ID>, DT_EVTFLC
24582       SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
24583
24584 ************************************************************************
24585 * Flavor conservation check.                                           *
24586 *        ID       identity of particle                                 *
24587 *        ID1 = 1  ID for q,aq,qq,aqaq in PDG-numbering scheme          *
24588 *            = 2  ID for particle/resonance in BAMJET numbering scheme *
24589 *            = 3  ID for particle/resonance in PDG    numbering scheme *
24590 *        MODE = 1 initialization and add ID                            *
24591 *             =-1 initialization and subtract ID                       *
24592 *             = 2 add ID                                               *
24593 *             =-2 subtract ID                                          *
24594 *             = 3 check flavor cons.                                   *
24595 *        IPOS     flag to give position of call of EVTFLC to output    *
24596 *                 unit in case of violation                            *
24597 * This version dated 10.01.95 is written by S. Roesler                 *
24598 ************************************************************************
24599
24600       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24601       SAVE
24602
24603       PARAMETER ( LINP = 5 ,
24604      &            LOUT = 6 ,
24605      &            LDAT = 9 )
24606
24607       PARAMETER (TINY10=1.0D-10)
24608
24609       IREJ = 0
24610
24611       IF (MODE.EQ.3) THEN
24612          IF (IFL.NE.0) THEN
24613             WRITE(LOUT,'(1X,A,I3,A,I3)')
24614      &         'EVTFLC: flavor-conservation failure at pos. ',IPOS,
24615      &         ' !  IFL = ',IFL
24616             IFL = 0
24617             GOTO 9999
24618          ENDIF
24619          IFL = 0
24620          RETURN
24621       ENDIF
24622
24623       IF (MODE.EQ.1) IFL = 0
24624       IF (ID.EQ.0)   RETURN
24625
24626       IF (ID1.EQ.1) THEN
24627          IDD = ABS(ID)
24628          NQ  = 1
24629          IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
24630          IF (IDD.GE.1000) NQ = 3
24631          DO 1 I=1,NQ
24632             IFBAM = IDT_IPDG2B(ID,I,2)
24633             IF (ABS(IFBAM).EQ.1) THEN
24634                IFBAM = SIGN(2,IFBAM)
24635             ELSEIF (ABS(IFBAM).EQ.2) THEN
24636                IFBAM = SIGN(1,IFBAM)
24637             ENDIF
24638             IF (MODE.GT.0) THEN
24639                IFL = IFL+IFBAM
24640             ELSE
24641                IFL = IFL-IFBAM
24642             ENDIF
24643     1    CONTINUE
24644          RETURN
24645       ENDIF
24646
24647       IDD = ID
24648       IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
24649       IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
24650          DO 2 I=1,3
24651             IF (MODE.GT.0) THEN
24652                IFL = IFL+IDT_IQUARK(I,IDD)
24653             ELSE
24654                IFL = IFL-IDT_IQUARK(I,IDD)
24655             ENDIF
24656     2    CONTINUE
24657       ENDIF
24658       RETURN
24659
24660  9999 CONTINUE
24661       IREJ = 1
24662       RETURN
24663       END
24664 *
24665 *===evtchg=============================================================*
24666 *
24667 CDECK  ID>, DT_EVTCHG
24668       SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
24669
24670 ************************************************************************
24671 * Charge conservation check.                                           *
24672 *        ID       identity of particle (PDG-numbering scheme)          *
24673 *        MODE = 1 initialization                                       *
24674 *             =-2 subtract ID-charge                                   *
24675 *             = 2 add ID-charge                                        *
24676 *             = 3 check charge cons.                                   *
24677 *        IPOS     flag to give position of call of EVTCHG to output    *
24678 *                 unit in case of violation                            *
24679 * This version dated 10.01.95 is written by S. Roesler                 *
24680 * Last change: s.r. 21.01.01                                           *
24681 ************************************************************************
24682
24683       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24684       SAVE
24685
24686       PARAMETER ( LINP = 5 ,
24687      &            LOUT = 6 ,
24688      &            LDAT = 9 )
24689
24690 * event history
24691
24692       PARAMETER (NMXHKK=200000)
24693
24694       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
24695      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
24696      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
24697 * particle properties (BAMJET index convention)
24698       CHARACTER*8  ANAME
24699       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24700      &                IICH(210),IIBAR(210),K1(210),K2(210)
24701
24702       IREJ = 0
24703
24704       IF (MODE.EQ.1) THEN
24705          ICH  = 0
24706          IBAR = 0
24707          RETURN
24708       ENDIF
24709
24710       IF (MODE.EQ.3) THEN
24711          IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
24712             WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
24713      &         'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
24714      &         '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
24715             ICH  = 0
24716             IBAR = 0
24717             GOTO 9999
24718          ENDIF
24719          ICH  = 0
24720          IBAR = 0
24721          RETURN
24722       ENDIF
24723
24724       IF (ID.EQ.0)   RETURN
24725
24726       IDD = IDT_ICIHAD(ID)
24727 * modification 21.1.01: use intrinsic phojet-functions to determine charge
24728 * and baryon number
24729 C     IF (IDD.GT.0) THEN
24730 C        IF (MODE.EQ.2) THEN
24731 C           ICH  = ICH+IICH(IDD)
24732 C           IBAR = IBAR+IIBAR(IDD)
24733 C        ELSEIF (MODE.EQ.-2) THEN
24734 C           ICH  = ICH-IICH(IDD)
24735 C           IBAR = IBAR-IIBAR(IDD)
24736 C        ENDIF
24737 C     ELSE
24738 C        WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
24739 C        CALL DT_EVTOUT(4)
24740 C        STOP
24741 C     ENDIF
24742       IF (MODE.EQ.2) THEN
24743          ICH  = ICH+IPHO_CHR3(ID,1)/3
24744          IBAR = IBAR+IPHO_BAR3(ID,1)/3
24745       ELSEIF (MODE.EQ.-2) THEN
24746          ICH  = ICH-IPHO_CHR3(ID,1)/3
24747          IBAR = IBAR-IPHO_BAR3(ID,1)/3
24748       ENDIF
24749
24750       RETURN
24751
24752  9999 CONTINUE
24753       IREJ = 1
24754       RETURN
24755       END
24756
24757 ************************************************************************
24758 *                                                                      *
24759 *                 4) Transformations                                   *
24760 *                                                                      *
24761 ************************************************************************
24762 *
24763 *===ltini==============================================================*
24764 *
24765 CDECK  ID>, DT_LTINI
24766       SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
24767
24768 ************************************************************************
24769 * Initializations of Lorentz-transformations, calculation of Lorentz-  *
24770 * parameters.                                                          *
24771 * This version dated 13.11.95 is written by  S. Roesler.               *
24772 ************************************************************************
24773
24774       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24775       SAVE
24776
24777       PARAMETER ( LINP = 5 ,
24778      &            LOUT = 6 ,
24779      &            LDAT = 9 )
24780
24781       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
24782      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
24783
24784 * Lorentz-parameters of the current interaction
24785       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
24786      &                UMO,PPCM,EPROJ,PPROJ
24787 * properties of photon/lepton projectiles
24788       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
24789 * particle properties (BAMJET index convention)
24790       CHARACTER*8  ANAME
24791       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24792      &                IICH(210),IIBAR(210),K1(210),K2(210)
24793 * nucleon-nucleon event-generator
24794       CHARACTER*8 CMODEL
24795       LOGICAL LPHOIN
24796       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
24797
24798       Q2   = VIRT
24799       IDP  = IDPR
24800       IF (MCGENE.NE.3) THEN
24801 * lepton-projectiles and PHOJET: initialize real photon instead
24802          IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
24803      &       (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
24804      &       (IDPR.EQ. 5).OR.(IDPR.EQ. 6))   THEN
24805             IDP = 7
24806             Q2  = ZERO
24807          ENDIF
24808       ENDIF
24809       IDT  = IDTA
24810       EPN  = EPN0
24811       PPN  = PPN0
24812       ECM  = ECM0
24813       AMP  = AAM(IDP)-SQRT(ABS(Q2))
24814       AMT  = AAM(IDT)
24815       AMP2 = SIGN(AMP**2,AMP)
24816       AMT2 = AMT**2
24817       IF (ECM0.GT.ZERO) THEN
24818          EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
24819          IF (AMP2.GT.ZERO) THEN
24820             PPN = SQRT((EPN+AMP)*(EPN-AMP))
24821          ELSE
24822             PPN = SQRT(EPN**2-AMP2)
24823          ENDIF
24824       ELSE
24825          IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
24826             IF (IDP.EQ.7) EPN = ABS(EPN)
24827             IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
24828             IF (AMP2.GT.ZERO) THEN
24829                PPN = SQRT((EPN+AMP)*(EPN-AMP))
24830             ELSE
24831                PPN = SQRT(EPN**2-AMP2)
24832             ENDIF
24833          ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
24834             IF (AMP2.GT.ZERO) THEN
24835                EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
24836             ELSE
24837                EPN = SQRT(PPN**2+AMP2)
24838             ENDIF
24839          ENDIF
24840          ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
24841       ENDIF
24842       UMO   = ECM
24843       EPROJ = EPN
24844       PPROJ = PPN
24845       IF (AMP2.GT.ZERO) THEN
24846          ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
24847          PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
24848       ELSE
24849          ETARG = TINY10
24850          PTARG = TINY10
24851       ENDIF
24852 * photon-projectiles (get momentum in cm-frame for virtuality Q^2)
24853       IF (IDP.EQ.7) THEN
24854          PGAMM(1) = ZERO
24855          PGAMM(2) = ZERO
24856          AMGAM  = AMP
24857          AMGAM2 = AMP2
24858          IF (ECM0.GT.ZERO) THEN
24859             S = ECM0**2
24860          ELSE
24861             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
24862                S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
24863             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
24864                S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
24865             ENDIF
24866          ENDIF
24867          PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
24868      &                     +AMGAM2**2+AMT2**2)/(4.0D0*S) )
24869          PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
24870          IF (MODE.EQ.1) THEN
24871             PNUCL(1) = ZERO
24872             PNUCL(2) = ZERO
24873             PNUCL(3) = -PGAMM(3)
24874             PNUCL(4) = SQRT(S)-PGAMM(4)
24875          ENDIF
24876       ENDIF
24877       IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
24878      &    (IDPR.EQ.10).OR.(IDPR.EQ.11))   THEN
24879          PLEPT0(1) = ZERO
24880          PLEPT0(2) = ZERO
24881 * neglect lepton masses
24882 C        AMLPT2   = AAM(IDPR)**2
24883          AMLPT2   = ZERO
24884 *
24885          IF (ECM0.GT.ZERO) THEN
24886             S = ECM0**2
24887          ELSE
24888             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
24889                S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
24890             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
24891                S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
24892             ENDIF
24893          ENDIF
24894          PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
24895      &                     +AMLPT2**2+AMT2**2)/(4.0D0*S) )
24896          PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
24897          PNUCL(1) = ZERO
24898          PNUCL(2) = ZERO
24899          PNUCL(3) = -PLEPT0(3)
24900          PNUCL(4) = SQRT(S)-PLEPT0(4)
24901       ENDIF
24902 * Lorentz-parameter for transformation Lab. - projectile rest system
24903       IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
24904          GALAB = TINY10
24905          BGLAB = TINY10
24906          BLAB  = TINY10
24907       ELSE
24908          GALAB = EPROJ/AMP
24909          BGLAB = PPROJ/AMP
24910          BLAB  = BGLAB/GALAB
24911       ENDIF
24912 * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
24913       IF (IDP.EQ.7) THEN
24914          GACMS(1) = TINY10
24915          BGCMS(1) = TINY10
24916       ELSE
24917          GACMS(1) = (ETARG+AMP)/UMO
24918          BGCMS(1) = PTARG/UMO
24919       ENDIF
24920 * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
24921       GACMS(2) = (EPROJ+AMT)/UMO
24922       BGCMS(2) = PPROJ/UMO
24923       PPCM     = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
24924
24925       EPN0 = EPN
24926       PPN0 = PPN
24927       ECM0 = ECM
24928
24929       RETURN
24930       END
24931 *
24932 *===ltrans=============================================================*
24933 *
24934 CDECK  ID>, DT_LTRANS
24935       SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
24936
24937 ************************************************************************
24938 * Lorentz-transformations.                                             *
24939 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
24940 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
24941 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
24942 * This version dated 01.11.95 is written by  S. Roesler.               *
24943 ************************************************************************
24944
24945       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24946       SAVE
24947
24948       PARAMETER ( LINP = 5 ,
24949      &            LOUT = 6 ,
24950      &            LDAT = 9 )
24951
24952       PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
24953
24954       PARAMETER (SQTINF=1.0D+15)
24955
24956 * particle properties (BAMJET index convention)
24957       CHARACTER*8  ANAME
24958       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24959      &                IICH(210),IIBAR(210),K1(210),K2(210)
24960
24961       PXO = PXI
24962       PYO = PYI
24963       CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
24964
24965 * check particle mass for consistency (numerical rounding errors)
24966       PO     = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
24967       AMO2   = (PEO-PO)*(PEO+PO)
24968       AMORQ2 = AAM(ID)**2
24969       AMDIF2 = ABS(AMO2-AMORQ2)
24970       IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
24971          DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
24972          PEO   = PEO+DELTA
24973          PO1   = PO -DELTA
24974          PXO   = PXO*PO1/PO
24975          PYO   = PYO*PO1/PO
24976          PZO   = PZO*PO1/PO
24977 C        WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
24978       ENDIF
24979
24980       RETURN
24981       END
24982 *
24983 *===ltnuc==============================================================*
24984 *
24985 CDECK  ID>, DT_LTNUC
24986       SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
24987
24988 ************************************************************************
24989 * Lorentz-transformations.                                             *
24990 *   PIN        longitudnal momentum       (input)                      *
24991 *   EIN        energy                     (input)                      *
24992 *   POUT       transformed long. momentum (output)                     *
24993 *   EOUT       transformed energy         (output)                     *
24994 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
24995 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
24996 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
24997 * This version dated 01.11.95 is written by  S. Roesler.               *
24998 ************************************************************************
24999
25000       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25001       SAVE
25002
25003       PARAMETER ( LINP = 5 ,
25004      &            LOUT = 6 ,
25005      &            LDAT = 9 )
25006
25007       PARAMETER (ZERO=0.0D0)
25008
25009 * Lorentz-parameters of the current interaction
25010       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
25011      &                UMO,PPCM,EPROJ,PPROJ
25012
25013       BDUM1 = ZERO
25014       BDUM2 = ZERO
25015       PDUM1 = ZERO
25016       PDUM2 = ZERO
25017       IF (ABS(MODE).EQ.1) THEN
25018          BG = -SIGN(BGLAB,DBLE(MODE))
25019          CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
25020      &                               DUM1,DUM2,DUM3,POUT,EOUT)
25021       ELSEIF (ABS(MODE).EQ.2) THEN
25022          BG = SIGN(BGCMS(1),DBLE(MODE))
25023          CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
25024      &                               DUM1,DUM2,DUM3,POUT,EOUT)
25025       ELSEIF (ABS(MODE).EQ.3) THEN
25026          BG = -SIGN(BGCMS(2),DBLE(MODE))
25027          CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
25028      &                               DUM1,DUM2,DUM3,POUT,EOUT)
25029       ELSE
25030          WRITE(LOUT,1000) MODE
25031  1000    FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
25032          EOUT = EIN
25033          POUT = PIN
25034       ENDIF
25035
25036       RETURN
25037       END
25038 *
25039 *===daltra=============================================================*
25040 *
25041 CDECK  ID>, DT_DALTRA
25042       SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
25043
25044 ************************************************************************
25045 * Arbitrary Lorentz-transformation.                                    *
25046 * Adopted from the original by S. Roesler. This version dated 15.01.95 *
25047 ************************************************************************
25048
25049       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25050       SAVE
25051       PARAMETER (ONE=1.0D0)
25052
25053       EP = PCX*BGX+PCY*BGY+PCZ*BGZ
25054       PE = EP/(GA+ONE)+EC
25055       PX = PCX+BGX*PE
25056       PY = PCY+BGY*PE
25057       PZ = PCZ+BGZ*PE
25058       P  = SQRT(PX*PX+PY*PY+PZ*PZ)
25059       E  = GA*EC+EP
25060
25061       RETURN
25062       END
25063 *
25064 *====dtrafo============================================================*
25065 *
25066 CDECK  ID>, DT_DTRAFO
25067       SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
25068      &                                    PL,CXL,CYL,CZL,EL)
25069
25070 C     LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
25071
25072       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25073       SAVE
25074
25075       IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
25076       SID  = SQRT(1.D0-COD*COD)
25077       PLX  = P*SID*COF
25078       PLY  = P*SID*SIF
25079       PCMZ = P*COD
25080       PLZ  = GAM*PCMZ+BGAM*ECM
25081       PL   = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
25082       EL   = GAM*ECM+BGAM*PCMZ
25083 C     ROTATION INTO THE ORIGINAL DIRECTION
25084       COZ  = PLZ/PL
25085       SIZ  = SQRT(1.D0-COZ**2)
25086       CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
25087
25088       RETURN
25089       END
25090 *
25091 *====sttran============================================================*
25092 *
25093 CDECK  ID>, DT_STTRAN
25094       SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
25095
25096       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25097       SAVE
25098       DATA ANGLSQ/1.D-30/
25099 ************************************************************************
25100 *     VERSION BY                     J. RANFT                          *
25101 *                                    LEIPZIG                           *
25102 *                                                                      *
25103 *     THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES      *
25104 *                                                                      *
25105 *     INPUT VARIABLES:                                                 *
25106 *        XO,YO,ZO = ORIGINAL DIRECTION COSINES                         *
25107 *        CDE,SDE  = COSINE AND SINE OF THE POLAR (THETA)               *
25108 *                   ANGLE OF "SCATTERING"                              *
25109 *        SDE      = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING"    *
25110 *        SFE,CFE  = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE       *
25111 *                   OF "SCATTERING"                                    *
25112 *                                                                      *
25113 *     OUTPUT VARIABLES:                                                *
25114 *        X,Y,Z     = NEW DIRECTION COSINES                             *
25115 *                                                                      *
25116 *     ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 )                  *
25117 ************************************************************************
25118 *
25119 *
25120 *  Changed by A. Ferrari
25121 *
25122 *     IF (ABS(XO)-0.0001D0) 1,1,2
25123 *   1 IF (ABS(YO)-0.0001D0) 3,3,2
25124 *   3 CONTINUE
25125       A = XO**2 + YO**2
25126       IF ( A .LT. ANGLSQ ) THEN
25127          X=SDE*CFE
25128          Y=SDE*SFE
25129          Z=CDE*ZO
25130       ELSE
25131          XI=SDE*CFE
25132          YI=SDE*SFE
25133          ZI=CDE
25134          A=SQRT(A)
25135          X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
25136          Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
25137          Z=A*YI+ZO*ZI
25138       ENDIF
25139
25140       RETURN
25141       END
25142 *
25143 *===mytran=============================================================*
25144 *
25145 CDECK  ID>, DT_MYTRAN
25146       SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
25147
25148 ************************************************************************
25149 * This subroutine rotates the coordinate frame                         *
25150 *    a) theta  around y                                                *
25151 *    b) phi    around z      if IMODE = 1                              *
25152 *                                                                      *
25153 *     x'          cos(ph) -sin(ph) 0      cos(th)  0  sin(th)   x      *
25154 *     y' = A B =  sin(ph) cos(ph)  0  .   0        1        0   y      *
25155 *     z'          0       0        1     -sin(th)  0  cos(th)   z      *
25156 *                                                                      *
25157 * and vice versa if IMODE = 0.                                         *
25158 * This version dated 5.4.94 is based on the original version DTRAN     *
25159 * by J. Ranft and is written by S. Roesler.                            *
25160 ************************************************************************
25161
25162       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25163       SAVE
25164
25165       PARAMETER ( LINP = 5 ,
25166      &            LOUT = 6 ,
25167      &            LDAT = 9 )
25168
25169       IF (IMODE.EQ.1) THEN
25170          X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
25171          Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
25172          Z=-SDE    *XO       +CDE    *ZO
25173       ELSE
25174          X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
25175          Y= -SFE*XO+CFE*YO
25176          Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
25177       ENDIF
25178       RETURN
25179       END
25180 *
25181 *===lt2lab=============================================================*
25182 *
25183 CDECK  ID>, DT_LT2LAO
25184       SUBROUTINE DT_LT2LAO
25185
25186 ************************************************************************
25187 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
25188 * for final state particles/fragments defined in nucleon-nucleon-cms   *
25189 * and transforms them back to the lab.                                 *
25190 * This version dated 16.11.95 is written by S. Roesler                 *
25191 ************************************************************************
25192
25193       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25194       SAVE
25195
25196       PARAMETER ( LINP = 5 ,
25197      &            LOUT = 6 ,
25198      &            LDAT = 9 )
25199
25200 * event history
25201
25202       PARAMETER (NMXHKK=200000)
25203
25204       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25205      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25206      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25207 * extended event history
25208       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25209      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25210      &                IHIST(2,NMXHKK)
25211
25212       NEND      = NHKK
25213       NPOINT(5) = NHKK+1
25214       IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
25215       DO 1 I=NPOINT(4),NEND
25216 C     DO 1 I=1,NEND
25217          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
25218      &                                (ISTHKK(I).EQ.1001)) THEN
25219             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
25220             NOB = NOBAM(I)
25221             CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
25222      &                            PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
25223             IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
25224                ISTHKK(I) = 3*ISTHKK(I)
25225                NOBAM(NHKK)  = NOB
25226             ELSE
25227                IF (ISTHKK(I).EQ.-1) NOBAM(NHKK)  = NOB
25228                ISTHKK(I) = SIGN(3,ISTHKK(I))
25229             ENDIF
25230             JDAHKK(1,I) = NHKK
25231          ENDIF
25232     1 CONTINUE
25233
25234       RETURN
25235       END
25236 *
25237 *===lt2lab=============================================================*
25238 *
25239 CDECK  ID>, DT_LT2LAB
25240       SUBROUTINE DT_LT2LAB
25241
25242 ************************************************************************
25243 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
25244 * for final state particles/fragments defined in nucleon-nucleon-cms   *
25245 * and transforms them to the lab.                                      *
25246 * This version dated 07.01.96 is written by S. Roesler                 *
25247 ************************************************************************
25248
25249       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25250       SAVE
25251
25252       PARAMETER ( LINP = 5 ,
25253      &            LOUT = 6 ,
25254      &            LDAT = 9 )
25255
25256 * event history
25257
25258       PARAMETER (NMXHKK=200000)
25259
25260       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25261      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25262      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25263 * extended event history
25264       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25265      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25266      &                IHIST(2,NMXHKK)
25267
25268       IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
25269       DO 1 I=NPOINT(4),NHKK
25270          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
25271      &                                (ISTHKK(I).EQ.1001)) THEN
25272             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
25273             PHKK(3,I) = PZ
25274             PHKK(4,I) = PE
25275          ENDIF
25276     1 CONTINUE
25277
25278       RETURN
25279       END
25280
25281 ************************************************************************
25282 *                                                                      *
25283 *                 5) Sampling from distributions                       *
25284 *                                                                      *
25285 ************************************************************************
25286 *
25287 *===npoiss=============================================================*
25288 *
25289 CDECK  ID>, IDT_NPOISS
25290       INTEGER FUNCTION IDT_NPOISS(AVN)
25291
25292 ************************************************************************
25293 * Sample according to Poisson distribution with Poisson parameter AVN. *
25294 * The original version written by J. Ranft.                            *
25295 * This version dated 11.1.95 is written by S. Roesler.                 *
25296 ************************************************************************
25297
25298       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25299       SAVE
25300
25301       PARAMETER ( LINP = 5 ,
25302      &            LOUT = 6 ,
25303      &            LDAT = 9 )
25304
25305       EXPAVN = EXP(-AVN)
25306       K = 1
25307       A = 1.0D0
25308
25309    10 CONTINUE
25310       A = DT_RNDM(A)*A
25311       IF (A.GE.EXPAVN) THEN
25312          K = K+1
25313          GOTO 10
25314       ENDIF
25315       IDT_NPOISS = K-1
25316
25317       RETURN
25318       END
25319 *
25320 *===sampxb=============================================================*
25321 *
25322 CDECK  ID>, DT_SAMPXB
25323       DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
25324
25325 ************************************************************************
25326 * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2.             *
25327 * Processed by S. Roesler, 6.5.95                                      *
25328 ************************************************************************
25329
25330       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25331       SAVE
25332       PARAMETER (TWO=2.0D0)
25333
25334       A1 = LOG(X1+SQRT(X1**2+B**2))
25335       A2 = LOG(X2+SQRT(X2**2+B**2))
25336       AN = A2-A1
25337       A  = AN*DT_RNDM(A1)+A1
25338       BB = EXP(A)
25339       DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
25340
25341       RETURN
25342       END
25343 *
25344 *===sampex=============================================================*
25345 *
25346 CDECK  ID>, DT_SAMPEX
25347       DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
25348
25349 ************************************************************************
25350 * Sampling from f(x)=1./x between x1 and x2.                           *
25351 * Processed by S. Roesler, 6.5.95                                      *
25352 ************************************************************************
25353
25354       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25355       SAVE
25356       PARAMETER (ONE=1.0D0)
25357
25358       R   = DT_RNDM(X1)
25359       AL1 = LOG(X1)
25360       AL2 = LOG(X2)
25361       DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
25362
25363       RETURN
25364       END
25365 *
25366 *===samsqx=============================================================*
25367 *
25368 CDECK  ID>, DT_SAMSQX
25369       DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
25370
25371 ************************************************************************
25372 * Sampling from f(x)=1./x^0.5 between x1 and x2.                       *
25373 * Processed by S. Roesler, 6.5.95                                      *
25374 ************************************************************************
25375
25376       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25377       SAVE
25378       PARAMETER (ONE=1.0D0)
25379
25380       R = DT_RNDM(X1)
25381       DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
25382
25383       RETURN
25384       END
25385 *
25386 *===samplw=============================================================*
25387 *
25388 CDECK  ID>, DT_SAMPLW
25389       DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
25390
25391 ************************************************************************
25392 * Sampling from f(x)=1/x^b between x_min and x_max.                    *
25393 * S. Roesler, 18.4.98                                                  *
25394 ************************************************************************
25395
25396       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25397       SAVE
25398       PARAMETER (ONE=1.0D0)
25399
25400       R = DT_RNDM(B)
25401       IF (B.EQ.ONE) THEN
25402          DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
25403       ELSE
25404          ONEMB  = ONE-B
25405          DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
25406       ENDIF
25407
25408       RETURN
25409       END
25410 *
25411 *===betrej=============================================================*
25412 *
25413 CDECK  ID>, DT_BETREJ
25414       DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
25415
25416       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25417       SAVE
25418
25419       PARAMETER ( LINP = 5 ,
25420      &            LOUT = 6 ,
25421      &            LDAT = 9 )
25422
25423       PARAMETER (ONE=1.0D0)
25424
25425       IF (XMIN.GE.XMAX)THEN
25426          WRITE (LOUT,500) XMIN,XMAX
25427   500    FORMAT(1X,'DT_BETREJ:  XMIN<XMAX execution stopped ',2F10.5)
25428          STOP
25429       ENDIF
25430
25431    10 CONTINUE
25432       XX     = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
25433       BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
25434       YY     = BETMAX*DT_RNDM(XX)
25435       BETXX  = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
25436       IF (YY.GT.BETXX) GOTO 10
25437       DT_BETREJ = XX
25438
25439       RETURN
25440       END
25441 *
25442 *===dgamrn=============================================================*
25443 *
25444 CDECK  ID>, DT_DGAMRN
25445       DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
25446
25447 ************************************************************************
25448 * Sampling from Gamma-distribution.                                    *
25449 *       F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)            *
25450 * Processed by S. Roesler, 6.5.95                                      *
25451 ************************************************************************
25452
25453       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25454       SAVE
25455       PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
25456
25457       NCOU = 0
25458       N    = INT(ETA)
25459       F    = ETA-DBLE(N)
25460       IF (F.EQ.ZERO) GOTO 20
25461    10 R = DT_RNDM(F)
25462       NCOU = NCOU+1
25463       IF (NCOU.GE.11) GOTO 20
25464       IF (R.LT.F/(F+2.71828D0)) GOTO 30
25465       YYY = LOG(DT_RNDM(R)+TINY9)/F
25466       IF (ABS(YYY).GT.50.0D0) GOTO 20
25467       Y = EXP(YYY)
25468       IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
25469       GOTO 40
25470    20 Y = 0.0D0
25471       GOTO 50
25472    30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
25473       IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
25474    40 IF (N.EQ.0) GOTO 70
25475    50 Z = 1.0D0
25476       DO 60 I = 1,N
25477    60 Z = Z*DT_RNDM(Z)
25478       Y = Y-LOG(Z+TINY9)
25479    70 DT_DGAMRN = Y/ALAM
25480
25481       RETURN
25482       END
25483 *
25484 *===dbetar=============================================================*
25485 *
25486 CDECK  ID>, DT_DBETAR
25487       DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
25488
25489 ************************************************************************
25490 * Sampling from Beta -distribution between 0.0 and 1.0                 *
25491 *  F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
25492 * Processed by S. Roesler, 6.5.95                                      *
25493 ************************************************************************
25494
25495       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25496       SAVE
25497
25498       Y = DT_DGAMRN(1.0D0,GAM)
25499       Z = DT_DGAMRN(1.0D0,ETA)
25500       DT_DBETAR = Y/(Y+Z)
25501
25502       RETURN
25503       END
25504 *
25505 *===rannor=============================================================*
25506 *
25507 CDECK  ID>, DT_RANNOR
25508       SUBROUTINE DT_RANNOR(X,Y)
25509
25510 ************************************************************************
25511 * Sampling from Gaussian distribution.                                 *
25512 * Processed by S. Roesler, 6.5.95                                      *
25513 ************************************************************************
25514
25515       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25516       SAVE
25517       PARAMETER (TINY10=1.0D-10)
25518
25519       CALL DT_DSFECF(SFE,CFE)
25520       V = MAX(TINY10,DT_RNDM(X))
25521       A = SQRT(-2.D0*LOG(V))
25522       X = A*SFE
25523       Y = A*CFE
25524
25525       RETURN
25526       END
25527 *
25528 *===dpoli==============================================================*
25529 *
25530 CDECK  ID>, DT_DPOLI
25531       SUBROUTINE DT_DPOLI(CS,SI)
25532
25533       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25534       SAVE
25535
25536       U  = DT_RNDM(CS)
25537       CS = DT_RNDM(U)
25538       IF (U.LT.0.5D0) CS=-CS
25539       SI = SQRT(1.0D0-CS*CS+1.0D-10)
25540
25541       RETURN
25542       END
25543 *
25544 *===dsfecf=============================================================*
25545 *
25546 CDECK  ID>, DT_DSFECF
25547       SUBROUTINE DT_DSFECF(SFE,CFE)
25548
25549       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25550       SAVE
25551       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
25552
25553     1 CONTINUE
25554       X  = DT_RNDM(SFE)
25555       Y  = DT_RNDM(X)
25556       XX = X*X
25557       YY = Y*Y
25558       XY = XX+YY
25559       IF (XY.GT.ONE) GOTO 1
25560       CFE = (XX-YY)/XY
25561       SFE = TWO*X*Y/XY
25562       IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
25563       RETURN
25564       END
25565 *
25566 *===raco===============================================================*
25567 *
25568 CDECK  ID>, DT_RACO
25569       SUBROUTINE DT_RACO(WX,WY,WZ)
25570
25571 ************************************************************************
25572 * Direction cosines of random uniform (isotropic) direction in three   *
25573 * dimensional space                                                    *
25574 * Processed by S. Roesler, 20.11.95                                    *
25575 ************************************************************************
25576
25577       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25578       SAVE
25579       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
25580
25581   10  CONTINUE
25582       X  = TWO*DT_RNDM(WX)-ONE
25583       Y  = DT_RNDM(X)
25584       X2 = X*X
25585       Y2 = Y*Y
25586       IF (X2+Y2.GT.ONE) GOTO 10
25587
25588       CFE = (X2-Y2)/(X2+Y2)
25589       SFE = TWO*X*Y/(X2+Y2)
25590 * z = 1/2 [ 1 + cos (theta) ]
25591       Z   = DT_RNDM(X)
25592 * 1/2 sin (theta)
25593       WZ = SQRT(Z*(ONE-Z))
25594       WX = TWO*WZ*CFE
25595       WY = TWO*WZ*SFE
25596       WZ = TWO*Z-ONE
25597
25598       RETURN
25599       END
25600
25601 ************************************************************************
25602 *                                                                      *
25603 *           6) Special functions, algorithms and service routines      *
25604 *                                                                      *
25605 ************************************************************************
25606 *
25607 *===ylamb==============================================================*
25608 *
25609 CDECK  ID>, DT_YLAMB
25610       DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
25611
25612 ************************************************************************
25613 *                                                                      *
25614 *     auxiliary function for three particle decay mode                 *
25615 *     (standard LAMBDA**(1/2) function)                                *
25616 *                                                                      *
25617 * Adopted from an original version written by R. Engel.                *
25618 * This version dated 12.12.94 is written by S. Roesler.                *
25619 ************************************************************************
25620
25621       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25622       SAVE
25623
25624       YZ   = Y-Z
25625       XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
25626       IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
25627       DT_YLAMB = SQRT(XLAM)
25628
25629       RETURN
25630       END
25631 *
25632 *===sort1==============================================================*
25633 *
25634 CDECK  ID>, DT_SORT
25635       SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
25636
25637 ************************************************************************
25638 * This subroutine sorts entries in A in increasing/decreasing order    *
25639 * of A(3,i).                                                           *
25640 *              MODE  = 1     increasing in A(3,i=1..N)                 *
25641 *                    = 2     decreasing in A(3,i=1..N)                 *
25642 * This version dated 21.04.95 is revised by S. Roesler                 *
25643 ************************************************************************
25644
25645       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25646       SAVE
25647
25648       DIMENSION A(3,N)
25649
25650       M = I1
25651    10 CONTINUE
25652       M = I1-1
25653       IF (M.LE.0) RETURN
25654       L = 0
25655       DO 20 I=I0,M
25656          J = I+1
25657          IF (MODE.EQ.1) THEN
25658             IF (A(3,I).LE.A(3,J)) GOTO 20
25659          ELSE
25660             IF (A(3,I).GE.A(3,J)) GOTO 20
25661          ENDIF
25662          B = A(3,I)
25663          C = A(1,I)
25664          D = A(2,I)
25665          A(3,I) = A(3,J)
25666          A(2,I) = A(2,J)
25667          A(1,I) = A(1,J)
25668          A(3,J) = B
25669          A(1,J) = C
25670          A(2,J) = D
25671          L = 1
25672    20 CONTINUE
25673       IF (L.EQ.1) GOTO 10
25674
25675       RETURN
25676       END
25677 *
25678 *===sort1==============================================================*
25679 *
25680 CDECK  ID>, DT_SORT1
25681       SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
25682
25683 ************************************************************************
25684 * This subroutine sorts entries in A in increasing/decreasing order    *
25685 * of A(i).                                                             *
25686 *              MODE  = 1     increasing in A(i=1..N)                   *
25687 *                    = 2     decreasing in A(i=1..N)                   *
25688 * This version dated 21.04.95 is revised by S. Roesler                 *
25689 ************************************************************************
25690
25691       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25692       SAVE
25693
25694       DIMENSION A(N),IDX(N)
25695
25696       M = I1
25697    10 CONTINUE
25698       M = I1-1
25699       IF (M.LE.0) RETURN
25700       L = 0
25701       DO 20 I=I0,M
25702          J = I+1
25703          IF (MODE.EQ.1) THEN
25704             IF (A(I).LE.A(J)) GOTO 20
25705          ELSE
25706             IF (A(I).GE.A(J)) GOTO 20
25707          ENDIF
25708          B    = A(I)
25709          A(I) = A(J)
25710          A(J) = B
25711          IX     = IDX(I)
25712          IDX(I) = IDX(J)
25713          IDX(J) = IX
25714          L = 1
25715    20 CONTINUE
25716       IF (L.EQ.1) GOTO 10
25717
25718       RETURN
25719       END
25720 *
25721 *===xtime==============================================================*
25722 *
25723 CDECK  ID>, DT_XTIME
25724       SUBROUTINE DT_XTIME
25725
25726       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25727       SAVE
25728
25729       PARAMETER ( LINP = 5 ,
25730      &            LOUT = 6 ,
25731      &            LDAT = 9 )
25732
25733       CHARACTER DAT*9,TIM*11
25734
25735       DAT = '         '
25736       TIM = '           '
25737 C     CALL GETDAT(IYEAR,IMONTH,IDAY)
25738 C     CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
25739
25740 C     CALL DATE(DAT)
25741 C     CALL TIME(TIM)
25742 C     WRITE(LOUT,1000) DAT,TIM
25743  1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
25744
25745       RETURN
25746       END
25747
25748 ************************************************************************
25749 *                                                                      *
25750 *                 7) Random number generator package                   *
25751 *                                                                      *
25752 *    THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND        *
25753 *    SERVICE ROUTINES.                                                 *
25754 *    THE ALGORITHM IS FROM                                             *
25755 *      'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR'                     *
25756 *      G.MARSAGLIA, A.ZAMAN ;  FSU-SCRI-87-50                          *
25757 *    IMPLEMENTATION BY K. HAHN  DEC. 88,                               *
25758 *    THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
25759 *    AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ),        *
25760 *    THE PERIOD IS ABOUT 2**144,                                       *
25761 *    TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS,            *
25762 *    THE PACKAGE CONTAINS                                              *
25763 *      FUNCTION DT_RNDM(I)                  : GENERATOR                *
25764 *      SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION           *
25765 *      SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)  : PUT SEED TO GENERATOR    *
25766 *      SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)  : TAKE SEED FROM GENERATOR *
25767 *      SUBROUTINE DT_RNDMTE(IO)             : TEST OF GENERATOR        *
25768 *---                                                                   *
25769 *    FUNCTION DT_RNDM(I)                                               *
25770 *       GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS  IN (0..1)          *
25771 *       I  - DUMMY VARIABLE, NOT USED                                  *
25772 *    SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)                             *
25773 *       INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
25774 *       NA1,NA2,NA3,NB1  - VALUES FOR INITIALIZING THE GENERATOR       *
25775 *                          NA? MUST BE IN 1..178 AND NOT ALL 1         *
25776 *                          12,34,56  ARE THE STANDARD VALUES           *
25777 *                          NB1 MUST BE IN 1..168                       *
25778 *                          78  IS THE STANDARD VALUE                   *
25779 *    SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)                               *
25780 *       PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS   *
25781 *       AS AFTER THE LAST DT_RNDMOU CALL )                             *
25782 *       U(97),C,CD,CM,I,J  - SEED VALUES AS TAKEN FROM DT_RNDMOU       *
25783 *    SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)                               *
25784 *       TAKES SEED FROM GENERATOR                                      *
25785 *       U(97),C,CD,CM,I,J  - SEED VALUES                               *
25786 *    SUBROUTINE DT_RNDMTE(IO)                                          *
25787 *       TEST OF THE GENERATOR                                          *
25788 *       IO     - DEFINES OUTPUT                                        *
25789 *                  = 0  OUTPUT ONLY IF AN ERROR IS DETECTED            *
25790 *                  = 1  OUTPUT INDEPENDEND ON AN ERROR                 *
25791 *       DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO   *
25792 *       SAME STATUS                                                    *
25793 *       AS BEFORE CALL OF DT_RNDMTE                                    *
25794 ************************************************************************
25795 *
25796 *===rndm===============================================================*
25797 *
25798 CDECK  ID>, DT_RNDM
25799       DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
25800
25801       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25802       SAVE
25803
25804 * counter of calls to random number generator
25805 * uncomment if needed
25806 C     COMMON /DTRNCT/ IRNCT0,IRNCT1
25807 C     LOGICAL LFIRST
25808 C     DATA LFIRST /.TRUE./
25809
25810 * counter of calls to random number generator
25811 * uncomment if needed
25812 C     IF (LFIRST) THEN
25813 C        IRNCT0 = 0
25814 C        IRNCT1 = 0
25815 C        LFIRST = .FALSE.
25816 C     ENDIF
25817
25818       DT_RNDM = FLRNDM(VDUMMY)
25819 * counter of calls to random number generator
25820 * uncomment if needed
25821 C     IRNCT1 = IRNCT1+1
25822
25823       RETURN
25824       END
25825 *
25826 *===rndmst=============================================================*
25827 *
25828 CDECK  ID>, DT_RNDMST
25829       SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
25830
25831       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25832       SAVE
25833
25834 * random number generator
25835       COMMON /DTRAND/ U(97),C,CD,CM,I,J
25836
25837       MA1 = NA1
25838       MA2 = NA2
25839       MA3 = NA3
25840       MB1 = NB1
25841       I   = 97
25842       J   = 33
25843       DO 20 II2 = 1,97
25844         S = 0
25845         T = 0.5D0
25846         DO 10 II1 = 1,24
25847           MAT  = MOD(MOD(MA1*MA2,179)*MA3,179)
25848           MA1  = MA2
25849           MA2  = MA3
25850           MA3  = MAT
25851           MB1  = MOD(53*MB1+1,169)
25852           IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
25853    10   T = 0.5D0*T
25854    20 U(II2) = S
25855       C  =   362436.0D0/16777216.0D0
25856       CD =  7654321.0D0/16777216.0D0
25857       CM = 16777213.0D0/16777216.0D0
25858       RETURN
25859       END
25860 *
25861 *===rndmin=============================================================*
25862 *
25863 CDECK  ID>, DT_RNDMIN
25864       SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
25865
25866       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25867       SAVE
25868
25869 * random number generator
25870       COMMON /DTRAND/ U(97),C,CD,CM,I,J
25871
25872       DIMENSION UIN(97)
25873
25874       DO 10 KKK = 1,97
25875    10 U(KKK) = UIN(KKK)
25876       C  = CIN
25877       CD = CDIN
25878       CM = CMIN
25879       I  = IIN
25880       J  = JIN
25881
25882       RETURN
25883       END
25884 *
25885 *===rndmou=============================================================*
25886 *
25887 CDECK  ID>, DT_RNDMOU
25888       SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
25889
25890       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25891       SAVE
25892
25893 * random number generator
25894       COMMON /DTRAND/ U(97),C,CD,CM,I,J
25895
25896       DIMENSION UOUT(97)
25897
25898       DO 10 KKK = 1,97
25899    10 UOUT(KKK) = U(KKK)
25900       COUT  = C
25901       CDOUT = CD
25902       CMOUT = CM
25903       IOUT  = I
25904       JOUT  = J
25905
25906       RETURN
25907       END
25908 *
25909 *===rndmte=============================================================*
25910 *
25911 CDECK  ID>, DT_RNDMTE
25912       SUBROUTINE DT_RNDMTE(IO)
25913
25914       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25915       SAVE
25916
25917       DIMENSION UU(97),U(6),X(6),D(6)
25918       DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
25919      +8354498.D0, 10633180.D0/
25920
25921       CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
25922       CALL DT_RNDMST(12,34,56,78)
25923       DO 10 II1 = 1,20000
25924    10 XX = DT_RNDM(XX)
25925       SD        = 0.0D0
25926       DO 20 II2 = 1,6
25927         X(II2)  = 4096.D0*(4096.D0*DT_RNDM(SD))
25928         D(II2)  = X(II2)-U(II2)
25929    20 SD = SD+D(II2)
25930       CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
25931 **sr 24.01.95
25932 C     IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
25933       IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
25934 C        WRITE(6,1000)
25935  1000    FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
25936      &          ' passed')
25937       ENDIF
25938 **
25939       RETURN
25940   500 FORMAT('  === TEST OF THE RANDOM-GENERATOR ===',/,
25941      &'    EXPECTED VALUE    CALCULATED VALUE     DIFFERENCE',/, 6(F17.
25942      &1,F20.1,F15.3,/), '  === END OF TEST ;',
25943      &'  GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
25944       END
25945 *
25946 *
25947 *===title==============================================================*
25948 *
25949 CDECK  ID>, DT_TITLE
25950       SUBROUTINE DT_TITLE
25951
25952       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25953       SAVE
25954
25955       PARAMETER ( LINP = 5 ,
25956      &            LOUT = 6 ,
25957      &            LDAT = 9 )
25958
25959       CHARACTER*6 CVERSI
25960       CHARACTER*11 CCHANG
25961       DATA CVERSI,CCHANG /'3.0-4 ','18 Sep 2001'/
25962
25963       CALL DT_XTIME
25964       WRITE(LOUT,1000) CVERSI,CCHANG
25965  1000 FORMAT(1X,'+-------------------------------------------------',
25966      &                  '----------------------+',/,
25967      &     1X,'|',71X,'|',/,
25968      &     1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
25969      &     1X,'|',71X,'|',/,
25970      &     1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
25971      &     1X,'|',71X,'|',/,
25972      &     1X,'|',12X,'Authors: Stefan Roesler   (CERN)',27X,'|',/,
25973      &     1X,'|',21X,'Ralph Engel      (Bartol Res. Inst.)',14X,'|',/,
25974      &     1X,'|',21X,'Johannes Ranft   (Siegen Univ.)',19X,'|',/,
25975      &     1X,'|',71X,'|',/,
25976      &     1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
25977      &                                              17X,'|',/,
25978      &     1X,'|',71X,'|',/,
25979      &     1X,'+-------------------------------------------------',
25980      &                '----------------------+',/,
25981      &     1X,'| Please send suggestions, bug reports, etc. to: ',
25982      &                                  'Stefan.Roesler@cern.ch |',/,
25983      &     1X,'+-------------------------------------------------',
25984      &                '----------------------+',/)
25985
25986       RETURN
25987       END
25988 *
25989 *===evtini=============================================================*
25990 *
25991 CDECK  ID>, DT_EVTINI
25992       SUBROUTINE DT_EVTINI
25993
25994 ************************************************************************
25995 * Initialization of DTEVT1.                                            *
25996 * This version dated 15.01.94 is written by S. Roesler                 *
25997 ************************************************************************
25998
25999       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26000       SAVE
26001
26002       PARAMETER ( LINP = 5 ,
26003      &            LOUT = 6 ,
26004      &            LDAT = 9 )
26005
26006 * event history
26007
26008       PARAMETER (NMXHKK=200000)
26009
26010       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26011      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26012      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26013 * extended event history
26014       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26015      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26016      &                IHIST(2,NMXHKK)
26017 * event flag
26018       COMMON /DTEVNO/ NEVENT,ICASCA
26019
26020       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
26021
26022 * emulsion treatment
26023       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
26024      &                NCOMPO,IEMUL
26025
26026 * initialization of DTEVT1/DTEVT2
26027       NEND = NHKK
26028       IF (NEVENT.EQ.1) NEND = NMXHKK
26029       NHKK   = 0
26030       NEVHKK = NEVENT
26031       DO 1 I=1,NEND
26032          ISTHKK(I)   = 0
26033          IDHKK(I)    = 0
26034          JMOHKK(1,I) = 0
26035          JMOHKK(2,I) = 0
26036          JDAHKK(1,I) = 0
26037          JDAHKK(2,I) = 0
26038          IDRES(I)    = 0
26039          IDXRES(I)   = 0
26040          NOBAM(I)    = 0
26041          IDCH(I)     = 0
26042          IHIST(1,I)  = 0
26043          IHIST(2,I)  = 0
26044          DO 2 J=1,4
26045             PHKK(J,I) = 0.0D0
26046             VHKK(J,I) = 0.0D0
26047             WHKK(J,I) = 0.0D0
26048     2    CONTINUE
26049          PHKK(5,I) = 0.0D0
26050     1 CONTINUE
26051       DO 3 I=1,10
26052          NPOINT(I) = 0
26053     3 CONTINUE
26054       CALL DT_CHASTA(-1)
26055
26056 C* initialization of DTLTRA
26057 C      IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
26058
26059       RETURN
26060       END
26061 *
26062 *===statis=============================================================*
26063 *
26064 CDECK  ID>, DT_STATIS
26065       SUBROUTINE DT_STATIS(MODE)
26066
26067 ************************************************************************
26068 * Initialization and output of run-statistics.                         *
26069 *              MODE  = 1     initialization                            *
26070 *                    = 2     output                                    *
26071 * This version dated 23.01.94 is written by S. Roesler                 *
26072 ************************************************************************
26073
26074       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26075       SAVE
26076
26077       PARAMETER ( LINP = 5 ,
26078      &            LOUT = 6 ,
26079      &            LDAT = 9 )
26080
26081       PARAMETER (TINY3=1.0D-3)
26082
26083 * statistics
26084       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
26085      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
26086      &                ICEVTG(8,0:30)
26087 * rejection counter
26088       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
26089      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
26090      &                IREXCI(3),IRDIFF(2),IRINC
26091 * central particle production, impact parameter biasing
26092       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
26093 * various options for treatment of partons (DTUNUC 1.x)
26094 * (chain recombination, Cronin,..)
26095       LOGICAL LCO2CR,LINTPT
26096       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
26097      &                LCO2CR,LINTPT
26098 * nucleon-nucleon event-generator
26099       CHARACTER*8 CMODEL
26100       LOGICAL LPHOIN
26101       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26102 * flags for particle decays
26103       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
26104      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
26105      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
26106 * diquark-breaking mechanism
26107       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
26108
26109       DIMENSION PP(4),PT(4)
26110
26111       GOTO (1,2) MODE
26112
26113 * initialization
26114     1 CONTINUE
26115
26116 *   initialize statistics counter
26117       ICREQU = 0
26118       ICSAMP = 0
26119       ICCPRO = 0
26120       ICDPR  = 0
26121       ICDTA  = 0
26122       ICRJSS = 0
26123       ICVV2S = 0
26124       DO 10 I=1,9
26125          ICRES(I)    = 0
26126          ICCHAI(1,I) = 0
26127          ICCHAI(2,I) = 0
26128    10 CONTINUE
26129 *   initialize rejection counter
26130       IRPT      = 0
26131       IRHHA     = 0
26132       LOMRES    = 0
26133       LOBRES    = 0
26134       IRFRAG    = 0
26135       IREVT     = 0
26136       IRRES(1)  = 0
26137       IRRES(2)  = 0
26138       IRCHKI(1) = 0
26139       IRCHKI(2) = 0
26140       IRCRON(1) = 0
26141       IRCRON(2) = 0
26142       IRCRON(3) = 0
26143       IRDIFF(1) = 0
26144       IRDIFF(2) = 0
26145       IRINC     = 0
26146       DO 11 I=1,5
26147          ICDIFF(I) = 0
26148    11 CONTINUE
26149       DO 12 I=1,8
26150          DO 13 J=0,30
26151             ICEVTG(I,J) = 0
26152    13    CONTINUE
26153    12 CONTINUE
26154
26155       RETURN
26156
26157 * output
26158     2 CONTINUE
26159
26160 *   statistics counter
26161       WRITE(LOUT,1000)
26162  1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
26163      &       28X,'---------------------')
26164       WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
26165  1001 FORMAT(/,1X,'number of events requested / sampled',13X,
26166      &       I8,' / ',I8,/,1X,'number of samp. evts per requested ',
26167      &       'event',11X,F9.1)
26168       IF (ICDIFF(1).NE.0) THEN
26169          WRITE(LOUT,1009) ICDIFF
26170  1009    FORMAT(/,1X,'diffractive events:    total   ',I8,/,49X,
26171      &          'low mass   high mass',/,24X,'single diffraction',
26172      &          7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
26173       ENDIF
26174       IF (ICENTR.GT.0) THEN
26175          WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
26176      &                    DBLE(ICSAMP)/DBLE(ICCPRO)
26177  1002    FORMAT(/,1X,'central production:',/,2X,'mean number',
26178      &          ' of sampled Glauber-events per event',9X,F9.1,/,
26179      &          2X,'fraction of production cross section',21X,F10.6)
26180       ENDIF
26181       WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
26182      &                 DBLE(ICDTA)/DBLE(ICSAMP)
26183  1003 FORMAT(/,54X,'proj.    targ.',/,1X,'average number of wounded',
26184      &       ' nucleons after x-sampling',2(4X,F6.2))
26185
26186       IF (MCGENE.EQ.1) THEN
26187          WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
26188  1004    FORMAT(/,1X,'mean number of sea-sea chain rejections per',
26189      &          ' event',3X,F9.1)
26190          IF (ISICHA.EQ.1) THEN
26191             WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
26192  1005       FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
26193      &             'of single chains  per event',13X,F9.1)
26194          ENDIF
26195          WRITE(LOUT,1006)
26196  1006    FORMAT(/,1X,'chain system statistics:  (per event)',/,
26197      &       23X,'mean number of chains      mean number of chains',/,
26198      &       23X,'sampled    hadronized      having mass of a reso.')
26199          WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
26200      &                     DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
26201      &                     DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
26202      &                  DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
26203  1007    FORMAT(1X,'sea     - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26204      &          1X,'disea   - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26205      &          1X,'sea     - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26206      &          1X,'sea     - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26207      &          1X,'disea   - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26208      &          1X,'valence - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26209      &          1X,'valence - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26210      &          1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26211      &          1X,'fused chains      ',18X,F4.1,17X,F4.1,/)
26212          WRITE(LOUT,1008)
26213      &     (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
26214      &     DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
26215      &     DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
26216      &     (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
26217      &     (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
26218      &     DBLE(IRHHA)/DBLE(ICREQU),
26219      &     DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
26220      &     (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
26221  1008    FORMAT(/,1X,'Rejection counter:  (NEVT = no. of events)',/,/,
26222      &       1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
26223      &       F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
26224      &       'Intrins. p_t (GETSPT)',21X,'IRPT     /NEVT = ',F7.2,/,
26225      &       1X,'Chain mass corr. for resonances (EVTRES)',2X,
26226      &       'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES)  IRRES(2) /',
26227      &       'NEVT = ',F7.2,/,43X,'LOMRES   /NEVT = ',F7.2,/,
26228      &       43X,'LOBRES   /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
26229      &       ' 2-chain systems (CHKINE)  IRCHKI(1)/NEVT = ',F7.2,/,
26230      &       43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
26231      &       'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
26232      &       F7.2,/,1X,'Total no. of rej.',
26233      &       ' in chain-systems treatment (GETCSY)',/,43X,
26234      &       'IRHHA    /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
26235      &       ' (not yet used!)',4X,'IRFRAG   /NEVT = ',F7.2,/,
26236      &       1X,'Total no. of rej. in DPM-treatment of one event',
26237      &       ' (EVENTA)',/,43X,'IREVT    /NEVT = ',F7.2,/,1X,
26238      &       'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
26239      &       ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
26240      &       'IREXCI(3) = ',I5,/)
26241       ELSEIF (MCGENE.EQ.2) THEN
26242 C *** Commented by Chiara
26243 C         WRITE(LOUT,1010) ELOJET
26244 C 1010    FORMAT(/,/,1X,'PHOJET-treatment of chain systems above  ',
26245 C     &          F4.1,' GeV')
26246 C         WRITE(LOUT,1011)
26247 C 1011    FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
26248 C     &          30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
26249 C     &          5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
26250 C         WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
26251 C     &                    (INT(ICCHAI(2,I)/2.0D0),I=1,8),
26252 C     &                    (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
26253 C     &                    ((ICEVTG(I,J),I=1,8),J=3,7),
26254 C     &                    ((ICEVTG(I,J),I=1,8),J=19,21),
26255 C     &                    (ICEVTG(I,8),I=1,8),
26256 C     &                    ((ICEVTG(I,J),I=1,8),J=22,24),
26257 C     &                    (ICEVTG(I,9),I=1,8),
26258 C     &                    ((ICEVTG(I,J),I=1,8),J=25,28),
26259 C     &                    ((ICEVTG(I,J),I=1,8),J=10,18)
26260 C 1012    FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
26261 C     &          8I8,/,/,1X,'PHOJET ',8I8,/,'   sngl ',8I8,/,/,
26262 C     &          ' no-dif.',8I8,/,
26263 C     &          ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
26264 C     &          ' diff-1 ',8I8,/,'  low   ',8I8,/,'  high  ',8I8,/,
26265 C     &          '  h-diff',8I8,/,' diff-2 ',8I8,/,'  low   ',8I8,/,
26266 C     &          '  high  ',8I8,/,'  h-diff',8I8,/,' dbl-di.',8I8,/,
26267 C     &          '  lo-lo ',8I8,/,'  hi-hi ',8I8,/,'  lo-hi ',8I8,/,
26268 C     &          '  hi-lo ',8I8,/,
26269 C     &          ' dir-ga.',8I8,/,/,' dir-1  ',8I8,/,' dir-2  ',8I8,/,
26270 C     &          ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
26271 C     &          ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
26272 C         WRITE(LOUT,1013)
26273 C 1013    FORMAT(/,1X,'2. chain system statistics -',
26274 C     &          ' mean numbers per evt:',/,30X,'---------------------',
26275 C     &          /,/,16X,'s-s',7X,'d-s',7X,'s-d')
26276 C         WRITE(LOUT,1014)
26277 C     &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
26278 C     &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
26279 C     &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
26280 C 1014    FORMAT(/,1X,'req.to.    ',3E10.2,/,/,1X,'low rq.    ',3E10.2,/,
26281 C     &          1X,'low ac.    ',3E10.2,/,/,1X,'PHOJET     ',3E10.2,/,/,
26282 C     &          ' no-dif.    ',3E10.2,/,' el-sca.    ',3E10.2,/,
26283 C     &          ' qel-sc.    ',3E10.2,/,' dbl-Po.    ',3E10.2,/,
26284 C     &          ' diff-1     ',3E10.2,/,' diff-2     ',3E10.2,/,
26285 C     &          ' dbl-di.    ',3E10.2,/,' dir-ga.    ',3E10.2,/,/,
26286 C     &          ' dir-1      ',3E10.2,/,' dir-2      ',3E10.2,/,
26287 C     &          ' dbl-dir    ',3E10.2,/,' s-Pom.     ',3E10.2,/,
26288 C     &          ' h-Pom.     ',3E10.2,/,' s-Reg.     ',3E10.2,/,
26289 C     &          ' enh-trg    ',3E10.2,/,' enh-log    ',3E10.2)
26290 C         WRITE(LOUT,1015)
26291 C 1015    FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
26292 C         WRITE(LOUT,1016)
26293 C     &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
26294 C     &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
26295 C     &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
26296 C 1016    FORMAT(/,1X,'req.to.    ',5E10.2,/,/,1X,'low rq.    ',5E10.2,/,
26297 C     &          1X,'low ac.    ',5E10.2,/,/,1X,'PHOJET     ',5E10.2,/,/,
26298 C     &          ' no-dif.    ',5E10.2,/,' el-sca.    ',5E10.2,/,
26299 C     &          ' qel-sc.    ',5E10.2,/,' dbl-Po.    ',5E10.2,/,
26300 C     &          ' diff-1     ',5E10.2,/,' diff-2     ',5E10.2,/,
26301 C     &          ' dbl-di.    ',5E10.2,/,' dir-ga.    ',5E10.2,/,/,
26302 C     &          ' dir-1      ',5E10.2,/,' dir-2      ',5E10.2,/,
26303 C     &          ' dbl-dir    ',5E10.2,/,' s-Pom.     ',5E10.2,/,
26304 C     &          ' h-Pom.     ',5E10.2,/,' s-Reg.     ',5E10.2,/,
26305 C     &          ' enh-trg    ',5E10.2,/,' enh-log    ',5E10.2)
26306
26307       ENDIF
26308       CALL DT_CHASTA(1)
26309
26310       IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
26311      &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
26312          WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
26313      &    DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
26314      &    DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
26315          WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
26316      &    DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
26317      &    DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
26318          WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
26319      &    DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
26320      &    DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
26321          WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
26322      &    DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
26323      &    DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
26324          WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
26325      &    DBRKA(3,1),DBRKA(3,2),
26326      &    DBRKA(3,3),DBRKA(3,4)
26327          WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
26328      &    DBRKR(3,1),DBRKR(3,2),
26329      &    DBRKR(3,3),DBRKR(3,4)
26330          WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
26331      &    DBRKA(3,5),DBRKA(3,6),
26332      &    DBRKA(3,7),DBRKA(3,8)
26333          WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
26334      &    DBRKR(3,5),DBRKR(3,6),
26335      &    DBRKR(3,7),DBRKR(3,8)
26336       ENDIF
26337
26338       FAC = 1.0D0
26339       IF (MCGENE.EQ.2) THEN
26340
26341 C        CALL PHO_PHIST(-2,SIGMAX)
26342          CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
26343
26344       ENDIF
26345
26346       CALL DT_XTIME
26347
26348       RETURN
26349       END
26350 *
26351 *===evtout=============================================================*
26352 *
26353 CDECK  ID>, DT_EVTOUT
26354       SUBROUTINE DT_EVTOUT(MODE)
26355
26356 ************************************************************************
26357 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
26358 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
26359 *                    4  plot entries of DTEVT1 and DTEVT2              *
26360 * This version dated 11.12.94 is written by S. Roesler                 *
26361 ************************************************************************
26362
26363       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26364       SAVE
26365
26366       PARAMETER ( LINP = 5 ,
26367      &            LOUT = 6 ,
26368      &            LDAT = 9 )
26369
26370 * event history
26371
26372       PARAMETER (NMXHKK=200000)
26373
26374       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26375      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26376      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26377
26378       DIMENSION IRANGE(NMXHKK)
26379
26380       IF (MODE.EQ.2) RETURN
26381
26382       CALL DT_EVTPLO(IRANGE,MODE)
26383
26384       RETURN
26385       END
26386 *
26387 *===evtplo=============================================================*
26388 *
26389 CDECK  ID>, DT_EVTPLO
26390       SUBROUTINE DT_EVTPLO(IRANGE,MODE)
26391
26392 ************************************************************************
26393 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
26394 *                    2  plot entries of DTEVT1 given by IRANGE         *
26395 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
26396 *                    4  plot entries of DTEVT1 and DTEVT2              *
26397 *                    5  plot rejection counter                         *
26398 * This version dated 11.12.94 is written by S. Roesler                 *
26399 ************************************************************************
26400
26401       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26402       SAVE
26403
26404       PARAMETER ( LINP = 5 ,
26405      &            LOUT = 6 ,
26406      &            LDAT = 9 )
26407
26408       CHARACTER*16 CHAU
26409
26410 * event history
26411
26412       PARAMETER (NMXHKK=200000)
26413
26414       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26415      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26416      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26417 * extended event history
26418       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26419      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26420      &                IHIST(2,NMXHKK)
26421 * rejection counter
26422       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
26423      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
26424      &                IREXCI(3),IRDIFF(2),IRINC
26425
26426       DIMENSION IRANGE(NMXHKK)
26427
26428       IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
26429          WRITE(LOUT,1000)
26430  1000    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTEVT1/',/,
26431      &         15X,'           --------------------------',/,/,
26432      &             '       ST    ID  M1   M2   D1   D2     PX     PY',
26433      &             '     PZ      E       M',/)
26434          DO 1 I=1,NHKK
26435             WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
26436      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
26437      &                       PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
26438      &                       PHKK(5,I)
26439 C           WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
26440 C    &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
26441 C    &                       PHKK(3,I),PHKK(4,I)
26442 C           WRITE(LOUT,'(4E15.4)')
26443 C    &         VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
26444  1001       FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
26445  1011       FORMAT(I5,I5,I6,4I5,2E15.5)
26446     1    CONTINUE
26447          WRITE(LOUT,*)
26448 C        DO 4 I=1,NHKK
26449 C           WRITE(LOUT,1006) I,ISTHKK(I),
26450 C    &                    VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
26451 C    &                    WHKK(2,I),WHKK(3,I)
26452 C1006       FORMAT(1X,I4,I6,6E10.3)
26453 C   4    CONTINUE
26454       ENDIF
26455
26456       IF (MODE.EQ.2) THEN
26457          WRITE(LOUT,1000)
26458          NC = 0
26459     2    CONTINUE
26460          NC = NC+1
26461          IF (IRANGE(NC).EQ.-100) GOTO 9999
26462          I = IRANGE(NC)
26463          WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
26464      &                    JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
26465      &                    PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
26466      &                    PHKK(5,I)
26467          GOTO 2
26468       ENDIF
26469
26470       IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
26471          WRITE(LOUT,1002)
26472  1002    FORMAT(/,1X,'EVTPLO:',14X,
26473      &         ' content of COMMON /DTEVT1/,/DTEVT2/',/,
26474      &         15X,'        -----------------------------------',/,/,
26475      &             '       ST    ID   M1   M2   D1   D2  IDR  IDXR',
26476      &             ' NOBAM IDCH    M',/)
26477          DO 3 I=1,NHKK
26478 C           IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
26479                KF    = IDHKK(I)
26480                IDCHK = KF/10000
26481                IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
26482      &            (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
26483
26484                CALL PYNAME(KF,CHAU)
26485
26486                WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
26487      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
26488      &                       IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
26489      &                       PHKK(5,I),CHAU
26490  1003          FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
26491 C           ENDIF
26492     3    CONTINUE
26493       ENDIF
26494
26495       IF (MODE.EQ.5) THEN
26496          WRITE(LOUT,1004)
26497  1004    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTREJC/',/,
26498      &         15X,'           --------------------------',/)
26499          WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
26500      &                    IRSEA,IRCRON
26501  1005    FORMAT(1X,'IRPT   = ',I5,'  IRHHA = ',I5,/,
26502      &          1X,'IRRES  = ',2I5,'  LOMRES = ',I5,'  LOBRES = ',I5,/,
26503      &          1X,'IREMC  = ',10I5,/,
26504      &          1X,'IRFRAG = ',I5,'  IRSEA = ',I5,' IRCRON = ',I5,/)
26505       ENDIF
26506
26507  9999 RETURN
26508       END
26509 *
26510 *===evtput=============================================================*
26511 *
26512 CDECK  ID>, DT_EVTPUT
26513       SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
26514
26515       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26516       SAVE
26517
26518       PARAMETER ( LINP = 5 ,
26519      &            LOUT = 6 ,
26520      &            LDAT = 9 )
26521
26522       PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
26523      &           TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
26524
26525 * event history
26526
26527       PARAMETER (NMXHKK=200000)
26528
26529       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26530      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26531      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26532 * extended event history
26533       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26534      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26535      &                IHIST(2,NMXHKK)
26536 * Lorentz-parameters of the current interaction
26537       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26538      &                UMO,PPCM,EPROJ,PPROJ
26539 * particle properties (BAMJET index convention)
26540       CHARACTER*8  ANAME
26541       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26542      &                IICH(210),IIBAR(210),K1(210),K2(210)
26543
26544 C     IF (MODE.GT.100) THEN
26545 C        WRITE(LOUT,'(1X,A,I5,A,I5)')
26546 C    &        'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
26547 C        NHKK = NHKK-MODE+100
26548 C        RETURN
26549 C     ENDIF
26550       MO1  = M1
26551       MO2  = M2
26552       NHKK = NHKK+1
26553
26554       IF (NHKK.GT.NMXHKK) THEN
26555          WRITE(LOUT,1000) NHKK
26556  1000    FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
26557      &             '! program execution stopped..')
26558          STOP
26559       ENDIF
26560       IF (M1.LT.0) MO1 = NHKK+M1
26561       IF (M2.LT.0) MO2 = NHKK+M2
26562       ISTHKK(NHKK)   = IST
26563       IDHKK(NHKK)    = ID
26564       JMOHKK(1,NHKK) = MO1
26565       JMOHKK(2,NHKK) = MO2
26566       JDAHKK(1,NHKK) = 0
26567       JDAHKK(2,NHKK) = 0
26568       IDRES(NHKK)    = IDR
26569       IDXRES(NHKK)   = IDXR
26570       IDCH(NHKK)     = IDC
26571 ** here we need to do something..
26572       IF (ID.EQ.88888) THEN
26573          IDMO1 = ABS(IDHKK(MO1))
26574          IDMO2 = ABS(IDHKK(MO2))
26575          IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
26576          IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
26577          IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
26578          IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
26579       ELSE
26580          NOBAM(NHKK) = 0
26581       ENDIF
26582       IDBAM(NHKK) = IDT_ICIHAD(ID)
26583       IF (MO1.GT.0) THEN
26584          IF (JDAHKK(1,MO1).NE.0) THEN
26585             JDAHKK(2,MO1) = NHKK
26586          ELSE
26587             JDAHKK(1,MO1) = NHKK
26588          ENDIF
26589       ENDIF
26590       IF (MO2.GT.0) THEN
26591          IF (JDAHKK(1,MO2).NE.0) THEN
26592             JDAHKK(2,MO2) = NHKK
26593          ELSE
26594             JDAHKK(1,MO2) = NHKK
26595          ENDIF
26596       ENDIF
26597 C      IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
26598 C         PTOT   = SQRT(PX**2+PY**2+PZ**2)
26599 C         AM0    = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
26600 C         AMRQ   = AAM(IDBAM(NHKK))
26601 C         AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
26602 C         IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
26603 C     &       (PTOT.GT.ZERO)) THEN
26604 C            DELTA = -AMDIF2/(2.0D0*(E+PTOT))
26605 CC           DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
26606 C            E     = E+DELTA
26607 C            PTOT1 = PTOT-DELTA
26608 C            PX    = PX*PTOT1/PTOT
26609 C            PY    = PY*PTOT1/PTOT
26610 C            PZ    = PZ*PTOT1/PTOT
26611 C         ENDIF
26612 C      ENDIF
26613       PHKK(1,NHKK) = PX
26614       PHKK(2,NHKK) = PY
26615       PHKK(3,NHKK) = PZ
26616       PHKK(4,NHKK) = E
26617       PTOT = SQRT( PX**2+PY**2+PZ**2 )
26618       IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
26619          PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
26620          PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
26621       ELSE
26622          PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
26623 C        IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
26624 C    &      WRITE(LOUT,'(1X,A,G10.3)')
26625 C    &        'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
26626          PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
26627       ENDIF
26628       IDCHK = ID/10000
26629       IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
26630 * special treatment for chains:
26631 *    z coordinate of chain in Lab  = pos. of target nucleon
26632 *    time of chain-creation in Lab = time of passage of projectile
26633 *                                    nucleus at pos. of taget nucleus
26634 C        VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
26635 C        VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
26636          VHKK(1,NHKK) = VHKK(1,MO2)
26637          VHKK(2,NHKK) = VHKK(2,MO2)
26638          VHKK(3,NHKK) = VHKK(3,MO2)
26639          VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
26640 C        WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
26641 C        WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
26642          WHKK(1,NHKK) = WHKK(1,MO1)
26643          WHKK(2,NHKK) = WHKK(2,MO1)
26644          WHKK(3,NHKK) = WHKK(3,MO1)
26645          WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
26646       ELSE
26647          IF (MO1.GT.0) THEN
26648             DO 1 I=1,4
26649                VHKK(I,NHKK) = VHKK(I,MO1)
26650                WHKK(I,NHKK) = WHKK(I,MO1)
26651     1       CONTINUE
26652          ELSE
26653             DO 2 I=1,4
26654                VHKK(I,NHKK) = ZERO
26655                WHKK(I,NHKK) = ZERO
26656     2       CONTINUE
26657          ENDIF
26658       ENDIF
26659
26660       RETURN
26661       END
26662 *
26663 *===chasta=============================================================*
26664 *
26665 CDECK  ID>, DT_CHASTA
26666       SUBROUTINE DT_CHASTA(MODE)
26667
26668 ************************************************************************
26669 * This subroutine performs CHAin STAtistics and checks sequence of     *
26670 * partons in dtevt1 and sorts them with projectile partons coming      *
26671 * first if necessary.                                                  *
26672 *                                                                      *
26673 * This version dated  8.5.00  is written by S. Roesler.                *
26674 ************************************************************************
26675
26676       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26677       SAVE
26678
26679       PARAMETER ( LINP = 5 ,
26680      &            LOUT = 6 ,
26681      &            LDAT = 9 )
26682
26683       CHARACTER*5 CCHTYP
26684
26685 * event history
26686
26687       PARAMETER (NMXHKK=200000)
26688
26689       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26690      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26691      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26692 * extended event history
26693       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26694      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26695      &                IHIST(2,NMXHKK)
26696 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
26697       PARAMETER (MAXCHN=10000)
26698       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
26699
26700       DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
26701      &          CCHTYP(9),ICHSTA(10),ITOT(10)
26702       DATA ICHCFG /1800*0/
26703       DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
26704       DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
26705       DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
26706       DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
26707       DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
26708       DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
26709       DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
26710      &              'ad aq',' d ad','ad d ',' g g '/
26711 *
26712 * initialization
26713 *
26714       IF (MODE.EQ.-1) THEN
26715          NCHAIN = 0
26716 *
26717 * loop over DTEVT1 and analyse chain configurations
26718 *
26719       ELSEIF (MODE.EQ.0) THEN
26720          DO 21 IDX=NPOINT(3),NHKK
26721             IDCHK = IDHKK(IDX)/10000
26722             IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
26723      &          (IDHKK(IDX).NE.80000).AND.
26724      &          (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
26725                IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
26726                   WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
26727      &                          ' at entry ',IDX
26728                   GOTO 21
26729                ENDIF
26730 *
26731                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
26732                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
26733                IMO1 = IST1/10
26734                IMO1 = IST1-10*IMO1
26735                IMO2 = IST2/10
26736                IMO2 = IST2-10*IMO2
26737 *   swop parton entries if necessary since we need projectile partons
26738 *   to come first in the common
26739                IF (IMO1.GT.IMO2) THEN
26740                   NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
26741                   DO 22 K=1,NPTN/2
26742                      I0 = JMOHKK(1,IDX)-1+K
26743                      I1 = JMOHKK(2,IDX)+1-K
26744                      ITMP = ISTHKK(I0)
26745                      ISTHKK(I0) = ISTHKK(I1)
26746                      ISTHKK(I1) = ITMP
26747                      ITMP = IDHKK(I0)
26748                      IDHKK(I0) = IDHKK(I1)
26749                      IDHKK(I1) = ITMP
26750                      IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
26751      &                  JDAHKK(1,JMOHKK(1,I0)) = I1
26752                      IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
26753      &                  JDAHKK(2,JMOHKK(1,I0)) = I1
26754                      IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
26755      &                  JDAHKK(1,JMOHKK(2,I0)) = I1
26756                      IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
26757      &                  JDAHKK(2,JMOHKK(2,I0)) = I1
26758                      IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
26759      &                  JDAHKK(1,JMOHKK(1,I1)) = I0
26760                      IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
26761      &                  JDAHKK(2,JMOHKK(1,I1)) = I0
26762                      IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
26763      &                  JDAHKK(1,JMOHKK(2,I1)) = I0
26764                      IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
26765      &                  JDAHKK(2,JMOHKK(2,I1)) = I0
26766                      ITMP = JMOHKK(1,I0)
26767                      JMOHKK(1,I0) = JMOHKK(1,I1)
26768                      JMOHKK(1,I1) = ITMP
26769                      ITMP = JMOHKK(2,I0)
26770                      JMOHKK(2,I0) = JMOHKK(2,I1)
26771                      JMOHKK(2,I1) = ITMP
26772                      ITMP = JDAHKK(1,I0)
26773                      JDAHKK(1,I0) = JDAHKK(1,I1)
26774                      JDAHKK(1,I1) = ITMP
26775                      ITMP = JDAHKK(2,I0)
26776                      JDAHKK(2,I0) = JDAHKK(2,I1)
26777                      JDAHKK(2,I1) = ITMP
26778                      DO 23 J=1,4
26779                         RTMP1 = PHKK(J,I0)
26780                         RTMP2 = VHKK(J,I0)
26781                         RTMP3 = WHKK(J,I0)
26782                         PHKK(J,I0) = PHKK(J,I1)
26783                         VHKK(J,I0) = VHKK(J,I1)
26784                         WHKK(J,I0) = WHKK(J,I1)
26785                         PHKK(J,I1) = RTMP1
26786                         VHKK(J,I1) = RTMP2
26787                         WHKK(J,I1) = RTMP3
26788    23                CONTINUE
26789                      RTMP1 = PHKK(5,I0)
26790                      PHKK(5,I0) = PHKK(5,I1)
26791                      PHKK(5,I1) = RTMP1
26792                      ITMP = IDRES(I0)
26793                      IDRES(I0) = IDRES(I1)
26794                      IDRES(I1) = ITMP
26795                      ITMP = IDXRES(I0)
26796                      IDXRES(I0) = IDXRES(I1)
26797                      IDXRES(I1) = ITMP
26798                      ITMP = NOBAM(I0)
26799                      NOBAM(I0) = NOBAM(I1)
26800                      NOBAM(I1) = ITMP
26801                      ITMP = IDBAM(I0)
26802                      IDBAM(I0) = IDBAM(I1)
26803                      IDBAM(I1) = ITMP
26804                      ITMP = IDCH(I0)
26805                      IDCH(I0) = IDCH(I1)
26806                      IDCH(I1) = ITMP
26807                      ITMP = IHIST(1,I0)
26808                      IHIST(1,I0) = IHIST(1,I1)
26809                      IHIST(1,I1) = ITMP
26810                      ITMP = IHIST(2,I0)
26811                      IHIST(2,I0) = IHIST(2,I1)
26812                      IHIST(2,I1) = ITMP
26813    22             CONTINUE
26814                ENDIF
26815                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
26816                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
26817 *
26818 *   parton 1 (projectile side)
26819                IF (IST1.EQ.21) THEN
26820                   IDX1 = 1
26821                ELSEIF (IST1.EQ.22) THEN
26822                   IDX1 = 2
26823                ELSEIF (IST1.EQ.31) THEN
26824                   IDX1 = 3
26825                ELSEIF (IST1.EQ.32) THEN
26826                   IDX1 = 4
26827                ELSEIF (IST1.EQ.41) THEN
26828                   IDX1 = 5
26829                ELSEIF (IST1.EQ.42) THEN
26830                   IDX1 = 6
26831                ELSEIF (IST1.EQ.51) THEN
26832                   IDX1 = 7
26833                ELSEIF (IST1.EQ.52) THEN
26834                   IDX1 = 8
26835                ELSEIF (IST1.EQ.61) THEN
26836                   IDX1 = 9
26837                ELSEIF (IST1.EQ.62) THEN
26838                   IDX1 = 10
26839                ELSE
26840 c                 WRITE(LOUT,*)
26841 c    &               ' CHASTA: unknown parton status flag (',
26842 c    &               IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
26843                   GOTO 21
26844                ENDIF
26845                ID = IDHKK(JMOHKK(1,IDX))
26846                IF (ABS(ID).LE.4) THEN
26847                   IF (ID.GT.0) THEN
26848                      ITYP1 = 1
26849                   ELSE
26850                      ITYP1 = 2
26851                   ENDIF
26852                ELSEIF (ABS(ID).GE.1000) THEN
26853                   IF (ID.GT.0) THEN
26854                      ITYP1 = 3
26855                   ELSE
26856                      ITYP1 = 4
26857                   ENDIF
26858                ELSEIF (ID.EQ.21) THEN
26859                   ITYP1 = 5
26860                ELSE
26861                   WRITE(LOUT,*)
26862      &               ' CHASTA: inconsistent parton identity (',
26863      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
26864                   GOTO 21
26865                ENDIF
26866 *
26867 *   parton 2 (target side)
26868                IF (IST2.EQ.21) THEN
26869                   IDX2 = 1
26870                ELSEIF (IST2.EQ.22) THEN
26871                   IDX2 = 2
26872                ELSEIF (IST2.EQ.31) THEN
26873                   IDX2 = 3
26874                ELSEIF (IST2.EQ.32) THEN
26875                   IDX2 = 4
26876                ELSEIF (IST2.EQ.41) THEN
26877                   IDX2 = 5
26878                ELSEIF (IST2.EQ.42) THEN
26879                   IDX2 = 6
26880                ELSEIF (IST2.EQ.51) THEN
26881                   IDX2 = 7
26882                ELSEIF (IST2.EQ.52) THEN
26883                   IDX2 = 8
26884                ELSEIF (IST2.EQ.61) THEN
26885                   IDX2 = 9
26886                ELSEIF (IST2.EQ.62) THEN
26887                   IDX2 = 10
26888                ELSE
26889 c                 WRITE(LOUT,*)
26890 c    &               ' CHASTA: unknown parton status flag (',
26891 c    &               IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
26892                   GOTO 21
26893                ENDIF
26894                ID = IDHKK(JMOHKK(2,IDX))
26895                IF (ABS(ID).LE.4) THEN
26896                   IF (ID.GT.0) THEN
26897                      ITYP2 = 1
26898                   ELSE
26899                      ITYP2 = 2
26900                   ENDIF
26901                ELSEIF (ABS(ID).GE.1000) THEN
26902                   IF (ID.GT.0) THEN
26903                      ITYP2 = 3
26904                   ELSE
26905                      ITYP2 = 4
26906                   ENDIF
26907                ELSEIF (ID.EQ.21) THEN
26908                   ITYP2 = 5
26909                ELSE
26910                   WRITE(LOUT,*)
26911      &               ' CHASTA: inconsistent parton identity (',
26912      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
26913                   GOTO 21
26914                ENDIF
26915 *
26916 *   fill counter
26917                ITYPE = ICHTYP(ITYP1,ITYP2)
26918                IF (ITYPE.NE.0) THEN
26919                   ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
26920                   NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
26921                   ICHCFG(IDX1,IDX2,ITYPE,2) =
26922      &               ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
26923
26924                   NCHAIN = NCHAIN+1
26925                   IF (NCHAIN.GT.MAXCHN) THEN
26926                      WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
26927      &                  NCHAIN,MAXCHN
26928                      STOP
26929                   ENDIF
26930                   IDXCHN(1,NCHAIN) = IDX
26931                   IDXCHN(2,NCHAIN) = ITYPE
26932                ELSE
26933                   WRITE(LOUT,*)
26934      &               ' CHASTA: inconsistent chain at entry ',IDX
26935                   GOTO 21
26936                ENDIF
26937             ENDIF
26938    21    CONTINUE
26939 *
26940 * write statistics to output unit
26941 *
26942       ELSEIF (MODE.EQ.1) THEN
26943 C *** Commented by Chiara
26944 C         WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
26945          DO 31 I=1,10
26946 C            WRITE(LOUT,'(/,2A)')
26947 C     &         ' -----------------------------------------',
26948 C     &         '------------------------------------'
26949 C            WRITE(LOUT,'(2A)')
26950 C     &         ' p\\t         21     22     31     32     41',
26951 C     &         '     42     51     52     61     62'
26952 C            WRITE(LOUT,'(2A)')
26953 C     &         ' -----------------------------------------',
26954 C     &         '------------------------------------'
26955             DO 32 J=1,10
26956                ITOT(J) = 0
26957                DO 33 K=1,9
26958                   ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
26959    33          CONTINUE
26960    32       CONTINUE
26961 C *** Commented by Chiara
26962 c            WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
26963             DO 34 K=1,9
26964                ISUM = 0
26965                DO 35 J=1,10
26966                   ISUM = ISUM+ICHCFG(I,J,K,1)
26967    35          CONTINUE
26968 C *** Commented by Chiara
26969 C               IF (ISUM.GT.0)
26970 C     &            WRITE(LOUT,'(1X,A5,2X,10I7)')
26971 C     &               CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
26972    34       CONTINUE
26973 C           WRITE(LOUT,'(2A)')
26974 C    &         ' -----------------------------------------',
26975 C    &         '-------------------------------'
26976    31    CONTINUE
26977 *
26978       ELSE
26979          WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
26980          STOP
26981       ENDIF
26982
26983       RETURN
26984       END
26985 *
26986 *===pohist=============================================================*
26987 *
26988
26989 CDECK  ID>, PHO_PHIST
26990       SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
26991
26992       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
26993       SAVE
26994
26995       PARAMETER ( LINP = 5 ,
26996      &            LOUT = 6 ,
26997      &            LDAT = 9 )
26998
26999       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27000
27001 * Glauber formalism: cross sections
27002       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
27003      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
27004      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
27005      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
27006      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
27007      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
27008      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
27009      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
27010      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
27011      &                BSLOPE,NEBINI,NQBINI
27012
27013       ILAB = 0
27014       IF (IMODE.EQ.10) THEN
27015          IMODE = 1
27016          ILAB  = 1
27017       ENDIF
27018       IF (ABS(IMODE).LT.1000) THEN
27019 * PHOJET-statistics
27020 C        CALL POHISX(IMODE,WEIGHT)
27021          IF (IMODE.EQ.-1) THEN
27022             MODE = 1
27023             XSTOT(1,1,1) = WEIGHT
27024          ENDIF
27025          IF (IMODE.EQ. 1) MODE = 2
27026          IF (IMODE.EQ.-2) MODE = 3
27027          IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
27028 C        IF (MODE.EQ.3) WRITE(LOUT,*)
27029 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
27030          CALL DT_HISTOG(MODE)
27031          CALL DT_USRHIS(MODE)
27032       ELSE
27033 * DTUNUC-statistics
27034          MODE = IMODE/1000
27035 C        IF (MODE.EQ.3) WRITE(LOUT,*)
27036 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
27037          CALL DT_HISTOG(MODE)
27038          CALL DT_USRHIS(MODE)
27039       ENDIF
27040
27041       RETURN
27042       END
27043 *
27044 *===swppho=============================================================*
27045 *
27046 CDECK  ID>, DT_SWPPHO
27047       SUBROUTINE DT_SWPPHO(ILAB)
27048
27049       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
27050       SAVE
27051
27052       PARAMETER ( LINP = 5 ,
27053      &            LOUT = 6 ,
27054      &            LDAT = 9 )
27055
27056       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
27057
27058       LOGICAL LSTART
27059
27060 * event history
27061
27062       PARAMETER (NMXHKK=200000)
27063
27064       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27065      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27066      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27067 * extended event history
27068       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27069      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27070      &                IHIST(2,NMXHKK)
27071 * flags for input different options
27072       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
27073       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
27074      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
27075 * properties of photon/lepton projectiles
27076       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
27077
27078 **PHOJET105a
27079 C     PARAMETER (NMXHEP=2000)
27080 C     COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27081 C    &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
27082 C     COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
27083 C     COMMON /PLASAV/ PLAB
27084 **PHOJET110
27085
27086 C  standard particle data interface
27087       INTEGER NMXHEP
27088
27089       PARAMETER (NMXHEP=4000)
27090
27091       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27092       DOUBLE PRECISION PHEP,VHEP
27093       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27094      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27095      &                VHEP(4,NMXHEP)
27096 C  extension to standard particle data interface (PHOJET specific)
27097       INTEGER IMPART,IPHIST,ICOLOR
27098       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27099
27100 C  global event kinematics and particle IDs
27101       INTEGER IFPAP,IFPAB
27102       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
27103       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
27104 **
27105       DATA ICOUNT/0/
27106
27107       DATA LSTART /.TRUE./
27108
27109 C     IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
27110       IF ((IFRAME.EQ.1).AND.LSTART) THEN
27111          UMO  = ECM
27112          ELA  = ZERO
27113          PLA  = ZERO
27114          IDP  = IDT_ICIHAD(IFPAP(1))
27115          IDT  = IDT_ICIHAD(IFPAP(2))
27116          VIRT = PVIRT(1)
27117          CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
27118          PLAB = PLA
27119          LSTART = .FALSE.
27120       ENDIF
27121
27122       NHKK   = 0
27123       ICOUNT = ICOUNT+1
27124 C     NEVHKK = NEVHEP
27125       NEVHKK = ICOUNT
27126       IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
27127       DO 1 I=3,NHEP
27128          IF (ISTHEP(I).EQ.1) THEN
27129             NHKK = NHKK+1
27130             ISTHKK(NHKK) = 1
27131             IDHKK(NHKK)  = IDHEP(I)
27132             JMOHKK(1,NHKK) = 0
27133             JMOHKK(2,NHKK) = 0
27134             JDAHKK(1,NHKK) = 0
27135             JDAHKK(2,NHKK) = 0
27136             DO 2 K=1,4
27137                PHKK(K,NHKK) = PHEP(K,I)
27138                VHKK(K,NHKK) = ZERO
27139                WHKK(K,NHKK) = ZERO
27140     2       CONTINUE
27141             IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
27142      &         CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
27143      &                    PHKK(3,NHKK),PHKK(4,NHKK),-3)
27144             PHKK(5,NHKK) = PHEP(5,I)
27145             IDRES(NHKK)  = 0
27146             IDXRES(NHKK) = 0
27147             NOBAM(NHKK)  = 0
27148             IDBAM(NHKK)  = IDT_ICIHAD(IDHEP(I))
27149             IDCH(NHKK)   = 0
27150          ENDIF
27151     1 CONTINUE
27152
27153       RETURN
27154       END
27155 *
27156 *===histog=============================================================*
27157 *
27158 CDECK  ID>, DT_HISTOG
27159       SUBROUTINE DT_HISTOG(MODE)
27160
27161 ************************************************************************
27162 * This version dated 25.03.96 is written by S. Roesler                 *
27163 ************************************************************************
27164
27165       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27166       SAVE
27167
27168       PARAMETER ( LINP = 5 ,
27169      &            LOUT = 6 ,
27170      &            LDAT = 9 )
27171
27172       LOGICAL LFSP,LRNL
27173
27174 * event history
27175
27176       PARAMETER (NMXHKK=200000)
27177
27178       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27179      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27180      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27181 * extended event history
27182       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27183      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27184      &                IHIST(2,NMXHKK)
27185 * event flag used for histograms
27186       COMMON /DTNORM/ ICEVT,IEVHKK
27187 * flags for activated histograms
27188       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
27189
27190       IEVHKK = NEVHKK
27191       GOTO (1,2,3) MODE
27192
27193 *------------------------------------------------------------------
27194 * initialization
27195     1 CONTINUE
27196       ICEVT = 0
27197       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
27198       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
27199
27200       RETURN
27201 *------------------------------------------------------------------
27202 * filling of histogram with event-record
27203     2 CONTINUE
27204       ICEVT = ICEVT+1
27205
27206       DO 20 I=1,NHKK
27207          CALL DT_SWPFSP(I,LFSP,LRNL)
27208          IF (LFSP) THEN
27209             IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
27210             IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
27211          ENDIF
27212          IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
27213    20 CONTINUE
27214       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
27215
27216       RETURN
27217 *------------------------------------------------------------------
27218 * output
27219     3 CONTINUE
27220       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
27221       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
27222
27223       RETURN
27224       END
27225 *
27226 *===swpfsp=============================================================*
27227 *
27228 CDECK  ID>, DT_SWPFSP
27229       SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
27230
27231       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27232       SAVE
27233       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
27234       PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
27235      &           PI   =TWOPI/TWO,
27236      &           BOG  =TWOPI/360.0D0)
27237
27238 * event history
27239
27240       PARAMETER (NMXHKK=200000)
27241
27242       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27243      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27244      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27245 * extended event history
27246       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27247      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27248      &                IHIST(2,NMXHKK)
27249 * particle properties (BAMJET index convention)
27250       CHARACTER*8  ANAME
27251       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27252      &                IICH(210),IIBAR(210),K1(210),K2(210)
27253 * Lorentz-parameters of the current interaction
27254       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
27255      &                UMO,PPCM,EPROJ,PPROJ
27256 * flags for input different options
27257       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
27258       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
27259      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
27260
27261       INCLUDE './flukapro/(DIMPAR)'
27262       INCLUDE './flukapro/(PAREVT)'
27263
27264 * temporary storage for one final state particle
27265       LOGICAL LFRAG,LGREY,LBLACK
27266       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
27267      &                SINTHE,COSTHE,THETA,THECMS,
27268      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
27269      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
27270      &                LFRAG,LGREY,LBLACK
27271
27272       LOGICAL LFSP,LRNL
27273
27274       LFSP = .FALSE.
27275       LRNL = .FALSE.
27276       ISTRNL = 1000
27277       MULDEF = 1
27278       IF (LEVPRT) ISTRNL = 1001
27279
27280       IF (ABS(ISTHKK(IDX)).EQ.1) THEN
27281          IST    = ISTHKK(IDX)
27282          IDPDG  = IDHKK(IDX)
27283          LFRAG  = .FALSE.
27284          IF (IDHKK(IDX).LT.80000) THEN
27285             IDBJT  = IDBAM(IDX)
27286             IBARY  = IIBAR(IDBJT)
27287             ICHAR  = IICH(IDBJT)
27288             AMASS  = AAM(IDBJT)
27289          ELSEIF (IDHKK(IDX).EQ.80000) THEN
27290             IDBJT  = 0
27291             IBARY  = IDRES(IDX)
27292             ICHAR  = IDXRES(IDX)
27293             AMASS  = PHKK(5,IDX)
27294             INUT   = IBARY-ICHAR
27295             IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
27296             IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
27297             IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
27298             IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
27299             IF (IDBJT.EQ.0) LFRAG = .TRUE.
27300          ELSE
27301             GOTO 9999
27302          ENDIF
27303          PE     = PHKK(4,IDX)
27304          PX     = PHKK(1,IDX)
27305          PY     = PHKK(2,IDX)
27306          PZ     = PHKK(3,IDX)
27307          PT2    = PX**2+PY**2
27308          PT     = SQRT(PT2)
27309          PTOT   = SQRT(PT2+PZ**2)
27310          SINTHE = PT/MAX(PTOT,TINY14)
27311          COSTHE = PZ/MAX(PTOT,TINY14)
27312          IF (COSTHE.GT.ONE) THEN
27313             THETA = ZERO
27314          ELSEIF (COSTHE.LT.-ONE) THEN
27315             THETA = TWOPI/2.0D0
27316          ELSE
27317             THETA = ACOS(COSTHE)
27318          ENDIF
27319          EKIN   = PE-AMASS
27320 **sr 15.4.96 new E_t-definition
27321          IF (IBARY.GT.0) THEN
27322             ET = EKIN*SINTHE
27323          ELSEIF (IBARY.LT.0) THEN
27324             ET = (EKIN+TWO*AMASS)*SINTHE
27325          ELSE
27326             ET = PE*SINTHE
27327          ENDIF
27328 **
27329          XLAB   = PZ/MAX(PPROJ,TINY14)
27330 C        XLAB   = PE/MAX(EPROJ,TINY14)
27331          BETA   = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
27332      &                     *(ONE+AMASS/MAX(PE,TINY14)) ))
27333          PPLUS  = PE+PZ
27334          PMINUS = PE-PZ
27335          IF (PMINUS.GT.TINY14) THEN
27336             YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
27337          ELSE
27338             YY = 100.0D0
27339          ENDIF
27340          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
27341             ETA = -LOG(TAN(THETA/TWO))
27342          ELSE
27343             ETA = 100.0D0
27344          ENDIF
27345          IF (IFRAME.EQ.1) THEN
27346             CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
27347             PPLUS  = EECMS+PZCMS
27348             PMINUS = EECMS-PZCMS
27349             IF ((PPLUS*PMINUS).GT.TINY14) THEN
27350                YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
27351             ELSE
27352                YYCMS = 100.0D0
27353             ENDIF
27354             PTOTCM = SQRT(PT2+PZCMS**2)
27355             COSTH = PZCMS/MAX(PTOTCM,TINY14)
27356             IF (COSTH.GT.ONE) THEN
27357                THECMS = ZERO
27358             ELSEIF (COSTH.LT.-ONE) THEN
27359                THECMS = TWOPI/2.0D0
27360             ELSE
27361                THECMS = ACOS(COSTH)
27362             ENDIF
27363             IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
27364                ETACMS = -LOG(TAN(THECMS/TWO))
27365             ELSE
27366                ETACMS = 100.0D0
27367             ENDIF
27368             XF = PZCMS/MAX(PPCM,TINY14)
27369             THECMS = THECMS/BOG
27370          ELSE
27371             PZCMS  = PZ
27372             EECMS  = PE
27373             YYCMS  = YY
27374             ETACMS = ETA
27375             XF     = XLAB
27376             THECMS = THETA/BOG
27377          ENDIF
27378          THETA  = THETA/BOG
27379
27380 * set flag for "grey/black"
27381          LGREY  = .FALSE.
27382          LBLACK = .FALSE.
27383          EK     = EKIN
27384          IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
27385          IF (MULDEF.EQ.1) THEN
27386 *  EMU01-Def.
27387             IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
27388      &                              (EK.LE.375.0D-3)      ).OR.
27389      &           ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
27390      &                              (EK.LE. 56.0D-3)      ).OR.
27391      &           ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
27392      &                              (EK.LE. 56.0D-3)      ).OR.
27393      &           ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
27394      &                              (EK.LE.198.0D-3)      ).OR.
27395      &           ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
27396      &                              (EK.LE.198.0D-3)      ).OR.
27397      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
27398      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
27399      &             (IDBJT.NE.16).AND.
27400      &             (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)    ) )
27401      &         LGREY = .TRUE.
27402             IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
27403      &           ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
27404      &           ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
27405      &           ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
27406      &           ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
27407      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
27408      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
27409      &             (IDBJT.NE.16).AND.(BETA.LE.0.23D0)  ) )
27410      &         LBLACK = .TRUE.
27411          ELSE
27412 *  common Def.
27413             IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
27414             IF (BETA.LE.0.23D0) LBLACK=.TRUE.
27415          ENDIF
27416          LFSP = .TRUE.
27417       ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
27418          IST    = ISTHKK(IDX)
27419          IDPDG  = IDHKK(IDX)
27420          LFRAG  = .TRUE.
27421          IDBJT  = 0
27422          IBARY  = IDRES(IDX)
27423          ICHAR  = IDXRES(IDX)
27424          AMASS  = PHKK(5,IDX)
27425          PE     = PHKK(4,IDX)
27426          PX     = PHKK(1,IDX)
27427          PY     = PHKK(2,IDX)
27428          PZ     = PHKK(3,IDX)
27429          PT2    = PX**2+PY**2
27430          PT     = SQRT(PT2)
27431          PTOT   = SQRT(PT2+PZ**2)
27432          SINTHE = PT/MAX(PTOT,TINY14)
27433          COSTHE = PZ/MAX(PTOT,TINY14)
27434          IF (COSTHE.GT.ONE) THEN
27435             THETA = ZERO
27436          ELSEIF (COSTHE.LT.-ONE) THEN
27437             THETA = TWOPI/2.0D0
27438          ELSE
27439             THETA  = ACOS(COSTHE)
27440          ENDIF
27441          EKIN   = PE-AMASS
27442 **sr 15.4.96 new E_t-definition
27443 C        ET     = PE*SINTHE
27444          ET     = EKIN*SINTHE
27445 **
27446          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
27447             ETA = -LOG(TAN(THETA/TWO))
27448          ELSE
27449             ETA = 100.0D0
27450          ENDIF
27451          THETA  = THETA/BOG
27452          LRNL   = .TRUE.
27453       ENDIF
27454
27455  9999 CONTINUE
27456       RETURN
27457       END
27458 *
27459 *===himult=============================================================*
27460 *
27461 CDECK  ID>, DT_HIMULT
27462       SUBROUTINE DT_HIMULT(MODE)
27463
27464 ************************************************************************
27465 * Tables of average energies/multiplicities.                           *
27466 * This version dated 30.08.2000 is written by S. Roesler               *
27467 ************************************************************************
27468
27469       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27470       SAVE
27471
27472       PARAMETER ( LINP = 5 ,
27473      &            LOUT = 6 ,
27474      &            LDAT = 9 )
27475
27476       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
27477
27478       PARAMETER (SWMEXP=1.7D0)
27479
27480       CHARACTER*8 ANAMEH(4)
27481
27482 * particle properties (BAMJET index convention)
27483       CHARACTER*8  ANAME
27484       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27485      &                IICH(210),IIBAR(210),K1(210),K2(210)
27486 * temporary storage for one final state particle
27487       LOGICAL LFRAG,LGREY,LBLACK
27488       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
27489      &                SINTHE,COSTHE,THETA,THECMS,
27490      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
27491      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
27492      &                LFRAG,LGREY,LBLACK
27493 * event flag used for histograms
27494       COMMON /DTNORM/ ICEVT,IEVHKK
27495 * Lorentz-parameters of the current interaction
27496       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
27497      &                UMO,PPCM,EPROJ,PPROJ
27498
27499       PARAMETER (NOPART=210)
27500       DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
27501      &          AVPT(4,NOPART),IAVPT(4,NOPART)
27502       DATA ANAMEH /'DEUTERON','3-H     ','3-HE    ','4-HE    '/
27503
27504       GOTO (1,2,3) MODE
27505
27506 *------------------------------------------------------------------
27507 * initialization
27508     1 CONTINUE
27509       DO 10 I=1,NOPART
27510          DO 11 J=1,4
27511             AVMULT(J,I) = ZERO
27512             AVE(J,I)    = ZERO
27513             AVSWM(J,I)  = ZERO
27514             AVPT(J,I)   = ZERO
27515             IAVPT(J,I)  = 0
27516    11    CONTINUE
27517    10 CONTINUE
27518
27519       RETURN
27520
27521 *------------------------------------------------------------------
27522 * filling of histogram with event-record
27523     2 CONTINUE
27524       IF (PE.LT.0.0D0) THEN
27525          WRITE(LOUT,*) ' HIMULT:  PE < 0 ! ',PE
27526          RETURN
27527       ENDIF
27528       IF (.NOT.LFRAG) THEN
27529          IVEL = 2
27530          IF (LGREY)  IVEL = 3
27531          IF (LBLACK) IVEL = 4
27532          AVE(1,IDBJT)       = AVE(1,IDBJT)   +PE
27533          AVE(IVEL,IDBJT)    = AVE(IVEL,IDBJT)+PE
27534          AVPT(1,IDBJT)     = AVPT(1,IDBJT)   +PT
27535          AVPT(IVEL,IDBJT)  = AVPT(IVEL,IDBJT)+PT
27536          IAVPT(1,IDBJT)    = IAVPT(1,IDBJT)   +1
27537          IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
27538          AVSWM(1,IDBJT)     = AVSWM(1,IDBJT)   +PE**SWMEXP
27539          AVSWM(IVEL,IDBJT)  = AVSWM(IVEL,IDBJT)+PE**SWMEXP
27540          AVMULT(1,IDBJT)    = AVMULT(1,IDBJT)   +ONE
27541          AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
27542          IF (IDBJT.LT.116) THEN
27543 *   total energy, multiplicity
27544             AVE(1,30)       = AVE(1,30)   +PE
27545             AVE(IVEL,30)    = AVE(IVEL,30)+PE
27546             AVPT(1,30)     = AVPT(1,30)   +PT
27547             AVPT(IVEL,30)  = AVPT(IVEL,30)+PT
27548             IAVPT(1,30)    = IAVPT(1,30)   +1
27549             IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
27550             AVSWM(1,30)     = AVSWM(1,30)+PE**SWMEXP
27551             AVSWM(IVEL,30)  = AVSWM(IVEL,30)+PE**SWMEXP
27552             AVMULT(1,30)    = AVMULT(1,30)   +ONE
27553             AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
27554 *   charged energy, multiplicity
27555             IF (ICHAR.LT.0) THEN
27556                AVE(1,26)       = AVE(1,26)   +PE
27557                AVE(IVEL,26)    = AVE(IVEL,26)+PE
27558                AVPT(1,26)     = AVPT(1,26)   +PT
27559                AVPT(IVEL,26)  = AVPT(IVEL,26)+PT
27560                IAVPT(1,26)    = IAVPT(1,26)   +1
27561                IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
27562                AVSWM(1,26)     = AVSWM(1,26)   +PE**SWMEXP
27563                AVSWM(IVEL,26)  = AVSWM(IVEL,26)+PE**SWMEXP
27564                AVMULT(1,26)    = AVMULT(1,26)   +ONE
27565                AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
27566             ENDIF
27567             IF (ICHAR.NE.0) THEN
27568                AVE(1,27)       = AVE(1,27)   +PE
27569                AVE(IVEL,27)    = AVE(IVEL,27)+PE
27570                AVPT(1,27)     = AVPT(1,27)   +PT
27571                AVPT(IVEL,27)  = AVPT(IVEL,27)+PT
27572                IAVPT(1,27)    = IAVPT(1,27)   +1
27573                IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
27574                AVSWM(1,27)     = AVSWM(1,27)   +PE**SWMEXP
27575                AVSWM(IVEL,27)  = AVSWM(IVEL,27)+PE**SWMEXP
27576                AVMULT(1,27)    = AVMULT(1,27)   +ONE
27577                AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
27578             ENDIF
27579          ENDIF
27580       ENDIF
27581
27582       RETURN
27583
27584 *------------------------------------------------------------------
27585 * output
27586     3 CONTINUE
27587       WRITE(LOUT,3000)
27588  3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
27589      &       29X,'---------------------',/)
27590       PRINT*,' MULDEF = ',MULDEF
27591       IF (MULDEF.EQ.1) THEN
27592          WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
27593       ELSE
27594          BETGRE = 0.7D0
27595          BETBLC = 0.23D0
27596          WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
27597  3002    FORMAT(1X,'fast:  beta > ',F4.2,'    grey:  ',F4.2,' > beta > '
27598      &          ,F4.2,'    black:  beta < ',F4.2,/)
27599       ENDIF
27600       WRITE(LOUT,3003) SWMEXP
27601  3003 FORMAT(1X,'particle    |',12X,'average multiplicity',/,
27602      &      13X,'|     total         fast',
27603 C    &      '       grey     black      K      f(',F3.1,')',/,1X,
27604      &      '       grey     black    <pt>     f(',F3.1,')',/,1X,
27605      &      '------------+--------------',
27606      &      '-------------------------------------------------')
27607       DO 30 I=1,NOPART
27608          DO 31 J=1,4
27609             AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
27610             AVE(J,I)    = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
27611             AVPT(J,I)   = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
27612             AVSWM(J,I)  = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
27613    31    CONTINUE
27614          IF (I.LE.115) THEN
27615             WRITE(LOUT,3004) ANAME(I),I,
27616      &                       AVMULT(1,I),AVMULT(2,I),
27617      &                       AVMULT(3,I),AVMULT(4,I),
27618 C    &                       AVE(1,I),AVSWM(1,I)
27619      &                       AVPT(1,I),AVSWM(1,I)
27620          ELSEIF (I.LE.119) THEN
27621             WRITE(LOUT,3004) ANAMEH(I-115),I,
27622      &                       AVMULT(1,I),AVMULT(2,I),
27623      &                       AVMULT(3,I),AVMULT(4,I),
27624 C    &                       AVE(1,I),AVSWM(1,I)
27625      &                       AVPT(1,I),AVSWM(1,I)
27626          ENDIF
27627  3004    FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
27628    30 CONTINUE
27629 **temporary
27630 C     WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
27631 C    &               AVMULT(3,27)+AVMULT(4,27)
27632 **
27633
27634       RETURN
27635       END
27636 *
27637 *===histat=============================================================*
27638 *
27639 CDECK  ID>, DT_HISTAT
27640       SUBROUTINE DT_HISTAT(IDX,MODE)
27641
27642 ************************************************************************
27643 * This version dated 26.02.96 is written by S. Roesler                 *
27644 ************************************************************************
27645
27646       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27647       SAVE
27648
27649       PARAMETER ( LINP = 5 ,
27650      &            LOUT = 6 ,
27651      &            LDAT = 9 )
27652
27653       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
27654       PARAMETER (NDIM=199)
27655
27656 * event history
27657
27658       PARAMETER (NMXHKK=200000)
27659
27660       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27661      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27662      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27663 * extended event history
27664       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27665      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27666      &                IHIST(2,NMXHKK)
27667 * particle properties (BAMJET index convention)
27668       CHARACTER*8  ANAME
27669       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27670      &                IICH(210),IIBAR(210),K1(210),K2(210)
27671
27672       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27673
27674 * Glauber formalism: cross sections
27675       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
27676      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
27677      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
27678      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
27679      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
27680      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
27681      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
27682      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
27683      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
27684      &                BSLOPE,NEBINI,NQBINI
27685 * emulsion treatment
27686       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27687      &                NCOMPO,IEMUL
27688 * properties of interacting particles
27689       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
27690 * rejection counter
27691       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27692      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27693      &                IREXCI(3),IRDIFF(2),IRINC
27694 * statistics: residual nuclei
27695       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
27696      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
27697      &                NINCST(2,4),NINCEV(2),
27698      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
27699      &                NRESPB(2),NRESCH(2),NRESEV(4),
27700      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
27701      &                NEVAFI(2,2)
27702 * parameter for intranuclear cascade
27703       LOGICAL LPAULI
27704       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
27705
27706       INCLUDE './flukapro/(DIMPAR)'
27707       INCLUDE './flukapro/(PAREVT)'
27708       INCLUDE './flukapro/(FRBKCM)'
27709       INCLUDE './flukapro/(EVAPAR)'
27710
27711 * temporary storage for one final state particle
27712       LOGICAL LFRAG,LGREY,LBLACK
27713       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
27714      &                SINTHE,COSTHE,THETA,THECMS,
27715      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
27716      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
27717      &                LFRAG,LGREY,LBLACK
27718 * event flag used for histograms
27719       COMMON /DTNORM/ ICEVT,IEVHKK
27720 * statistics: double-Pomeron exchange
27721       COMMON /DTFLG2/ INTFLG,IPOPO
27722
27723       DIMENSION EMUSAM(NCOMPX)
27724
27725       CHARACTER*13 CMSG(3)
27726       DATA CMSG /'not requested','not requested','not requested'/
27727
27728       GOTO (1,2,3,4,5) MODE
27729
27730 *------------------------------------------------------------------
27731 * initialization
27732     1 CONTINUE
27733 *  emulsion treatment
27734       IF (NCOMPO.GT.0) THEN
27735          DO 10 I=1,NCOMPX
27736             EMUSAM(I) = ZERO
27737    10    CONTINUE
27738       ENDIF
27739 * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
27740       NINCGE = 0
27741       DO 11 I=1,2
27742          EXCDPM(I)   = ZERO
27743          EXCDPM(I+2) = ZERO
27744          EXCEVA(I)   = ZERO
27745          NINCWO(I)   = 0
27746          NINCEV(I)   = 0
27747          NRESTO(I)   = 0
27748          NRESPR(I)   = 0
27749          NRESNU(I)   = 0
27750          NRESBA(I)   = 0
27751          NRESPB(I)   = 0
27752          NRESCH(I)   = 0
27753          NRESEV(I)   = 0
27754          NRESEV(I+2) = 0
27755          NEVAGA(I)   = 0
27756          NEVAHT(I)   = 0
27757          NEVAFI(1,I) = 0
27758          NEVAFI(2,I) = 0
27759          DO 12 J=1,6
27760             IF (J.LE.2) NINCHR(I,J) = 0
27761             IF (J.LE.3) NINCCO(I,J) = 0
27762             IF (J.LE.4) NINCST(I,J) = 0
27763             NEVA(I,J) = 0
27764    12    CONTINUE
27765          DO 13 J=1,210
27766             NEVAHY(1,I,J) = 0
27767             NEVAHY(2,I,J) = 0
27768    13    CONTINUE
27769    11 CONTINUE
27770       MAXGEN = 0
27771 **dble Po statistics.
27772       KPOPO = 0
27773
27774       RETURN
27775 *------------------------------------------------------------------
27776 * filling of histogram with event-record
27777     2 CONTINUE
27778       IF (IST.EQ.-1) THEN
27779          IF (.NOT.LFRAG) THEN
27780             IF (IDPDG.EQ.2212) THEN
27781                NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
27782             ELSEIF (IDPDG.EQ.2112) THEN
27783                NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
27784             ELSEIF (IDPDG.EQ.22) THEN
27785                NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
27786             ELSEIF (IDPDG.EQ.80000) THEN
27787                IF (IDBJT.EQ.116) THEN
27788                   NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
27789                ELSEIF (IDBJT.EQ.117) THEN
27790                   NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
27791                ELSEIF (IDBJT.EQ.118) THEN
27792                   NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
27793                ELSEIF (IDBJT.EQ.119) THEN
27794                   NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
27795                ENDIF
27796             ENDIF
27797          ELSE
27798 *   heavy fragments (here: fission products only)
27799             NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
27800             NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
27801             NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
27802          ENDIF
27803       ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
27804          IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
27805       ENDIF
27806
27807       RETURN
27808 *------------------------------------------------------------------
27809 * output
27810     3 CONTINUE
27811
27812 **dble Po statistics.
27813 C     WRITE(LOUT,'(1X,A,2I7,2E12.4)')
27814 C    &   '# evts. / # dble-Po. evts / s_in / s_popo :',
27815 C    & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
27816
27817 *  emulsion treatment
27818       IF (NCOMPO.GT.0) THEN
27819          WRITE(LOUT,3000)
27820  3000    FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
27821      &          22X,'----------------------------',/,/,19X,
27822      &          'mass    charge          fraction',/,39X,
27823      &          'input     treated',/)
27824          DO 30 I=1,NCOMPO
27825             WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
27826      &                       EMUSAM(I)/DBLE(ICEVT)
27827  3013       FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
27828    30    CONTINUE
27829       ENDIF
27830
27831 *  i.n.c. statistics: output
27832       WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
27833  3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
27834      &       22X,'---------------------------------',/,/,1X,
27835      &       'no. of events for normalization: (accepted final events,',
27836      &       ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
27837      &       /,1X,'no. of rejected events due to intranuclear',
27838      &       ' cascade',15X,I6,/)
27839       ICEV  = MAX(ICEVT,1)
27840       ICEV1 = ICEV
27841       IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
27842       WRITE(LOUT,3002)
27843      &     (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
27844      &     ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
27845      &     KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
27846      &    (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
27847      &     (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
27848      &     (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
27849      &     (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
27850  3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
27851      &       5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
27852      &       ' proj./ target (mean per evt)',/,8X,'baryons:  pos. ',
27853      &       F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,/,8X,
27854      &       'mesons:   pos. ',F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,
27855      &       /,1X,'maximum no. of generations treated (maximum allowed:'
27856      &       ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
27857      &       ' interactions in proj./ target (mean per evt1)',
27858      &       F7.3,' /',F7.3,/,8X,'out of which by inelastic',
27859      &       ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
27860      &       'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
27861      &       '(ap, K-, pi- only)     ',F7.3,' /',F7.3,/)
27862       WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
27863      &                 IREXCI(1)+IREXCI(2)+IREXCI(3)
27864  3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
27865      &       'evaporation',/,22X,'-----------------------------',
27866      &       '------------',/,/,1X,'no. of events for normal.: ',
27867      &       '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
27868      &       ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
27869      &       ' rejected events     (',I4,',',I4,',',I4,')',22X,I6,/)
27870
27871       WRITE(LOUT,3004)
27872  3004 FORMAT(/,22X,'1) before evaporation-step:',/)
27873       ICEV  = MAX(NRESEV(2),1)
27874       WRITE(LOUT,3005)
27875      &     (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
27876      &     (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
27877      &     (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
27878      &     (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
27879      &     (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
27880      &     (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
27881      &     (EXCDPM(I)/DBLE(ICEV),I=1,2),
27882      &     (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
27883  3005    FORMAT(1X,'residual nuclei:  (mean values per evt)',12X,
27884      &       'proj. / target',/,/,8X,'total number of particles',15X,
27885      &       2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
27886      &       'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
27887      &       'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
27888      &       /,8X,'excitation energy (bef. evap.-step)   ',2E11.3,/,
27889      &       8X,'excitation energy per nucleon         ',2E11.3,/,/)
27890
27891 * evaporation / fission / fragmentation statistics: output
27892       ICEV  = MAX(NRESEV(2),1)
27893       ICEV1 = MAX(NRESEV(4),1)
27894       NTEVA1 =
27895      &   NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
27896       NTEVA2 =
27897      &   NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
27898       IF (LEVPRT) THEN
27899          IF (IFISS.EQ.1) CMSG(1) = 'requested    '
27900          IF (LFRMBK)     CMSG(2) = 'requested    '
27901          IF (LDEEXG)     CMSG(3) = 'requested    '
27902          WRITE(LOUT,3006)
27903      &        CMSG,
27904      &        DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
27905      &        (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
27906      &        (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
27907      &        (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
27908      &        (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
27909      &        (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
27910      &        (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
27911      &        (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
27912      &        (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
27913  3006    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,'Fission:',
27914      &       13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
27915      &       'deexcitation:',2X,A13,/,/,
27916      &       1X,'evaporation/deexcitation:  (mean values per evt1)  ',
27917      &       'proj. / target',/,/,8X,'total number of evap. particles',
27918      &       9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
27919      &       'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
27920      &       '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
27921      &       2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
27922      &       'heavy fragments',25X,2F9.3,/)
27923          IF (IFISS.EQ.1) THEN
27924             WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
27925      &                       NEVAFI(2,1),NEVAFI(2,2),
27926      &             DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
27927      &             DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
27928  3007       FORMAT(1X,'Fission:   total number of events',14X,2I9,/
27929      &             12X,'out of which fission occured',8X,2I9,/,
27930      &             50X,'(',F5.2,'%) (',F5.2,'%)',/)
27931          ENDIF
27932 C        IF ((LFRMBK).OR.(IFISS.EQ.1)) THEN
27933 C           WRITE(LOUT,3008)
27934 C3008       FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
27935 C    &             '       proj.   / target',/)
27936 C           DO 31 I=1,210
27937 C              IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
27938 C                 WRITE(LOUT,3009) I,
27939 C    &            (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
27940 C3009             FORMAT(38X,I3,3X,2E12.3)
27941 C              ENDIF
27942 C  31       CONTINUE
27943 C           WRITE(LOUT,3010)
27944 C3010       FORMAT(1X,'heavy fragments - statistics:',7X,'mass  ',
27945 C    &             '       proj.   / target',/)
27946 C           DO 32 I=1,210
27947 C              IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
27948 C                 WRITE(LOUT,3011) I,
27949 C    &            (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
27950 C3011             FORMAT(38X,I3,3X,2E12.3)
27951 C              ENDIF
27952 C  32       CONTINUE
27953 C           WRITE(LOUT,*)
27954 C        ENDIF
27955       ELSE
27956          WRITE(LOUT,3012)
27957  3012    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,
27958      &       'Evaporation:         not requested',/)
27959       ENDIF
27960
27961       RETURN
27962 *------------------------------------------------------------------
27963 * filling of histogram with event-record
27964     4 CONTINUE
27965 *  emulsion treatment
27966       IF (NCOMPO.GT.0) THEN
27967          DO 40 I=1,NCOMPO
27968             IF (IT.EQ.IEMUMA(I)) THEN
27969                EMUSAM(I) = EMUSAM(I)+ONE
27970             ENDIF
27971    40    CONTINUE
27972       ENDIF
27973       NINCGE = NINCGE+MAXGEN
27974       MAXGEN = 0
27975 **dble Po statistics.
27976       IF (IPOPO.EQ.1) KPOPO = KPOPO+1
27977
27978       RETURN
27979 *------------------------------------------------------------------
27980 * filling of histogram with event-record
27981     5 CONTINUE
27982       IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
27983          IB = IIBAR(IDBAM(IDX))
27984          IC = IICH(IDBAM(IDX))
27985          J  = ISTHKK(IDX)-14
27986          IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
27987             NINCST(J,1) = NINCST(J,1)+1
27988          ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
27989             NINCST(J,2) = NINCST(J,2)+1
27990          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
27991             NINCST(J,3) = NINCST(J,3)+1
27992          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
27993             NINCST(J,4) = NINCST(J,4)+1
27994          ENDIF
27995       ELSEIF (ISTHKK(IDX).EQ.17) THEN
27996          NINCWO(1) = NINCWO(1)+1
27997       ELSEIF (ISTHKK(IDX).EQ.18) THEN
27998          NINCWO(2) = NINCWO(2)+1
27999       ELSEIF (ISTHKK(IDX).EQ.1001) THEN
28000          IB = IDRES(IDX)
28001          IC = IDXRES(IDX)
28002          IF (IC.GT.0) THEN
28003             NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
28004             NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
28005          ENDIF
28006          NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
28007       ENDIF
28008
28009       RETURN
28010       END
28011 *
28012 *===newhgr=============================================================*
28013 *
28014 CDECK  ID>, DT_NEWHGR
28015       SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
28016
28017 ************************************************************************
28018 *                                                                      *
28019 *     Histogram initialization.                                        *
28020 *                                                                      *
28021 *     input:  XLIM1/XLIM2  lower/upper edge of histogram-window        *
28022 *             XLIM3        bin size                                    *
28023 *             IBIN    > 0  number of bins in equidistant lin. binning  *
28024 *                     = -1 reset histograms                            *
28025 *                     < -1 |IBIN| number of bins in equidistant log.   *
28026 *                          binning or log. binning in user def. struc. *
28027 *             XLIMB(*)     user defined bin structure                  *
28028 *                                                                      *
28029 *     The bin structure is sensitive to                                *
28030 *             XLIM1, XLIM3, IBIN     if     XLIM3 > 0   (lin.)         *
28031 *             XLIM1, XLIM2, IBIN     if     XLIM3 = 0   (lin. & log.)  *
28032 *             XLIMB, IBIN            if     XLIM3 < 0                  *
28033 *                                                                      *
28034 *                                                                      *
28035 *     output: IREFN        histogram index                             *
28036 *                          (= -1 for inconsistent histogr. request)    *
28037 *                                                                      *
28038 * This subroutine is based on a original version by R. Engel.          *
28039 * This version dated 22.4.95 is written  by S. Roesler.                *
28040 ************************************************************************
28041
28042       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28043       SAVE
28044
28045       PARAMETER ( LINP = 5 ,
28046      &            LOUT = 6 ,
28047      &            LDAT = 9 )
28048
28049       LOGICAL LSTART
28050
28051       PARAMETER (ZERO   =  0.0D0,
28052      &           TINY   =  1.0D-10)
28053
28054       DIMENSION XLIMB(*)
28055
28056 * histograms
28057
28058       PARAMETER (NHIS=150, NDIM=250)
28059
28060       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28061      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28062 * auxiliary common for histograms
28063       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
28064
28065       DATA LSTART /.TRUE./
28066
28067 * reset histogram counter
28068       IF (LSTART.OR.(IBIN.EQ.-1)) THEN
28069          IHISL  = 0
28070          IF (IBIN.EQ.-1) RETURN
28071          LSTART = .FALSE.
28072       ENDIF
28073
28074       IHIS  = IHISL+1
28075 * check for maximum number of allowed histograms
28076       IF (IHIS.GT.NHIS) THEN
28077          WRITE(LOUT,1003) IHIS,NHIS,IHIS
28078  1003    FORMAT(1X,'NEWHGR:   warning!  number of histograms (',
28079      &          I4,') exceeds array size (',I4,')',/,21X,
28080      &          'histogram',I3,' skipped!')
28081          GOTO 9999
28082       ENDIF
28083
28084       IREFN = IHIS
28085       IBINS(IHIS) = ABS(IBIN)
28086 * check requested number of bins
28087       IF (IBINS(IHIS).GE.NDIM) THEN
28088          WRITE(LOUT,1000) IBIN,NDIM,NDIM
28089  1000    FORMAT(1X,'NEWHGR:   warning!  number of bins (',
28090      &          I3,') exceeds array size (',I3,')',/,21X,
28091      &          'and will be reset to ',I3)
28092          IBINS(IHIS) = NDIM
28093       ENDIF
28094       IF (IBINS(IHIS).EQ.0) THEN
28095          WRITE(LOUT,1001) IBIN,IHIS
28096  1001    FORMAT(1X,'NEWHGR:   warning!  inconsistent number of',
28097      &          ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
28098          GOTO 9999
28099       ENDIF
28100
28101 * initialize arrays
28102       DO 1 I=1,NDIM
28103          DO 2 K=1,3
28104             HIST(K,IHIS,I)   = ZERO
28105             HIST(K+3,IHIS,I) = ZERO
28106             TMPHIS(K,IHIS,I) = ZERO
28107     2    CONTINUE
28108          HIST(7,IHIS,I)   = ZERO
28109     1 CONTINUE
28110       DENTRY(1,IHIS)= ZERO
28111       DENTRY(2,IHIS)= ZERO
28112       OVERF(IHIS)   = ZERO
28113       UNDERF(IHIS)  = ZERO
28114       TMPUFL(IHIS)  = ZERO
28115       TMPOFL(IHIS)  = ZERO
28116
28117 * bin str. sensitive to lower edge, bin size, and numb. of bins
28118       IF (XLIM3.GT.ZERO) THEN
28119          DO 3 K=1,IBINS(IHIS)+1
28120             HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
28121     3    CONTINUE
28122          ISWI(IHIS) = 1
28123 * bin str. sensitive to lower/upper edge and numb. of bins
28124       ELSEIF (XLIM3.EQ.ZERO) THEN
28125 *   linear binning
28126          IF (IBIN.GT.0) THEN
28127             XLOW = XLIM1
28128             XHI  = XLIM2
28129             IF (XLIM2.LE.XLIM1) THEN
28130                WRITE(LOUT,1002) XLIM1,XLIM2
28131  1002          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
28132      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
28133                GOTO 9999
28134             ENDIF
28135             ISWI(IHIS) = 1
28136          ELSEIF (IBIN.LT.-1) THEN
28137 *   logarithmic binning
28138             IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
28139                WRITE(LOUT,1004) XLIM1,XLIM2
28140  1004          FORMAT(1X,'NEWHGR:   warning!  inconsistent log. ',
28141      &                'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
28142                GOTO 9999
28143             ENDIF
28144             IF (XLIM2.LE.XLIM1) THEN
28145                WRITE(LOUT,1005) XLIM1,XLIM2
28146  1005          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
28147      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
28148                GOTO 9999
28149             ENDIF
28150             XLOW = LOG10(XLIM1)
28151             XHI  = LOG10(XLIM2)
28152             ISWI(IHIS) = 3
28153          ENDIF
28154          DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
28155          DO 4 K=1,IBINS(IHIS)+1
28156             HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
28157     4    CONTINUE
28158       ELSE
28159 * user defined bin structure
28160          DO 5 K=1,IBINS(IHIS)+1
28161             IF (IBIN.GT.0) THEN
28162                HIST(1,IHIS,K) = XLIMB(K)
28163                ISWI(IHIS) = 2
28164             ELSEIF (IBIN.LT.-1) THEN
28165                HIST(1,IHIS,K) = LOG10(XLIMB(K))
28166                ISWI(IHIS) = 4
28167             ENDIF
28168     5    CONTINUE
28169       ENDIF
28170
28171 * histogram accepted
28172       IHISL = IHIS
28173
28174       RETURN
28175
28176  9999 CONTINUE
28177       IREFN = -1
28178       RETURN
28179       END
28180 *
28181 *===filhgr=============================================================*
28182 *
28183 CDECK  ID>, DT_FILHGR
28184       SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
28185
28186 ************************************************************************
28187 *                                                                      *
28188 *     Scoring for histogram IHIS.                                      *
28189 *                                                                      *
28190 * This subroutine is based on a original version by R. Engel.          *
28191 * This version dated 23.4.95 is written  by S. Roesler.                *
28192 ************************************************************************
28193
28194       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28195       SAVE
28196
28197       PARAMETER ( LINP = 5 ,
28198      &            LOUT = 6 ,
28199      &            LDAT = 9 )
28200
28201       PARAMETER (ZERO = 0.0D0,
28202      &           ONE  = 1.0D0,
28203      &           TINY = 1.0D-10)
28204
28205 * histograms
28206
28207       PARAMETER (NHIS=150, NDIM=250)
28208
28209       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28210      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28211 * auxiliary common for histograms
28212       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
28213
28214       DATA NCEVT /1/
28215
28216       X = XI
28217       Y = YI
28218
28219 * dump content of temorary arrays into histograms
28220       IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
28221          CALL DT_EVTHIS(IDUM)
28222          NCEVT = NEVT
28223       ENDIF
28224
28225 * check histogram index
28226       IF (IHIS.EQ.-1) RETURN
28227       IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
28228 C        WRITE(LOUT,1000) IHIS,IHISL
28229  1000    FORMAT(1X,'FILHGR:   warning!  histogram index',I4,
28230      &          ' out of range (1..',I3,')')
28231          RETURN
28232       ENDIF
28233
28234       IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
28235 * bin structure not explicitly given
28236          IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
28237          DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
28238          IF (X.LT.HIST(1,IHIS,1)) THEN
28239             I1 = 0
28240          ELSE
28241             I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
28242          ENDIF
28243
28244       ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
28245 * user defined bin structure
28246          IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
28247          IF (X.LT.HIST(1,IHIS,1)) THEN
28248             I1 = 0
28249          ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
28250             I1 = IBINS(IHIS)+1
28251          ELSE
28252 *   binary sort algorithm
28253             KMIN = 0
28254             KMAX = IBINS(IHIS)+1
28255     1       CONTINUE
28256             IF ((KMAX-KMIN).EQ.1) GOTO 2
28257             KK = (KMAX+KMIN)/2
28258             IF (X.LE.HIST(1,IHIS,KK)) THEN
28259                KMAX=KK
28260             ELSE
28261                KMIN=KK
28262             ENDIF
28263             GOTO 1
28264     2       CONTINUE
28265             I1 = KMIN
28266          ENDIF
28267
28268       ELSE
28269          WRITE(LOUT,1001)
28270  1001    FORMAT(1X,'FILHGR:   warning!  histogram not initialized')
28271          RETURN
28272       ENDIF
28273
28274 * scoring
28275       IF (I1.LE.0) THEN
28276          TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
28277       ELSEIF (I1.LE.IBINS(IHIS)) THEN
28278          TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
28279          IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
28280             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
28281          ELSE
28282             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
28283          ENDIF
28284          TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
28285       ELSE
28286          TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
28287       ENDIF
28288
28289       RETURN
28290       END
28291 *
28292 *===evthis=============================================================*
28293 *
28294 CDECK  ID>, DT_EVTHIS
28295       SUBROUTINE DT_EVTHIS(NEVT)
28296
28297 ************************************************************************
28298 * Dump content of temorary histograms into /DTHIS1/. This subroutine   *
28299 * is called after each event and for the last event before any call    *
28300 * to OUTHGR.                                                           *
28301 *         NEVT   number of events dumped, this is only needed to       *
28302 *                get the normalization after the last event            *
28303 * This version dated 23.4.95 is written  by S. Roesler.                *
28304 ************************************************************************
28305
28306       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28307       SAVE
28308
28309       PARAMETER ( LINP = 5 ,
28310      &            LOUT = 6 ,
28311      &            LDAT = 9 )
28312
28313       LOGICAL LNOETY
28314
28315       PARAMETER (ZERO = 0.0D0,
28316      &           ONE  = 1.0D0,
28317      &           TINY = 1.0D-10)
28318
28319 * histograms
28320
28321       PARAMETER (NHIS=150, NDIM=250)
28322
28323       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28324      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28325 * auxiliary common for histograms
28326       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
28327
28328       DATA NCEVT /0/
28329
28330       NCEVT = NCEVT+1
28331       NEVT  = NCEVT
28332
28333       DO 1 I=1,IHISL
28334          LNOETY = .TRUE.
28335          DO 2 J=1,IBINS(I)
28336             IF (TMPHIS(1,I,J).GT.ZERO) THEN
28337                LNOETY = .FALSE.
28338                HIST(2,I,J)   = HIST(2,I,J)+ONE
28339                HIST(7,I,J)   = HIST(7,I,J)+TMPHIS(1,I,J)
28340                DENTRY(2,I)   = DENTRY(2,I)+TMPHIS(1,I,J)
28341                AVX           = TMPHIS(2,I,J)/TMPHIS(1,I,J)
28342                HIST(3,I,J)   = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
28343                HIST(4,I,J)   = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
28344                HIST(5,I,J)   = HIST(5,I,J)+TMPHIS(3,I,J)
28345                HIST(6,I,J)   = HIST(6,I,J)+TMPHIS(3,I,J)**2
28346                TMPHIS(1,I,J) = ZERO
28347                TMPHIS(2,I,J) = ZERO
28348                TMPHIS(3,I,J) = ZERO
28349             ENDIF
28350     2    CONTINUE
28351          IF (LNOETY) THEN
28352             IF (TMPUFL(I).GT.ZERO) THEN
28353                UNDERF(I) = UNDERF(I)+ONE
28354                TMPUFL(I) = ZERO
28355             ELSEIF (TMPOFL(I).GT.ZERO) THEN
28356                OVERF(I)  = OVERF(I)+ONE
28357                TMPOFL(I) = ZERO
28358             ENDIF
28359          ELSE
28360             DENTRY(1,I) = DENTRY(1,I)+ONE
28361          ENDIF
28362     1 CONTINUE
28363
28364       RETURN
28365       END
28366 *
28367 *===outhgr=============================================================*
28368 *
28369 CDECK  ID>, DT_OUTHGR
28370       SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
28371      &                  ILOGY,INORM,NMODE)
28372
28373 ************************************************************************
28374 *                                                                      *
28375 *     Plot histogram(s) to standard output unit                        *
28376 *                                                                      *
28377 *         I1..6         indices of histograms to be plotted            *
28378 *         CHEAD,IHEAD   header string,integer                          *
28379 *         NEVTS         number of events                               *
28380 *         FAC           scaling factor                                 *
28381 *         ILOGY   = 1   logarithmic y-axis                             *
28382 *         INORM         normalization                                  *
28383 *                 = 0   no further normalization (FAC is obsolete)     *
28384 *                 = 1   per event and bin width                        *
28385 *                 = 2   per entry and bin width                        *
28386 *                 = 3   per bin entry                                  *
28387 *                 = 4   per event and "bin width" x1^2...x2^2          *
28388 *                 = 5   per event and "log. bin width" ln x1..ln x2    *
28389 *                 = 6   per event                                      *
28390 *         MODE    = 0   no output but normalization applied            *
28391 *                 = 1   all valid histograms separately (small frame)  *
28392 *                       all valid histograms separately (small frame)  *
28393 *                 = -1  and tables as histograms                       *
28394 *                 = 2   all valid histograms (one plot, wide frame)    *
28395 *                       all valid histograms (one plot, wide frame)    *
28396 *                 = -2  and tables as histograms                       *
28397 *                                                                      *
28398 *                                                                      *
28399 *     Note: All histograms to be plotted with one call to this         *
28400 *           subroutine and |MODE|=2 must have the same bin structure!  *
28401 *           There is no test included ensuring this fact.              *
28402 *                                                                      *
28403 * This version dated 23.4.95 is written  by S. Roesler.                *
28404 ************************************************************************
28405
28406       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28407       SAVE
28408
28409       PARAMETER ( LINP = 5 ,
28410      &            LOUT = 6 ,
28411      &            LDAT = 9 )
28412
28413       CHARACTER*72 CHEAD
28414
28415       PARAMETER (ZERO   =  0.0D0,
28416      &           IZERO  =  0,
28417      &           ONE    =  1.0D0,
28418      &           TWO    =  2.0D0,
28419      &           OHALF  =  0.5D0,
28420      &           EPS    =  1.0D-5,
28421      &           TINY   =  1.0D-8,
28422      &           SMALL  =  -1.0D8,
28423      &           RLARGE =  1.0D8 )
28424
28425 * histograms
28426
28427       PARAMETER (NHIS=150, NDIM=250)
28428
28429       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28430      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28431
28432       PARAMETER (NDIM2 = 2*NDIM)
28433       DIMENSION XX(NDIM2),YY(NDIM2)
28434
28435       PARAMETER (NHISTO = 6)
28436       DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
28437      &          IDX(NHISTO)
28438
28439       CHARACTER*43 CNORM(0:8)
28440       DATA CNORM /'no further normalization                   ',
28441      &            'per event and bin width                    ',
28442      &            'per entry1 and bin width                   ',
28443      &            'per bin entry                              ',
28444      &            'per event and "bin width" x1^2...x2^2      ',
28445      &            'per event and "log. bin width" ln x1..ln x2',
28446      &            'per event                                  ',
28447      &            'per bin entry1                             ',
28448      &            'per entry2 and bin width                   '/
28449
28450       IDX1(1) = I1
28451       IDX1(2) = I2
28452       IDX1(3) = I3
28453       IDX1(4) = I4
28454       IDX1(5) = I5
28455       IDX1(6) = I6
28456
28457       MODE = NMODE
28458
28459 * initialization if "wide frame" is requested
28460       IF (ABS(MODE).EQ.2) THEN
28461          DO 1 I=1,NHISTO
28462             DO 2 J=1,NDIM
28463                XX1(J,I) = ZERO
28464                YY1(J,I) = ZERO
28465     2       CONTINUE
28466     1    CONTINUE
28467       ENDIF
28468
28469 * plot header
28470       WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
28471
28472 * check histogram indices
28473       NHI = 0
28474       DO 3 I=1,NHISTO
28475          IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
28476             IF (ISWI(IDX1(I)).NE.0) THEN
28477                IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
28478                   WRITE(LOUT,1000)
28479      &                 IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
28480  1000             FORMAT(/,1X,'OUTHGR:   warning!  no entries in',
28481      &                   ' histogram ',I3,/,21X,'underflows:',F10.0,
28482      &                   '   overflows:  ',F10.0)
28483                ELSE
28484                   NHI = NHI+1
28485                   IDX(NHI) = IDX1(I)
28486                ENDIF
28487             ENDIF
28488          ENDIF
28489     3 CONTINUE
28490       IF (NHI.EQ.0) THEN
28491          WRITE(LOUT,1001)
28492  1001    FORMAT(/,1X,'OUTHGR:   warning!  histogram indices not valid')
28493          RETURN
28494       ENDIF
28495
28496 * check normalization request
28497       IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
28498      &     ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
28499      &                        (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
28500      &     (INORM.LT.0).OR.(INORM.GT.8) ) THEN
28501          WRITE(LOUT,1002) NEVTS,INORM,FAC
28502  1002    FORMAT(/,1X,'OUTHGR:   warning!  normalization request not ',
28503      &          'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
28504      &          'FAC = ',E11.4)
28505          RETURN
28506       ENDIF
28507
28508       WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
28509
28510 * apply normalization
28511       DO 4 N=1,NHI
28512
28513          I = IDX(N)
28514
28515          IF (ISWI(I).EQ.1) THEN
28516             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
28517  1003       FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
28518      &             ' to',2X,E10.4,',',2X,I3,' bins')
28519          ELSEIF (ISWI(I).EQ.2) THEN
28520             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
28521             WRITE(LOUT,1007)
28522  1007       FORMAT(1X,'user defined bin structure')
28523          ELSEIF (ISWI(I).EQ.3) THEN
28524             WRITE(LOUT,1004)
28525      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
28526  1004       FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
28527      &             ' to',2X,E10.4,',',2X,I3,' bins')
28528          ELSEIF (ISWI(I).EQ.4) THEN
28529             WRITE(LOUT,1004)
28530      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
28531             WRITE(LOUT,1007)
28532          ELSE
28533             WRITE(LOUT,1008) ISWI(I)
28534  1008       FORMAT(/,1X,'warning!  inconsistent bin structure flag ',I4)
28535          ENDIF
28536          WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
28537  1005    FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
28538      &          ' overfl.:',F8.0)
28539          WRITE(LOUT,1009) CNORM(INORM)
28540  1009    FORMAT(1X,'normalization: ',A,/)
28541
28542          DO 5 K=1,IBINS(I)
28543             CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
28544             YMEAN = FAC*YMEAN
28545             YERR  = FAC*YERR
28546             WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
28547             WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
28548  1006       FORMAT(1X,5E11.3)
28549 *    small frame
28550             II = 2*K
28551             XX(II-1) = HIST(1,I,K)
28552             XX(II)   = HIST(1,I,K+1)
28553             YY(II-1) = YMEAN
28554             YY(II)   = YMEAN
28555 *    wide frame
28556             XX1(K,N) = XMEAN
28557             IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
28558      &         XX1(K,N) = LOG10(XMEAN)
28559             YY1(K,N) = YMEAN
28560     5    CONTINUE
28561
28562 * plot small frame
28563          IF (ABS(MODE).EQ.1) THEN
28564             IBIN2 = 2*IBINS(I)
28565             WRITE(LOUT,'(/,1X,A)') 'Preview:'
28566             IF(ILOGY.EQ.1) THEN
28567               CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
28568             ELSE
28569               CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
28570             ENDIF
28571          ENDIF
28572
28573     4 CONTINUE
28574
28575 * plot wide frame
28576       IF (ABS(MODE).EQ.2) THEN
28577          WRITE(LOUT,'(/,1X,A)') 'Preview:'
28578          NSIZE = NDIM*NHISTO
28579          DXLOW = HIST(1,IDX(1),1)
28580          DDX   = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
28581          YLOW  = RLARGE
28582          YHI   = SMALL
28583          DO 6 I=1,NHISTO
28584             DO 7 J=1,NDIM
28585                IF (YY1(J,I).LT.YLOW) THEN
28586                   IF (ILOGY.EQ.1) THEN
28587                      IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
28588                   ELSE
28589                      YLOW = YY1(J,I)
28590                   ENDIF
28591                ENDIF
28592                IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
28593     7       CONTINUE
28594     6    CONTINUE
28595          DY = (YHI-YLOW)/DBLE(NDIM)
28596          IF (DY.LE.ZERO) THEN
28597             WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
28598      &         'OUTHGR:   warning! zero bin width for histograms ',
28599      &         IDX,': ',YLOW,YHI
28600             RETURN
28601          ENDIF
28602          IF (ILOGY.EQ.1) THEN
28603             YLOW = LOG10(YLOW)
28604             DY   = (LOG10(YHI)-YLOW)/100.0D0
28605             DO 8 I=1,NHISTO
28606                DO 9 J=1,NDIM
28607                   IF (YY1(J,I).LE.ZERO) THEN
28608                      YY1(J,I) = YLOW
28609                   ELSE
28610                      YY1(J,I) = LOG10(YY1(J,I))
28611                   ENDIF
28612     9          CONTINUE
28613     8       CONTINUE
28614          ENDIF
28615          CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
28616       ENDIF
28617
28618       RETURN
28619       END
28620 *
28621 *===getbin=============================================================*
28622 *
28623 CDECK  ID>, DT_GETBIN
28624       SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
28625      &                  XMEAN,YMEAN,YERR)
28626
28627 ************************************************************************
28628 * This version dated 23.4.95 is written  by S. Roesler.                *
28629 ************************************************************************
28630
28631       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28632       SAVE
28633
28634       PARAMETER ( LINP = 5 ,
28635      &            LOUT = 6 ,
28636      &            LDAT = 9 )
28637
28638       PARAMETER (ZERO   = 0.0D0,
28639      &           ONE    = 1.0D0,
28640      &           TINY35 = 1.0D-35)
28641
28642 * histograms
28643
28644       PARAMETER (NHIS=150, NDIM=250)
28645
28646       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28647      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28648
28649       XLOW = HIST(1,IHIS,IBIN)
28650       XHI  = HIST(1,IHIS,IBIN+1)
28651       IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
28652          XLOW = 10**XLOW
28653          XHI  = 10**XHI
28654       ENDIF
28655       IF (NORM.EQ.2) THEN
28656          DX   = XHI-XLOW
28657          NEVT = INT(DENTRY(1,IHIS))
28658       ELSEIF (NORM.EQ.3) THEN
28659          DX   = ONE
28660          NEVT = INT(HIST(2,IHIS,IBIN))
28661       ELSEIF (NORM.EQ.4) THEN
28662          DX   = XHI**2-XLOW**2
28663          NEVT = KEVT
28664       ELSEIF (NORM.EQ.5) THEN
28665          DX   = LOG(ABS(XHI))-LOG(ABS(XLOW))
28666          NEVT = KEVT
28667       ELSEIF (NORM.EQ.6) THEN
28668          DX   = ONE
28669          NEVT = KEVT
28670       ELSEIF (NORM.EQ.7) THEN
28671          DX   = ONE
28672          NEVT = INT(HIST(7,IHIS,IBIN))
28673       ELSEIF (NORM.EQ.8) THEN
28674          DX   = XHI-XLOW
28675          NEVT = INT(DENTRY(2,IHIS))
28676       ELSE
28677          DX   = ABS(XHI-XLOW)
28678          NEVT = KEVT
28679       ENDIF
28680       IF (ABS(DX).LT.TINY35) DX = ONE
28681       NEVT   = MAX(NEVT,1)
28682       YMEAN  = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
28683       YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
28684       YERR   = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
28685       YSUM   = HIST(5,IHIS,IBIN)
28686       IF (ABS(YSUM).LT.TINY35) YSUM = ONE
28687 C     XMEAN  = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
28688       XMEAN  = HIST(3,IHIS,IBIN)/YSUM
28689       IF (XMEAN.EQ.ZERO) XMEAN = XLOW
28690
28691       RETURN
28692       END
28693 *
28694 *===joihis=============================================================*
28695 *
28696 CDECK  ID>, DT_JOIHIS
28697       SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
28698
28699 ************************************************************************
28700 *                                                                      *
28701 *     Operation on histograms.                                         *
28702 *                                                                      *
28703 *     input:  IH1,IH2      histogram indices to be joined              *
28704 *             COPER        character defining the requested operation, *
28705 *                          i.e. '+', '-', '*', '/'                     *
28706 *             FAC1,FAC2    factors for joining, i.e.                   *
28707 *                          FAC1*histo1 COPER FAC2*histo2               *
28708 *                                                                      *
28709 * This version dated 23.4.95 is written  by S. Roesler.                *
28710 ************************************************************************
28711
28712       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28713       SAVE
28714
28715       PARAMETER ( LINP = 5 ,
28716      &            LOUT = 6 ,
28717      &            LDAT = 9 )
28718
28719       CHARACTER COPER*1
28720
28721       PARAMETER (ZERO   =  0.0D0,
28722      &           ONE    =  1.0D0,
28723      &           OHALF  =  0.5D0,
28724      &           TINY8  =  1.0D-8,
28725      &           SMALL  =  -1.0D8,
28726      &           RLARGE =  1.0D8 )
28727
28728 * histograms
28729
28730       PARAMETER (NHIS=150, NDIM=250)
28731
28732       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28733      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28734
28735       PARAMETER (NDIM2 = 2*NDIM)
28736       DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
28737
28738       CHARACTER*43 CNORM(0:6)
28739       DATA CNORM /'no further normalization                   ',
28740      &            'per event and bin width                    ',
28741      &            'per entry and bin width                    ',
28742      &            'per bin entry                              ',
28743      &            'per event and "bin width" x1^2...x2^2      ',
28744      &            'per event and "log. bin width" ln x1..ln x2',
28745      &            'per event                                  '/
28746
28747 * check histogram indices
28748       IF ((IH1.LT.    1).OR.(IH2.LT.    1).OR.
28749      &    (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
28750          WRITE(LOUT,1000) IH1,IH2,IHISL
28751  1000    FORMAT(1X,'JOIHIS:   warning!  inconsistent histogram ',
28752      &          'indices (',I3,',',I3,'),',/,21X,'valid range:  1,',I3)
28753          GOTO 9999
28754       ENDIF
28755
28756 * check bin structure of histograms to be joined
28757       IF (IBINS(IH1).NE.IBINS(IH2)) THEN
28758          WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
28759  1001    FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
28760      &          ' and ',I3,' failed',/,21X,
28761      &          'due to different numbers of bins (',I3,',',I3,')')
28762          GOTO 9999
28763       ENDIF
28764       DO 1 K=1,IBINS(IH1)+1
28765          IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
28766             WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
28767  1002       FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
28768      &             ' and ',I3,' failed at bin edge ',I3,/,21X,
28769      &             'X1,X2 = ',2E11.4)
28770             GOTO 9999
28771          ENDIF
28772     1 CONTINUE
28773
28774       WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
28775  1003 FORMAT(1X,'JOIHIS:   joining histograms ',I3,',',I3,' with ',
28776      &       'operation ',A,/,11X,'and factors ',2E11.4)
28777       WRITE(LOUT,1004) CNORM(NORM)
28778  1004 FORMAT(1X,'normalization: ',A,/)
28779
28780       DO 2 K=1,IBINS(IH1)
28781          CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
28782          CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
28783          XLOW  = XLOW1
28784          XHI   = XHI1
28785          XMEAN = OHALF*(XMEAN1+XMEAN2)
28786          IF (COPER.EQ.'+') THEN
28787             YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
28788          ELSEIF (COPER.EQ.'*') THEN
28789             YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
28790          ELSEIF (COPER.EQ.'/') THEN
28791             IF (YMEAN2.EQ.ZERO) THEN
28792                YMEAN = ZERO
28793             ELSE
28794                IF (FAC2.EQ.ZERO) FAC2 = ONE
28795                YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
28796             ENDIF
28797          ELSE
28798             GOTO 9998
28799          ENDIF
28800          WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
28801          WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
28802  1006    FORMAT(1X,5E11.3)
28803 *    small frame
28804          II = 2*K
28805          XX(II-1) = HIST(1,IH1,K)
28806          XX(II)   = HIST(1,IH1,K+1)
28807          YY(II-1) = YMEAN
28808          YY(II)   = YMEAN
28809 *    wide frame
28810          XX1(K) = XMEAN
28811          IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
28812          YY1(K) = YMEAN
28813     2 CONTINUE
28814
28815 * plot small frame
28816       IF (ABS(MODE).EQ.1) THEN
28817          IBIN2 = 2*IBINS(IH1)
28818          WRITE(LOUT,'(/,1X,A)') 'Preview:'
28819          IF(ILOGY.EQ.1) THEN
28820            CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
28821          ELSE
28822            CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
28823          ENDIF
28824       ENDIF
28825
28826 * plot wide frame
28827       IF (ABS(MODE).EQ.2) THEN
28828          WRITE(LOUT,'(/,1X,A)') 'Preview:'
28829          NSIZE = NDIM
28830          DXLOW = HIST(1,IH1,1)
28831          DDX   = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
28832          YLOW  = RLARGE
28833          YHI   = SMALL
28834          DO 3 I=1,NDIM
28835             IF (YY1(I).LT.YLOW) THEN
28836                IF (ILOGY.EQ.1) THEN
28837                   IF (YY1(I).GT.ZERO) YLOW = YY1(I)
28838                ELSE
28839                   YLOW = YY1(I)
28840                ENDIF
28841             ENDIF
28842             IF (YY1(I).GT.YHI) YHI = YY1(I)
28843     3    CONTINUE
28844          DY = (YHI-YLOW)/DBLE(NDIM)
28845          IF (DY.LE.ZERO) THEN
28846             WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
28847      &         'JOIHIS:   warning! zero bin width for histograms ',
28848      &         IH1,IH2,': ',YLOW,YHI
28849             RETURN
28850          ENDIF
28851          IF (ILOGY.EQ.1) THEN
28852             YLOW = LOG10(YLOW)
28853             DY   = (LOG10(YHI)-YLOW)/100.0D0
28854             DO 4 I=1,NDIM
28855                IF (YY1(I).LE.ZERO) THEN
28856                   YY1(I) = YLOW
28857                ELSE
28858                   YY1(I) = LOG10(YY1(I))
28859                ENDIF
28860     4       CONTINUE
28861          ENDIF
28862          CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
28863       ENDIF
28864
28865       RETURN
28866
28867  9998 CONTINUE
28868       WRITE(LOUT,1005) COPER
28869  1005 FORMAT(1X,'JOIHIS:   unknown operation ',A)
28870
28871  9999 CONTINUE
28872       RETURN
28873       END
28874 *
28875 *===qgraph=============================================================*
28876 *
28877 CDECK  ID>, DT_XGRAPH
28878       SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
28879 C***********************************************************************
28880 C
28881 C     calculate quasi graphic picture with 25 lines and 79 columns
28882 C     ranges will be chosen automatically
28883 C
28884 C     input     N          dimension of input fields
28885 C               IARG       number of curves (fields) to plot
28886 C               X          field of X
28887 C               Y1         field of Y1
28888 C               Y2         field of Y2
28889 C
28890 C This subroutine is written by R. Engel.
28891 C***********************************************************************
28892       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28893       SAVE
28894
28895       PARAMETER ( LINP = 5 ,
28896      &            LOUT = 6 ,
28897      &            LDAT = 9 )
28898
28899 C
28900       DIMENSION X(N),Y1(N),Y2(N)
28901       PARAMETER (EPS=1.D-30)
28902       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
28903       CHARACTER SYMB(5)
28904       CHARACTER COL(0:149,0:49)
28905 C
28906       DATA SYMB /'0','e','z','#','x'/
28907 C
28908       ISPALT=IBREIT-10
28909 C
28910 C***  automatic range fitting
28911 C
28912       XMAX=X(1)
28913       XMIN=X(1)
28914       DO 600 I=1,N
28915          XMAX=MAX(X(I),XMAX)
28916          XMIN=MIN(X(I),XMIN)
28917  600  CONTINUE
28918       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
28919 C
28920       ITEST=0
28921       DO 1100 K=0,IZEIL-1
28922          ITEST=ITEST+1
28923          IF (ITEST.EQ.IYRAST) THEN
28924             DO 1010 L=1,ISPALT-1
28925                COL(L,K)='-'
28926 1010        CONTINUE
28927             COL(ISPALT,K)='+'
28928             ITEST=0
28929             DO 1020 L=0,ISPALT-1,IXRAST
28930                COL(L,K)='+'
28931 1020        CONTINUE
28932          ELSE
28933             DO 1030 L=1,ISPALT-1
28934                COL(L,K)=' '
28935 1030        CONTINUE
28936             DO 1040 L=0,ISPALT-1,IXRAST
28937                COL(L,K)='|'
28938 1040        CONTINUE
28939             COL(ISPALT,K)='|'
28940          ENDIF
28941 1100  CONTINUE
28942 C
28943 C***  plot curve Y1
28944 C
28945       YMAX=Y1(1)
28946       YMIN=Y1(1)
28947       DO 500 I=1,N
28948          YMAX=MAX(Y1(I),YMAX)
28949          YMIN=MIN(Y1(I),YMIN)
28950 500   CONTINUE
28951       IF(IARG.GT.1) THEN
28952         DO 550 I=1,N
28953            YMAX=MAX(Y2(I),YMAX)
28954            YMIN=MIN(Y2(I),YMIN)
28955 550     CONTINUE
28956       ENDIF
28957       YMAX=(YMAX-YMIN)/40.0D0+YMAX
28958       YMIN=YMIN-(YMAX-YMIN)/40.0D0
28959       YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
28960       IF(YZOOM.LT.EPS) THEN
28961         WRITE(LOUT,'(1X,A)')
28962      &    'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
28963         RETURN
28964       ENDIF
28965 C
28966 C***  plot curve Y1
28967 C
28968       ILAST=-1
28969       LLAST=-1
28970       DO 1200 K=1,N
28971          L=NINT((X(K)-XMIN)/XZOOM)
28972          I=NINT((YMAX-Y1(K))/YZOOM)
28973          IF(ILAST.GE.0) THEN
28974            LD = L-LLAST
28975            ID = I-ILAST
28976            DO 55 II=0,LD,SIGN(1,LD)
28977              DO 66 KK=0,ID,SIGN(1,ID)
28978                COL(II+LLAST,KK+ILAST)=SYMB(1)
28979  66          CONTINUE
28980  55        CONTINUE
28981          ELSE
28982            COL(L,I)=SYMB(1)
28983          ENDIF
28984          ILAST = I
28985          LLAST = L
28986 1200  CONTINUE
28987 C
28988       IF(IARG.GT.1) THEN
28989 C
28990 C***  plot curve Y2
28991 C
28992         DO 1250 K=1,N
28993            L=NINT((X(K)-XMIN)/XZOOM)
28994            I=NINT((YMAX-Y2(K))/YZOOM)
28995            COL(L,I)=SYMB(2)
28996 1250    CONTINUE
28997       ENDIF
28998 C
28999 C***  write it
29000 C
29001       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
29002 C
29003 C***  write range of X
29004 C
29005       XZOOM = (XMAX-XMIN)/DBLE(7)
29006       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
29007 C
29008       DO 1300 K=0,IZEIL-1
29009          YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
29010          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
29011  110     FORMAT(1X,1PE9.2,70A1)
29012 1300  CONTINUE
29013 C
29014 C***  write range of X
29015 C
29016       XZOOM = (XMAX-XMIN)/DBLE(7)
29017       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
29018       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
29019  120  FORMAT(6X,7(1PE10.3))
29020       END
29021 *
29022 *===qglogy=============================================================*
29023 *
29024 CDECK  ID>, DT_XGLOGY
29025       SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
29026 C***********************************************************************
29027 C
29028 C     calculate quasi graphic picture with 25 lines and 79 columns
29029 C     logarithmic y axis
29030 C     ranges will be chosen automatically
29031 C
29032 C     input     N          dimension of input fields
29033 C               IARG       number of curves (fields) to plot
29034 C               X          field of X
29035 C               Y1         field of Y1
29036 C               Y2         field of Y2
29037 C
29038 C This subroutine is written by R. Engel.
29039 C***********************************************************************
29040 C
29041       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29042       SAVE
29043
29044       PARAMETER ( LINP = 5 ,
29045      &            LOUT = 6 ,
29046      &            LDAT = 9 )
29047
29048       DIMENSION X(N),Y1(N),Y2(N)
29049       PARAMETER (EPS=1.D-30)
29050       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
29051       CHARACTER SYMB(5)
29052       CHARACTER COL(0:149,0:49)
29053       PARAMETER (DEPS = 1.D-10)
29054 C
29055       DATA SYMB /'0','e','z','#','x'/
29056 C
29057       ISPALT=IBREIT-10
29058 C
29059 C***  automatic range fitting
29060 C
29061       XMAX=X(1)
29062       XMIN=X(1)
29063       DO 600 I=1,N
29064          XMAX=MAX(X(I),XMAX)
29065          XMIN=MIN(X(I),XMIN)
29066  600  CONTINUE
29067       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
29068 C
29069       ITEST=0
29070       DO 1100 K=0,IZEIL-1
29071          ITEST=ITEST+1
29072          IF (ITEST.EQ.IYRAST) THEN
29073             DO 1010 L=1,ISPALT-1
29074                COL(L,K)='-'
29075 1010        CONTINUE
29076             COL(ISPALT,K)='+'
29077             ITEST=0
29078             DO 1020 L=0,ISPALT-1,IXRAST
29079                COL(L,K)='+'
29080 1020        CONTINUE
29081          ELSE
29082             DO 1030 L=1,ISPALT-1
29083                COL(L,K)=' '
29084 1030        CONTINUE
29085             DO 1040 L=0,ISPALT-1,IXRAST
29086                COL(L,K)='|'
29087 1040        CONTINUE
29088             COL(ISPALT,K)='|'
29089          ENDIF
29090 1100  CONTINUE
29091 C
29092 C***  plot curve Y1
29093 C
29094       YMAX=Y1(1)
29095       YMIN=MAX(Y1(1),EPS)
29096       DO 500 I=1,N
29097          YMAX =MAX(Y1(I),YMAX)
29098          IF(Y1(I).GT.EPS) THEN
29099            IF(YMIN.EQ.EPS) THEN
29100              YMIN = Y1(I)/10.D0
29101            ELSE
29102              YMIN = MIN(Y1(I),YMIN)
29103            ENDIF
29104          ENDIF
29105 500   CONTINUE
29106       IF(IARG.GT.1) THEN
29107         DO 550 I=1,N
29108            YMAX=MAX(Y2(I),YMAX)
29109            IF(Y2(I).GT.EPS) THEN
29110              IF(YMIN.EQ.EPS) THEN
29111                YMIN = Y2(I)
29112              ELSE
29113                YMIN = MIN(Y2(I),YMIN)
29114              ENDIF
29115            ENDIF
29116 550     CONTINUE
29117       ENDIF
29118 C
29119       DO 560 I=1,N
29120         Y1(I) = MAX(Y1(I),YMIN)
29121  560  CONTINUE
29122       IF(IARG.GT.1) THEN
29123         DO 570 I=1,N
29124           Y2(I) = MAX(Y2(I),YMIN)
29125  570    CONTINUE
29126       ENDIF
29127 C
29128       IF(YMAX.LE.YMIN) THEN
29129         WRITE(LOUT,'(/1X,A,2E12.3,/)')
29130      &     'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
29131         WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
29132         RETURN
29133       ENDIF
29134 C
29135       YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
29136       YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
29137       YZOOM=(YMA-YMI)/DBLE(IZEIL)
29138       IF(YZOOM.LT.EPS) THEN
29139         WRITE(LOUT,'(1X,A)')
29140      &    'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
29141         RETURN
29142       ENDIF
29143 C
29144 C***  plot curve Y1
29145 C
29146       ILAST=-1
29147       LLAST=-1
29148       DO 1200 K=1,N
29149          L=NINT((X(K)-XMIN)/XZOOM)
29150          I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
29151          IF(ILAST.GE.0) THEN
29152            LD = L-LLAST
29153            ID = I-ILAST
29154            DO 55 II=0,LD,SIGN(1,LD)
29155              DO 66 KK=0,ID,SIGN(1,ID)
29156                COL(II+LLAST,KK+ILAST)=SYMB(1)
29157  66          CONTINUE
29158  55        CONTINUE
29159          ELSE
29160            COL(L,I)=SYMB(1)
29161          ENDIF
29162          ILAST = I
29163          LLAST = L
29164 1200  CONTINUE
29165 C
29166       IF(IARG.GT.1) THEN
29167 C
29168 C***  plot curve Y2
29169 C
29170         DO 1250 K=1,N
29171            L=NINT((X(K)-XMIN)/XZOOM)
29172            I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
29173            COL(L,I)=SYMB(2)
29174 1250    CONTINUE
29175       ENDIF
29176 C
29177 C***  write it
29178 C
29179       WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
29180       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
29181 C
29182 C***  write range of X
29183 C
29184       XZOOM1 = (XMAX-XMIN)/DBLE(7)
29185       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
29186 C
29187       DO 1300 K=0,IZEIL-1
29188          YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
29189          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
29190  110     FORMAT(1X,1PE9.2,70A1)
29191 1300  CONTINUE
29192 C
29193 C***  write range of X
29194 C
29195       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
29196       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
29197  120  FORMAT(6X,7(1PE10.3))
29198 C
29199       END
29200 *
29201 *===plot===============================================================*
29202 *
29203 CDECK  ID>, DT_SRPLOT
29204       SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
29205
29206       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29207       SAVE
29208
29209       PARAMETER ( LINP = 5 ,
29210      &            LOUT = 6 ,
29211      &            LDAT = 9 )
29212
29213 *
29214 *     initial version
29215 *     J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
29216 *     This is a subroutine of fluka to plot Y across the page
29217 *     as a function of X down the page. Up to 37 curves can be
29218 *     plotted in the same picture with different plotting characters.
29219 *     Output of first 10 overprinted characters addad by FB 88
29220 *  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
29221 *
29222 *     Input Variables:
29223 *        X   = array containing the values of X
29224 *        Y   = array containing the values of Y
29225 *        N   = number of values in X and in Y
29226 *              can exceed the fixed number of lines
29227 *        M   = number of different curves X,Y are containing
29228 *        MM  = number of points in each curve i.e. N=M*MM
29229 *        XO  = smallest value of X to be plotted
29230 *        DX  = increment of X between subsequent lines
29231 *        YO  = smallest value of Y to be plotted
29232 *        DY  = increment of Y between subsequent character spaces
29233 *
29234 *        other variables used inside:
29235 *        XX  = numbers along the X-coordinate axis
29236 *        YY  = numbers along the Y-coordinate axis
29237 *        LL  = ten lines temporary storage for the plot
29238 *        L   = character set used to plot different curves
29239 *        LOV = memorizes overprinted symbols
29240 *              the first 10 overprinted symbols are printed on
29241 *              the end of the line to avoid ambiguities
29242 *              (added by FB as considered quite helpful)
29243 *
29244 *********************************************************************
29245 *
29246       DIMENSION XX(61),YY(61),LL(101,10)
29247       DIMENSION X(N),Y(N),L(40),LOV(40,10)
29248       DATA  L/
29249      11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
29250      21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
29251      31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
29252      41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H  /
29253 *
29254 *
29255       MN=51
29256       DO 10 I=1,MN
29257         AI=I-1
29258    10 XX(I)=XO+AI*DX
29259       DO 20 I=1,11
29260         AI=I-1
29261    20 YY(I)=YO+10.0D0*AI*DY
29262       WRITE(LOUT, 500) (YY(I),I=1,11)
29263       MMN=MN-1
29264 *
29265 *
29266       DO 90 JJ=1,MMN,10
29267         JJJ=JJ-1
29268         DO 30 I=1,101
29269           DO 30 J=1,10
29270    30   LL(I,J)=L(40)
29271         DO 40 I=1,101
29272    40   LL(I,1)=L(39)
29273         DO 50 I=1,101,10
29274           DO 50 J=1,10
29275    50   LL(I,J)=L(38)
29276         DO 60 I=1,40
29277           DO 60 J=1,10
29278    60   LOV(I,J)=L(40)
29279 *
29280 *
29281         DO 70 I=1,M
29282           DO 70 J=1,MM
29283             II=J+(I-1)*MM
29284             AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
29285             AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
29286             AIX=AIX-DBLE(JJJ)
29287 *           changed Sept.88 by FB to avoid INTEGER OVERFLOW
29288             IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
29289      +      . AIY .LT. 102.D0) THEN
29290               IX=INT(AIX)
29291               IY=INT(AIY)
29292               IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
29293      +        THEN
29294                 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
29295      +          =LL(IY,IX)
29296                 LL(IY,IX)=L(I)
29297               ENDIF
29298             ENDIF
29299    70   CONTINUE
29300 *
29301 *
29302         DO 80 I=1,10
29303           II=I+JJJ
29304           III=II+1
29305           WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
29306      &                    (LOV(J,I),J=1,10)
29307    80   CONTINUE
29308    90 CONTINUE
29309 *
29310 *
29311       WRITE(LOUT, 520)
29312       WRITE(LOUT, 500) (YY(I),I=1,11)
29313       RETURN
29314 *
29315   500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
29316   510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
29317   520 FORMAT(20X,10('1---------'),'1')
29318       END
29319 *
29320 *===defset=============================================================*
29321 *
29322 CDECK  ID>, DT_DEFSET
29323       BLOCK DATA DT_DEFSET
29324
29325       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29326       SAVE
29327
29328 * flags for input different options
29329       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
29330       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
29331      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
29332
29333       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29334
29335 * emulsion treatment
29336       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29337      &                NCOMPO,IEMUL
29338
29339 * / DTFLG1 /
29340       DATA IFRAG  / 2, 1 /
29341       DATA IRESCO / 1 /
29342       DATA IMSHL  / 1 /
29343       DATA IRESRJ / 0 /
29344       DATA IOULEV / -1, -1, -1, -1, -1, -1 /
29345       DATA LEMCCK / .FALSE. /
29346       DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
29347      &              .TRUE.,.TRUE.,.TRUE./
29348       DATA LSEADI / .TRUE. /
29349       DATA LEVAPO / .TRUE. /
29350       DATA IFRAME / 1 /
29351 * Introduced by Chiara -> Forcing CMS-system
29352 *      DATA IFRAME / 2 /
29353       DATA ITRSPT / 0 /
29354
29355 * / DTCOMP /
29356       DATA EMUFRA / NCOMPX*0.0D0 /
29357       DATA IEMUMA / NCOMPX*1 /
29358       DATA IEMUCH / NCOMPX*1 /
29359       DATA NCOMPO / 0 /
29360       DATA IEMUL  / 0 /
29361
29362       END
29363 *
29364 *
29365 *===hadprp=============================================================*
29366 *
29367 CDECK  ID>, DT_HADPRP
29368       BLOCK DATA DT_HADPRP
29369
29370       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29371       SAVE
29372
29373 * auxiliary common for reggeon exchange (DTUNUC 1.x)
29374       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
29375      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
29376      &                IQTCHR(-6:6),MQUARK(3,39)
29377 * hadron index conversion (BAMJET <--> PDG)
29378       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
29379      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
29380      &                IAMCIN(210)
29381 * names of hadrons used in input-cards
29382       CHARACTER*8 BTYPE
29383       COMMON /DTPAIN/ BTYPE(30)
29384
29385 * / DTQUAR /
29386 *----------------------------------------------------------------------*
29387 *                                                                      *
29388 *     Quark content of particles:                                      *
29389 *          index   quark   el. charge  bar. charge  isospin  isospin3  *
29390 *              1 = u          2/3          1/3        1/2       1/2    *
29391 *             -1 = ubar      -2/3         -1/3        1/2      -1/2    *
29392 *              2 = d         -1/3          1/3        1/2      -1/2    *
29393 *             -2 = dbar       1/3         -1/3        1/2       1/2    *
29394 *              3 = s         -1/3          1/3         0         0     *
29395 *             -3 = sbar       1/3         -1/3         0         0     *
29396 *              4 = c          2/3          1/3         0         0     *
29397 *             -4 = cbar      -2/3         -1/3         0         0     *
29398 *              5 = b         -1/3          1/3         0         0     *
29399 *             -5 = bbar       1/3         -1/3         0         0     *
29400 *              6 = t          2/3          1/3         0         0     *
29401 *             -6 = tbar      -2/3         -1/3         0         0     *
29402 *                                                                      *
29403 *         Mquark = particle quark composition (Paprop numbering)       *
29404 *         Iqechr = electric charge ( in 1/3 unit )                     *
29405 *         Iqbchr = baryonic charge ( in 1/3 unit )                     *
29406 *         Iqichr = isospin ( in 1/2 unit ), z component                *
29407 *         Iqschr = strangeness                                         *
29408 *         Iqcchr = charm                                               *
29409 *         Iquchr = beauty                                              *
29410 *         Iqtchr = ......                                              *
29411 *                                                                      *
29412 *----------------------------------------------------------------------*
29413       DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
29414       DATA IQBCHR / 6*-1, 0, 6*1 /
29415       DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
29416       DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
29417       DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
29418       DATA IQUCHR / 0, 1, 9*0, -1, 0 /
29419       DATA IQTCHR / -1, 11*0, 1 /
29420       DATA MQUARK /
29421      &   2, 1, 1,   -2,-1,-1,    0, 0, 0,    0, 0, 0,    0, 0, 0,
29422      &   0, 0, 0,    0, 0, 0,    2, 2, 1,   -2,-2,-1,    0, 0, 0,
29423      &   0, 0, 0,    0, 0, 0,    1,-2, 0,    2,-1, 0,    1,-3, 0,
29424      &   3,-1, 0,    1, 2, 3,   -1,-2,-3,    0, 0, 0,    2, 2, 3,
29425      &   1, 1, 3,    1, 2, 3,    1,-1, 0,    2,-3, 0,    3,-2, 0,
29426      &   2,-2, 0,    3,-3, 0,    0, 0, 0,    0, 0, 0,    0, 0, 0,
29427      &  -1,-1,-3,   -1,-2,-3,   -2,-2,-3,    1, 3, 3,   -1,-3,-3,
29428      &   2, 3, 3,   -2,-3,-3,    3, 3, 3,   -3,-3,-3 /
29429
29430 * / DTHAIC /
29431 * (renamed) (HAdron InDex COnversion)
29432 * translation table version filled up by r.e. 25.01.94                 *
29433       DATA IAMCIN /
29434      &2212,-2212,11,-11,12,              -12,22,2112,-2112,-13,
29435      &13,130,211,-211,321,               -321,3122,-3122,310,3112,
29436      &3222,3212,111,311,-311,            0,0,0,0,0,
29437      &221,213,113,-213,223,              323,313,-323,-313,10323,
29438      &10313,-10323,-10313,30323,30313,   -30323,-30313,3224,3214,3114,
29439      &3216,3218,2224,2214,2114,          1114,12224,12214,12114,11114,
29440      &99999,99999,22212,22112,32124,     31214,-2224,-2214,-2114,-1114,
29441      &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
29442      &5*99999,                           5*99999,
29443      &4*99999,331,                       333,3322,3312,-3222,-3212,
29444      &-3112,-3322,-3312,3224,3214,       3114,3324,3314,3334,-3224,
29445      &-3214,-3114,-3324,-3314,-3334,     421,411,-411,-421,431,
29446      &-431,441,423,413,-413,             -423,433,-433,20443,443,
29447      &-15,15,16,-16,14,                  -14,4122,4232,4132,4222,
29448      &4212,4112,3*99999,                 3*99999,-4122,-4232,
29449      &-4132,-4222,-4212,-4112,99999,     5*99999,
29450      &5*99999,                           5*99999,
29451      &10*99999,
29452      &5*99999 , 20211,20111,-20211,99999,20321,
29453      &-20321,20311,-20311,7*99999 ,
29454      &7*99999,12212,12112,99999/
29455
29456 * / DTHAIC /
29457 * (HAdron InDex COnversion)
29458       DATA (IPDG2(1,K),K=1,7)
29459      &   /   -11,   -12,   -13,   -15,   -16,   -14,     0/
29460       DATA (IBAM2(1,K),K=1,7)
29461      &   /     4,     6,    10,   131,   134,   136,     0/
29462       DATA (IPDG2(2,K),K=1,7)
29463      &   /    11,    12,    22,    13,    15,    16,    14/
29464       DATA (IBAM2(2,K),K=1,7)
29465      &   /     3,     5,     7,    11,   132,   133,   135/
29466       DATA (IPDG3(1,K),K=1,22)
29467      &   /  -211,  -321,  -311,  -213,  -323,  -313,  -411,  -421,
29468      &      -431,  -413,  -423,  -433,     0,     0,     0,     0,
29469      &         0,     0,     0,     0,     0,     0/
29470       DATA (IBAM3(1,K),K=1,22)
29471      &   /    14,    16,    25,    34,    38,    39,   118,   119,
29472      &       121,   125,   126,   128,     0,     0,     0,     0,
29473      &         0,     0,     0,     0,     0,     0/
29474       DATA (IPDG3(2,K),K=1,22)
29475      &   /   130,   211,   321,   310,   111,   311,   221,   213,
29476      &       113,   223,   323,   313,   331,   333,   421,   411,
29477      &       431,   441,   423,   413,   433,   443/
29478       DATA (IBAM3(2,K),K=1,22)
29479      &   /    12,    13,    15,    19,    23,    24,    31,    32,
29480      &        33,    35,    36,    37,    95,    96,   116,   117,
29481      &       120,   122,   123,   124,   127,   130/
29482       DATA (IPDG4(1,K),K=1,29)
29483      &   / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
29484      &     -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
29485      &     -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
29486      &     -4212, -4112,     0,     0,     0/
29487       DATA (IBAM4(1,K),K=1,29)
29488      &   /     2,     9,    18,    67,    68,    69,    70,    75,
29489      &        76,    99,   100,   101,   102,   103,   110,   111,
29490      &       112,   113,   114,   115,   149,   150,   151,   152,
29491      &       153,   154,     0,     0,     0/
29492       DATA (IPDG4(2,K),K=1,29)
29493      &   /  2212,  2112,  3122,  3112,  3222,  3212,  3224,  3214,
29494      &      3114,  3216,  3218,  2224,  2214,  2114,  1114,  3322,
29495      &      3312,  3224,  3214,  3114,  3324,  3314,  3334,  4122,
29496      &      4232,  4132,  4222,  4212,  4112/
29497       DATA (IBAM4(2,K),K=1,29)
29498      &   /     1,     8,    17,    20,    21,    22,    48,    49,
29499      &        50,    51,    52,    53,    54,    55,    56,    97,
29500      &        98,   104,   105,   106,   107,   108,   109,   137,
29501      &       138,   139,   140,   141,   142/
29502       DATA (IPDG5(1,K),K=1,19)
29503      &   /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
29504      &    -20211,-20321,-20311,     0,     0,     0,     0,     0,
29505      &         0,     0,     0/
29506       DATA (IBAM5(1,K),K=1,19)
29507      &   /    42,    43,    46,    47,    71,    72,    73,    74,
29508      &       188,   191,   193,     0,     0,     0,     0,     0,
29509      &         0,     0,     0/
29510       DATA (IPDG5(2,K),K=1,19)
29511      &   / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
29512      &     22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
29513      &     20311, 12212, 12112/
29514       DATA (IBAM5(2,K),K=1,19)
29515      &   /    40,    41,    44,    45,    57,    58,    59,    60,
29516      &        63,    64,    65,    66,   129,   186,   187,   190,
29517      &       192,   208,   209/
29518
29519 * / DTPAIN /
29520 * internal particle names
29521       DATA BTYPE / 'PROTON  ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
29522      &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON  ' , 'NEUTRON ' , 'ANEUTRON' ,
29523      &'MUON+   ' , 'MUON-   ' , 'KAONLONG' , 'PION+   ' , 'PION-   ' ,
29524      &'KAON+   ' , 'KAON-   ' , 'LAMBDA  ' , 'ALAMBDA ' , 'KAONSHRT' ,
29525      &'SIGMA-  ' , 'SIGMA+  ' , 'SIGMAZER' , 'PIZERO  ' , 'KAONZERO' ,
29526      &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
29527      &'BLANK   ' /
29528
29529       END
29530 *
29531 *===blkd46=============================================================*
29532 *
29533 CDECK  ID>, DT_BLKD46
29534       BLOCK DATA DT_BLKD46
29535
29536       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29537       SAVE
29538
29539       PARAMETER ( AMELCT = 0.51099906         D-03 )
29540       PARAMETER ( AMMUON = 0.105658389        D+00 )
29541
29542 * particle properties (BAMJET index convention)
29543       CHARACTER*8  ANAME
29544       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29545      &                IICH(210),IIBAR(210),K1(210),K2(210)
29546
29547 * / DTPART /
29548 * Particle  masses Engel version JETSET compatible
29549       DATA (AAM(K),K=1,85) /
29550      &   .9383D+00, .9383D+00,  AMELCT  ,  AMELCT  , .0000D+00,
29551      &   .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON   ,
29552      &   AMMUON   , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
29553      &   .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
29554      &   .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
29555      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29556      &   .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
29557      &   .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
29558      &   .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
29559      &   .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
29560      &   .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
29561      &   .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
29562      &   .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
29563      &   .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
29564      &   .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
29565      &   .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
29566      &   .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01  /
29567       DATA (AAM(K),K=86,183) /
29568      &   .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
29569      &   .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
29570      &   .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
29571      &   .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
29572      &   .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
29573      &   .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
29574      &   .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
29575      &   .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
29576      &   .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
29577      &   .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
29578      &   .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
29579      &   .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
29580      &   .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
29581      &   .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
29582      &   .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
29583      &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
29584      &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
29585      &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
29586      &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
29587      &   .1250D+01, .1250D+01, .1250D+01  /
29588       DATA (AAM ( I ), I = 184,210 ) /
29589      & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
29590      & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
29591      & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
29592      & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
29593      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
29594      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
29595      & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
29596      & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
29597      & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
29598 * Particle  mean lives
29599       DATA (TAU(K),K=1,183) /
29600      &   .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
29601      &   .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
29602      &   .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
29603      &   .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
29604      &   .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
29605      &   70*.0000D+00,
29606      &   .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
29607      &   .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
29608      &   .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
29609      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
29610      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29611      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29612      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29613      &   .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
29614      &   .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29615      &   40*.0000D+00,
29616      &   .0000D+00, .0000D+00, .0000D+00  /
29617       DATA ( TAU ( I ), I = 184,210 ) /
29618      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
29619      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
29620      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
29621      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
29622      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
29623      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
29624      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
29625      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
29626      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
29627 * Resonance width Gamma in GeV
29628       DATA (GA(K),K=  1,85) /
29629      &    30*.0000D+00,
29630      &   .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
29631      &   .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
29632      &   .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
29633      &   .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
29634      &   .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
29635      &   .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
29636      &   .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
29637      &   .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
29638      &   .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
29639      &   .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
29640      &   .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00  /
29641       DATA (GA(K),K= 86,183) /
29642      &   .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
29643      &   .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
29644      &   .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29645      &   .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
29646      &   .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
29647      &   .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
29648      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29649      &   .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
29650      &   .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
29651      &   50*.0000D+00,
29652      &   .3000D+00, .3000D+00, .3000D+00  /
29653       DATA ( GA ( I ), I = 184,210 ) /
29654      & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
29655      & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
29656      & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
29657      & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
29658      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
29659      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
29660      & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
29661      & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
29662      & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
29663 * Particle  names
29664 * S+1385+Sigma+(1385)    L02030+Lambda0(2030)
29665 * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
29666 * designation N*@@ means N*@1(@2)
29667       DATA (ANAME(K),K=1,85) /
29668      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
29669      &  'ANUE    ','GAM     ','NEU     ','ANEU    ','MUE+    ',
29670      &  'MUE-    ','K0L     ','PI+     ','PI-     ','K+      ',
29671      &  'K-      ','LAM     ','ALAM    ','K0S     ','SIGM-   ',
29672      &  'SIGM+   ','SIGM0   ','PI0     ','K0      ','AK0     ',
29673      &  'BLANK   ','BLANK   ','BLANK   ','BLANK   ','BLANK   ',
29674      &  'ETA550  ','RHO+77  ','RHO077  ','RHO-77  ','OM0783  ',
29675      &  'K*+892  ','K*0892  ','K*-892  ','AK*089  ','KA+125  ',
29676      &  'KA0125  ','KA-125  ','AKA012  ','K*+142  ','K*0142  ',
29677      &  'K*-142  ','AK*014  ','S+1385  ','S01385  ','S-1385  ',
29678      &  'L01820  ','L02030  ','N*++12  ','N*+ 12  ','N*012   ',
29679      &  'N*-12   ','N*++16  ','N*+16   ','N*016   ','N*-16   ',
29680      &  'N*+14   ','N*014   ','N*+15   ','N*015   ','N*+18   ',
29681      &  'N*018   ','AN--12  ','AN*-12  ','AN*012  ','AN*+12  ',
29682      &  'AN--16  ','AN*-16  ','AN*016  ','AN*+16  ','AN*-15  ',
29683      &  'AN*015  ','DE*=24  ','RPI+49  ','RPI049  ','RPI-49  ',
29684      &  'PIN++   ','PIN+0   ','PIN+-   ','PIN-0   ','PPPI    ' /
29685       DATA (ANAME(K),K=86,183) /
29686      &  'PNPI    ','APPPI   ','APNPI   ','K+PPI   ','K-PPI   ',
29687      &  'K+NPI   ','K-NPI   ','S+1820  ','S-2030  ','ETA*    ',
29688      &  'PHI     ','TETA0   ','TETA-   ','ASIG-   ','ASIG0   ',
29689      &  'ASIG+   ','ATETA0  ','ATETA+  ','SIG*+   ','SIG*0   ',
29690      &  'SIG*-   ','TETA*0  ','TETA*   ','OMEGA-  ','ASIG*-  ',
29691      &  'ASIG*0  ','ASIG*+  ','ATET*0  ','ATET*+  ','OMEGA+  ',
29692      &  'D0      ','D+      ','D-      ','AD0     ','F+      ',
29693      &  'F-      ','ETAC    ','D*0     ','D*+     ','D*-     ',
29694      &  'AD*0    ','F*+     ','F*-     ','PSI     ','JPSI    ',
29695      &  'TAU+    ','TAU-    ','NUET    ','ANUET   ','NUEM    ',
29696      &  'ANUEM   ','C0+     ','A+      ','A0      ','C1++    ',
29697      &  'C1+     ','C10     ','S+      ','S0      ','T0      ',
29698      &  'XU++    ','XD+     ','XS+     ','AC0-    ','AA-     ',
29699      &  'AA0     ','AC1--   ','AC1-    ','AC10    ','AS-     ',
29700      &  'AS0     ','AT0     ','AXU--   ','AXD-    ','AXS     ',
29701      &  'C1*++   ','C1*+    ','C1*0    ','S*+     ','S*0     ',
29702      &  'T*0     ','XU*++   ','XD*+    ','XS*+    ','TETA++  ',
29703      &  'AC1*--  ','AC1*-   ','AC1*0   ','AS*-    ','AS*0    ',
29704      &  'AT*0    ','AXU*--  ','AXD*-   ','AXS*-   ','ATET--  ',
29705      &  'RO      ','R+      ','R-      '  /
29706       DATA (    ANAME ( I ), I = 184,210 ) /
29707      &'AN*-14  ','AN*014  ','PI+130  ','PI0130  ','PI-130  ','F01400  ',
29708      &'K*+146  ','K*-146  ','K*0146  ','AK0146  ','L01600  ','AL0160  ',
29709      &'S+1660  ','S01660  ','S-1660  ','AS-166  ','AS0166  ','AS+166  ',
29710      &'X01950  ','X-1950  ','AX0195  ','AX+195  ','OM-225  ','AOM+22  ',
29711      &'N*+14   ','N*014   ','BLANK   '/
29712 * Charge of particles and resonances
29713       DATA (IICH ( I ), I =   1,210 ) /
29714      &  1, -1, -1,  1,  0,  0,  0,  0,  0,  1, -1,  0,  1, -1,  1,
29715      & -1,  0,  0,  0, -1,  1,  0,  0,  0,  0,  0,  0,  0,  0,  0,
29716      &  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0,
29717      & -1,  0,  1,  0, -1,  0,  0,  2,  1,  0, -1,  2,  1,  0, -1,
29718      &  1,  0,  1,  0,  1,  0, -2, -1,  0,  1, -2, -1,  0,  1, -1,
29719      &  0,  1,  1,  0, -1,  2,  1,  0, -1,  2,  1,  0, -1,  2,  0,
29720      &  1, -1,  1, -1,  0,  0,  0, -1, -1,  0,  1,  0,  1,  1,  0,
29721      & -1,  0, -1, -1, -1,  0,  1,  0,  1,  1,  0,  1, -1,  0,  1,
29722      & -1,  0,  0,  1, -1,  0,  1, -1,  0,  0,  1, -1,  0,  0,  0,
29723      &  0,  1,  1,  0,  2,  1,  0,  1,  0,  0,  2,  1,  1, -1, -1,
29724      &  0, -2, -1,  0, -1,  0,  0, -2, -1, -1,  2,  1,  0,  1,  0,
29725      &  0,  2,  1,  1,  2, -2, -1,  0, -1,  0,  0, -2, -1, -1, -2,
29726      &  0,  1, -1, -1,  0,  1,  0, -1,  0,  1, -1,  0,  0,  0,  0,
29727      &  1,  0, -1, -1,  0,  1,  0, -1,  0,  1, -1,  1,  1,  0,  0/
29728 * Particle  baryonic charges
29729       DATA (IIBAR ( I ), I =   1,210 ) /
29730      &  1, -1,  0,  0,  0,  0,  0,  1, -1,  0,  0,  0,  0,  0,  0,
29731      &  0,  1, -1,  0,  1,  1,  1,  0,  0,  0,  0,  0,  0,  0,  0,
29732      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
29733      &  0,  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
29734      &  1,  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
29735      & -1,  2,  0,  0,  0,  1,  1,  1,  1,  2,  2,  0,  0,  1,  1,
29736      &  1,  1,  1,  1,  0,  0,  1,  1, -1, -1, -1, -1, -1,  1,  1,
29737      &  1,  1,  1,  1, -1, -1, -1, -1, -1, -1,  0,  0,  0,  0,  0,
29738      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
29739      &  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1, -1, -1,
29740      & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,  1,  1,  1,  1,  1,
29741      &  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
29742      &  0,  0,  0, -1, -1,  0,  0,  0,  0,  0,  0,  0,  0,  1, -1,
29743      &  1,  1,  1, -1, -1, -1,  1,  1, -1, -1,  1, -1,  1,  1,  0/
29744 * First number of decay channels used for resonances
29745 * and decaying particles
29746       DATA K1/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 16, 17,
29747      &  18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
29748      &   2*330, 46, 51, 52, 54, 55, 58,
29749 *                                                             50
29750      &  60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
29751      & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
29752      & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
29753 *                                         85
29754      & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
29755      & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
29756      & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
29757      & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
29758      & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
29759      & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
29760      & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
29761      & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
29762      & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
29763      & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
29764      & 590, 596, 602 /
29765 * Last number of decay channels used for resonances
29766 * and decaying particles
29767       DATA K2/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 15, 16, 17,
29768      & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
29769      & 2* 330, 50, 51, 53, 54, 57,
29770 *                                                                 50
29771      & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
29772      & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
29773      & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
29774 *                                              85
29775      & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
29776      & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
29777      & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
29778      & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
29779      & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
29780      & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
29781      & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
29782      & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
29783      & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
29784      & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
29785      & 589, 595, 601, 602 /
29786
29787        END
29788 *
29789 *===blkd47=============================================================*
29790 *
29791 CDECK  ID>, DT_BLKD47
29792       BLOCK DATA DT_BLKD47
29793
29794       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29795       SAVE
29796
29797 * HADRIN: decay channel information
29798       PARAMETER (IDMAX9=602)
29799       CHARACTER*8 ZKNAME
29800       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
29801
29802 * Name of decay channel
29803 * Designation N*@ means N*@1(1236)
29804 * @1=# means ++,  @1 = = means --
29805 * Designation  P+/0/- means Pi+/Pi0/Pi- , respectively
29806       DATA (ZKNAME(K),K=  1, 85) /
29807      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
29808      &  'ANUE    ','GAM     ','PE-NUE  ','APEANU  ','EANUNU  ',
29809      &  'E-NUAN  ','3PI0    ','PI+-0   ','PIMUNU  ','PIE-NU  ',
29810      &  'MU+NUE  ','MU-NUE  ','MU+NUE  ','PI+PI0  ','PI++-   ',
29811      &  'PI+00   ','M+P0NU  ','E+P0NU  ','MU-NU   ','PI-0    ',
29812      &  'PI+--   ','PI-00   ','M-P0NU  ','E-P0NU  ','PPI-    ',
29813      &  'NPI0    ','PD-NUE  ','PM-NUE  ','APPI+   ','ANPI0   ',
29814      &  'APE+NU  ','APM+NU  ','PI+PI-  ','PI0PI0  ','NPI-    ',
29815      &  'PPI0    ','NPI+    ','LAGA    ','GAGA    ','GAE+E-  ',
29816      &  'GAGA    ','GAGAP0  ','PI000   ','PI+-0   ','PI+-GA  ',
29817      &  'PI+0    ','PI+-    ','PI00    ','PI-0    ','PI+-0   ',
29818      &  'PI+-    ','PI0GA   ','K+PI0   ','K0PI+   ','KOPI0   ',
29819      &  'K+PI-   ','K-PI0   ','AK0PI-  ','AK0PI0  ','K-PI+   ',
29820      &  'K+PI0   ','K0PI+   ','K0PI0   ','K+PI-   ','K-PI0   ',
29821      &  'K0PI-   ','AK0PI0  ','K-PI+   ','K+PI0   ','K0PI+   ',
29822      &  'K+89P0  ','K08PI+  ','K+RO77  ','K0RO+7  ','K+OM07  ',
29823      &  'K+E055  ','K0PI0   ','K+PI+   ','K089P0  ','K+8PI-  '  /
29824       DATA (ZKNAME(K),K= 86,170) /
29825      &  'K0R077  ','K+R-77  ','K+R-77  ','K0OM07  ','K0E055  ',
29826      &  'K-PI0   ','K0PI-   ','K-89P0  ','AK08P-  ','K-R077  ',
29827      &  'AK0R-7  ','K-OM07  ','K-E055  ','AK0PI0  ','K-PI+   ',
29828      &  'AK08P0  ','K-8PI+  ','AK0R07  ','AK0OM7  ','AK0E05  ',
29829      &  'LA0PI+  ','SI0PI+  ','SI+PI0  ','LA0PI0  ','SI+PI-  ',
29830      &  'SI-PI+  ','LA0PI-  ','SI0PI-  ','NEUAK0  ','PK-     ',
29831      &  'SI+PI-  ','SI0PI0  ','SI-PI+  ','LA0ET0  ','S+1PI-  ',
29832      &  'S-1PI+  ','SO1PI0  ','NEUAK0  ','PK-     ','LA0PI0  ',
29833      &  'LA0OM0  ','LA0RO0  ','SI+RO-  ','SI-RO+  ','SI0RO0  ',
29834      &  'LA0ET0  ','SI0ET0  ','SI+PI-  ','SI-PI+  ','SI0PI0  ',
29835      &  'K0S     ','K0L     ','K0S     ','K0L     ','P PI+   ',
29836      &  'P PI0   ','N PI+   ','P PI-   ','N PI0   ','N PI-   ',
29837      &  'P PI+   ','N*#PI0  ','N*+PI+  ','PRHO+   ','P PI0   ',
29838      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
29839      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
29840      &  'N*-PI+  ','PRHO-   ','NRHO0   ','N PI-   ','N*0PI-  ',
29841      &  'N*-PI0  ','NRHO-   ','PETA0   ','N*#PI-  ','N*+PI0  '  /
29842       DATA (ZKNAME(K),K=171,255) /
29843      &  'N*0PI+  ','PRHO0   ','NRHO+   ','NETA0   ','N*+PI-  ',
29844      &  'N*0PI0  ','N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ',
29845      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
29846      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
29847      &  'N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ','N PI+   ',
29848      &  'PRHO0   ','NRHO+   ','LAMK+   ','S+ K0   ','S0 K+   ',
29849      &  'PETA0   ','P PI-   ','N PI0   ','PRHO-   ','NRHO0   ',
29850      &  'LAMK0   ','S0 K0   ','S- K+   ','NETA/   ','APPI-   ',
29851      &  'APPI0   ','ANPI-   ','APPI+   ','ANPI0   ','ANPI+   ',
29852      &  'APPI-   ','AN*=P0  ','AN*-P-  ','APRHO-  ','APPI0   ',
29853      &  'ANPI-   ','AN*=P+  ','AN*-P0  ','AN*0P-  ','APRHO0  ',
29854      &  'ANRHO-  ','APPI+   ','ANPI0   ','AN*-P+  ','AN*0P0  ',
29855      &  'AN*+P-  ','APRHO+  ','ANRHO0  ','ANPI+   ','AN*0P+  ',
29856      &  'AN*+P0  ','ANRHO+  ','APPI0   ','ANPI-   ','AN*=P+  ',
29857      &  'AN*-P0  ','AN*0P-  ','APRHO0  ','ANRHO-  ','APPI+,  ',
29858      &  'ANPI0   ','AN*-P+  ','AN*0P0  ','AN*+P-  ','APRHO+  ',
29859      &  'ANRHO0  ','PN*014  ','NN*=14  ','PI+0    ','PI+-    '  /
29860       DATA (ZKNAME(K),K=256,340) /
29861      &  'PI-0    ','P+0     ','N++     ','P+-     ','P00     ',
29862      &  'N+0     ','N+-     ','N00     ','P-0     ','N-0     ',
29863      &  'P--     ','PPPI0   ','PNPI+   ','PNPI0   ','PPPI-   ',
29864      &  'NNPI+   ','APPPI0  ','APNPI+  ','ANNPI0  ','ANPPI-  ',
29865      &  'APNPI0  ','APPPI-  ','ANNPI-  ','K+PPI0  ','K+NPI+  ',
29866      &  'K0PPI0  ','K-PPI0  ','K-NPI+  ','AKPPI-  ','AKNPI0  ',
29867      &  'K+NPI0  ','K+PPI-  ','K0PPI0  ','K0NPI+  ','K-NPI0  ',
29868      &  'K-PPI-  ','AKNPI-  ','PAK0    ','SI+PI0  ','SI0PI+  ',
29869      &  'SI+ETA  ','S+1PI0  ','S01PI+  ','NEUK-   ','LA0PI-  ',
29870      &  'SI-OM0  ','LA0RO-  ','SI0RO-  ','SI-RO0  ','SI-ET0  ',
29871      &  'SI0PI-  ','SI-0    ','BLANC   ','BLANC   ','BLANC   ',
29872      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
29873      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
29874      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
29875      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
29876      &  'EPI+-   ','EPI00   ','GAPI+-  ','GAGA*   ','K+-     ',
29877      &  'KLKS    ','PI+-0   ','EGA     ','LPI0    ','LPI     '  /
29878       DATA (ZKNAME(K),K=341,425) /
29879      &  'APPI0   ','ANPI-   ','ALAGA   ','ANPI    ','ALPI0   ',
29880      &  'ALPI+   ','LAPI+   ','SI+PI0  ','SI0PI+  ','LAPI0   ',
29881      &  'SI+PI-  ','SI-PI+  ','LAPI-   ','SI-PI0  ','SI0PI-  ',
29882      &  'TE0PI0  ','TE-PI+  ','TE0PI-  ','TE-PI0  ','TE0PI   ',
29883      &  'TE-PI   ','LAK-    ','ALPI-   ','AS-PI0  ','AS0PI-  ',
29884      &  'ALPI0   ','AS+PI-  ','AS-PI+  ','ALPI+   ','AS+PI0  ',
29885      &  'AS0PI+  ','AT0PI0  ','AT+PI-  ','AT0PI+  ','AT+PI0  ',
29886      &  'AT0PI   ','AT+PI   ','ALK+    ','K-PI+   ','K-PI+0  ',
29887      &  'K0PI+-  ','K0PI0   ','K-PI++  ','AK0PI+  ','K+PI--  ',
29888      &  'K0PI-   ','K+PI-   ','K+PI-0  ','AKPI-+  ','AK0PI0  ',
29889      &  'ETAPIF  ','K++-    ','K+AK0   ','ETAPI-  ','K--+    ',
29890      &  'K-K0    ','PI00    ','PI+-    ','GAGA    ','D0PI0   ',
29891      &  'D0GA    ','D0PI+   ','D+PI0   ','DFGA    ','AD0PI-  ',
29892      &  'D-PI0   ','D-GA    ','AD0PI0  ','AD0GA   ','F+GA    ',
29893      &  'F+GA    ','F-GA    ','F-GA    ','PSPI+-  ','PSPI00  ',
29894      &  'PSETA   ','E+E-    ','MUE+-   ','PI+-0   ','M+NN    ',
29895      &  'E+NN    ','RHO+NT  ','PI+ANT  ','K*+ANT  ','M-NN    '  /
29896       DATA (ZKNAME(K),K=426,510) /
29897      &  'E-NN    ','RHO-NT  ','PI-NT   ','K*-NT   ','NUET    ',
29898      &  'ANUET   ','NUEM    ','ANUEM   ','SI+ETA  ','SI+ET*  ',
29899      &  'PAK0    ','TET0K+  ','SI*+ET  ','N*+AK0  ','N*++K-  ',
29900      &  'LAMRO+  ','SI0RO+  ','SI+RO0  ','SI+OME  ','PAK*0   ',
29901      &  'N*+AK*  ','N*++K*  ','SI+AK0  ','TET0PI  ','SI+AK*  ',
29902      &  'TET0RO  ','SI0AK*  ','SI+K*-  ','TET0OM  ','TET-RO  ',
29903      &  'SI*0AK  ','C0+PI+  ','C0+PI0  ','C0+PI-  ','A+GAM   ',
29904      &  'A0GAM   ','TET0AK  ','TET0K*  ','OM-RO+  ','OM-PI+  ',
29905      &  'C1++AK  ','A+PI+   ','C0+AK0  ','A0PI+   ','A+AK0   ',
29906      &  'T0PI+   ','ASI-ET  ','ASI-E*  ','APK0    ','ATET0K  ',
29907      &  'ASI*-E  ','AN*-K0  ','AN*--K  ','ALAMRO  ','ASI0RO  ',
29908      &  'ASI-RO  ','ASI-OM  ','APK*0   ','AN*-K*  ','AN*--K  ',
29909      &  'ASI-K0  ','ATETPI  ','ASI-K*  ','ATETRO  ','ASI0K*  ',
29910      &  'ASI-K*  ','ATE0OM  ','ATE+RO  ','ASI*0K  ','AC-PI-  ',
29911      &  'AC-PI0  ','AC-PI+  ','AA-GAM  ','AA0GAM  ','ATET0K  ',
29912      &  'ATE0K*  ','AOM+RO  ','AOM+PI  ','AC1--K  ','AA-PI-  ',
29913      &  'AC0-K0  ','AA0PI-  ','AA-K0   ','AT0PI-  ','C1++GA  '  /
29914       DATA (ZKNAME(K),K=511,540) /
29915      &  'C1++GA  ','C10GAM  ','S+GAM   ','S0GAM   ','T0GAM   ',
29916      &  'XU++GA  ','XD+GAM  ','XS+GAM  ','A+AKPI  ','T02PI+  ',
29917      &  'C1++2K  ','AC1--G  ','AC1-GA  ','AC10GA  ','AS-GAM  ',
29918      &  'AS0GAM  ','AT0GAM  ','AXU--G  ','AXD-GA  ','AXS-GA  ',
29919      &  'AA-KPI  ','AT02PI  ','AC1--K  ','RH-PI+  ','RH+PI-  ',
29920      &  'RH3PI0  ','RH0PI+  ','RH+PI0  ','RH0PI-  ','RH-PI0  '  /
29921       DATA (ZKNAME(I),I=541,602)/
29922      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
29923      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
29924      & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
29925      & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
29926      & 'PI+PI-','K+K-  ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
29927      & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
29928      & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
29929      & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
29930      & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
29931 * Weight of decay channel
29932       DATA (WT(K),K=  1, 85) /
29933      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
29934      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
29935      &   .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
29936      &   .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
29937      &   .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
29938      &   .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
29939      &   .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
29940      &   .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
29941      &   .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
29942      &   .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
29943      &   .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
29944      &   .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
29945      &   .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
29946      &   .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
29947      &   .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
29948      &   .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
29949      &   .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00  /
29950       DATA (WT(K),K= 86,170) /
29951      &   .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
29952      &   .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
29953      &   .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
29954      &   .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
29955      &   .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
29956      &   .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
29957      &   .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
29958      &   .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
29959      &   .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
29960      &   .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
29961      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
29962      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
29963      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
29964      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
29965      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
29966      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
29967      &   .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00  /
29968       DATA (WT(K),K=171,255) /
29969      &   .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
29970      &   .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
29971      &   .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
29972      &   .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
29973      &   .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
29974      &   .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
29975      &   .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
29976      &   .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
29977      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
29978      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
29979      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
29980      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
29981      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
29982      &   .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
29983      &   .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
29984      &   .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
29985      &   .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01  /
29986       DATA (WT(K),K=256,340) /
29987      &   .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
29988      &   .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
29989      &   .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
29990      &   .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
29991      &   .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
29992      &   .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
29993      &   .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
29994      &   .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
29995      &   .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
29996      &   .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
29997      &   .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
29998      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
29999      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30000      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30001      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30002      &   .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
30003      &   .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01  /
30004       DATA (WT(K),K=341,425) /
30005      &   .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
30006      &   .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
30007      &   .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
30008      &   .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
30009      &   .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
30010      &   .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
30011      &   .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
30012      &   .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
30013      &   .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
30014      &   .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
30015      &   .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
30016      &   .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
30017      &   .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
30018      &   .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
30019      &   .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
30020      &   .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
30021      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00  /
30022       DATA (WT(K),K=426,510) /
30023      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
30024      &   .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
30025      &   .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
30026      &   .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
30027      &   .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
30028      &   .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
30029      &   .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30030      &   .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
30031      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
30032      &   .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
30033      &   .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
30034      &   .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
30035      &   .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
30036      &   .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
30037      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
30038      &   .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
30039      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01  /
30040       DATA (WT(K),K=511,540) /
30041      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30042      &   .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
30043      &   .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30044      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30045      &   .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
30046      &   .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00  /
30047 C
30048       DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
30049      & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
30050      & .125D+00,  0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
30051      & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
30052      & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
30053      & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
30054      & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
30055 * Particle numbers in decay channel
30056       DATA (NZK(K,1),K=  1,170) /
30057      &     1,   2,   3,   4,   5,   6,   7,   1,   2,   4,
30058      &     3,  23,  13,  13,  13,  10,  11,  10,  13,  13,
30059      &    13,  10,   4,  11,  14,  14,  14,  11,   3,   1,
30060      &     8,   1,   1,   2,   9,   2,   2,  13,  23,   8,
30061      &     1,   8,  17,   7,   7,   7,  23,  23,  13,  13,
30062      &    13,  13,  23,  14,  13,  13,  23,  15,  24,  24,
30063      &    15,  16,  25,  25,  16,  15,  24,  24,  15,  16,
30064      &    24,  25,  16,  15,  24,  36,  37,  15,  24,  15,
30065      &    15,  24,  15,  37,  36,  24,  15,  24,  24,  16,
30066      &    24,  38,  39,  16,  25,  16,  16,  25,  16,  39,
30067      &    38,  25,  16,  25,  25,  17,  22,  21,  17,  21,
30068      &    20,  17,  22,   8,   1,  21,  22,  20,  17,  48,
30069      &    50,  49,   8,   1,  17,  17,  17,  21,  20,  22,
30070      &    17,  22,  21,  20,  22,  19,  12,  19,  12,   1,
30071      &     1,   8,   1,   8,   8,   1,  53,  54,   1,   1,
30072      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
30073      &    56,   1,   8,   8,  55,  56,   8,   1,  53,  54  /
30074       DATA (NZK(K,1),K=171,340) /
30075      &    55,   1,   8,   8,  54,  55,  56,   1,   8,   1,
30076      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
30077      &    56,   1,   8,   1,   8,   1,   8,  17,  21,  22,
30078      &     1,   1,   8,   1,   8,  17,  22,  20,   8,   2,
30079      &     2,   9,   2,   9,   9,   2,  67,  68,   2,   2,
30080      &     9,  67,  68,  69,   2,   9,   2,   9,  68,  69,
30081      &    70,   2,   9,   9,  69,  70,   9,   2,   9,  67,
30082      &    68,  69,   2,   9,   2,   9,  68,  69,  70,   2,
30083      &     9,   1,   8,  13,  13,  14,   1,   8,   1,   1,
30084      &     8,   8,   8,   1,   8,   1,   1,   1,   1,   1,
30085      &     8,   2,   2,   9,   9,   2,   2,   9,  15,  15,
30086      &    24,  16,  16,  25,  25,  15,  15,  24,  24,  16,
30087      &    16,  25,   1,  21,  22,  21,  48,  49,   8,  17,
30088      &    20,  17,  22,  20,  20,  22,  20,   0,   0,   0,
30089      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
30090      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
30091      &    31,  31,  13,   7,  15,  12,  13,  31,  17,  17  /
30092       DATA (NZK(K,1),K=341,510) /
30093      &     2,   9,  18,   9,  18,  18,  17,  21,  22,  17,
30094      &    21,  20,  17,  20,  22,  97,  98,  97,  98,  97,
30095      &    98,  17,  18,  99, 100,  18, 101,  99,  18, 101,
30096      &   100, 102, 103, 102, 103, 102, 103,  18,  16,  16,
30097      &    24,  24,  16,  25,  15,  24,  15,  15,  25,  25,
30098      &    31,  15,  15,  31,  16,  16,  23,  13,   7, 116,
30099      &   116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
30100      &   120, 121, 121, 130, 130, 130,   4,  10,  13,  10,
30101      &     4,  32,  13,  36,  11,   3,  34,  14,  38, 133,
30102      &   134, 135, 136,  21,  21,   1,  97, 104,  54,  53,
30103      &    17,  22,  21,  21,   1,  54,  53,  21,  97,  21,
30104      &    97,  22,  21,  97,  98, 105, 137, 137, 137, 138,
30105      &   139,  97,  97, 109, 109, 140, 138, 137, 139, 138,
30106      &   145,  99,  99,   2, 102, 110,  68,  67,  18, 100,
30107      &    99,  99,   2,  68,  67,  99, 102,  99, 102, 100,
30108      &    99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
30109      &   113, 115, 115, 152, 150, 149, 151, 150, 157, 140  /
30110       DATA (NZK(K,1),K=511,540) /
30111      &   141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
30112      &   140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
30113      &   150, 157, 152,  34,  32,  33,  33,  32,  33,  34  /
30114       DATA (NZK(I,1),I=541,602) /  2, 67, 68, 69,  2,  9,  9, 68, 69,
30115      & 70,  2,  9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
30116      & 14, 189, 23, 13, 15, 24,  36,  38,  37,  39, 194, 195, 196, 197,
30117      & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
30118      & 55, 8, 1, 8, 8, 54, 55, 210/
30119       DATA (NZK(K,2),K=  1,170) /
30120      &     0,   0,   0,   0,   0,   0,   0,   3,   4,   6,
30121      &     5,  23,  14,  11,   3,   5,   5,   5,  23,  13,
30122      &    23,  23,  23,   5,  23,  13,  23,  23,  23,  14,
30123      &    23,   3,  11,  13,  23,   4,  10,  14,  23,  14,
30124      &    23,  13,   7,   7,   4,   7,   7,  23,  14,  14,
30125      &    23,  14,  23,  23,  14,  14,   7,  23,  13,  23,
30126      &    14,  23,  14,  23,  13,  23,  13,  23,  14,  23,
30127      &    14,  23,  13,  23,  13,  23,  13,  33,  32,  35,
30128      &    31,  23,  14,  23,  14,  33,  34,  35,  31,  23,
30129      &    14,  23,  14,  33,  34,  35,  31,  23,  13,  23,
30130      &    13,  33,  32,  35,  31,  13,  13,  23,  23,  14,
30131      &    13,  14,  14,  25,  16,  14,  23,  13,  31,  14,
30132      &    13,  23,  25,  16,  23,  35,  33,  34,  32,  33,
30133      &    31,  31,  14,  13,  23,   0,   0,   0,   0,  13,
30134      &    23,  13,  14,  23,  14,  13,  23,  13,  78,  23,
30135      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
30136      &    13,  80,  79,  14,  14,  23,  80,  31,  14,  23  /
30137       DATA (NZK(K,2),K=171,340) /
30138      &    13,  79,  78,  31,  14,  23,  13,  80,  79,  23,
30139      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
30140      &    13,  80,  79,  23,  13,  33,  32,  15,  24,  15,
30141      &    31,  14,  23,  34,  33,  24,  24,  15,  31,  14,
30142      &    23,  14,  13,  23,  13,  14,  23,  14,  80,  23,
30143      &    14,  13,  23,  14,  79,  80,  13,  23,  13,  23,
30144      &    14,  78,  79,  13,  13,  23,  78,  23,  14,  13,
30145      &    23,  14,  79,  80,  13,  23,  13,  23,  14,  78,
30146      &    79,  62,  61,  23,  14,  23,  13,  13,  13,  23,
30147      &    13,  13,  23,  14,  14,  14,   1,   8,   8,   1,
30148      &     8,   1,   8,   8,   1,   8,   1,   8,   1,   8,
30149      &     1,   1,   8,   1,   8,   8,   1,   1,   8,   8,
30150      &     1,   8,  25,  23,  13,  31,  23,  13,  16,  14,
30151      &    35,  34,  34,  33,  31,  14,  23,   0,   0,   0,
30152      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
30153      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
30154      &    13,  23,  14,   7,  16,  19,  14,   7,  23,  14  /
30155       DATA (NZK(K,2),K=341,510) /
30156      &    23,  14,   7,  13,  23,  13,  13,  23,  13,  23,
30157      &    14,  13,  14,  23,  14,  23,  13,  14,  23,  14,
30158      &    23,  16,  14,  23,  14,  23,  14,  13,  13,  23,
30159      &    13,  23,  14,  13,  23,  13,  23,  15,  13,  13,
30160      &    13,  23,  13,  13,  14,  14,  14,  14,  14,  23,
30161      &    13,  16,  25,  14,  15,  24,  23,  14,   7,  23,
30162      &     7,  13,  23,   7,  14,  23,   7,  23,   7,   7,
30163      &     7,   7,   7,  13,  23,  31,   3,  11,  14, 135,
30164      &     5, 134, 134, 134, 136,   6, 133, 133, 133,   0,
30165      &     0,   0,   0,  31,  95,  25,  15,  31,  95,  16,
30166      &    32,  32,  33,  35,  39,  39,  38,  25,  13,  39,
30167      &    32,  39,  38,  35,  32,  39,  13,  23,  14,   7,
30168      &     7,  25,  37,  32,  13,  25,  13,  25,  13,  25,
30169      &    13,  31,  95,  24,  16,  31,  24,  15,  34,  34,
30170      &    33,  35,  37,  37,  36,  24,  14,  37,  34,  37,
30171      &    36,  35,  34,  37,  14,  23,  13,   7,   7,  24,
30172      &    39,  34,  14,  24,  14,  24,  14,  24,  14,   7  /
30173       DATA (NZK(K,2),K=511,540) /
30174      &     7,   7,   7,   7,   7,   7,   7,   7,  25,  13,
30175      &    25,   7,   7,   7,   7,   7,   7,   7,   7,   7,
30176      &    24,  14,  24,  13,  14,  23,  13,  23,  14,  23  /
30177       DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
30178      & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
30179      & 14, 14, 23, 14, 16, 25,
30180      & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
30181      & 23, 13, 14, 23,  0 /
30182       DATA (NZK(K,3),K=  1,170) /
30183      &     0,   0,   0,   0,   0,   0,   0,   5,   6,   5,
30184      &     6,  23,  23,   5,   5,   0,   0,   0,   0,  14,
30185      &    23,   5,   5,   0,   0,  14,  23,   5,   5,   0,
30186      &     0,   5,   5,   0,   0,   5,   5,   0,   0,   0,
30187      &     0,   0,   0,   0,   3,   0,   7,  23,  23,   7,
30188      &     0,   0,   0,   0,  23,   0,   0,   0,   0,   0,
30189      &     110*0   /
30190       DATA (NZK(K,3),K=171,340) /
30191      &     80*0,
30192      &     0,   0,   0,   0,   0,   0,  23,  13,  14,  23,
30193      &    23,  14,  23,  23,  23,  14,  23,  13,  23,  14,
30194      &    13,  23,  13,  23,  14,  23,  14,  14,  23,  13,
30195      &    13,  23,  13,  14,  23,  23,  14,  23,  13,  23,
30196      &    14,  14,   0,   0,   0,   0,   0,   0,   0,   0,
30197      &     30*0,
30198      &    14,  23,   7,   0,   0,   0,  23,   0,   0,   0  /
30199       DATA (NZK(K,3),K=341,510) /
30200      &     30*0,
30201      &     0,   0,   0,   0,   0,   0,   0,   0,   0,  23,
30202      &    14,   0,  13,   0,  14,   0,   0,  23,  13,   0,
30203      &     0,  15,   0,   0,  16,   0,   0,   0,   0,   0,
30204      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
30205      &     0,   0,   0,  14,  23,   0,   0,   0,  23, 134,
30206      &   134,   0,   0,   0, 133, 133,   0,   0,   0,   0,
30207      &     80*0  /
30208       DATA (NZK(K,3),K=511,540) /
30209      &     0,   0,   0,   0,   0,   0,   0,   0,  13,  13,
30210      &    25,   0,   0,   0,   0,   0,   0,   0,   0,   0,
30211      &    14,  14,  24,   0,   0,   0,   0,   0,   0,   0  /
30212       DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
30213      & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
30214
30215       END
30216
30217 *
30218 *====phoini============================================================*
30219 *
30220 CDECK  ID>, DT_XHOINI
30221       SUBROUTINE DT_XHOINI
30222 C     SUBROUTINE DT_PHOINI
30223
30224       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30225       SAVE
30226
30227       PARAMETER ( LINP = 5 ,
30228      &            LOUT = 6 ,
30229      &            LDAT = 9 )
30230
30231       RETURN
30232       END
30233 *
30234 *====eventb============================================================*
30235 *
30236 CDECK  ID>, DT_XVENTB
30237       SUBROUTINE DT_XVENTB(NCSY,IREJ)
30238 C     SUBROUTINE DT_EVENTB(NCSY,IREJ)
30239
30240       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30241       SAVE
30242
30243       PARAMETER ( LINP = 5 ,
30244      &            LOUT = 6 ,
30245      &            LDAT = 9 )
30246
30247       WRITE(LOUT,1000)
30248  1000 FORMAT(1X,'EVENTB:   PHOJET-package requested but not linked!')
30249       STOP
30250
30251       END
30252 *
30253 *===event==============================================================*
30254 *
30255 CDECK  ID>, DT_XVENT
30256       SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
30257 C     SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
30258
30259       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30260       SAVE
30261
30262       DIMENSION PP(4),PT(4)
30263
30264       RETURN
30265       END
30266 *
30267 *===pohisx=============================================================*
30268 *
30269 CDECK  ID>, DT_XOHISX
30270       SUBROUTINE DT_XOHISX(I,X)
30271 C     SUBROUTINE POHISX(I,X)
30272
30273       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30274       SAVE
30275
30276       RETURN
30277       END
30278 *
30279 *===poluhi=============================================================*
30280 *
30281 **PHOJET105a
30282 C     SUBROUTINE XOLUHI(I,X)
30283 **PHOJET112
30284
30285 CDECK  ID>, PHO_LHIST
30286       SUBROUTINE PHO_LHIST(I,X)
30287
30288 **
30289
30290       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30291       SAVE
30292
30293       RETURN
30294       END
30295 *
30296 CDECK  ID>, PDFSET
30297 C**********************************************************************
30298 C
30299 C   dummy subroutines, remove to link PDFLIB
30300 C
30301 C**********************************************************************
30302       SUBROUTINE PDFSET(PARAM,VALUE)
30303       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30304       DIMENSION PARAM(20),VALUE(20)
30305       CHARACTER*20 PARAM
30306       END
30307 CDECK  ID>, STRUCTM
30308       SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
30309       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30310       END
30311 CDECK  ID>, STRUCTP
30312       SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
30313       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30314       END
30315 *
30316 *===diqbrk=============================================================*
30317 *
30318 CDECK  ID>, DT_DIQBRK
30319       SUBROUTINE DT_XIQBRK
30320 C     SUBROUTINE DT_DIQBRK
30321
30322       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30323       SAVE
30324
30325       STOP 'diquark-breaking not implemeted !'
30326
30327       RETURN
30328       END
30329 *
30330 *===pho_rndm===========================================================*
30331 *
30332 CDECK  ID>, PHO_RNDM
30333       DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
30334
30335       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30336       SAVE
30337
30338       PHO_RNDM = DT_RNDM(DUMMY)
30339
30340       RETURN
30341       END
30342 *
30343 *===pyr================================================================*
30344 *
30345 CDECK  ID>, PYR
30346       DOUBLE PRECISION FUNCTION PYR(IDUMMY)
30347
30348       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30349       SAVE
30350
30351       DUMMY = DBLE(IDUMMY)
30352       PYR = DT_RNDM(DUMMY)
30353
30354       RETURN
30355       END
30356 *
30357 *===elhain=============================================================*
30358 *
30359 CDECK  ID>, DT_ELHAIN
30360       SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
30361
30362 ************************************************************************
30363 * Elastic hadron-hadron scattering.                                    *
30364 * This is a revised version of the original.                           *
30365 * This version dated 03.04.98 is written by S. Roesler                 *
30366 ************************************************************************
30367
30368       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30369       SAVE
30370
30371       PARAMETER ( LINP = 5 ,
30372      &            LOUT = 6 ,
30373      &            LDAT = 9 )
30374
30375       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
30376      &           TINY10=1.0D-10)
30377
30378       PARAMETER (ENNTHR = 3.5D0)
30379       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
30380      &           BLOWB=0.05D0,BHIB=0.2D0,
30381      &           BLOWM=0.1D0, BHIM=2.0D0)
30382
30383 * particle properties (BAMJET index convention)
30384       CHARACTER*8  ANAME
30385       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
30386      &                IICH(210),IIBAR(210),K1(210),K2(210)
30387 * final state from HADRIN interaction
30388       PARAMETER (MAXFIN=10)
30389       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
30390      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
30391
30392 C     DATA TSLOPE /10.0D0/
30393
30394       IREJ = 0
30395
30396     1 CONTINUE
30397
30398       PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
30399       EKIN = ELAB-AAM(IP)
30400 *   kinematical quantities in cms of the hadrons
30401       AMP2 = AAM(IP)**2
30402       AMT2 = AAM(IT)**2
30403       S    = AMP2+AMT2+TWO*ELAB*AAM(IT)
30404       ECM  = SQRT(S)
30405       ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
30406       PCM  = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
30407
30408 * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
30409       IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
30410      &     ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
30411 *   TSAMCS treats pp and np only, therefore change pn into np and
30412 *   nn into pp
30413          IF (IT.EQ.1) THEN
30414             KPROJ = IP
30415          ELSE
30416             KPROJ = 8
30417             IF (IP.EQ.8) KPROJ = 1
30418          ENDIF
30419          CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
30420          T = TWO*PCM**2*(CTCMS-ONE)
30421
30422 * very crude treatment otherwise: sample t from exponential dist.
30423       ELSE
30424 *   momentum transfer t
30425          TMAX = TWO*TWO*PCM**2
30426          RR = (PLAB-PLOWH)/(PHIH-PLOWH)
30427          IF (IIBAR(IP).NE.0) THEN
30428             TSLOPE = BLOWB+RR*(BHIB-BLOWB)
30429          ELSE
30430             TSLOPE = BLOWM+RR*(BHIM-BLOWM)
30431          ENDIF
30432          FMAX = EXP(-TSLOPE*TMAX)-ONE
30433          R = DT_RNDM(RR)
30434          T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
30435          IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
30436       ENDIF
30437
30438 *   target hadron in Lab after scattering
30439       ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
30440       PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
30441       IF (PLRH(2).LE.TINY10) THEN
30442 C        WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
30443          GOTO 1
30444       ENDIF
30445 *   projectile hadron in Lab after scattering
30446       ELRH(1) = ELAB+AAM(IT)-ELRH(2)
30447       PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
30448 *   scattering angle of projectile in Lab
30449       CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
30450       STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
30451       CALL DT_DSFECF(SPLABP,CPLABP)
30452 *   direction cosines of projectile in Lab
30453       CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
30454      &                          CXRH(1),CYRH(1),CZRH(1))
30455 *   scattering angle of target in Lab
30456       PLLABT = PLAB-CTLABP*PLRH(1)
30457       CTLABT = PLLABT/PLRH(2)
30458       STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
30459 *   direction cosines of target in Lab
30460       CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
30461      &                            CXRH(2),CYRH(2),CZRH(2))
30462 *   fill /HNFSPA/
30463       IRH = 2
30464       ITRH(1) = IP
30465       ITRH(2) = IT
30466
30467       RETURN
30468       END
30469 *
30470 *===tsamcs=============================================================*
30471 *
30472 CDECK  ID>, DT_TSAMCS
30473       SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
30474
30475 ************************************************************************
30476 * Sampling of cos(theta) for nucleon-proton scattering according to    *
30477 * hetkfa2/bertini parametrization.                                     *
30478 * This is a revised version of the original (HJM 24/10/88)             *
30479 * This version dated 28.10.95 is written by S. Roesler                 *
30480 ************************************************************************
30481
30482       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30483       SAVE
30484
30485       PARAMETER ( LINP = 5 ,
30486      &            LOUT = 6 ,
30487      &            LDAT = 9 )
30488
30489       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
30490      &           TINY10=1.0D-10)
30491
30492       DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
30493       DIMENSION PDCI(60),PDCH(55)
30494
30495       DATA (DCLIN(I),I=1,80) /
30496      &     5.000D-01,  1.000D+00,  0.000D+00,  1.000D+00,  0.000D+00,
30497      &     4.993D-01,  9.881D-01,  5.963D-02,  9.851D-01,  5.945D-02,
30498      &     4.936D-01,  8.955D-01,  5.224D-01,  8.727D-01,  5.091D-01,
30499      &     4.889D-01,  8.228D-01,  8.859D-01,  7.871D-01,  8.518D-01,
30500      &     4.874D-01,  7.580D-01,  1.210D+00,  7.207D-01,  1.117D+00,
30501      &     4.912D-01,  6.969D-01,  1.516D+00,  6.728D-01,  1.309D+00,
30502      &     5.075D-01,  6.471D-01,  1.765D+00,  6.667D-01,  1.333D+00,
30503      &     5.383D-01,  6.054D-01,  1.973D+00,  7.059D-01,  1.176D+00,
30504      &     5.397D-01,  5.990D-01,  2.005D+00,  7.023D-01,  1.191D+00,
30505      &     5.336D-01,  6.083D-01,  1.958D+00,  6.959D-01,  1.216D+00,
30506      &     5.317D-01,  6.075D-01,  1.962D+00,  6.897D-01,  1.241D+00,
30507      &     5.300D-01,  6.016D-01,  1.992D+00,  6.786D-01,  1.286D+00,
30508      &     5.281D-01,  6.063D-01,  1.969D+00,  6.786D-01,  1.286D+00,
30509      &     5.280D-01,  5.960D-01,  2.020D+00,  6.667D-01,  1.333D+00,
30510      &     5.273D-01,  5.920D-01,  2.040D+00,  6.604D-01,  1.358D+00,
30511      &     5.273D-01,  5.862D-01,  2.069D+00,  6.538D-01,  1.385D+00/
30512       DATA (DCLIN(I),I=81,160) /
30513      &     5.223D-01,  5.980D-01,  2.814D+00,  6.538D-01,  1.385D+00,
30514      &     5.202D-01,  5.969D-01,  2.822D+00,  6.471D-01,  1.412D+00,
30515      &     5.183D-01,  5.881D-01,  2.883D+00,  6.327D-01,  1.469D+00,
30516      &     5.159D-01,  5.866D-01,  2.894D+00,  6.250D-01,  1.500D+00,
30517      &     5.133D-01,  5.850D-01,  2.905D+00,  6.170D-01,  1.532D+00,
30518      &     5.106D-01,  5.833D-01,  2.917D+00,  6.087D-01,  1.565D+00,
30519      &     5.084D-01,  5.801D-01,  2.939D+00,  6.000D-01,  1.600D+00,
30520      &     5.063D-01,  5.763D-01,  2.966D+00,  5.909D-01,  1.636D+00,
30521      &     5.036D-01,  5.730D-01,  2.989D+00,  5.814D-01,  1.674D+00,
30522      &     5.014D-01,  5.683D-01,  3.022D+00,  5.714D-01,  1.714D+00,
30523      &     4.986D-01,  5.641D-01,  3.051D+00,  5.610D-01,  1.756D+00,
30524      &     4.964D-01,  5.580D-01,  3.094D+00,  5.500D-01,  1.800D+00,
30525      &     4.936D-01,  5.573D-01,  3.099D+00,  5.431D-01,  1.827D+00,
30526      &     4.909D-01,  5.509D-01,  3.144D+00,  5.313D-01,  1.875D+00,
30527      &     4.885D-01,  5.512D-01,  3.142D+00,  5.263D-01,  1.895D+00,
30528      &     4.857D-01,  5.437D-01,  3.194D+00,  5.135D-01,  1.946D+00/
30529       DATA (DCLIN(I),I=161,195) /
30530      &     4.830D-01,  5.353D-01,  3.253D+00,  5.000D-01,  2.000D+00,
30531      &     4.801D-01,  5.323D-01,  3.274D+00,  4.915D-01,  2.034D+00,
30532      &     4.770D-01,  5.228D-01,  3.341D+00,  4.767D-01,  2.093D+00,
30533      &     4.738D-01,  5.156D-01,  3.391D+00,  4.643D-01,  2.143D+00,
30534      &     4.701D-01,  5.010D-01,  3.493D+00,  4.444D-01,  2.222D+00,
30535      &     4.672D-01,  4.990D-01,  3.507D+00,  4.375D-01,  2.250D+00,
30536      &     4.634D-01,  4.856D-01,  3.601D+00,  4.194D-01,  2.323D+00/
30537
30538       DATA PDCI /
30539      &     4.400D+02,  1.896D-01,  1.931D-01,  1.982D-01,  1.015D-01,
30540      &     1.029D-01,  4.180D-02,  4.228D-02,  4.282D-02,  4.350D-02,
30541      &     2.204D-02,  2.236D-02,  5.900D+02,  1.433D-01,  1.555D-01,
30542      &     1.774D-01,  1.000D-01,  1.128D-01,  5.132D-02,  5.600D-02,
30543      &     6.158D-02,  6.796D-02,  3.660D-02,  3.820D-02,  6.500D+02,
30544      &     1.192D-01,  1.334D-01,  1.620D-01,  9.527D-02,  1.141D-01,
30545      &     5.283D-02,  5.952D-02,  6.765D-02,  7.878D-02,  4.796D-02,
30546      &     6.957D-02,  8.000D+02,  4.872D-02,  6.694D-02,  1.152D-01,
30547      &     9.348D-02,  1.368D-01,  6.912D-02,  7.953D-02,  9.577D-02,
30548      &     1.222D-01,  7.755D-02,  9.525D-02,  1.000D+03,  3.997D-02,
30549      &     5.456D-02,  9.804D-02,  8.084D-02,  1.208D-01,  6.520D-02,
30550      &     8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,  1.093D-01/
30551
30552       DATA PDCH /
30553      &     1.000D+03,  9.453D-02,  9.804D-02,  8.084D-02,  1.208D-01,
30554      &     6.520D-02,  8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,
30555      &     1.093D-01,  1.400D+03,  1.072D-01,  7.450D-02,  6.645D-02,
30556      &     1.136D-01,  6.750D-02,  8.580D-02,  1.110D-01,  1.530D-01,
30557      &     1.010D-01,  1.350D-01,  2.170D+03,  4.004D-02,  3.013D-02,
30558      &     2.664D-02,  5.511D-02,  4.240D-02,  7.660D-02,  1.364D-01,
30559      &     2.300D-01,  1.670D-01,  2.010D-01,  2.900D+03,  1.870D-02,
30560      &     1.804D-02,  1.320D-02,  2.970D-02,  2.860D-02,  5.160D-02,
30561      &     1.020D-01,  2.400D-01,  2.250D-01,  3.370D-01,  4.400D+03,
30562      &     1.196D-03,  8.784D-03,  1.517D-02,  2.874D-02,  2.488D-02,
30563      &     4.464D-02,  8.330D-02,  2.008D-01,  2.360D-01,  3.567D-01/
30564
30565       DATA (DCHN(I),I=1,90) /
30566      &     4.770D-01,  4.750D-01,  4.715D-01,  4.685D-01,  4.650D-01,
30567      &     4.610D-01,  4.570D-01,  4.550D-01,  4.500D-01,  4.450D-01,
30568      &     4.405D-01,  4.350D-01,  4.300D-01,  4.250D-01,  4.200D-01,
30569      &     4.130D-01,  4.060D-01,  4.000D-01,  3.915D-01,  3.840D-01,
30570      &     3.760D-01,  3.675D-01,  3.580D-01,  3.500D-01,  3.400D-01,
30571      &     3.300D-01,  3.200D-01,  3.100D-01,  3.000D-01,  2.900D-01,
30572      &     2.800D-01,  2.700D-01,  2.600D-01,  2.500D-01,  2.400D-01,
30573      &     2.315D-01,  2.240D-01,  2.150D-01,  2.060D-01,  2.000D-01,
30574      &     1.915D-01,  1.850D-01,  1.780D-01,  1.720D-01,  1.660D-01,
30575      &     1.600D-01,  1.550D-01,  1.500D-01,  1.450D-01,  1.400D-01,
30576      &     1.360D-01,  1.320D-01,  1.280D-01,  1.250D-01,  1.210D-01,
30577      &     1.180D-01,  1.150D-01,  1.120D-01,  1.100D-01,  1.070D-01,
30578      &     1.050D-01,  1.030D-01,  1.010D-01,  9.900D-02,  9.700D-02,
30579      &     9.550D-02,  9.480D-02,  9.400D-02,  9.200D-02,  9.150D-02,
30580      &     9.100D-02,  9.000D-02,  8.990D-02,  8.900D-02,  8.850D-02,
30581      &     8.750D-02,  8.700D-02,  8.650D-02,  8.550D-02,  8.500D-02,
30582      &     8.499D-02,  8.450D-02,  8.350D-02,  8.300D-02,  8.250D-02,
30583      &     8.150D-02,  8.100D-02,  8.030D-02,  8.000D-02,  7.990D-02/
30584       DATA (DCHN(I),I=91,143) /
30585      &     7.980D-02,  7.950D-02,  7.900D-02,  7.860D-02,  7.800D-02,
30586      &     7.750D-02,  7.650D-02,  7.620D-02,  7.600D-02,  7.550D-02,
30587      &     7.530D-02,  7.500D-02,  7.499D-02,  7.498D-02,  7.480D-02,
30588      &     7.450D-02,  7.400D-02,  7.350D-02,  7.300D-02,  7.250D-02,
30589      &     7.230D-02,  7.200D-02,  7.100D-02,  7.050D-02,  7.020D-02,
30590      &     7.000D-02,  6.999D-02,  6.995D-02,  6.993D-02,  6.991D-02,
30591      &     6.990D-02,  6.870D-02,  6.850D-02,  6.800D-02,  6.780D-02,
30592      &     6.750D-02,  6.700D-02,  6.650D-02,  6.630D-02,  6.600D-02,
30593      &     6.550D-02,  6.525D-02,  6.510D-02,  6.500D-02,  6.499D-02,
30594      &     6.498D-02,  6.496D-02,  6.494D-02,  6.493D-02,  6.490D-02,
30595      &     6.488D-02,  6.485D-02,  6.480D-02/
30596
30597       DATA DCHNA /
30598      &     6.300D+02,  7.810D-02,  1.421D-01,  1.979D-01,  2.479D-01,
30599      &     3.360D-01,  5.400D-01,  7.236D-01,  1.000D+00,  1.540D+03,
30600      &     2.225D-01,  3.950D-01,  5.279D-01,  6.298D-01,  7.718D-01,
30601      &     9.405D-01,  9.835D-01,  1.000D+00,  2.560D+03,  2.625D-01,
30602      &     4.550D-01,  5.963D-01,  7.020D-01,  8.380D-01,  9.603D-01,
30603      &     9.903D-01,  1.000D+00,  3.520D+03,  4.250D-01,  6.875D-01,
30604      &     8.363D-01,  9.163D-01,  9.828D-01,  1.000D+00,  1.000D+00,
30605      &     1.000D+00/
30606
30607       DATA DCHNB /
30608      &     6.300D+02,  3.800D-02,  7.164D-02,  1.275D-01,  2.171D-01,
30609      &     3.227D-01,  4.091D-01,  5.051D-01,  6.061D-01,  7.074D-01,
30610      &     8.434D-01,  1.000D+00,  2.040D+03,  1.200D-01,  2.115D-01,
30611      &     3.395D-01,  5.295D-01,  7.251D-01,  8.511D-01,  9.487D-01,
30612      &     9.987D-01,  1.000D+00,  1.000D+00,  1.000D+00,  2.200D+03,
30613      &     1.344D-01,  2.324D-01,  3.754D-01,  5.674D-01,  7.624D-01,
30614      &     8.896D-01,  9.808D-01,  1.000D+00,  1.000D+00,  1.000D+00,
30615      &     1.000D+00,  2.850D+03,  2.330D-01,  4.130D-01,  6.610D-01,
30616      &     9.010D-01,  9.970D-01,  1.000D+00,  1.000D+00,  1.000D+00,
30617      &     1.000D+00,  1.000D+00,  1.000D+00,  3.500D+03,  3.300D-01,
30618      &     5.450D-01,  7.950D-01,  1.000D+00,  1.000D+00,  1.000D+00,
30619      &     1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00/
30620
30621       CST = ONE
30622       IF (EKIN.GT.3.5D0) RETURN
30623 C
30624       IF(KPROJ.EQ.8) GOTO 101
30625       IF(KPROJ.EQ.1) GOTO 102
30626 C*                                             INVALID REACTION
30627       WRITE(LOUT,'(A,I5/A)')
30628      &        ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
30629      &        ' COS(THETA) = 1D0 RETURNED'
30630       RETURN
30631 C-------------------------------- NP ELASTIC SCATTERING----------
30632 101   CONTINUE
30633       IF (EKIN.GT.0.740D0)GOTO 1000
30634       IF (EKIN.LT.0.300D0)THEN
30635 C                                 EKIN .LT. 300 MEV
30636          IDAT=1
30637       ELSE
30638 C                                 300 MEV < EKIN < 740 MEV
30639          IDAT=6
30640       END IF
30641 C
30642       ENER=EKIN
30643       IE=INT(ABS(ENER/0.020D0))
30644       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
30645 C                                            FORWARD/BACKWARD DECISION
30646       K=IDAT+5*IE
30647       BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
30648       IF (DT_RNDM(CST).LT.BWFW)THEN
30649          VALUE2=-1D0
30650          K=K+1
30651       ELSE
30652          VALUE2=1D0
30653          K=K+3
30654       END IF
30655 C
30656       COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
30657       RND=DT_RNDM(COEF)
30658 C
30659       IF(RND.LT.COEF)THEN
30660          CST=DT_RNDM(RND)
30661          CST=CST*VALUE2
30662       ELSE
30663          R1=DT_RNDM(CST)
30664          R2=DT_RNDM(R1)
30665          R3=DT_RNDM(R2)
30666          R4=DT_RNDM(R3)
30667 C
30668          IF(VALUE2.GT.0.0)THEN
30669             CST=MAX(R1,R2,R3,R4)
30670             GOTO 1500
30671          ELSE
30672             R5=DT_RNDM(R4)
30673 C
30674             IF (IDAT.EQ.1)THEN
30675                CST=-MAX(R1,R2,R3,R4,R5)
30676             ELSE
30677                R6=DT_RNDM(R5)
30678                R7=DT_RNDM(R6)
30679                CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
30680             END IF
30681 C
30682          END IF
30683 C
30684       END IF
30685 C
30686       GOTO 1500
30687 C
30688 C********                                EKIN  .GT.  0.74 GEV
30689 C
30690 1000  ENER=EKIN - 0.66D0
30691 C     IE=ABS(ENER/0.02)
30692       IE=INT(ENER/0.02D0)
30693       EMEV=EKIN*1D3
30694 C
30695       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
30696       K=IE
30697       BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
30698       RND=DT_RNDM(BWFW)
30699 C                                        FORWARD NEUTRON
30700       IF (RND.GE.BWFW)THEN
30701          DO 1200 K=10,36,9
30702            IF (DCHNA(K).GT.EMEV) THEN
30703               UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
30704               UNIV=DT_RNDM(UNIVE)
30705               DO 1100 I=1,8
30706                  II=K+I
30707                  P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
30708 C
30709                  IF (P.GT.UNIV)THEN
30710                     UNIV=DT_RNDM(UNIVE)
30711                     FLTI=DBLE(I)-UNIV
30712                     GOTO(290,290,290,290,330,340,350,360) I
30713                  END IF
30714  1100         CONTINUE
30715            END IF
30716  1200    CONTINUE
30717 C
30718       ELSE
30719 C                                        BACKWARD NEUTRON
30720          DO 1400 K=13,60,12
30721             IF (DCHNB(K).GT.EMEV) THEN
30722                UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
30723                UNIV=DT_RNDM(UNIVE)
30724                DO 1300 I=1,11
30725                  II=K+I
30726                  P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
30727 C
30728                  IF (P.GT.UNIV)THEN
30729                    UNIV=DT_RNDM(P)
30730                    FLTI=DBLE(I)-UNIV
30731                    GOTO(120,120,140,150,160,160,180,190,200,210,220) I
30732                  END IF
30733  1300          CONTINUE
30734             END IF
30735  1400    CONTINUE
30736       END IF
30737 C
30738 120   CST=1.0D-2*FLTI-1.0D0
30739       GOTO 1500
30740 140   CST=2.0D-2*UNIV-0.98D0
30741       GOTO 1500
30742 150   CST=4.0D-2*UNIV-0.96D0
30743       GOTO 1500
30744 160   CST=6.0D-2*FLTI-1.16D0
30745       GOTO 1500
30746 180   CST=8.0D-2*UNIV-0.80D0
30747       GOTO 1500
30748 190   CST=1.0D-1*UNIV-0.72D0
30749       GOTO 1500
30750 200   CST=1.2D-1*UNIV-0.62D0
30751       GOTO 1500
30752 210   CST=2.0D-1*UNIV-0.50D0
30753       GOTO 1500
30754 220   CST=3.0D-1*(UNIV-1.0D0)
30755       GOTO 1500
30756 C
30757 290   CST=1.0D0-2.5d-2*FLTI
30758       GOTO 1500
30759 330   CST=0.85D0+0.5D-1*UNIV
30760       GOTO 1500
30761 340   CST=0.70D0+1.5D-1*UNIV
30762       GOTO 1500
30763 350   CST=0.50D0+2.0D-1*UNIV
30764       GOTO 1500
30765 360   CST=0.50D0*UNIV
30766 C
30767 1500  RETURN
30768 C
30769 C-----------------------------------  PP ELASTIC SCATTERING -------
30770 C
30771  102  CONTINUE
30772       EMEV=EKIN*1D3
30773 C
30774       IF (EKIN.LE.0.500D0) THEN
30775          RND=DT_RNDM(EMEV)
30776          CST=2.0D0*RND-1.0D0
30777          RETURN
30778 C
30779       ELSEIF (EKIN.LT.1.0D0) THEN
30780          DO 2200 K=13,60,12
30781             IF (PDCI(K).GT.EMEV) THEN
30782                UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
30783                UNIV=DT_RNDM(UNIVE)
30784                SUM=0
30785                DO 2100 I=1,11
30786                  II=K+I
30787                  SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
30788 C
30789                  IF (UNIV.LT.SUM)THEN
30790                    UNIV=DT_RNDM(SUM)
30791                    FLTI=DBLE(I)-UNIV
30792                    GOTO(55,55,55,60,60,65,65,65,65,70,70) I
30793                  END IF
30794  2100          CONTINUE
30795             END IF
30796  2200    CONTINUE
30797       ELSE
30798          DO 2400 K=12,55,11
30799             IF (PDCH(K).GT.EMEV) THEN
30800               UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
30801               UNIV=DT_RNDM(UNIVE)
30802               SUM=0.0D0
30803               DO 2300 I=1,10
30804                 II=K+I
30805                 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
30806 C
30807                 IF (UNIV.LT.SUM)THEN
30808                   UNIV=DT_RNDM(SUM)
30809                   FLTI=UNIV+DBLE(I)
30810                   GOTO(50,55,60,60,65,65,65,65,70,70) I
30811                 END IF
30812  2300         CONTINUE
30813             END IF
30814  2400    CONTINUE
30815       END IF
30816 C
30817 50    CST=0.4D0*UNIV
30818       GOTO 2500
30819 55    CST=0.2D0*FLTI
30820       GOTO 2500
30821 60    CST=0.3D0+0.1D0*FLTI
30822       GOTO 2500
30823 65    CST=0.6D0+0.04D0*FLTI
30824       GOTO 2500
30825 70    CST=0.78D0+0.02D0*FLTI
30826 C
30827 2500  CONTINUE
30828       IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
30829 C
30830       RETURN
30831       END
30832 *
30833 *===dhadri=============================================================*
30834 *
30835 CDECK  ID>, DT_DHADRI
30836       SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
30837
30838       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30839       SAVE
30840
30841       PARAMETER ( LINP = 5 ,
30842      &            LOUT = 6 ,
30843      &            LDAT = 9 )
30844
30845 C
30846 C-----------------------------
30847 C*** INPUT VARIABLES LIST:
30848 C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
30849 C*** GEV/C LABORATORY MOMENTUM REGION
30850 C*** N    - PROJECTILE HADRON INDEX
30851 C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
30852 C*** ELAB - LABORATORY ENERGY OF N (GEV)
30853 C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
30854 C*** ITTA - TARGET NUCLEON INDEX
30855 C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
30856 C  IR COUNTS THE NUMBER OF PRODUCED PARTICLES
30857 C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
30858 C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
30859 C*** RESPECT., UNITS (GEV/C AND GEV)
30860 C----------------------------
30861
30862       COMMON /HNGAMR/ REDU,AMO,AMM(15)
30863       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
30864       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
30865      &                NRK(2,268),NURE(30,2)
30866 * particle properties (BAMJET index convention),
30867 * (dublicate of DTPART for HADRIN)
30868       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
30869      &                K1H(110),K2H(110)
30870       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
30871       COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
30872      &                ITS(149),IS
30873       COMMON /HNDRUN/ RUNTES,EFTES
30874 * particle properties (BAMJET index convention)
30875       CHARACTER*8  ANAME
30876       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
30877      &                IICH(210),IIBAR(210),K1(210),K2(210)
30878 * final state from HADRIN interaction
30879       PARAMETER (MAXFIN=10)
30880       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
30881      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
30882
30883       DIMENSION ITPRF(110)
30884       DATA NNN/0/
30885       DATA UMODA/0./
30886       DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
30887       LOWP=0
30888       IF (N.LE.0.OR.N.GE.111)N=1
30889       IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
30890         GOTO 280
30891 *       WRITE (6,1000)
30892 *    +  ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
30893 *       STOP
30894 *1000   FORMAT (3(5H ****/),A,2I4,3(5H ****/))
30895 *    +  45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
30896       ENDIF
30897       IATMPT=0
30898       IF (ABS(PLAB-5.0D0).LT.4.99999D0)                        GO TO 20
30899 C     IF(IPRI.GE.1) WRITE (6,1010) PLAB
30900 C     STOP
30901  1010 FORMAT ( '  PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
30902      + ALLOWED REGION, PLAB=',1E15.5)
30903
30904    20 CONTINUE
30905       UMODAT=N*1.11111D0+ITTA*2.19291D0
30906       IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
30907       UMODA=UMODAT
30908    30 IATMPT=0
30909       LOWP=LOWP+1
30910    40 CONTINUE
30911       IMACH=0
30912       REDU=2.0D0
30913       IF (LOWP.GT.20) THEN
30914 C        WRITE(LOUT,*) ' jump 1'
30915          GO TO 280
30916       ENDIF
30917       NNN=N
30918       IF (NNN.EQ.N)                                             GO TO 50
30919       RUNTES=0.0D0
30920       EFTES=0.0D0
30921    50 CONTINUE
30922       IS=1
30923       IRH=0
30924       IST=1
30925       NSTAB=23
30926       IRE=NURE(N,1)
30927       IF(ITTA.GT.1) IRE=NURE(N,2)
30928 C
30929 C-----------------------------
30930 C*** IE,AMT,ECM,SI DETERMINATION
30931 C----------------------------
30932       CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
30933       IANTH=-1
30934 **sr
30935 C     IF (AMH(1).NE.0.93828D0) IANTH=1
30936       IF (AMH(1).NE.0.9383D0) IANTH=1
30937 **
30938       IF (IANTH.GE.0) SI=1.0D0
30939       ECMMH=ECM
30940 C
30941 C-----------------------------
30942 C    ENERGY INDEX
30943 C  IRE CHARACTERIZES THE REACTION
30944 C  IE IS THE ENERGY INDEX
30945 C----------------------------
30946       IF (SI.LT.1.D-6) THEN
30947 C        WRITE(LOUT,*) ' jump 2'
30948          GO TO 280
30949       ENDIF
30950       IF (N.LE.NSTAB)                                           GO TO 60
30951       RUNTES=RUNTES+1.0D0
30952       IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
30953  1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
30954       IF(IBARH(N).EQ.1) N=8
30955       IF(IBARH(N).EQ.-1)  N=9
30956    60 CONTINUE
30957       IMACH=IMACH+1
30958 **sr 19.2.97: loop for direct channel suppression
30959 C     IF (IMACH.GT.10) THEN
30960       IF (IMACH.GT.1000) THEN
30961 **
30962 C        WRITE(LOUT,*) ' jump 3'
30963          GO TO 280
30964       ENDIF
30965       ECM =ECMMH
30966       AMN2=AMN**2
30967       AMT2=AMT**2
30968       ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM    )
30969       IF(ECMN.LE.AMN) ECMN=AMN
30970       PCMN=SQRT(ECMN**2-AMN2)
30971       GAM=(ELAB+AMT)/ECM
30972       BGAM=PLAB/ECM
30973       IF (IANTH.GE.0) ECM=2.1D0
30974 C
30975 C-----------------------------
30976 C*** RANDOM CHOICE OF REACTION CHANNEL
30977 C----------------------------
30978       IST=0
30979       VV=DT_RNDM(AMN2)
30980       VV=VV-1.D-17
30981 C
30982 C-----------------------------
30983 C***  PLACE REDUCED VERSION
30984 C----------------------------
30985       IIEI=IEII(IRE)
30986       IDWK=IEII(IRE+1)-IIEI
30987       IIWK=IRII(IRE)
30988       IIKI=IKII(IRE)
30989 C
30990 C-----------------------------
30991 C***  SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
30992 C----------------------------
30993       HECM=ECM
30994       HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
30995       IF (HUMO.LT.ECM) ECM=HUMO
30996 C
30997 C-----------------------------
30998 C*** INTERPOLATION PREPARATION
30999 C----------------------------
31000       ECMO=UMO(IE)
31001       ECM1=UMO(IE-1)
31002       DECM=ECMO-ECM1
31003       DEC=ECMO-ECM
31004 C
31005 C-----------------------------
31006 C*** RANDOM LOOP
31007 C----------------------------
31008       IK=0
31009       WKK=0.0D0
31010       WICOR=0.0D0
31011    70 IK=IK+1
31012       IWK=IIWK+(IK-1)*IDWK+IE-IIEI
31013       WOK=WK(IWK)
31014       WDK=WOK-WK(IWK-1)
31015 C
31016 C-----------------------------
31017 C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
31018 C    GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
31019 C    CONTRIBUTE
31020 C----------------------------
31021       IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
31022       WICO=WOK*1.23459876D0+WDK*1.735218469D0
31023       IF (WICO.EQ.WICOR)                                        GO TO 70
31024       IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
31025       WICOR=WICO
31026 C
31027 C-----------------------------
31028 C*** INTERPOLATION IN CHANNEL WEIGHTS
31029 C----------------------------
31030       EKLIM=-THRESH(IIKI+IK)
31031       IELIM=IDT_IEFUND(EKLIM,IRE)
31032       DELIM=UMO(IELIM)+EKLIM
31033      *+1.D-16
31034       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
31035       IF (DELIM*DELIM-DETE*DETE) 90,90,80
31036    80 DECC=DELIM
31037                                                                GO TO 100
31038    90 DECC=DECM
31039   100 CONTINUE
31040       WKK=WOK-WDK*DEC/(DECC+1.D-9)
31041 C
31042 C-----------------------------
31043 C*** RANDOM CHOICE
31044 C----------------------------
31045 C
31046       IF (VV.GT.WKK)                                            GO TO 70
31047 C
31048 C***IK IS THE REACTION CHANNEL
31049 C----------------------------
31050       INRK=IKII(IRE)+IK
31051       ECM=HECM
31052       I1001 =0
31053 C
31054   110 CONTINUE
31055       IT1=NRK(1,INRK)
31056       AM1=DT_DAMG(IT1)
31057       IT2=NRK(2,INRK)
31058       AM2=DT_DAMG(IT2)
31059       AMS=AM1+AM2
31060       I1001=I1001+1
31061       IF (I1001.GT.50)                                          GO TO 60
31062 C
31063       IF (IT2*AMS.GT.IT2*ECM)                                  GO TO 110
31064       IT11=IT1
31065       IT22=IT2
31066       IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
31067       AM11=AM1
31068       AM22=AM2
31069       IF (IT2.GT.0)                                            GO TO 120
31070 **sr 19.2.97: supress direct channel for pp-collisions
31071       IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
31072          RR = DT_RNDM(AM11)
31073          IF (RR.LE.0.75D0) GOTO 60
31074       ENDIF
31075 **
31076 C
31077 C-----------------------------
31078 C  INCLUSION OF DIRECT RESONANCES
31079 C  RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE  IT1
31080 C------------------------
31081       KZ1=K1H(IT1)
31082       IST=IST+1
31083       IECO=0
31084       ECO=ECM
31085       GAM=(ELAB+AMT)/ECO
31086       BGAM=PLAB/ECO
31087       CXS(1)=CX
31088       CYS(1)=CY
31089       CZS(1)=CZ
31090                                                                GO TO 170
31091   120 CONTINUE
31092       WW=DT_RNDM(ECO)
31093       IF(WW.LT. 0.5D0)                                         GO TO 130
31094       IT1=IT22
31095       IT2=IT11
31096       AM1=AM22
31097       AM2=AM11
31098   130 CONTINUE
31099 C
31100 C-----------------------------
31101 C   THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
31102       IBN=IBARH(N)
31103       IB1=IBARH(IT1)
31104       IT11=IT1
31105       IT22=IT2
31106       AM11=AM1
31107       AM22=AM2
31108       IF(IB1.EQ.IBN)                                           GO TO 140
31109       IT1=IT22
31110       IT2=IT11
31111       AM1=AM22
31112       AM2=AM11
31113   140 CONTINUE
31114 C-----------------------------
31115 C***IT1,IT2 ARE THE CREATED PARTICLES
31116 C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
31117 C------------------------
31118       CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
31119      *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
31120       IST=IST+1
31121       ITS(IST)=IT1
31122       AMM(IST)=AM1
31123 C
31124 C-----------------------------
31125 C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
31126 C----------------------------
31127       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
31128      &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
31129       IST=IST+1
31130       ITS(IST)=IT2
31131       AMM(IST)=AM2
31132       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
31133      *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
31134   150 CONTINUE
31135 C
31136 C-----------------------------
31137 C***TEST   STABLE OR UNSTABLE
31138 C----------------------------
31139       IF(ITS(IST).GT.NSTAB)                                    GO TO 160
31140       IRH=IRH+1
31141 C
31142 C-----------------------------
31143 C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
31144 C----------------------------
31145 C*    IF (REDU.LT.0.D0) GO TO 1009
31146       ITRH(IRH)=ITS(IST)
31147       PLRH(IRH)=PLS(IST)
31148       CXRH(IRH)=CXS(IST)
31149       CYRH(IRH)=CYS(IST)
31150       CZRH(IRH)=CZS(IST)
31151       ELRH(IRH)=ELS(IST)
31152       IST=IST-1
31153       IF(IST.GE.1)                                             GO TO 150
31154                                                                GO TO 260
31155   160 CONTINUE
31156 C
31157 C  RANDOM CHOICE OF DECAY CHANNELS
31158 C----------------------------
31159 C
31160       IT=ITS(IST)
31161       ECO=AMM(IST)
31162       GAM=ELS(IST)/ECO
31163       BGAM=PLS(IST)/ECO
31164       IECO=0
31165       KZ1=K1H(IT)
31166   170 CONTINUE
31167       IECO=IECO+1
31168       VV=DT_RNDM(GAM)
31169       VV=VV-1.D-17
31170       IIK=KZ1-1
31171   180 IIK=IIK+1
31172       IF (VV.GT.WTI(IIK))                                      GO TO 180
31173 C
31174 C  IIK IS THE DECAY CHANNEL
31175 C----------------------------
31176       IT1=NZKI(IIK,1)
31177       I310=0
31178   190 CONTINUE
31179       I310=I310+1
31180       AM1=DT_DAMG(IT1)
31181       IT2=NZKI(IIK,2)
31182       AM2=DT_DAMG(IT2)
31183       IF (IT2-1.LT.0)                                          GO TO 240
31184       IT3=NZKI(IIK,3)
31185       AM3=DT_DAMG(IT3)
31186       AMS=AM1+AM2+AM3
31187 C
31188 C  IF  IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
31189 C----------------------------
31190       IF (IECO.LE.10)                                          GO TO 200
31191       IATMPT=IATMPT+1
31192       IF(IATMPT.GT.3) THEN
31193 C        WRITE(LOUT,*) ' jump 4'
31194          GO TO 280
31195       ENDIF
31196                                                                 GO TO 40
31197   200 CONTINUE
31198       IF (I310.GT.50)                                          GO TO 170
31199       IF (AMS.GT.ECO)                                          GO TO 190
31200 C
31201 C  FOR THE DECAY CHANNEL
31202 C  IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM  IT
31203 C----------------------------
31204       IF (REDU.LT.0.D0)                                        GO TO 30
31205       ITWTHC=0
31206       REDU=2.0D0
31207       IF(IT3.EQ.0)                                             GO TO 220
31208   210 CONTINUE
31209       ITWTH=1
31210       CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
31211      *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
31212                                                                GO TO 230
31213   220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
31214      &COD2,COF2,SIF2,AM1,AM2)
31215       ITWTH=-1
31216       IT3=0
31217   230 CONTINUE
31218       ITWTHC=ITWTHC+1
31219       IF (REDU.GT.0.D0)                                        GO TO 240
31220       REDU=2.0D0
31221       IF (ITWTHC.GT.100)                                        GO TO 30
31222       IF (ITWTH) 220,220,210
31223   240 CONTINUE
31224       ITS(IST  )=IT1
31225       IF (IT2-1.LT.0)                                          GO TO 250
31226       ITS(IST+1)  =IT2
31227       ITS(IST+2)=IT3
31228       RX=CXS(IST)
31229       RY=CYS(IST)
31230       RZ=CZS(IST)
31231       AMM(IST)=AM1
31232       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
31233      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
31234       IST=IST+1
31235       AMM(IST)=AM2
31236       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
31237      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
31238       IF (IT3.LE.0)                                            GO TO 250
31239       IST=IST+1
31240       AMM(IST)=AM3
31241       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
31242      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
31243   250 CONTINUE
31244                                                                GO TO 150
31245   260 CONTINUE
31246   270 CONTINUE
31247       RETURN
31248   280 CONTINUE
31249 C
31250 C----------------------------
31251 C
31252 C   ZERO CROSS SECTION CASE
31253 C----------------------------
31254 C
31255       IRH=1
31256       ITRH(1)=N
31257       CXRH(1)=CX
31258       CYRH(1)=CY
31259       CZRH(1)=CZ
31260       ELRH(1)=ELAB
31261       PLRH(1)=PLAB
31262       RETURN
31263       END
31264 *
31265 *===runtt==============================================================*
31266 *
31267 CDECK  ID>, DT_RUNTT
31268       BLOCK DATA DT_RUNTT
31269
31270       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31271       SAVE
31272
31273       COMMON /HNDRUN/ RUNTES,EFTES
31274
31275       DATA RUNTES,EFTES /100.D0,100.D0/
31276
31277       END
31278 *
31279 *===noname=============================================================*
31280 *
31281 CDECK  ID>, DT_NONAME
31282       BLOCK DATA DT_NONAME
31283
31284       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31285       SAVE
31286
31287 * slope parameters for HADRIN interactions
31288       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
31289       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
31290
31291 C     DATAS     DATAS    DATAS      DATAS     DATAS
31292 C******          *********
31293       DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
31294      &           207, 224, 241, 252, 268 /
31295       DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
31296      &           220, 241, 262, 279, 296 /
31297       DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
31298      &           3364, 3507, 4011, 4368, 4725, 4912, 5184/
31299
31300 C
31301 C     MASSES FOR THE SLOPE B(M) IN GEV
31302 C     SLOPE B(M) FOR AN MESONIC SYSTEM
31303 C     SLOPE B(M) FOR A BARYONIC SYSTEM
31304
31305 *
31306       DATA SM,BBM,BBB/  0.8D0, 0.85D0,  0.9D0, 0.95D0, 1.D0,
31307      &     1.05D0,  1.1D0, 1.15D0,  1.2D0, 1.25D0,
31308      &      1.3D0,  1.35D0, 1.4D0,  1.45D0,  1.5D0,
31309      &     1.55D0,  1.6D0,  1.65D0, 1.7D0,   1.75D0,
31310      &      1.8D0,  1.85D0, 1.9D0,  1.95D0,  2.D0,
31311      &     15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
31312      &    12.35D0, 11.7D0, 10.85D0, 10.D0,  9.15D0,
31313      &      8.3D0,  7.8D0,  7.3D0,  7.25D0,  7.2D0,
31314      &     6.95D0,  6.7D0,  6.6D0,  6.5D0,   6.3D0,
31315      &      6.1D0,  5.85D0, 5.6D0,  5.35D0,  5.1D0,
31316      &      15.D0,   15.D0, 15.D0,  15.D0,   15.D0, 15.D0, 15.D0,
31317      &     14.2D0,  13.4D0, 12.6D0,
31318      &     11.8D0, 11.2D0, 10.6D0,  9.8D0,    9.D0,
31319      &     8.25D0,  7.5D0, 6.25D0,  5.D0,    4.5D0, 5*4.D0 /
31320 *
31321       END
31322 *
31323 *===damg===============================================================*
31324 *
31325 CDECK  ID>, DT_DAMG
31326       DOUBLE PRECISION FUNCTION DT_DAMG(IT)
31327
31328       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31329       SAVE
31330
31331 * particle properties (BAMJET index convention),
31332 * (dublicate of DTPART for HADRIN)
31333       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31334      &                K1H(110),K2H(110)
31335
31336       DIMENSION GASUNI(14)
31337       DATA GASUNI/
31338      *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
31339      *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
31340       DATA GAUNO/2.352D0/
31341       DATA GAUNON/2.4D0/
31342       DATA IO/14/
31343       DATA NSTAB/23/
31344
31345       I=1
31346       IF (IT.LE.0)                                              GO TO 30
31347       IF (IT.LE.NSTAB)                                          GO TO 20
31348       DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
31349       VV=DT_RNDM(DGAUNI)
31350       VV=VV*2.0D0-1.0D0+1.D-16
31351    10 CONTINUE
31352       VO=GASUNI(I)
31353       I=I+1
31354       V1=GASUNI(I)
31355       IF (VV.GT.V1)                                             GO TO 10
31356       UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
31357      &      (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
31358       DAM=GAH(IT)*UNIGA/GAUNO
31359       AAM=AMH(IT)+DAM
31360       DT_DAMG=AAM
31361       RETURN
31362    20 CONTINUE
31363       DT_DAMG=AMH(IT)
31364       RETURN
31365    30 CONTINUE
31366       DT_DAMG=0.0D0
31367       RETURN
31368       END
31369 *
31370 *===dcalum=============================================================*
31371 *
31372 CDECK  ID>, DT_DCALUM
31373       SUBROUTINE DT_DCALUM(N,ITTA)
31374
31375       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31376       SAVE
31377
31378 C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
31379
31380 * particle properties (BAMJET index convention),
31381 * (dublicate of DTPART for HADRIN)
31382       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31383      &                K1H(110),K2H(110)
31384       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
31385       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
31386       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
31387      &                NRK(2,268),NURE(30,2)
31388
31389       IRE=NURE(N,ITTA/8+1)
31390       IEO=IEII(IRE)+1
31391       IEE=IEII(IRE +1)
31392       AM1=AMH(N   )
31393       AM12=AM1**2
31394       AM2=AMH(ITTA)
31395       AM22=AM2**2
31396       DO 10 IE=IEO,IEE
31397         PLAB2=PLABF(IE)**2
31398         ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
31399         UMO(IE)=ELAB
31400    10 CONTINUE
31401       IKO=IKII(IRE)+1
31402       IKE=IKII(IRE +1)
31403       UMOO=UMO(IEO)
31404       DO 30 IK=IKO,IKE
31405         IF(NRK(2,IK).GT.0)                                      GO TO 30
31406         IKI=NRK(1,IK)
31407         AMSS=5.0D0
31408         K11=K1H(IKI)
31409         K22=K2H(IKI)
31410         DO 20 IK1=K11,K22
31411           IN=NZKI(IK1,1)
31412           AMS=AMH(IN)
31413           IN=NZKI(IK1,2)
31414           IF(IN.GT.0)AMS=AMS+AMH(IN)
31415           IN=NZKI(IK1,3)
31416           IF(IN.GT.0) AMS=AMS+AMH(IN)
31417           IF (AMS.LT.AMSS) AMSS=AMS
31418    20   CONTINUE
31419         IF(UMOO.LT.AMSS) UMOO=AMSS
31420         THRESH(IK)=UMOO
31421    30 CONTINUE
31422       RETURN
31423       END
31424 *
31425 *===dchanh=============================================================*
31426 *
31427 CDECK  ID>, DT_DCHANH
31428       SUBROUTINE DT_DCHANH
31429
31430       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31431       SAVE
31432
31433       PARAMETER ( LINP = 5 ,
31434      &            LOUT = 6 ,
31435      &            LDAT = 9 )
31436
31437 * particle properties (BAMJET index convention),
31438 * (dublicate of DTPART for HADRIN)
31439       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31440      &                K1H(110),K2H(110)
31441       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
31442       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
31443       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
31444      &                NRK(2,268),NURE(30,2)
31445
31446       DIMENSION HWT(460),HWK(40),SI(5184)
31447       EQUIVALENCE (WK(1),SI(1))
31448 C--------------------
31449 C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
31450 C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
31451 C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
31452 C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
31453 C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
31454 C--------------------------
31455       IREG=16
31456       DO 90 IRE=1,IREG
31457         IWKO=IRII(IRE)
31458         IEE=IEII(IRE+1)-IEII(IRE)
31459         IKE=IKII(IRE+1)-IKII(IRE)
31460         IEO=IEII(IRE)+1
31461         IIKA=IKII(IRE)
31462 *   modifications to suppress elestic scattering  24/07/91
31463         DO 80 IE=1,IEE
31464           SIS=1.D-14
31465           SINORC=0.0D0
31466           DO 10 IK=1,IKE
31467             IWK=IWKO+IEE*(IK-1)+IE
31468             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
31469             SIS=SIS+SI(IWK)*SINORC
31470    10     CONTINUE
31471           SIIN(IEO+IE-1)=SIS
31472           SIO=0.D0
31473           IF (SIS.GE.1.D-12)                                    GO TO 20
31474           SIS=1.D0
31475           SIO=1.D0
31476    20     CONTINUE
31477           SINORC=0.0D0
31478           DO 30 IK=1,IKE
31479             IWK=IWKO+IEE*(IK-1)+IE
31480             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
31481             SIO=SIO+SI(IWK)*SINORC/SIS
31482             HWK(IK)=SIO
31483    30     CONTINUE
31484           DO 40 IK=1,IKE
31485             IWK=IWKO+IEE*(IK-1)+IE
31486    40     WK(IWK)=HWK(IK)
31487           IIKI=IKII(IRE)
31488           DO 70 IK=1,IKE
31489             AM111=0.D0
31490             INRK1=NRK(1,IIKI+IK)
31491             IF (INRK1.GT.0) AM111=AMH(INRK1)
31492             AM222=0.D0
31493             INRK2=NRK(2,IIKI+IK)
31494             IF (INRK2.GT.0) AM222=AMH(INRK2)
31495             THRESH(IIKI+IK)=AM111 +AM222
31496             IF (INRK2-1.GE.0)                                   GO TO 60
31497             INRKK=K1H(INRK1)
31498             AMSS=5.D0
31499             INRKO=K2H(INRK1)
31500             DO 50 INRK1=INRKK,INRKO
31501               INZK1=NZKI(INRK1,1)
31502               INZK2=NZKI(INRK1,2)
31503               INZK3=NZKI(INRK1,3)
31504               IF (INZK1.LE.0.OR.INZK1.GT.110)                   GO TO 50
31505               IF (INZK2.LE.0.OR.INZK2.GT.110)                   GO TO 50
31506               IF (INZK3.LE.0.OR.INZK3.GT.110)                   GO TO 50
31507 C     WRITE (6,310)INRK1,INZK1,INZK2,INZK3
31508  1000 FORMAT (4I10)
31509               AMS=AMH(INZK1)+AMH(INZK2)
31510               IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
31511               IF (AMSS.GT.AMS) AMSS=AMS
31512    50       CONTINUE
31513             AMS=AMSS
31514             IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
31515             THRESH(IIKI+IK)=AMS
31516    60       CONTINUE
31517    70     CONTINUE
31518    80   CONTINUE
31519    90 CONTINUE
31520       DO 100 J=1,460
31521   100 HWT(J)=0.D0
31522       DO 120 I=1,110
31523         IK1=K1H(I)
31524         IK2=K2H(I)
31525         HV=0.D0
31526         IF (IK2.GT.460)IK2=460
31527         IF (IK1.LE.0)IK1=1
31528         DO 110 J=IK1,IK2
31529           HV=HV+WTI(J)
31530           HWT(J)=HV
31531           JI=J
31532   110   CONTINUE
31533         IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
31534  1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
31535   120 CONTINUE
31536       DO 130 J=1,460
31537   130 WTI(J)=HWT(J)
31538       RETURN
31539       END
31540 *
31541 *===dhadde=============================================================*
31542 *
31543 CDECK  ID>, DT_DHADDE
31544       SUBROUTINE DT_DHADDE
31545
31546       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31547       SAVE
31548
31549 * particle properties (BAMJET index convention)
31550       CHARACTER*8  ANAME
31551       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31552      &                IICH(210),IIBAR(210),K1(210),K2(210)
31553 * HADRIN: decay channel information
31554       PARAMETER (IDMAX9=602)
31555       CHARACTER*8 ZKNAME
31556       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31557 * particle properties (BAMJET index convention),
31558 * (dublicate of DTPART for HADRIN)
31559       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31560      &                K1H(110),K2H(110)
31561       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
31562 * decay channel information for HADRIN
31563       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
31564      &                K1Z(16),K2Z(16),WTZ(153),II22,
31565      &                NZK1(153),NZK2(153),NZK3(153)
31566
31567       DATA IRETUR/0/
31568
31569       IRETUR=IRETUR+1
31570       AMH(31)=0.48D0
31571       IF (IRETUR.GT.1) RETURN
31572       DO 10 I=1,94
31573         AMH(I)   = AAM(I)
31574         GAH(I)   = GA(I)
31575         TAUH(I)  = TAU(I)
31576         ICHH(I)  = IICH(I)
31577         IBARH(I) = IIBAR(I)
31578         K1H(I)   = K1(I)
31579         K2H(I)   = K2(I)
31580    10 CONTINUE
31581 **sr
31582 C     AMH(1)=0.93828D0
31583       AMH(1)=0.9383D0
31584 **
31585       AMH(2)=AMH(1)
31586       DO 20 I=26,30
31587         K1H(I)=452
31588         K2H(I)=452
31589    20 CONTINUE
31590       DO 30 I=1,307
31591         WTI(I)    = WT(I)
31592         NZKI(I,1) = NZK(I,1)
31593         NZKI(I,2) = NZK(I,2)
31594         NZKI(I,3) = NZK(I,3)
31595    30 CONTINUE
31596       DO 40 I=1,16
31597         L=I+94
31598         AMH(L)=AMZ(I)
31599         GAH( L)=GAZ(I)
31600         TAUH( L)=TAUZ(I)
31601         ICHH( L)=ICHZ(I)
31602         IBARH( L)=IBARZ(I)
31603         K1H( L)=K1Z(I)
31604         K2H( L)=K2Z(I)
31605    40 CONTINUE
31606       DO 50 I=1,153
31607         L=I+307
31608         WTI(L)    = WTZ(I)
31609         NZKI(L,3) = NZK3(I)
31610         NZKI(L,2) = NZK2(I)
31611         NZKI(L,1) = NZK1(I)
31612    50 CONTINUE
31613       RETURN
31614       END
31615 *
31616 *===iefund=============================================================*
31617 *
31618 CDECK  ID>, IDT_IEFUND
31619       INTEGER FUNCTION IDT_IEFUND(PL,IRE)
31620
31621       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31622       SAVE
31623
31624 C*****IEFUN CALCULATES A MOMENTUM INDEX
31625
31626       PARAMETER ( LINP = 5 ,
31627      &            LOUT = 6 ,
31628      &            LDAT = 9 )
31629
31630       COMMON /HNDRUN/ RUNTES,EFTES
31631       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
31632       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
31633      &                NRK(2,268),NURE(30,2)
31634
31635       IPLA=IEII(IRE)+1
31636      *+1
31637       IPLE=IEII(IRE+1)
31638       IF (PL.LT.0.)                                             GO TO 30
31639       DO 10 I=IPLA,IPLE
31640         J=I-IPLA+1
31641         IF (PL.LE.PLABF(I))                                     GO TO 60
31642    10 CONTINUE
31643       I=IPLE
31644       IF ( EFTES.GT.40.D0)                                      GO TO 20
31645       EFTES=EFTES+1.0D0
31646       WRITE(LOUT,1000)PL,J
31647    20 CONTINUE
31648                                                                 GO TO 70
31649    30 CONTINUE
31650       DO 40 I=IPLA,IPLE
31651         J=I-IPLA+1
31652         IF (-PL.LE.UMO(I))                                      GO TO 60
31653    40 CONTINUE
31654       I=IPLE
31655       IF ( EFTES.GT.40.D0)                                      GO TO 50
31656       EFTES=EFTES+1.0D0
31657       WRITE(LOUT,1000)PL,I
31658    50 CONTINUE
31659    60 CONTINUE
31660    70 CONTINUE
31661       IDT_IEFUND=I
31662       RETURN
31663  1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
31664      +7H IEFUN=,I5)
31665       END
31666 *
31667 *===dsigin=============================================================*
31668 *
31669 CDECK  ID>, DT_DSIGIN
31670       SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
31671
31672       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31673       SAVE
31674
31675 * particle properties (BAMJET index convention),
31676 * (dublicate of DTPART for HADRIN)
31677       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31678      &                K1H(110),K2H(110)
31679       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
31680       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
31681      &                NRK(2,268),NURE(30,2)
31682
31683       IE=IDT_IEFUND(PLAB,IRE)
31684       IF (IE.LE.IEII(IRE)) IE=IE+1
31685       AMT=AMH(ITAR)
31686       AMN=AMH(N)
31687       AMN2=AMN*AMN
31688       AMT2=AMT*AMT
31689       ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
31690 C*** INTERPOLATION PREPARATION
31691       ECMO=UMO(IE)
31692       ECM1=UMO(IE-1)
31693       DECM=ECMO-ECM1
31694       DEC=ECMO-ECM
31695       IIKI=IKII(IRE)+1
31696       EKLIM=-THRESH(IIKI)
31697       WOK=SIIN(IE)
31698       WDK=WOK-SIIN(IE-1)
31699       IF (ECM.GT.ECMO) WDK=0.0D0
31700 C*** INTERPOLATION IN CHANNEL WEIGHTS
31701       IELIM=IDT_IEFUND(EKLIM,IRE)
31702       DELIM=UMO(IELIM)+EKLIM
31703      *+1.D-16
31704       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
31705       IF (DELIM*DELIM-DETE*DETE) 20,20,10
31706    10 DECC=DELIM
31707                                                                 GO TO 30
31708    20 DECC=DECM
31709    30 CONTINUE
31710       WKK=WOK-WDK*DEC/(DECC+1.D-9)
31711       IF (WKK.LT.0.0D0) WKK=0.0D0
31712       SI=WKK+1.D-12
31713       IF (-EKLIM.GT.ECM) SI=1.D-14
31714       RETURN
31715       END
31716 *
31717 *===dtchoi=============================================================*
31718 *
31719 CDECK  ID>, DT_DTCHOI
31720       SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
31721
31722       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31723       SAVE
31724
31725 C     ****************************
31726 C     TCHOIC CALCULATES A RANDOM VALUE
31727 C     FOR THE FOUR-MOMENTUM-TRANSFER T
31728 C     ****************************
31729
31730 * particle properties (BAMJET index convention),
31731 * (dublicate of DTPART for HADRIN)
31732       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31733      &                K1H(110),K2H(110)
31734 * slope parameters for HADRIN interactions
31735       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
31736
31737       AMA=AM1
31738       AMB=AM2
31739       IF (I.GT.30.AND.II.GT.30)                                 GO TO 20
31740       III=II
31741       AM3=AM2
31742       IF (I.LE.30)                                              GO TO 10
31743       III=I
31744       AM3=AM1
31745    10 CONTINUE
31746                                                                 GO TO 30
31747    20 CONTINUE
31748       III=II
31749       AM3=AM2
31750       IF (AMA.LE.AMB)                                           GO TO 30
31751       III=I
31752       AM3=AM1
31753    30 CONTINUE
31754       IB=IBARH(III)
31755       AMA=AM3
31756       K=INT((AMA-0.75D0)/0.05D0)
31757       IF (K-2.LT.0) K=1
31758       IF (K-26.GE.0) K=25
31759       IF (IB)50,40,50
31760    40 BM=BBM(K)
31761                                                                 GO TO 60
31762    50 BM=BBB(K)
31763    60 CONTINUE
31764 C     NORMALIZATION
31765       TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1  **2
31766       TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1  **2
31767       VB=DT_RNDM(TMIN)
31768 **sr test
31769 C     IF (VB.LT.0.2D0) BM=BM*0.1
31770 C    **0.5
31771       BM = BM*5.05D0
31772 **
31773       TMI=BM*TMIN
31774       TMA=BM*TMAX
31775       ETMA=0.D0
31776       IF (ABS(TMA).GT.120.D0)                                   GO TO 70
31777       ETMA=EXP(TMA)
31778    70 CONTINUE
31779       AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
31780 C*** RANDOM CHOICE OF THE T - VALUE
31781       R=DT_RNDM(TMI)
31782       T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
31783       RETURN
31784       END
31785 *
31786 *===dtwopa=============================================================*
31787 *
31788 CDECK  ID>, DT_DTWOPA
31789       SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
31790      &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
31791
31792       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31793       SAVE
31794
31795 C     ******************************************************
31796 C     QUASI TWO PARTICLE PRODUCTION
31797 C     TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
31798 C     FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
31799 C     IN THE CM - SYSTEM
31800 C     COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
31801 C     SPHERICAL COORDINATES
31802 C     ******************************************************
31803
31804 * particle properties (BAMJET index convention),
31805 * (dublicate of DTPART for HADRIN)
31806       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31807      &                K1H(110),K2H(110)
31808
31809       AMA=AM1
31810       AMB=AM2
31811       AMA2=AMA*AMA
31812       E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
31813       E2=UMOO - E1
31814       IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
31815       AMTE=(E1-AMA)*(E1+AMA)
31816       AMTE=AMTE+1.D-18
31817       P1=SQRT(AMTE)
31818       P2=P1
31819 C     / P2 / = / P1 /  BUT OPPOSITE DIRECTIONS
31820 C     DETERMINATION  OF  THE ANGLES
31821 C     COS(THETA1)=COD1      COS(THETA2)=COD2
31822 C     SIN(PHI1)=SIF1        SIN(PHI2)=SIF2
31823 C     COS(PHI1)=COF1        COS(PHI2)=COF2
31824 C     PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
31825       CALL DT_DSFECF(COF1,SIF1)
31826       COF2=-COF1
31827       SIF2=-SIF1
31828 C     CALCULATION OF THETA1
31829       CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
31830       COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
31831       IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
31832       COD2=-COD1
31833       RETURN
31834       END
31835 *
31836 *===zk=================================================================*
31837 *
31838 CDECK  ID>, DT_ZK
31839       BLOCK DATA DT_ZK
31840
31841       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31842       SAVE
31843
31844 * decay channel information for HADRIN
31845       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
31846      &                K1Z(16),K2Z(16),WTZ(153),II22,
31847      &                NZK1(153),NZK2(153),NZK3(153)
31848 * decay channel information for HADRIN
31849       CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
31850       COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
31851
31852 *     Particle masses in GeV                                           *
31853       DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
31854      &          2*1.7D0, 3*0.D0/
31855 *     Resonance width Gamma in GeV                                     *
31856       DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
31857 *     Mean life time in seconds                                        *
31858       DATA TAUZ / 16*0.D0 /
31859 *     Charge of particles and resonances                               *
31860       DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
31861 *     Baryonic charge                                                  *
31862       DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
31863 *     First number of decay channels used for resonances               *
31864 *     and decaying particles                                           *
31865       DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
31866      &          3*460/
31867 *     Last number of decay channels used for resonances                *
31868 *     and decaying particles                                           *
31869       DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
31870      &          3*460/
31871 *     Weight of decay channel                                          *
31872       DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
31873      & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
31874      & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
31875      & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
31876      & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
31877      & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
31878      & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
31879      & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
31880      & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
31881      & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
31882      & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
31883      & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
31884      & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
31885      & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
31886      & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
31887      & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
31888      & .05D0, .65D0, 9*1.D0 /
31889 *     Particle numbers in decay channel                                *
31890       DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
31891      & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
31892      & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
31893      & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
31894      & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
31895      & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
31896      & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
31897      & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
31898       DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
31899      & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
31900      & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
31901      & 4*33, 32, 3*35,  2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
31902      & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
31903      & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
31904      & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
31905      & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
31906      & 1, 8, 1, 8, 1, 9*0 /
31907       DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
31908      & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
31909      & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
31910      & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
31911      & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
31912      & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
31913 *     Particle  names                                                  *
31914       DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS  ',' PAP  ',' PAN  ',
31915      & 'APN', 'DEO   ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
31916      & 3*'BLANK' /
31917 *     Name of decay channel                                            *
31918       DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
31919      & 'ANNPI0','APPPI0','ANPPI-'/
31920       DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K-  ','K0AK0 ',
31921      & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET  ','&0R0  ','P-R+  ',
31922      & 'P+R-  ','POOM  ',' ETET ','ETSP0 ','R0ET  ',' R0R0 ','R+R-  ',
31923      & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
31924      & 'P+R-R0','R0OM  ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
31925      & 'P+R-OM','OMOM  ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
31926      & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
31927      & 'OMOMOM',
31928      & ' P+PO ','P+POPO','P+P+P-','P+ET  ','P0R+  ','P+R0  ','ETSP+ ',
31929      & 'R+ET  ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
31930      & 'P+R-R+','R+OM  ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
31931      & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
31932      & 'P-PO  ','P-POPO','P-P-P+','P-ET  ','POR-  ','P-R0  ','ETSP- ',
31933      & 'R-ET  ','R-R0  ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
31934       DATA ZKNAM6/'P+R-R-','R-OM  ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
31935      & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
31936      & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO  ','LPI+  ',
31937      & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
31938      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
31939      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
31940      & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
31941      & 9*'BLANK'/
31942 *=                                               end*block.zk      *
31943       END
31944 *
31945 *===blkd43=============================================================*
31946 *
31947 CDECK  ID>, DT_BLKD43
31948       BLOCK DATA DT_BLKD43
31949
31950       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31951       SAVE
31952
31953 *$ CREATE REAC.ADD
31954 *COPY REAC
31955 *
31956 *=== reac =============================================================*
31957 *
31958 *----------------------------------------------------------------------*
31959 *                                                                      *
31960 *     Created on 10 december 1991  by    Alfredo Ferrari & Paola Sala  *
31961 *                                                   Infn - Milan       *
31962 *                                                                      *
31963 *     Last change on 10-dec-91     by    Alfredo Ferrari               *
31964 *                                                                      *
31965 *     This is the original common reac of Hadrin                       *
31966 *                                                                      *
31967 *----------------------------------------------------------------------*
31968 *
31969       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
31970      &                NRK(2,268),NURE(30,2)
31971
31972       DIMENSION
31973      & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
31974      & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
31975      & SPIKP1(315), SPIKPU(278), SPIKPV(372),
31976      & SPIKPW(278), SPIKPX(372), SPIKP4(315),
31977      & SPIKP5(187), SPIKP6(289),
31978      & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
31979      & SPIKP9(143), SPIKP0(169), SPKPV(143),
31980      & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
31981      & SANPEL(84) , SPIKPF(273),
31982      & SPKP15(187), SPKP16(272),
31983      & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
31984      & NURELN(60)
31985 *
31986        DIMENSION NRKLIN(532)
31987        EQUIVALENCE (NRK(1,1), NRKLIN(1))
31988        EQUIVALENCE (   UMO(  1),  UMOPI(1)), (   UMO( 93),  UMOKC(1))
31989        EQUIVALENCE (   UMO(161),   UMOP(1)), (   UMO(200),   UMON(1))
31990        EQUIVALENCE (   UMO(263),  UMOK0(1))
31991        EQUIVALENCE ( PLABF(  1),  PLAPI(1)), ( PLABF( 93),  PLAKC(1))
31992        EQUIVALENCE ( PLABF(161),   PLAP(1)), ( PLABF(200),   PLAN(1))
31993        EQUIVALENCE ( PLABF(263),  PLAK0(1))
31994        EQUIVALENCE (   WK(   1), SPIKP1(1)), (   WK( 316), SPIKPU(1))
31995        EQUIVALENCE (   WK( 594), SPIKPV(1)), (   WK( 966), SPIKPW(1))
31996        EQUIVALENCE (   WK(1244), SPIKPX(1)), (   WK(1616), SPIKP4(1))
31997        EQUIVALENCE (   WK(1931), SPIKP5(1)), (   WK(2118), SPIKP6(1))
31998        EQUIVALENCE (   WK(2407), SKMPEL(1)), (   WK(2509), SPIKP7(1))
31999        EQUIVALENCE (   WK(2798), SKMNEL(1)), (   WK(2866), SPIKP8(1))
32000        EQUIVALENCE (   WK(3053), SPIKP9(1)), (   WK(3196), SPIKP0(1))
32001        EQUIVALENCE (   WK(3365),  SPKPV(1)), (   WK(3508), SAPPEL(1))
32002        EQUIVALENCE (   WK(3613), SPIKPE(1)), (   WK(4012), SAPNEL(1))
32003        EQUIVALENCE (   WK(4096), SPIKPZ(1)), (   WK(4369), SANPEL(1))
32004        EQUIVALENCE (   WK(4453), SPIKPF(1)), (   WK(4726), SPKP15(1))
32005        EQUIVALENCE (   WK(4913), SPKP16(1))
32006        EQUIVALENCE (NRK(1,1), NRKLIN(1))
32007        EQUIVALENCE (NRKLIN(   1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
32008        EQUIVALENCE (NRKLIN( 297),  NRKP(1)), (NRKLIN( 367),  NRKN(1))
32009        EQUIVALENCE (NRKLIN( 483), NRKK0(1))
32010        EQUIVALENCE (NURE(1,1), NURELN(1))
32011 *
32012 **** pi- p data                                                        *
32013 **** pi+ n data                                                        *
32014       DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
32015      & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
32016      & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
32017      & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
32018      & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
32019      & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
32020      & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
32021      & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
32022      & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
32023      & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
32024       DATA PLAKC /
32025      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
32026      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
32027      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
32028      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
32029      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
32030      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
32031      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
32032      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
32033      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
32034      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
32035      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
32036      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
32037       DATA PLAK0 /
32038      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
32039      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
32040      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
32041      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
32042      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
32043      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
32044 *                 pp   pn   np   nn                                    *
32045       DATA PLAP /
32046      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
32047      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
32048      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
32049      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
32050      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
32051      & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
32052 *    app   apn   anp   ann                                             *
32053       DATA PLAN /
32054      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
32055      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
32056      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
32057      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
32058      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
32059      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
32060      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
32061      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
32062      & 3.43D0, 3.75D0, 4.07D0, 4.43D0  /
32063       DATA SIIN / 296*0.D0 /
32064       DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
32065      & 1.557D0,1.615D0,1.6435D0,
32066      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
32067      & 2.286D0,2.366D0,2.482D0,2.56D0,
32068      & 2.735D0,2.90D0,
32069      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
32070      & 1.496D0,1.527D0,1.557D0,
32071      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
32072      & 2.071D0,2.159D0,2.286D0,2.366D0,
32073      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
32074      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
32075      & 1.496D0,1.527D0,1.557D0,
32076      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
32077      & 2.071D0,2.159D0,2.286D0,2.366D0,
32078      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
32079      &                   1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
32080      & 1.557D0,1.615D0,1.6435D0,
32081      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
32082      & 2.286D0,2.366D0,2.482D0,2.56D0,
32083      &  2.735D0, 2.90D0/
32084       DATA UMOKC/ 1.44D0,
32085      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
32086      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
32087      & 3.1D0,1.44D0,
32088      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
32089      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
32090      & 3.1D0,1.44D0,
32091      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
32092      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
32093      & 3.1D0,1.44D0,
32094      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
32095      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
32096      &  3.1D0/
32097       DATA UMOK0/ 1.44D0,
32098      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
32099      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
32100      & 3.1D0,1.44D0,
32101      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
32102      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
32103      &  3.1D0/
32104 *                 pp   pn   np   nn                                    *
32105       DATA UMOP/
32106      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
32107      & 3.D0,3.1D0,3.2D0,
32108      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
32109      & 3.D0,3.1D0,3.2D0,
32110      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
32111      & 3.D0,3.1D0,3.2D0/
32112 *    app   apn   anp   ann                                             *
32113       DATA UMON /
32114      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
32115      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
32116      & 3.D0,3.1D0,3.2D0,
32117      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
32118      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
32119      & 3.D0,3.1D0,3.2D0,
32120      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
32121      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
32122      &  3.D0,3.1D0,3.2D0/
32123 **** reaction channel state particles                                  *
32124       DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
32125      & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
32126      & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
32127      & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
32128      & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
32129      & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
32130      & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
32131      & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
32132      & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
32133      & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
32134       DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
32135      & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
32136      & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
32137      & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
32138      & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
32139      & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
32140      & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
32141      & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
32142 *                                                                      *
32143 *   k0 p   k0 n   ak0 p   ak/ n                                        *
32144 *                                                                      *
32145       DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
32146      & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13,   22, 13, 21, 23,
32147      & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
32148      & 53, 47, 1, 103, 0, 93, 0/
32149 *   pp  pn   np   nn                                                   *
32150       DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
32151      & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
32152      & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
32153      & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
32154 *     app   apn   anp   ann                                            *
32155       DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
32156      & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
32157      & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
32158      & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
32159      & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
32160      & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
32161      & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
32162 **** channel cross section                                             *
32163       DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
32164      & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
32165      & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
32166      & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
32167      & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
32168      &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
32169      & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
32170      & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
32171      &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
32172      & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
32173      & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
32174      & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
32175      & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
32176      & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
32177      & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
32178      & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
32179      & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
32180      & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
32181      & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
32182      & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
32183 **** pi+ n data                                                        *
32184       DATA SPIKPU/   0.D0, 25.D0, 13.D0,  11.D0, 10.5D0, 14.D0,  20.D0,
32185      & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
32186      & 10.D0, 10.D0, 9.5D0,  9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
32187      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0,   5.5D0,  4.8D0,
32188      & 4.2D0, 7.5D0, 3.4D0,  2.5D0, 2.5D0, 2.1D0, 1.4D0,   1.D0,   .8D0,
32189      &  .6D0, .46D0,  .3D0, .2D0, .15D0, .13D0, 11*0.D0,  .95D0,  .65D0,
32190      & .48D0, .35D0,  .2D0, .18D0, .17D0, .16D0,  .15D0,   .1D0,  .09D0,
32191      & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0,  .2D0,   .1D0,
32192      & .08D0, .06D0, .045D0,   .03D0, .02D0, .01D0,      .005D0, .003D0,
32193      & 12*0.D0, .3D0, .24D0,   .18D0, .15D0, .13D0,  .12D0, .11D0, .1D0,
32194      & .09D0,  .08D0, .05D0,   .04D0, .03D0,  0.D0, 0.16D0, .7D0, 1.3D0,
32195      & 3.1D0,  4.5D0,  2.D0, 18*0.D0, 3*.0D0,  0.D0, 0.D0, 4.0D0, 11.D0,
32196      & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0,  1.5D0, .9D0, .55D0,
32197      &  .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0,   2.25D0, 3.3D0,
32198      & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
32199      & .64D0,  1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0,  4.4D0,   3.D0, 1.8D0,
32200      &  .9D0, .53D0, .28D0,      10*0.D0, 2*0.D0,  .25D0,  .82D0,
32201      & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0,  5.7D0, 3.9D0, 2.35D0, 1.15D0,
32202      & .69D0, .37D0, 10*0.D0,     7*0.D0,   .0D0, .34D0,  1.5D0, 3.47D0,
32203      & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0,  .3D0,  .15D0, 6*0.D0/
32204 *
32205       DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
32206      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
32207      & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
32208      & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
32209      & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
32210      & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
32211      & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
32212      & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
32213      & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
32214      & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
32215      & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
32216      & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
32217      & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
32218      & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
32219      & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
32220      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
32221      & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
32222      & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
32223      & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
32224      & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
32225 **** pi- p data                                                        *
32226       DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
32227      & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
32228      & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
32229      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
32230      & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
32231      & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
32232      & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
32233      & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
32234      & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
32235      & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
32236      & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
32237      & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
32238      & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
32239      & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
32240      & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
32241      & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
32242      & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
32243      & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
32244      & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
32245 *
32246       DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
32247      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
32248      & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
32249      & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
32250      & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
32251      & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
32252      & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
32253      & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
32254      & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
32255      & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
32256      & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
32257      & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
32258      & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
32259      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
32260      & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
32261      & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
32262      & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
32263      & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
32264      & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
32265      & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
32266 **** pi- n data                                                        *
32267       DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
32268      & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
32269      & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
32270      & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
32271      & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
32272      & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
32273      & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
32274      & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
32275      & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
32276      & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
32277      & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
32278      & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
32279      & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
32280      & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
32281      & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
32282      & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
32283      & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
32284      & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
32285      & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
32286      & 3.3D0, 5.4D0, 7.D0 /
32287 **** k+  p data                                                        *
32288       DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
32289      & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
32290      & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
32291      & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
32292      & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
32293      & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
32294      & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
32295      & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
32296      & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
32297      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
32298      & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
32299      & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
32300      & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
32301 **** k+  n data                                                        *
32302       DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
32303      & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
32304      & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
32305      & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
32306      & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
32307      & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
32308      & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
32309      & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
32310      & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
32311      & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
32312      & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
32313      & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
32314      & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
32315      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
32316      & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
32317      & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
32318      & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
32319      & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
32320      & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
32321 **** k-  p data                                                        *
32322       DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
32323      &     7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
32324      &    0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
32325      &    .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
32326      &    0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
32327      &    .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
32328      &    0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
32329      &    .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
32330      &    0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
32331      &    .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
32332      &    0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
32333      &    .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
32334       DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
32335      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
32336      & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
32337      & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
32338      & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,  3*0.D0, 1.0D0, 3.03D0,
32339      & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
32340      & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
32341      & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
32342      & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
32343      & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
32344      & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
32345      & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
32346      & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
32347      & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
32348      & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
32349      & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
32350      & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
32351      & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
32352      & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
32353      & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
32354      & 10*0.D0/
32355 ***** k- n data                                                        *
32356       DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
32357      &        3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
32358      &        0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
32359      &        1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
32360      &        0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
32361      &        .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
32362      &        0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
32363      &       .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
32364       DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
32365      &  14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
32366      &  1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
32367      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
32368      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
32369      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
32370      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
32371      &  7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
32372      &  .39D0, .22D0, .07D0, 0.D0,
32373      &  6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
32374      &  4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
32375      &  10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
32376      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
32377      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
32378      &  9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
32379      &  5.10D0, 5.44D0, 5.3D0,
32380      &  4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
32381 *****  p p data                                                        *
32382       DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
32383      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
32384      &              0.D0, 3.6D0, 1.7D0, 10*0.D0,
32385      &              .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
32386      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
32387      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
32388      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
32389      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
32390      &              16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
32391      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
32392      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
32393      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
32394      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
32395      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
32396      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
32397 *****  p n data                                                        *
32398       DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
32399      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
32400      &              0.D0, 1.8D0, .2D0,  12*0.D0,
32401      &              3.2D0, 6.05D0, 9.9D0, 5.1D0,
32402      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
32403      &              2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
32404      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
32405      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
32406      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
32407      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
32408      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
32409      &              10*0.D0, .7D0, 5.1D0, 8.D0,
32410      &              10*0.D0, .7D0, 5.1D0, 8.D0,
32411      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
32412      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
32413      &              7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
32414      &              7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
32415      &              5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
32416 *   nn - data                                                          *
32417 *                                                                      *
32418       DATA SPKPV/  0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
32419      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
32420      &              0.D0, 3.6D0, 1.7D0, 12*0.D0,
32421      &              8.7D0, 17.7D0, 18.8D0, 15.9D0,
32422      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
32423      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
32424      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
32425      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
32426      &              11.D0, 5.5D0, 3.5D0,
32427      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
32428      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
32429      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
32430      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
32431      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
32432      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
32433 ****************   ap - p - data                                       *
32434       DATA SAPPEL/ 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
32435      &  50.D0,  50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
32436      &  25.D0,  22.D0, 21.D0, 20.D0, 18.D0, 17.D0,  11*0.D0,
32437      &  .05D0,  .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
32438      &  0.D0,  1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
32439      &  .1D0,  .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
32440      &  0.D0,  55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
32441      &  10.D0,  7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
32442      &  1.55D0,  1.3D0, .95D0, .75D0,
32443      &  0.D0,  3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
32444      &  .25D0,  .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
32445      & .01D0,  .008D0, .006D0, .005D0/
32446       DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
32447      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
32448      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
32449      & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
32450      & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
32451      & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
32452      & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
32453      & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
32454      & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
32455      & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
32456      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
32457      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
32458      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
32459      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
32460      & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
32461      & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
32462      & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
32463      & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
32464      & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
32465      & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
32466 ****************   ap - n - data                                       *
32467       DATA SAPNEL/
32468      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0,  68.D0, 65.D0,
32469      & 50.D0, 50.D0,  43.D0,  42.D0,  40.5D0, 35.D0, 30.D0,  28.D0,
32470      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0,  17.D0, 11*0.D0,
32471      & .05D0, .15D0, .18D0,  .2D0,    .2D0,  .3D0,  .4D0,   .6D0,  .7D0,
32472      & .85D0,  0.D0,  1.D0,  .9D0,    .46D0, .3D0,  .23D0, .18D0, .16D0,
32473      & .14D0,  .1D0, .08D0, .05D0,    .02D0, .015D0, 4*.011D0, 3*.005D0,
32474      & 0.D0,  3.3D0,  3.D0, 1.5D0,     1.D0, .7D0,  .4D0,  .35D0, .4D0,
32475      & .25D0, .18D0, .08D0, .04D0,    .03D0, .023D0, .016D0, .014D0,
32476      & .01D0, .008D0, .006D0, .005D0 /
32477        DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
32478      &  84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
32479      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
32480      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
32481      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
32482      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
32483      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
32484      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
32485      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
32486      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
32487      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
32488      & 4.9D0, 8.5D0,  15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
32489      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
32490      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
32491 *                                                                      *
32492 *                                                                      *
32493 ****************   an - p - data                                       *
32494 *                                                                      *
32495       DATA SANPEL/
32496      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
32497      & 50.D0, 43.D0,  42.D0,  40.5D0, 35.D0, 30.D0, 28.D0,
32498      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0, 17.D0, 11*0.D0, .05D0,
32499      & .15D0, .18D0,   .2D0,   .2D0,   .3D0,  .4D0, .6D0,   .7D0, .85D0,
32500      & 0.D0,   1.D0,   .9D0,  .46D0,  .3D0,  .23D0, .18D0, .16D0, .14D0,
32501      & .1D0,  .08D0,  .05D0,  .02D0, .015D0, 4*.011D0, 3*.005D0,
32502      & 0.D0,  3.3D0,  3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
32503      & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
32504      & .01D0, .008D0, .006D0, .005D0 /
32505       DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
32506      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
32507      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
32508      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
32509      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
32510      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
32511      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
32512      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
32513      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
32514      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
32515      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
32516      & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
32517      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
32518      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
32519 ****  ko - n - data                                                    *
32520       DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
32521      &      6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
32522      &      0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
32523      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
32524      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
32525      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
32526      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
32527      &    4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
32528      &     1.4D0, 1.2D0, 1.05D0, .9D0, .66D0,  .5D0,
32529      &    7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
32530      &   11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
32531      &    4.85D0, 4.9D0,
32532      &   10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
32533      &    6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
32534      &    2.85D0, 2.35D0, 2.01D0, 1.8D0,
32535      &   12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
32536      &   12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0  /
32537 **** ako - p - data                                                    *
32538       DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
32539      & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
32540      & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
32541      & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
32542      & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
32543      & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
32544      & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
32545      & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
32546      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
32547      & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
32548      & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
32549      & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
32550      & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
32551      & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
32552      & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
32553      & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
32554      & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
32555      & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
32556      & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
32557      & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
32558      & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
32559       DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
32560      & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
32561 *=                                               end*block.blkdt3      *
32562       END
32563 *
32564 *===qel_pol============================================================*
32565 *
32566 CDECK  ID>, DT_QEL_POL
32567       SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
32568
32569       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32570       SAVE
32571
32572       CALL DT_MASS_INI
32573       CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
32574
32575       RETURN
32576       END
32577
32578 C==================================================================
32579 C   Generation of  a Quasi-Elastic neutrino scattering
32580 C==================================================================
32581 *
32582 *===gen_qel============================================================*
32583 *
32584 CDECK  ID>, DT_GEN_QEL
32585       SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
32586
32587 C...Generate a quasi-elastic   neutrino/antineutrino
32588 C.  Interaction on a nuclear target
32589 C.  INPUT  : LTYP = neutrino type (1,...,6)
32590 C.           ENU (GeV) = neutrino energy
32591 C----------------------------------------------------
32592
32593       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32594       SAVE
32595
32596       PARAMETER ( LINP = 5 ,
32597      &            LOUT = 6 ,
32598      &            LDAT = 9 )
32599
32600       PARAMETER (MAXLND=4000)
32601       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
32602
32603 * nuclear potential
32604       LOGICAL LFERMI
32605       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
32606      &                EBINDP(2),EBINDN(2),EPOT(2,210),
32607      &                ETACOU(2),ICOUL,LFERMI
32608 * steering flags for qel neutrino scattering modules
32609       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
32610 **sr - removed (not needed)
32611 C     COMMON /CBAD/  LBAD, NBAD
32612 C     COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
32613 **
32614
32615       DIMENSION PI(3),PO(3)
32616 CJR+
32617       DATA ININU/0/
32618 CJR-
32619 C     REAL*8 DBETA(3)
32620 C     REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
32621       DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
32622       DATA AMN  /0.93827231D0, 0.93956563D0/
32623       DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
32624       DATA INIPRI/0/
32625
32626 C     DATA PFERMI/0.22D0/
32627 CGB+...Binding Energy
32628       DATA EBIND/0.008D0/
32629 CGB-...
32630
32631       ININU=ININU+1
32632       IF(ININU.EQ.1)NDSIG=0
32633       LBAD = 0
32634       enu0=enu
32635 c      write(*,*) enu0
32636 C...Lepton mass
32637       AML = AML0(LTYP)       !  massa leptoni
32638       AML2 = AML**2          !  massa leptoni **2
32639 C...Particle labels (LUND)
32640       N = 5
32641       K(1,1) = 21
32642       K(2,1) = 21
32643       K(3,1) = 21
32644       K(3,3) = 1
32645       K(4,1) = 1
32646       K(4,3) = 1
32647       K(5,1) = 1
32648       K(5,3) = 2
32649       K0 = (LTYP-1)/2          !  2
32650       K1 = LTYP/2              !  2
32651       KA = 12 + 2*K0           !  16
32652       IS = -1 + 2*LTYP - 4*K1  !  -1 +10 -8 = 1
32653       K(1,2) = IS*KA
32654       K(4,2) = IS*(KA-1)
32655       K(3,2) = IS*24
32656       LNU = 2 - LTYP + 2*K1    !  2 - 5 + 2 = - 1
32657       IF (LNU .EQ. 2)  THEN
32658         K(2,2) = 2212
32659         K(5,2) = 2112
32660         AMI = AMN(1)
32661         AMF = AMN(2)
32662 CJR+
32663         PFERMI=PFERMN(2)
32664 CJR-
32665       ELSE
32666         K(2,2) = 2112
32667         K(5,2) = 2212
32668         AMI = AMN(2)
32669         AMF = AMN(1)
32670 CJR+
32671         PFERMI=PFERMP(2)
32672 CJR-
32673       ENDIF
32674       AMI2 = AMI**2
32675       AMF2 = AMF**2
32676
32677       DO IGB=1,5
32678         P(3,IGB) = 0.
32679         P(4,IGB) = 0.
32680         P(5,IGB) = 0.
32681       END DO
32682
32683       NTRY = 0
32684 CGB+...
32685       EFMAX  = SQRT(PFERMI**2 + AMI2) -AMI             ! max. Fermi Energy
32686       ENWELL = EFMAX + EBIND ! depth of nuclear potential well
32687 CGB-...
32688
32689   100 CONTINUE
32690
32691 C...4-momentum initial lepton
32692       P(1,5) = 0.     ! massa
32693       P(1,4) = ENU0    ! energia
32694       P(1,1) = 0.     ! px
32695       P(1,2) = 0.     ! py
32696       P(1,3) = ENU0    ! pz
32697
32698 C     PF = PFERMI*PYR(0)**(1./3.)
32699 c       write(23,*) PYR(0)
32700 c      write(*,*) 'Pfermi=',PF
32701 c      PF = 0.
32702       NTRY=NTRY+1
32703 C     IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
32704       IF (NTRY .GT. 500)  THEN
32705         LBAD = 1
32706         WRITE (LOUT,1001)  NBAD, ENU
32707         RETURN
32708       ENDIF
32709 C     CT = -1. + 2.*PYR(0)
32710 c      CT = -1.
32711 C     ST =  SQRT(1.-CT*CT)
32712 C     F = 2.*3.1415926*PYR(0)
32713 c      F = 0.
32714
32715 C     P(2,4) = SQRT(PF*PF + MI2) - EBIND  ! energia
32716 C     P(2,1) = PF*ST*COS(F)               ! px
32717 C     P(2,2) = PF*ST*SIN(F)               ! py
32718 C     P(2,3) = PF*CT                      ! pz
32719 C     P(2,5) = SQRT(P(2,4)**2-PF*PF)      ! massa
32720        P(2,1) = P21
32721        P(2,2) = P22
32722        P(2,3) = P23
32723        P(2,4) = P24
32724        P(2,5) = P25
32725       beta1=-p(2,1)/p(2,4)
32726       beta2=-p(2,2)/p(2,4)
32727       beta3=-p(2,3)/p(2,4)
32728       N=2
32729 C      WRITE(6,*)' before transforming into target rest frame'
32730
32731       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
32732
32733 C      print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
32734       N=5
32735
32736       phi11=atan(p(1,2)/p(1,3))
32737       pi(1)=p(1,1)
32738       pi(2)=p(1,2)
32739       pi(3)=p(1,3)
32740
32741       CALL DT_TESTROT(PI,Po,PHI11,1)
32742       DO ll=1,3
32743         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
32744       END DO
32745 c        WRITE(*,*) po
32746       p(1,1)=po(1)
32747       p(1,2)=po(2)
32748       p(1,3)=po(3)
32749       phi12=atan(p(1,1)/p(1,3))
32750
32751       pi(1)=p(1,1)
32752       pi(2)=p(1,2)
32753       pi(3)=p(1,3)
32754       CALL DT_TESTROT(Pi,Po,PHI12,2)
32755       DO ll=1,3
32756         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
32757       END DO
32758 c        WRITE(*,*) po
32759       p(1,1)=po(1)
32760       p(1,2)=po(2)
32761       p(1,3)=po(3)
32762
32763       enu=p(1,4)
32764
32765 C...Kinematical limits in Q**2
32766 c      S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) !            ????
32767       S = P(2,5)**2 + 2.*ENU*P(2,5)
32768       SQS = SQRT(S)                          ! E centro massa
32769       IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
32770       ELF = (S-AMF2+AML2)/(2.*SQS)           ! energia leptone finale p
32771       PSTAR = (S-P(2,5)**2)/(2.*SQS)       ! p* neutrino nel c.m.
32772       PLF = SQRT(ELF**2-AML2)               ! 3-momento leptone finale
32773       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)    ! + o -
32774       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)    ! according con cos(theta)
32775       IF (Q2MIN .LT. 0.)   Q2MIN = 0.      ! ??? non fisico
32776
32777 C...Generate Q**2
32778       DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
32779   200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
32780       DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
32781       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
32782       CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
32783       NDSIG=NDSIG+1
32784 C     WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
32785 C    &Q2,Q2min,Q2MAX,DSIGEV
32786
32787 C...c.m. frame. Neutrino along z axis
32788       DETOT = (P(1,4)) + (P(2,4)) ! e totale
32789       DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
32790       DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
32791       DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
32792 c      WRITE(*,*)
32793 c      WRITE(*,*)
32794 C      WRITE(*,*) 'Input values laboratory frame'
32795       N=2
32796
32797       CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
32798
32799       N=5
32800 c      STHETA = ULANGL(P(1,3),P(1,1))
32801 c      write(*,*) 'stheta' ,stheta
32802 c      stheta=0.
32803 c      CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
32804 c      WRITE(*,*)
32805 c      WRITE(*,*)
32806 C      WRITE(*,*) 'Output values cm frame'
32807 C...Kinematic in c.m. frame
32808       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
32809       STSTAR = SQRT(1.-CTSTAR**2)
32810       PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
32811       P(4,5) = AML                  ! massa leptone
32812       P(4,4) = ELF                 ! e leptone
32813       P(4,3) = PLF*CTSTAR          ! px
32814       P(4,1) = PLF*STSTAR*COS(PHI) ! py
32815       P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
32816
32817       P(5,5) = AMF                  ! barione
32818       P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
32819       P(5,3) = -P(4,3)             ! px
32820       P(5,1) = -P(4,1)             ! py
32821       P(5,2) = -P(4,2)             ! pz
32822
32823       P(3,5) = -Q2
32824       P(3,1) = P(1,1)-P(4,1)
32825       P(3,2) = P(1,2)-P(4,2)
32826       P(3,3) = P(1,3)-P(4,3)
32827       P(3,4) = P(1,4)-P(4,4)
32828
32829 C...Transform back to laboratory  frame
32830 C      WRITE(*,*) 'before going back to nucl rest frame'
32831 c      CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
32832       N=5
32833
32834       CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
32835
32836 C      WRITE(*,*) 'Now back in nucl rest frame'
32837       IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
32838
32839 c********************************************
32840
32841       DO kw=1,5
32842         pi(1)=p(kw,1)
32843         pi(2)=p(kw,2)
32844         pi(3)=p(kw,3)
32845         CALL DT_TESTROT(Pi,Po,PHI12,3)
32846         DO ll=1,3
32847           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
32848         END DO
32849         p(kw,1)=po(1)
32850         p(kw,2)=po(2)
32851         p(kw,3)=po(3)
32852       END DO
32853 c********************************************
32854
32855       DO kw=1,5
32856         pi(1)=p(kw,1)
32857         pi(2)=p(kw,2)
32858         pi(3)=p(kw,3)
32859         CALL DT_TESTROT(Pi,Po,PHI11,4)
32860         DO ll=1,3
32861           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
32862         END DO
32863         p(kw,1)=po(1)
32864         p(kw,2)=po(2)
32865         p(kw,3)=po(3)
32866       END DO
32867
32868 c********************************************
32869
32870 C      WRITE(*,*) 'Now back in lab frame'
32871
32872       CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
32873
32874 CGB+...
32875 C...test (on final momentum of nucleon) if Fermi-blocking
32876 C...is operating
32877       ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
32878      &  - P(5,5)
32879       IF (ENUCL.LT. EFMAX) THEN
32880         IF(INIPRI.LT.10)THEN
32881           INIPRI=INIPRI+1
32882 C         WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
32883 C...the interaction is not possible due to Pauli-Blocking and
32884 C...it must be resampled
32885         ENDIF
32886         GOTO 100
32887       ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
32888         IF(INIPRI.LT.10)THEN
32889           INIPRI=INIPRI+1
32890 C     WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
32891         ENDIF
32892 C                      Reject (J:R) here all these events
32893 C                      are otherwise rejected in dpmjet
32894         GOTO 100
32895 C...the interaction is possible, but the nucleon remains inside
32896 C...the nucleus. The nucleus is therefore left excited.
32897 C...We treat this case as a nucleon with 0 kinetic energy.
32898 C       P(5,5) = AMF
32899 C       P(5,4) = AMF
32900 C       P(5,1) = 0.
32901 C       P(5,2) = 0.
32902 C       P(5,3) = 0.
32903       ELSE IF (ENUCL.GE.ENWELL) THEN
32904 C     WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
32905 C...the interaction is possible, the nucleon can exit the nucleus
32906 C...but the nuclear well depth must be subtracted. The nucleus could be
32907 C...left in an excited state.
32908         Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
32909 C       P(5,4) = ENUCL-ENWELL + AMF
32910         Pnucl = SQRT(P(5,4)**2-AMF**2)
32911 C...The 3-momentum is scaled assuming that the direction remains
32912 C...unaffected
32913         P(5,1) = P(5,1) * Pnucl/Pstart
32914         P(5,2) = P(5,2) * Pnucl/Pstart
32915         P(5,3) = P(5,3) * Pnucl/Pstart
32916 C     WRITE(6,*)' qel new P(5,4) ',P(5,4)
32917       ENDIF
32918 CGB-...
32919       DSIGSU=DSIGSU+DSIGEV
32920
32921          GA=P(4,4)/P(4,5)
32922          BGX=P(4,1)/P(4,5)
32923          BGY=P(4,2)/P(4,5)
32924          BGZ=P(4,3)/P(4,5)
32925 *
32926          DBETB(1)=BGX/GA
32927          DBETB(2)=BGY/GA
32928          DBETB(3)=BGZ/GA
32929          IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
32930
32931             CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
32932
32933          ENDIF
32934 c
32935 C      PRINT*,' FINE   EVENTO '
32936       enu=enu0
32937       RETURN
32938
32939  1001 FORMAT(2X, 'DT_GEN_QEL   : event rejected ', I5,  G10.3)
32940       END
32941
32942 C====================================================================
32943 C.  Masses
32944 C====================================================================
32945
32946 *
32947 *===mass_ini===========================================================*
32948 *
32949 CDECK  ID>, DT_MASS_INI
32950       SUBROUTINE DT_MASS_INI
32951 C...Initialize  the kinematics for the quasi-elastic cross section
32952
32953       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32954       SAVE
32955
32956 * particle masses used in qel neutrino scattering modules
32957       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
32958      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
32959      &                EMPROTSQ,EMNEUTSQ,EMNSQ
32960
32961       EML(1) = 0.51100D-03   ! e-
32962       EML(2) = EML(1)        ! e+
32963       EML(3) = 0.105659D0      ! mu-
32964       EML(4) = EML(3)        ! mu+
32965       EML(5) = 1.7777D0        ! tau-
32966       EML(6) = EML(5)        ! tau+
32967       EMPROT = 0.93827231D0    ! p
32968       EMNEUT = 0.93956563D0    ! n
32969       EMPROTSQ = EMPROT**2
32970       EMNEUTSQ = EMNEUT**2
32971       EMN = (EMPROT + EMNEUT)/2.
32972       EMNSQ = EMN**2
32973       DO J=1,3
32974         J0 = 2*(J-1)
32975         EMN1(J0+1) = EMNEUT
32976         EMN1(J0+2) = EMPROT
32977         EMN2(J0+1) = EMPROT
32978         EMN2(J0+2) = EMNEUT
32979       ENDDO
32980       DO J=1,6
32981         EMLSQ(J) = EML(J)**2
32982         ETQE(J)  = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
32983       ENDDO
32984       RETURN
32985       END
32986 *
32987 *===dsqel_q2===========================================================*
32988 *
32989 CDECK  ID>, DT_DSQEL_Q2
32990       DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
32991
32992 C...differential cross section for  Quasi-Elastic scattering
32993 C.       nu + N -> l + N'
32994 C.  From Llewellin Smith  Phys.Rep.  3C, 261, (1971).
32995 C.
32996 C.  INPUT :  JTYP = 1,...,6    nu_e, ...., nubar_tau
32997 C.           ENU (GeV) =  Neutrino energy
32998 C.           Q2  (GeV**2) =  (Transfer momentum)**2
32999 C.
33000 C.  OUTPUT : DSQEL_Q2  = differential  cross section :
33001 C.                       dsigma/dq**2  (10**-38 cm+2/GeV**2)
33002 C------------------------------------------------------------------
33003
33004       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33005       SAVE
33006
33007 * particle masses used in qel neutrino scattering modules
33008       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
33009      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
33010      &                EMPROTSQ,EMNEUTSQ,EMNSQ
33011 **sr - removed (not needed)
33012 C     COMMON /CAXIAL/ FA0, AXIAL2
33013 **
33014
33015       DIMENSION SS(6)
33016       DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
33017       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
33018       DATA AXIAL2 /1.03D0/  ! to be checked
33019
33020       FA0=-1.253D0
33021       CSI = 3.71D0                   !  ???
33022       GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2   ! G_e(q**2)
33023       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
33024       X = Q2/(EMN*EMN)     ! emn=massa barione
33025       XA = X/4.D0
33026       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
33027       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
33028       FA = FA0/(1.D0 + Q2/AXIAL2)**2
33029       FFA = FA*FA
33030       FFV1 = FV1*FV1
33031       FFV2 = FV2*FV2
33032       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
33033       A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
33034       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
33035       AA = (XA+0.25D0*RM)*(A1 + A2)
33036       BB = -X*FA*(FV1 + FV2)
33037       CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
33038       SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
33039       DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU)  !
33040       IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
33041
33042       RETURN
33043       END
33044 *
33045 *===prepola============================================================*
33046 *
33047 CDECK  ID>, DT_PREPOLA
33048       SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
33049
33050       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33051       SAVE
33052 c
33053 c By G. Battistoni and E. Scapparone (sept. 1997)
33054 c According to:
33055 c     Albright & Jarlskog, Nucl Phys B84 (1975) 467
33056 c
33057 c
33058
33059       PARAMETER (MAXLND=4000)
33060       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
33061
33062       COMMON /QNPOL/ POLARX(4),PMODUL
33063 * particle masses used in qel neutrino scattering modules
33064       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
33065      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
33066      &                EMPROTSQ,EMNEUTSQ,EMNSQ
33067 * steering flags for qel neutrino scattering modules
33068       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
33069 **sr - removed (not needed)
33070 C     COMMON /CAXIAL/ FA0, AXIAL2
33071 C     COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
33072 C    &        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
33073 **
33074       REAL*8 POL(4,4),BB2(3)
33075       DIMENSION SS(6)
33076 C     DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
33077       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
33078 **sr uncommented since common block CAXIAL is now commented
33079       DATA AXIAL2 /1.03D0/  ! to be checked
33080 **
33081
33082       RML=P(4,5)
33083       RMM=0.93960D+00
33084       FM2 = RMM**2
33085       MPI = 0.135D+00
33086       OLDQ2=Q2
33087       FA0=-1.253D+00
33088       CSI = 3.71D+00                      !
33089       GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2   ! G_e(q**2)
33090       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
33091       X = Q2/(EMN*EMN)     ! emn=massa barione
33092       XA = X/4.D0
33093       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
33094       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
33095       FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
33096       FFA = FA*FA
33097       FFV1 = FV1*FV1
33098       FFV2 = FV2*FV2
33099       FP=2.D0*FA*RMM/(MPI**2 + Q2)
33100       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
33101       A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
33102       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
33103       AA = (XA+0.25D+00*RM)*(A1 + A2)
33104       BB = -X*FA*(FV1 + FV2)
33105       CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
33106       SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
33107
33108       OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2   )  ! articolo di ll...-smith
33109       OMEGA2=4.D+00*CC
33110       OMEGA3=2.D+00*FA*(FV1+FV2)
33111       OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
33112      1     (Q2/FM2))*FP**2)
33113       OMEGA5=OMEGA2
33114       OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
33115       WW1=2.D+00*OMEGA1*EMN**2
33116       WW2=2.D+00*OMEGA2*EMN**2
33117       WW3=2.D+00*OMEGA3*EMN**2
33118       WW4=2.D+00*OMEGA4*EMN**2
33119       WW5=2.D+00*OMEGA5*EMN**2
33120
33121       DO I=1,3
33122         BB2(I)=-P(4,I)/P(4,4)
33123       END DO
33124 c      WRITE(*,*)
33125 c      WRITE(*,*)
33126 c      WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
33127       N=5
33128
33129       CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
33130
33131 * NOW PARTICLES ARE IN THE SCATTERED LEPTON  REST FRAME
33132 c      WRITE(*,*)
33133 c      WRITE(*,*)
33134 c      WRITE(*,*) 'Prepola: now in lepton rest frame'
33135       EE=ENU
33136       QM2=Q2+RML**2
33137       U=Q2/(2.*RMM)
33138       FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
33139      +     (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
33140      +     ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
33141
33142       FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
33143      +     - ((RML**2)/FM2)*WW4                        !<=FM2 inv di RMM!!
33144
33145       FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
33146
33147       DO I=1,3
33148         POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
33149         POLARX(I)=POL(4,I)
33150       END DO
33151
33152       PMODUL=0.D0
33153       DO I=1,3
33154         PMODUL=PMODUL+POL(4,I)**2
33155       END DO
33156
33157       IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
33158          IF(NEUDEC.EQ.1) THEN
33159             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
33160      +        ETL,PXL,PYL,PZL,
33161      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
33162 c
33163 c     Tau has decayed in muon
33164 c
33165          ENDIF
33166          IF(NEUDEC.EQ.2) THEN
33167             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
33168      +        ETL,PXL,PYL,PZL,
33169      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
33170 c
33171 c     Tau has decayed in electron
33172 c
33173          ENDIF
33174          K(4,1)=15
33175          K(4,4) = 6
33176          K(4,5) = 8
33177          N=N+3
33178 c
33179 c     fill common for muon(electron)
33180 c
33181          P(6,1)=PXL
33182          P(6,2)=PYL
33183          P(6,3)=PZL
33184          P(6,4)=ETL
33185          K(6,1)=1
33186          IF(JTYP.EQ.5) THEN
33187             IF(NEUDEC.EQ.1) THEN
33188                P(6,5)=EML(JTYP-2)
33189                K(6,2)=13
33190             ELSEIF(NEUDEC.EQ.2) THEN
33191                P(6,5)=EML(JTYP-4)
33192                K(6,2)=11
33193             ENDIF
33194          ELSEIF(JTYP.EQ.6) THEN
33195             IF(NEUDEC.EQ.1) THEN
33196                K(6,2)=-13
33197             ELSEIF(NEUDEC.EQ.2) THEN
33198                K(6,2)=-11
33199             ENDIF
33200          END IF
33201          K(6,3)=4
33202          K(6,4)=0
33203          K(6,5)=0
33204 c
33205 c     fill common for tau_(anti)neutrino
33206 c
33207          P(7,1)=PXB
33208          P(7,2)=PYB
33209          P(7,3)=PZB
33210          P(7,4)=ETB
33211          P(7,5)=0.
33212          K(7,1)=1
33213          IF(JTYP.EQ.5) THEN
33214             K(7,2)=16
33215          ELSEIF(JTYP.EQ.6) THEN
33216             K(7,2)=-16
33217          END IF
33218          K(7,3)=4
33219          K(7,4)=0
33220          K(7,5)=0
33221 c
33222 c     Fill common for muon(electron)_(anti)neutrino
33223 c
33224          P(8,1)=PXN
33225          P(8,2)=PYN
33226          P(8,3)=PZN
33227          P(8,4)=ETN
33228          P(8,5)=0.
33229          K(8,1)=1
33230          IF(JTYP.EQ.5) THEN
33231             IF(NEUDEC.EQ.1) THEN
33232                K(8,2)=-14
33233             ELSEIF(NEUDEC.EQ.2) THEN
33234                K(8,2)=-12
33235             ENDIF
33236          ELSEIF(JTYP.EQ.6) THEN
33237             IF(NEUDEC.EQ.1) THEN
33238                K(8,2)=14
33239             ELSEIF(NEUDEC.EQ.2) THEN
33240                K(8,2)=12
33241             ENDIF
33242          END IF
33243          K(8,3)=4
33244          K(8,4)=0
33245          K(8,5)=0
33246       ENDIF
33247 c      WRITE(*,*)
33248 c      WRITE(*,*)
33249
33250 c      IF(PMODUL.GE.1.D+00) THEN
33251 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
33252 c        write(*,*) pmodul
33253 c        DO I=1,3
33254 c          POL(4,I)=POL(4,I)/PMODUL
33255 c          POLARX(I)=POL(4,I)
33256 c        END DO
33257 c        PMODUL=0.
33258 c        DO I=1,3
33259 c          PMODUL=PMODUL+POL(4,I)**2
33260 c        END DO
33261 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
33262 c
33263 c      ENDIF
33264
33265 c      WRITE(*,*) 'PMODUL = ',PMODUL
33266
33267 c      WRITE(*,*)
33268 c      WRITE(*,*)
33269 c      WRITE(*,*) 'prepola: Now back to nucl rest frame'
33270
33271       CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
33272
33273       XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
33274       YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
33275       ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
33276       DO NDC =6,8
33277          V(NDC,1) = XDC
33278          V(NDC,2) = YDC
33279          V(NDC,3) = ZDC
33280       END DO
33281
33282       RETURN
33283       END
33284 *
33285 *===testrot============================================================*
33286 *
33287 CDECK  ID>, DT_TESTROT
33288       SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
33289
33290       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33291       SAVE
33292
33293       DIMENSION ROT(3,3),PI(3),PO(3)
33294
33295       IF (MODE.EQ.1) THEN
33296          ROT(1,1) = 1.D0
33297          ROT(1,2) = 0.D0
33298          ROT(1,3) = 0.D0
33299          ROT(2,1) = 0.D0
33300          ROT(2,2) = COS(PHI)
33301          ROT(2,3) = -SIN(PHI)
33302          ROT(3,1) = 0.D0
33303          ROT(3,2) = SIN(PHI)
33304          ROT(3,3) = COS(PHI)
33305       ELSEIF (MODE.EQ.2) THEN
33306          ROT(1,1) = 0.D0
33307          ROT(1,2) = 1.D0
33308          ROT(1,3) = 0.D0
33309          ROT(2,1) = COS(PHI)
33310          ROT(2,2) = 0.D0
33311          ROT(2,3) = -SIN(PHI)
33312          ROT(3,1) = SIN(PHI)
33313          ROT(3,2) = 0.D0
33314          ROT(3,3) = COS(PHI)
33315       ELSEIF (MODE.EQ.3) THEN
33316          ROT(1,1) = 0.D0
33317          ROT(2,1) = 1.D0
33318          ROT(3,1) = 0.D0
33319          ROT(1,2) = COS(PHI)
33320          ROT(2,2) = 0.D0
33321          ROT(3,2) = -SIN(PHI)
33322          ROT(1,3) = SIN(PHI)
33323          ROT(2,3) = 0.D0
33324          ROT(3,3) = COS(PHI)
33325       ELSEIF (MODE.EQ.4) THEN
33326          ROT(1,1) = 1.D0
33327          ROT(2,1) = 0.D0
33328          ROT(3,1) = 0.D0
33329          ROT(1,2) = 0.D0
33330          ROT(2,2) = COS(PHI)
33331          ROT(3,2) = -SIN(PHI)
33332          ROT(1,3) = 0.D0
33333          ROT(2,3) = SIN(PHI)
33334          ROT(3,3) = COS(PHI)
33335       ELSE
33336          STOP ' TESTROT: mode not supported!'
33337       ENDIF
33338       DO 1 J=1,3
33339         PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
33340     1 CONTINUE
33341
33342       RETURN
33343       END
33344 *
33345 *===lepdcyp============================================================*
33346 *
33347 CDECK  ID>, DT_LEPDCYP
33348       SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
33349      &                      ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
33350 C
33351 C-----------------------------------------------------------------
33352 C
33353 C   Author   :- G. Battistoni         10-NOV-1995
33354 C
33355 C=================================================================
33356 C
33357 C   Purpose   : performs decay of polarized lepton in
33358 C               its rest frame: a => b + l + anti-nu
33359 C               (Example: mu- => nu-mu + e- + anti-nu-e)
33360 C               Polarization is assumed along Z-axis
33361 C               WARNING:
33362 C               1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
33363 C                  OF NEGLIGIBLE MASS
33364 C               2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
33365 C                  IN THIS VERSION
33366 C
33367 C   Method    : modifies phase space distribution obtained
33368 C               by routine EXPLOD using a rejection against the
33369 C               matrix element for unpolarized lepton decay
33370 C
33371 C   Inputs    : Mass of a :  AMA
33372 C               Mass of l :  AML
33373 C               Polar. of a: POL
33374 C               (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
33375 C                                                 POL = -1)
33376 C
33377 C   Outputs   : kinematic variables in the rest frame of decaying lepton
33378 C               ETL,PXL,PYL,PZL 4-moment of l
33379 C               ETB,PXB,PYB,PZB 4-moment of b
33380 C               ETN,PXN,PYN,PZN 4-moment of anti-nu
33381 C
33382 C============================================================
33383 C +
33384 C Declarations.
33385 C -
33386       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33387       SAVE
33388
33389       PARAMETER ( LINP = 5 ,
33390      &            LOUT = 6 ,
33391      &            LDAT = 9 )
33392
33393       PARAMETER ( KALGNM = 2 )
33394       PARAMETER ( ANGLGB = 5.0D-16 )
33395       PARAMETER ( ANGLSQ = 2.5D-31 )
33396       PARAMETER ( AXCSSV = 0.2D+16 )
33397       PARAMETER ( ANDRFL = 1.0D-38 )
33398       PARAMETER ( AVRFLW = 1.0D+38 )
33399       PARAMETER ( AINFNT = 1.0D+30 )
33400       PARAMETER ( AZRZRZ = 1.0D-30 )
33401       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
33402       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
33403       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
33404       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
33405       PARAMETER ( CSNNRM = 2.0D-15 )
33406       PARAMETER ( DMXTRN = 1.0D+08 )
33407       PARAMETER ( ZERZER = 0.D+00 )
33408       PARAMETER ( ONEONE = 1.D+00 )
33409       PARAMETER ( TWOTWO = 2.D+00 )
33410       PARAMETER ( THRTHR = 3.D+00 )
33411       PARAMETER ( FOUFOU = 4.D+00 )
33412       PARAMETER ( FIVFIV = 5.D+00 )
33413       PARAMETER ( SIXSIX = 6.D+00 )
33414       PARAMETER ( SEVSEV = 7.D+00 )
33415       PARAMETER ( EIGEIG = 8.D+00 )
33416       PARAMETER ( ANINEN = 9.D+00 )
33417       PARAMETER ( TENTEN = 10.D+00 )
33418       PARAMETER ( HLFHLF = 0.5D+00 )
33419       PARAMETER ( ONETHI = ONEONE / THRTHR )
33420       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
33421       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
33422       PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
33423       PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
33424       PARAMETER ( CLIGHT = 2.99792458         D+10 )
33425       PARAMETER ( AVOGAD = 6.0221367          D+23 )
33426       PARAMETER ( AMELGR = 9.1093897          D-28 )
33427       PARAMETER ( PLCKBR = 1.05457266         D-27 )
33428       PARAMETER ( ELCCGS = 4.8032068          D-10 )
33429       PARAMETER ( ELCMKS = 1.60217733         D-19 )
33430       PARAMETER ( AMUGRM = 1.6605402          D-24 )
33431       PARAMETER ( AMMUMU = 0.113428913        D+00 )
33432       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
33433       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
33434       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
33435       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
33436       PARAMETER ( PLABRC = 0.197327053        D+00 )
33437       PARAMETER ( AMELCT = 0.51099906         D-03 )
33438       PARAMETER ( AMUGEV = 0.93149432         D+00 )
33439       PARAMETER ( AMMUON = 0.105658389        D+00 )
33440       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
33441       PARAMETER ( GEVMEV = 1.0                D+03 )
33442       PARAMETER ( EMVGEV = 1.0                D-03 )
33443       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
33444       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
33445       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
33446 C +
33447 C    variables for EXPLOD
33448 C -
33449       PARAMETER ( KPMX = 10 )
33450       DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
33451      &          PZEXPL (KPMX), ETEXPL (KPMX)
33452 C +
33453 C      test variables
33454 C -
33455 **sr - removed (not needed)
33456 C     COMMON /GBATNU/ ELERAT,NTRY
33457 **
33458 C +
33459 C     Initializes test variables
33460 C -
33461       NTRY = 0
33462       ELERAT = 0.D+00
33463 C +
33464 C     Maximum value for matrix element
33465 C -
33466       ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
33467      &  SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
33468 C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
33469 C     Inputs for EXPLOD
33470 C part. no. 1 is l       (e- in mu- decay)
33471 C part. no. 2 is b       (nu-mu in mu- decay)
33472 C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
33473 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
33474       NPEXPL = 3
33475       ETOTEX = AMA
33476       AMEXPL(1) = AML
33477       AMEXPL(2) = 0.D+00
33478       AMEXPL(3) = 0.D+00
33479 C +
33480 C     phase space distribution
33481 C -
33482   100 CONTINUE
33483       NTRY = NTRY + 1
33484
33485       CALL EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
33486      &              PYEXPL, PZEXPL )
33487
33488 C +
33489 C  Calculates matrix element:
33490 C  64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
33491 C  Here CTH is the cosine of the angle between anti-nu and Z axis
33492 C -
33493       CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
33494      &  PZEXPL(3)**2 )
33495       PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
33496       PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
33497      &     PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
33498       ELEMAT = 16.D+00 * PROD1 * PROD2
33499       IF(ELEMAT.GT.ELEMAX) THEN
33500         WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
33501         STOP
33502       ENDIF
33503 C +
33504 C     Here performs the rejection
33505 C -
33506       TEST = DT_RNDM(ETOTEX) * ELEMAX
33507       IF ( TEST .GT. ELEMAT ) GO TO 100
33508 C +
33509 C     final assignment of variables
33510 C -
33511       ELERAT = ELEMAT/ELEMAX
33512       ETL = ETEXPL(1)
33513       PXL = PXEXPL(1)
33514       PYL = PYEXPL(1)
33515       PZL = PZEXPL(1)
33516       ETB = ETEXPL(2)
33517       PXB = PXEXPL(2)
33518       PYB = PYEXPL(2)
33519       PZB = PZEXPL(2)
33520       ETN = ETEXPL(3)
33521       PXN = PXEXPL(3)
33522       PYN = PYEXPL(3)
33523       PZN = PZEXPL(3)
33524   999 RETURN
33525       END
33526
33527 C==================================================================
33528 C.  Generation of  Delta resonance events
33529 C==================================================================
33530 *
33531 *===gen_delta==========================================================*
33532 *
33533 CDECK  ID>, DT_GEN_DELTA
33534       SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
33535
33536       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33537       SAVE
33538
33539       PARAMETER ( LINP = 5 ,
33540      &            LOUT = 6 ,
33541      &            LDAT = 9 )
33542
33543 C...Generate a Delta-production neutrino/antineutrino
33544 C.  CC-interaction on a nucleon
33545 C
33546 C.  INPUT  ENU (GeV) = Neutrino Energy
33547 C.         LLEP = neutrino type
33548 C.         LTARG = nucleon target type 1=p, 2=n.
33549 C.         JINT = 1:CC, 2::NC
33550 C.
33551 C.  OUTPUT PPL(4)  4-monentum of final lepton
33552 C----------------------------------------------------
33553
33554       PARAMETER (MAXLND=4000)
33555       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
33556
33557 **sr - removed (not needed)
33558 C     COMMON /CBAD/  LBAD, NBAD
33559 **
33560
33561       DIMENSION PI(3),PO(3)
33562 C     REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
33563       DIMENSION AML0(6),AMN(2)
33564       DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
33565       DATA AMN  /0.93827231, 0.93956563/
33566       DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
33567
33568 c     WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
33569       LBAD = 0
33570 C...Final lepton mass
33571       IF (JINT.EQ.1) THEN
33572         AML = AML0(LLEP)
33573       ELSE
33574         AML = 0.
33575       ENDIF
33576       AML2 = AML**2
33577
33578 C...Particle labels (LUND)
33579       N = 5
33580       K(1,1) = 21
33581       K(2,1) = 21
33582       K(3,1) = 21
33583       K(4,1) = 1
33584       K(3,3) = 1
33585       K(4,3) = 1
33586       IF (LTARG .EQ. 1)  THEN
33587          K(2,2) = 2212
33588       ELSE
33589          K(2,2) = 2112
33590       ENDIF
33591       K0 = (LLEP-1)/2
33592       K1 = LLEP/2
33593       KA = 12 + 2*K0
33594       IS = -1 + 2*LLEP - 4*K1
33595       LNU = 2 - LLEP + 2*K1
33596       K(1,2) = IS*KA
33597       K(5,1) = 1
33598       K(5,3) = 2
33599       IF (JINT .EQ. 1)  THEN                    ! CC interactions
33600          K(3,2) = IS*24
33601          K(4,2) = IS*(KA-1)
33602         IF(LNU.EQ.1) THEN
33603           IF (LTARG .EQ. 1)  THEN
33604               K(5,2) = 2224
33605           ELSE
33606               K(5,2) = 2214
33607           ENDIF
33608         ELSE
33609           IF (LTARG .EQ. 1)  THEN
33610               K(5,2) = 2114
33611           ELSE
33612               K(5,2) = 1114
33613           ENDIF
33614         ENDIF
33615       ELSE
33616          K(3,2) = 23                           ! NC (Z0) interactions
33617          K(4,2) = K(1,2)
33618 **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
33619 *                                Delta0 for neutron (LTARG=2)
33620 C        IF (LTARG .EQ. 1)  THEN
33621 C           K(5,2) = 2114
33622 C        ELSE
33623 C           K(5,2) = 2214
33624 C        ENDIF
33625          IF (LTARG .EQ. 1)  THEN
33626             K(5,2) = 2214
33627          ELSE
33628             K(5,2) = 2114
33629          ENDIF
33630 **
33631       ENDIF
33632
33633 C...4-momentum initial lepton
33634       P(1,5) = 0.
33635       P(1,4) = ENU
33636       P(1,1) = 0.
33637       P(1,2) = 0.
33638       P(1,3) = ENU
33639 C...4-momentum initial nucleon
33640       P(2,5) = AMN(LTARG)
33641 C     P(2,4) = P(2,5)
33642 C     P(2,1) = 0.
33643 C     P(2,2) = 0.
33644 C     P(2,3) = 0.
33645        P(2,1) = P21
33646        P(2,2) = P22
33647        P(2,3) = P23
33648        P(2,4) = P24
33649        P(2,5) = P25
33650       N=2
33651       beta1=-p(2,1)/p(2,4)
33652       beta2=-p(2,2)/p(2,4)
33653       beta3=-p(2,3)/p(2,4)
33654       N=2
33655
33656       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
33657
33658 C     print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
33659
33660       phi11=atan(p(1,2)/p(1,3))
33661       pi(1)=p(1,1)
33662       pi(2)=p(1,2)
33663       pi(3)=p(1,3)
33664
33665       CALL DT_TESTROT(PI,Po,PHI11,1)
33666       DO ll=1,3
33667        IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
33668       END DO
33669       p(1,1)=po(1)
33670       p(1,2)=po(2)
33671       p(1,3)=po(3)
33672       phi12=atan(p(1,1)/p(1,3))
33673
33674       pi(1)=p(1,1)
33675       pi(2)=p(1,2)
33676       pi(3)=p(1,3)
33677       CALL DT_TESTROT(Pi,Po,PHI12,2)
33678       DO ll=1,3
33679         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
33680       END DO
33681       p(1,1)=po(1)
33682       p(1,2)=po(2)
33683       p(1,3)=po(3)
33684
33685       ENUU=P(1,4)
33686
33687 C...Generate the Mass of the Delta
33688       NTRY = 0
33689 100   R = PYR(0)
33690       AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
33691       NTRY = NTRY + 1
33692       IF (NTRY .GT. 1000)  THEN
33693          LBAD = 1
33694          WRITE (LOUT,1001)  NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
33695          RETURN
33696       ENDIF
33697       IF (AMD .LT. AMDMIN)  GOTO 100
33698       ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
33699       IF (ENUU .LT. ET) GOTO 100
33700
33701 C...Kinematical  limits in Q**2
33702       S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
33703       SQS = SQRT(S)
33704       PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
33705       ELF = (S - AMD**2 + AML2)/(2.*SQS)
33706       PLF = SQRT(ELF**2 - AML2)
33707       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
33708       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
33709       IF (Q2MIN .LT. 0.)   Q2MIN = 0.
33710
33711       DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
33712 200   Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
33713       DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
33714       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
33715
33716 C...Generate the kinematics of the final particles
33717       EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
33718       GAM = EISTAR/AMN(LTARG)
33719       BET = PSTAR/EISTAR
33720       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
33721       EL  = GAM*(ELF + BET*PLF*CTSTAR)
33722       PLZ = GAM*(PLF*CTSTAR + BET*ELF)
33723       PL  = SQRT(EL**2 - AML2)
33724       PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
33725       PHI = 6.28319*PYR(0)
33726       P(4,1) = PLT*COS(PHI)
33727       P(4,2) = PLT*SIN(PHI)
33728       P(4,3) = PLZ
33729       P(4,4) = EL
33730       P(4,5) = AML
33731
33732 C...4-momentum of Delta
33733       P(5,1) = -P(4,1)
33734       P(5,2) = -P(4,2)
33735       P(5,3) = ENUU-P(4,3)
33736       P(5,4) = ENUU+AMN(LTARG)-P(4,4)
33737       P(5,5) = AMD
33738
33739 C...4-momentum  of intermediate boson
33740       P(3,5) = -Q2
33741       P(3,4) = P(1,4)-P(4,4)
33742       P(3,1) = P(1,1)-P(4,1)
33743       P(3,2) = P(1,2)-P(4,2)
33744       P(3,3) = P(1,3)-P(4,3)
33745       N=5
33746
33747       DO kw=1,5
33748         pi(1)=p(kw,1)
33749         pi(2)=p(kw,2)
33750         pi(3)=p(kw,3)
33751         CALL DT_TESTROT(Pi,Po,PHI12,3)
33752         DO ll=1,3
33753           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
33754         END DO
33755         p(kw,1)=po(1)
33756         p(kw,2)=po(2)
33757         p(kw,3)=po(3)
33758       END DO
33759
33760 c********************************************
33761
33762         DO kw=1,5
33763           pi(1)=p(kw,1)
33764           pi(2)=p(kw,2)
33765           pi(3)=p(kw,3)
33766           CALL DT_TESTROT(Pi,Po,PHI11,4)
33767           DO ll=1,3
33768             IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
33769           END DO
33770           p(kw,1)=po(1)
33771           p(kw,2)=po(2)
33772           p(kw,3)=po(3)
33773        END DO
33774 c********************************************
33775 C         transform back into Lab.
33776
33777       CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
33778
33779 C     WRITE(6,*)' Lab fram ( fermi incl.) '
33780       N=5
33781       CALL PYEXEC
33782
33783       RETURN
33784 1001  FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5,  6G10.3)
33785       END
33786 *
33787 *===dsigma_delta=======================================================*
33788 *
33789 CDECK  ID>, DT_DSIGMA_DELTA
33790       DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
33791
33792       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33793       SAVE
33794
33795 C...Reaction nu + N -> lepton + Delta
33796 C.  returns the  cross section
33797 C.  dsigma/dt
33798 C.  INPUT  LNU = 1, 2  (neutrino-antineutrino)
33799 C.         QQ = t (always negative)  GeV**2
33800 C.         S  = (c.m energy)**2      GeV**2
33801 C.  OUTPUT =  10**-38 cm+2/GeV**2
33802 C-----------------------------------------------------
33803       REAL*8 MN, MN2, MN4, MD,MD2, MD4
33804       DATA MN /0.938/
33805       DATA PI /3.1415926/
33806
33807       GF = (1.1664 * 1.97)
33808       GF2 = GF*GF
33809       MN2 = MN*MN
33810       MN4 = MN2*MN2
33811       MD2 = MD*MD
33812       MD4 = MD2*MD2
33813       AML2 = AML*AML
33814       AML4 = AML2*AML2
33815       VQ  = (MN2 - MD2 - QQ)/2.
33816       VPI = (MN2 + MD2 - QQ)/2.
33817       VK  = (S + QQ - MN2 - AML2)/2.
33818       PIK = (S - MN2)/2.
33819       QK = (AML2 - QQ)/2.
33820       PIQ = (QQ + MN2 - MD2)/2.
33821       Q = SQRT(-QQ)
33822       C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
33823       C3 = SQRT(3.)*C3V/MN
33824       C4 = -C3/MD             ! attenzione al segno
33825       C5A = 1.18/(1.-QQ/0.4225)**2
33826       C32 = C3**2
33827       C42 = C4**2
33828       C5A2 = C5A**2
33829
33830       IF (LNU .EQ. 1)  THEN
33831       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
33832      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
33833      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
33834      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
33835       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
33836      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
33837      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
33838      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
33839      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
33840      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
33841      . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
33842      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
33843      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
33844      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
33845      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
33846      . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
33847      . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
33848      . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
33849      . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
33850      . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
33851      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
33852      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
33853      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
33854       ELSE
33855       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
33856      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
33857      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
33858      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
33859       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
33860      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
33861      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
33862      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
33863      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
33864      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
33865      . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
33866      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
33867      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
33868      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
33869      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
33870      . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
33871      . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
33872      . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
33873      . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
33874      . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
33875      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
33876      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
33877      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
33878       ENDIF
33879       ANS1=32.*ANS2
33880       ANS=ANS1/(3.*MD2)
33881       P1CM = (S-MN2)/(2.*SQRT(S))
33882       DT_DSIGMA_DELTA  = GF2/2. * ANS/(64.*PI*S*P1CM**2)
33883
33884       RETURN
33885       END
33886 *
33887 *===qgaus==============================================================*
33888 *
33889 CDECK  ID>, DT_QGAUS
33890       SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
33891
33892       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33893       SAVE
33894
33895       DIMENSION X(5),W(5)
33896       DATA X/.1488743389D0,.4333953941D0,
33897      & .6794095682D0,.8650633666D0,.9739065285D0
33898      */
33899       DATA W/.2955242247D0,.2692667193D0,
33900      & .2190863625D0,.1494513491D0,.0666713443D0
33901      */
33902       XM=0.5D0*(B+A)
33903       XR=0.5D0*(B-A)
33904       SS=0
33905       DO 11 J=1,5
33906         DX=XR*X(J)
33907         SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
33908      *  DT_DSQEL_Q2(LTYP,ENU,XM-DX))
33909 11    CONTINUE
33910       SS=XR*SS
33911
33912       RETURN
33913       END
33914 *
33915 *===diqbrk=============================================================*
33916 *
33917 CDECK  ID>, DT_DIQBRK
33918       SUBROUTINE DT_DIQBRK
33919
33920       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33921       SAVE
33922
33923 * event history
33924
33925       PARAMETER (NMXHKK=200000)
33926
33927       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
33928      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
33929      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
33930 * extended event history
33931       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
33932      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
33933      &                IHIST(2,NMXHKK)
33934 * event flag
33935       COMMON /DTEVNO/ NEVENT,ICASCA
33936
33937 C     IF(DT_RNDM(VV).LE.0.5D0)THEN
33938 C       CALL GSQBS1(NHKK)
33939 C       CALL GSQBS2(NHKK)
33940 C       CALL USQBS1(NHKK)
33941 C       CALL USQBS2(NHKK)
33942 C       CALL GSABS1(NHKK)
33943 C       CALL GSABS2(NHKK)
33944 C       CALL USABS1(NHKK)
33945 C       CALL USABS2(NHKK)
33946 C     ELSE
33947 C       CALL GSQBS2(NHKK)
33948 C       CALL GSQBS1(NHKK)
33949 C       CALL USQBS2(NHKK)
33950 C       CALL USQBS1(NHKK)
33951 C       CALL GSABS2(NHKK)
33952 C       CALL GSABS1(NHKK)
33953 C       CALL USABS2(NHKK)
33954 C       CALL USABS1(NHKK)
33955 C     ENDIF
33956
33957       IF(DT_RNDM(VV).LE.0.5D0) THEN
33958         CALL DT_DBREAK(1)
33959         CALL DT_DBREAK(2)
33960         CALL DT_DBREAK(3)
33961         CALL DT_DBREAK(4)
33962         CALL DT_DBREAK(5)
33963         CALL DT_DBREAK(6)
33964         CALL DT_DBREAK(7)
33965         CALL DT_DBREAK(8)
33966       ELSE
33967         CALL DT_DBREAK(2)
33968         CALL DT_DBREAK(1)
33969         CALL DT_DBREAK(4)
33970         CALL DT_DBREAK(3)
33971         CALL DT_DBREAK(6)
33972         CALL DT_DBREAK(5)
33973         CALL DT_DBREAK(8)
33974         CALL DT_DBREAK(7)
33975       ENDIF
33976
33977       RETURN
33978       END
33979 C
33980 C
33981 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
33982       SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
33983      *              IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
33984 C
33985 C                  USQBS-2 diagram (split target diquark)
33986 C
33987       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33988       SAVE
33989
33990       PARAMETER ( LINP = 5 ,
33991      &            LOUT = 6 ,
33992      &            LDAT = 9 )
33993
33994 * event history
33995
33996       PARAMETER (NMXHKK=200000)
33997
33998       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
33999      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
34000      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
34001 * extended event history
34002       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
34003      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
34004      &                IHIST(2,NMXHKK)
34005 * Lorentz-parameters of the current interaction
34006       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
34007      &                UMO,PPCM,EPROJ,PPROJ
34008 * diquark-breaking mechanism
34009       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
34010
34011 C
34012       PARAMETER (NTMHKK= 300)
34013       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
34014      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
34015      +(4,NTMHKK)
34016 *KEEP,XSEADI.
34017       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
34018      +SSMIMQ,VVMTHR
34019 *KEEP,DPRIN.
34020       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
34021       COMMON /EVFLAG/ NUMEV
34022 C
34023 C                  USQBS-2 diagram (split target diquark)
34024 C
34025 C
34026 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
34027 C     Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
34028 C
34029 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
34030 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
34031 C
34032 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
34033 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34034 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
34035 C
34036 C
34037 C       Put new chains into COMMON /HKKTMP/
34038 C
34039       IIGLU1=NC1T-NC1P-1
34040       IIGLU2=NC2T-NC2P-1
34041       IGCOUN=0
34042 C     WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
34043       CVQ=1.D0
34044       IREJ=0
34045       IF(IPIP.EQ.2)THEN
34046 C     IF(NUMEV.EQ.-324)THEN
34047 C     WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
34048 C    *             'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
34049 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
34050 C    *              IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
34051       ENDIF
34052 C
34053 C
34054 C
34055 C     determine x-values of NC1T diquark
34056       XDIQT=PHKK(4,NC1T)*2.D0/UMO
34057       XVQP=PHKK(4,NC1P)*2.D0/UMO
34058 C
34059 C     determine x-values of sea quark pair
34060 C
34061       IPCO=1
34062       ICOU=0
34063  2234 CONTINUE
34064       ICOU=ICOU+1
34065       IF(ICOU.GE.500)THEN
34066         IREJ=1
34067         IF(ISQ.EQ.3)IREJ=3
34068         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
34069         IPCO=0
34070         RETURN
34071       ENDIF
34072       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
34073      * UMO, XDIQT,XVQP
34074       XSQ=0.D0
34075       XSAQ=0.D0
34076 **NEW
34077 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
34078       IF (IPIP.EQ.1) THEN
34079          XQMAX  = XDIQT/2.0D0
34080          XAQMAX = 2.D0*XVQP/3.0D0
34081       ELSE
34082          XQMAX  = 2.D0*XVQP/3.0D0
34083          XAQMAX = XDIQT/2.0D0
34084       ENDIF
34085       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
34086       ISAQ = 6+ISQ
34087 C     write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
34088 **
34089         IF(IPCO.GE.3)
34090      &     WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
34091       IF(IREJ.GE.1)THEN
34092         IF(IPCO.GE.3)
34093      &     WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
34094         IPCO=0
34095         RETURN
34096       ENDIF
34097       IF(IPIP.EQ.1)THEN
34098         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
34099       ELSEIF(IPIP.EQ.2)THEN
34100         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
34101       ENDIF
34102       IF(IPCO.GE.3)THEN
34103         WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
34104      *  XDIQT,XVQP,XSQ,XSAQ
34105       ENDIF
34106 C
34107 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
34108 C
34109 C     XSQ=0.D0
34110       IF(IPIP.EQ.1)THEN
34111         XDIQT=XDIQT-XSQ
34112         XVQP =XVQP -XSAQ
34113       ELSEIF(IPIP.EQ.2)THEN
34114         XDIQT=XDIQT-XSAQ
34115         XVQP =XVQP -XSQ
34116       ENDIF
34117       IF(IPCO.GE.3)
34118      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
34119 C
34120 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
34121 C
34122       XVTHRO=CVQ/UMO
34123       IVTHR=0
34124  3466 CONTINUE
34125       IF(IVTHR.EQ.10)THEN
34126         IREJ=1
34127         IF(ISQ.EQ.3)IREJ=3
34128         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
34129       IPCO=0
34130         RETURN
34131       ENDIF
34132       IVTHR=IVTHR+1
34133       XVTHR=XVTHRO/(201-IVTHR)
34134       UNOPRV=UNON
34135  380  CONTINUE
34136       IF(XVTHR.GT.0.66D0*XDIQT)THEN
34137         IREJ=1
34138         IF(ISQ.EQ.3)IREJ=3
34139         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR  large ',
34140      *  XVTHR
34141       IPCO=0
34142         RETURN
34143       ENDIF
34144       IF(DT_RNDM(V).LT.0.5D0)THEN
34145         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
34146         XVTQII=XDIQT-XVTQI
34147       ELSE
34148         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
34149         XVTQI=XDIQT-XVTQII
34150       ENDIF
34151       IF(IPCO.GE.3)THEN
34152         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
34153       ENDIF
34154 C
34155 C     Prepare 4 momenta of new chains and chain ends
34156 C
34157 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
34158 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
34159 C    +(4,NTMHKK)
34160 C
34161 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
34162 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34163 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
34164 C
34165 C     SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
34166 C    *              IP1,IP21,IP22,IPP1,IPP2)
34167 C
34168       IF(IPIP.EQ.1)THEN
34169         XSQ1=XSQ
34170         XSAQ1=XSAQ
34171         ISQ1=ISQ
34172         ISAQ1=ISAQ
34173       ELSEIF(IPIP.EQ.2)THEN
34174         XSQ1=XSAQ
34175         XSAQ1=XSQ
34176         ISQ1=ISAQ
34177         ISAQ1=ISQ
34178       ENDIF
34179       IDHKT(1)   =IPP1
34180       ISTHKT(1)  =951
34181       JMOHKT(1,1)=NC2P
34182       JMOHKT(2,1)=0
34183       JDAHKT(1,1)=3+IIGLU1
34184       JDAHKT(2,1)=0
34185 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
34186       PHKT(1,1)  =PHKK(1,NC2P)
34187       PHKT(2,1)  =PHKK(2,NC2P)
34188       PHKT(3,1)  =PHKK(3,NC2P)
34189       PHKT(4,1)  =PHKK(4,NC2P)
34190 C     PHKT(5,1)  =PHKK(5,NC2P)
34191       XMIST  =(PHKT(4,1)**2-
34192      * PHKT(3,1)**2-PHKT(2,1)**2-
34193      *PHKT(1,1)**2)
34194       IF(XMIST.GT.0.D0)THEN
34195       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
34196      *PHKT(1,1)**2)
34197       ELSE
34198 C     WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
34199       PHKT(5,1)=0.D0
34200       ENDIF
34201       VHKT(1,1)  =VHKK(1,NC2P)
34202       VHKT(2,1)  =VHKK(2,NC2P)
34203       VHKT(3,1)  =VHKK(3,NC2P)
34204       VHKT(4,1)  =VHKK(4,NC2P)
34205       WHKT(1,1)  =WHKK(1,NC2P)
34206       WHKT(2,1)  =WHKK(2,NC2P)
34207       WHKT(3,1)  =WHKK(3,NC2P)
34208       WHKT(4,1)  =WHKK(4,NC2P)
34209 C     Add here IIGLU1 gluons to this chaina
34210       PG1=0.D0
34211       PG2=0.D0
34212       PG3=0.D0
34213       PG4=0.D0
34214       IF(IIGLU1.GE.1)THEN
34215       JJG=NC1P
34216       DO 61 IIG=2,2+IIGLU1-1
34217         KKG=JJG+IIG-1
34218         IDHKT(IIG)   =IDHKK(KKG)
34219         ISTHKT(IIG)  =921
34220         JMOHKT(1,IIG)=KKG
34221         JMOHKT(2,IIG)=0
34222         JDAHKT(1,IIG)=3+IIGLU1
34223         JDAHKT(2,IIG)=0
34224         PHKT(1,IIG)=PHKK(1,KKG)
34225         PG1=PG1+ PHKT(1,IIG)
34226         PHKT(2,IIG)=PHKK(2,KKG)
34227         PG2=PG2+ PHKT(2,IIG)
34228         PHKT(3,IIG)=PHKK(3,KKG)
34229         PG3=PG3+ PHKT(3,IIG)
34230         PHKT(4,IIG)=PHKK(4,KKG)
34231         PG4=PG4+ PHKT(4,IIG)
34232         PHKT(5,IIG)=PHKK(5,KKG)
34233         VHKT(1,IIG)  =VHKK(1,KKG)
34234         VHKT(2,IIG)  =VHKK(2,KKG)
34235         VHKT(3,IIG)  =VHKK(3,KKG)
34236         VHKT(4,IIG)  =VHKK(4,KKG)
34237         WHKT(1,IIG) =WHKK(1,KKG)
34238         WHKT(2,IIG) =WHKK(2,KKG)
34239         WHKT(3,IIG) =WHKK(3,KKG)
34240         WHKT(4,IIG) =WHKK(4,KKG)
34241    61 CONTINUE
34242       ENDIF
34243       IDHKT(2+IIGLU1)   =IP21
34244       ISTHKT(2+IIGLU1)  =952
34245       JMOHKT(1,2+IIGLU1)=NC1T
34246       JMOHKT(2,2+IIGLU1)=0
34247       JDAHKT(1,2+IIGLU1)=3+IIGLU1
34248       JDAHKT(2,2+IIGLU1)=0
34249       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
34250       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
34251       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
34252       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
34253 C     PHKT(5,2)  =PHKK(5,NC1T)
34254       XMIST  =(PHKT(4,2+IIGLU1)**2-
34255      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
34256      *PHKT(1,2+IIGLU1)**2)
34257       IF(XMIST.GT.0.D0)THEN
34258       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
34259      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
34260      *PHKT(1,2+IIGLU1)**2)
34261       ELSE
34262 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
34263         PHKT(5,5+IIGLU1)=0.D0
34264       ENDIF
34265       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
34266       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
34267       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
34268       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
34269       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
34270       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
34271       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
34272       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
34273       IDHKT(3+IIGLU1)   =88888
34274       ISTHKT(3+IIGLU1)  =95
34275       JMOHKT(1,3+IIGLU1)=1
34276       JMOHKT(2,3+IIGLU1)=2+IIGLU1
34277       JDAHKT(1,3+IIGLU1)=0
34278       JDAHKT(2,3+IIGLU1)=0
34279       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
34280       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
34281       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
34282       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
34283       XMIST
34284      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
34285      *            -PHKT(3,3+IIGLU1)**2)
34286       IF(XMIST.GT.0.D0)THEN
34287       PHKT(5,3+IIGLU1)
34288      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
34289      *            -PHKT(3,3+IIGLU1)**2)
34290       ELSE
34291 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
34292         PHKT(5,5+IIGLU1)=0.D0
34293       ENDIF
34294       IF(IPIP.GE.2)THEN
34295 C     IF(NUMEV.EQ.-324)THEN
34296 C     WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
34297 C    * JDAHKT(1,1),
34298 C    *JDAHKT(2,1),(PHKT(III,1),III=1,5)
34299       DO 71 IIG=2,2+IIGLU1-1
34300 C     WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
34301 C    &             JMOHKT(1,IIG),JMOHKT(2,IIG),
34302 C    * JDAHKT(1,IIG),
34303 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
34304    71 CONTINUE
34305 C     WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
34306 C    * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
34307 C    *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
34308 C     WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
34309 C    * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
34310 C    *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
34311       ENDIF
34312       CHAMAL=CHAM1
34313       IF(IPIP.EQ.1)THEN
34314         IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
34315       ELSEIF(IPIP.EQ.2)THEN
34316         IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
34317       ENDIF
34318       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
34319 C       IREJ=1
34320         IPCO=0
34321 C       RETURN
34322 C       WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
34323         GO TO 3466
34324       ENDIF
34325       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
34326       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
34327       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
34328       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
34329       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
34330       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
34331       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
34332       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
34333       IF(IPIP.EQ.1)THEN
34334         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
34335       ELSEIF(IPIP.EQ.2)THEN
34336         IDHKT(4+IIGLU1)   =ISAQ1
34337       ENDIF
34338       ISTHKT(4+IIGLU1)  =951
34339       JMOHKT(1,4+IIGLU1)=NC1P
34340       JMOHKT(2,4+IIGLU1)=0
34341       JDAHKT(1,4+IIGLU1)=6+IIGLU1
34342       JDAHKT(2,4+IIGLU1)=0
34343 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34344       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
34345       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
34346       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
34347       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
34348 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
34349       XMIST  =(PHKT(4,4+IIGLU1)**2-
34350      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
34351      *PHKT(1,4+IIGLU1)**2)
34352       IF(XMIST.GT.0.D0)THEN
34353       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
34354      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
34355      *PHKT(1,4+IIGLU1)**2)
34356       ELSE
34357 C     WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
34358       PHKT(5,4+IIGLU1)=0.D0
34359       ENDIF
34360       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
34361       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
34362       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
34363       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
34364       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
34365       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
34366       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
34367       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
34368       IDHKT(5+IIGLU1)   =IP22
34369       ISTHKT(5+IIGLU1)  =952
34370       JMOHKT(1,5+IIGLU1)=NC1T
34371       JMOHKT(2,5+IIGLU1)=0
34372       JDAHKT(1,5+IIGLU1)=6+IIGLU1
34373       JDAHKT(2,5+IIGLU1)=0
34374       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
34375       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
34376       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
34377       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
34378 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
34379       XMIST  =(PHKT(4,5+IIGLU1)**2-
34380      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
34381      *PHKT(1,5+IIGLU1)**2)
34382       IF(XMIST.GT.0.D0)THEN
34383       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
34384      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
34385      *PHKT(1,5+IIGLU1)**2)
34386       ELSE
34387 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
34388         PHKT(5,5+IIGLU1)=0.D0
34389       ENDIF
34390       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
34391       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
34392       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
34393       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
34394       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
34395       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
34396       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
34397       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
34398       IDHKT(6+IIGLU1)   =88888
34399       ISTHKT(6+IIGLU1)  =95
34400       JMOHKT(1,6+IIGLU1)=4+IIGLU1
34401       JMOHKT(2,6+IIGLU1)=5+IIGLU1
34402       JDAHKT(1,6+IIGLU1)=0
34403       JDAHKT(2,6+IIGLU1)=0
34404       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
34405       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
34406       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
34407       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
34408       XMIST
34409      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
34410      *            -PHKT(3,6+IIGLU1)**2)
34411       IF(XMIST.GT.0.D0)THEN
34412       PHKT(5,6+IIGLU1)
34413      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
34414      *            -PHKT(3,6+IIGLU1)**2)
34415       ELSE
34416 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
34417         PHKT(5,5+IIGLU1)=0.D0
34418       ENDIF
34419 C     IF(IPIP.GE.2)THEN
34420 C     IF(NUMEV.EQ.-324)THEN
34421 C     WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
34422 C    * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
34423 C    *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
34424 C     WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
34425 C    * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
34426 C    *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
34427 C     WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
34428 C    * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
34429 C    *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
34430 C     ENDIF
34431       CHAMAL=CHAM1
34432       IF(IPIP.EQ.1)THEN
34433         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
34434       ELSEIF(IPIP.EQ.2)THEN
34435         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
34436       ENDIF
34437       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
34438 C       IREJ=1
34439         IPCO=0
34440 C       RETURN
34441 C       WRITE(6,*)' MUSQBS1 jump back from chain 6',
34442 C    *  CHAMAL,PHKT(5,6+IIGLU1)
34443         GO TO 3466
34444       ENDIF
34445       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
34446       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
34447       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
34448       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
34449       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
34450       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
34451       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
34452       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
34453 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
34454       IDHKT(7+IIGLU1)   =IP1
34455       ISTHKT(7+IIGLU1)  =951
34456       JMOHKT(1,7+IIGLU1)=NC1P
34457       JMOHKT(2,7+IIGLU1)=0
34458 **NEW
34459 C     JDAHKT(1,7+IIGLU1)=9+IIGLU1
34460       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
34461 **
34462       JDAHKT(2,7+IIGLU1)=0
34463       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
34464       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
34465       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
34466       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
34467 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
34468       XMIST  =(PHKT(4,7+IIGLU1)**2-
34469      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
34470      *PHKT(1,7+IIGLU1)**2)
34471       IF(XMIST.GT.0.D0)THEN
34472       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
34473      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
34474      *PHKT(1,7+IIGLU1)**2)
34475       ELSE
34476 C     WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
34477       PHKT(5,7+IIGLU1)=0.D0
34478       ENDIF
34479       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
34480       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
34481       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
34482       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
34483       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
34484       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
34485       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
34486       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
34487 C     Insert here the IIGLU2 gluons
34488       PG1=0.D0
34489       PG2=0.D0
34490       PG3=0.D0
34491       PG4=0.D0
34492       IF(IIGLU2.GE.1)THEN
34493       JJG=NC2P
34494       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
34495         KKG=JJG+IIG-7-IIGLU1
34496         IDHKT(IIG)   =IDHKK(KKG)
34497         ISTHKT(IIG)  =921
34498         JMOHKT(1,IIG)=KKG
34499         JMOHKT(2,IIG)=0
34500         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
34501         JDAHKT(2,IIG)=0
34502         PHKT(1,IIG)=PHKK(1,KKG)
34503         PG1=PG1+ PHKT(1,IIG)
34504         PHKT(2,IIG)=PHKK(2,KKG)
34505         PG2=PG2+ PHKT(2,IIG)
34506         PHKT(3,IIG)=PHKK(3,KKG)
34507         PG3=PG3+ PHKT(3,IIG)
34508         PHKT(4,IIG)=PHKK(4,KKG)
34509         PG4=PG4+ PHKT(4,IIG)
34510         PHKT(5,IIG)=PHKK(5,KKG)
34511         VHKT(1,IIG)  =VHKK(1,KKG)
34512         VHKT(2,IIG)  =VHKK(2,KKG)
34513         VHKT(3,IIG)  =VHKK(3,KKG)
34514         VHKT(4,IIG)  =VHKK(4,KKG)
34515         WHKT(1,IIG)  =WHKK(1,KKG)
34516         WHKT(2,IIG) =WHKK(2,KKG)
34517         WHKT(3,IIG) =WHKK(3,KKG)
34518         WHKT(4,IIG) =WHKK(4,KKG)
34519    81 CONTINUE
34520       ENDIF
34521       IF(IPIP.EQ.1)THEN
34522         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
34523         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
34524         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
34525         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
34526       ELSEIF(IPIP.EQ.2)THEN
34527         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
34528         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
34529         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
34530         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
34531       ENDIF
34532       ISTHKT(8+IIGLU1+IIGLU2)  =952
34533       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
34534       JMOHKT(2,8+IIGLU1+IIGLU2)=0
34535       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
34536       JDAHKT(2,8+IIGLU1+IIGLU2)=0
34537       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC2T)+
34538      * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
34539       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC2T)+
34540      * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
34541       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC2T)+
34542      * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
34543       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC2T)+
34544      * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
34545 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
34546 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
34547       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
34548 C       IREJ=1
34549 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
34550 C    *  ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
34551         IPCO=0
34552 C       RETURN
34553         GO TO 3466
34554       ENDIF
34555 C     PHKT(5,8)  =PHKK(5,NC2T)
34556       XMIST  =(PHKT(4,8+IIGLU1+IIGLU2)**2-
34557      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
34558      *PHKT(1,8+IIGLU1+IIGLU2)**2)
34559       IF(XMIST.GT.0.D0)THEN
34560       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
34561      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
34562      *PHKT(1,8+IIGLU1+IIGLU2)**2)
34563       ELSE
34564 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
34565         PHKT(5,5+IIGLU1)=0.D0
34566       ENDIF
34567       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
34568       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
34569       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
34570       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
34571       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
34572       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
34573       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
34574       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
34575       IDHKT(9+IIGLU1+IIGLU2)   =88888
34576       ISTHKT(9+IIGLU1+IIGLU2)  =95
34577       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
34578       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
34579       JDAHKT(1,9+IIGLU1+IIGLU2)=0
34580       JDAHKT(2,9+IIGLU1+IIGLU2)=0
34581 **NEW
34582 C     PHKT(1,9+IIGLU1+IIGLU2)
34583 C    * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
34584 C     PHKT(2,9+IIGLU1+IIGLU2)
34585 C    * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
34586 C     PHKT(3,9+IIGLU1+IIGLU2)
34587 C    * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
34588 C     PHKT(4,9+IIGLU1+IIGLU2)
34589 C    * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
34590       PHKT(1,9+IIGLU1+IIGLU2)
34591      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
34592       PHKT(2,9+IIGLU1+IIGLU2)
34593      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
34594       PHKT(3,9+IIGLU1+IIGLU2)
34595      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
34596       PHKT(4,9+IIGLU1+IIGLU2)
34597      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
34598 **
34599       XMIST
34600      * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
34601      * -PHKT(2,9+IIGLU1+IIGLU2)**2
34602      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
34603       IF(XMIST.GT.0.D0)THEN
34604       PHKT(5,9+IIGLU1+IIGLU2)
34605      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
34606      * -PHKT(2,9+IIGLU1+IIGLU2)**2
34607      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
34608       ELSE
34609 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
34610         PHKT(5,5+IIGLU1)=0.D0
34611       ENDIF
34612       IF(IPIP.GE.2)THEN
34613 C     IF(NUMEV.EQ.-324)THEN
34614 C     WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
34615 C    * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
34616 C    *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
34617 C     DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
34618 C     WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
34619 C    * JDAHKT(1,IIG),
34620 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
34621 C  91 CONTINUE
34622 C     WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
34623 C    * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
34624 C    *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
34625 C    *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
34626 C     WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
34627 C    * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
34628 C    *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
34629 C    *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
34630       ENDIF
34631       CHAMAL=CHAB1
34632       IF(IPIP.EQ.1)THEN
34633         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
34634       ELSEIF(IPIP.EQ.2)THEN
34635         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
34636       ENDIF
34637       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
34638 C       IREJ=1
34639         IPCO=0
34640 C       RETURN
34641 C       WRITE(6,*)' MUSQBS1 jump back from chain 9',
34642 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
34643         GO TO 3466
34644       ENDIF
34645       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
34646       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
34647       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
34648       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
34649       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
34650       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
34651       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
34652       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
34653 C
34654       IPCO=0
34655       IGCOUN=9+IIGLU1+IIGLU2
34656        RETURN
34657        END
34658 C
34659 C
34660 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
34661       SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
34662      *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
34663 C
34664 C                  GSQBS-2 diagram (split target diquark)
34665 C
34666       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34667       SAVE
34668
34669       PARAMETER ( LINP = 5 ,
34670      &            LOUT = 6 ,
34671      &            LDAT = 9 )
34672
34673 * event history
34674
34675       PARAMETER (NMXHKK=200000)
34676
34677       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
34678      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
34679      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
34680 * extended event history
34681       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
34682      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
34683      &                IHIST(2,NMXHKK)
34684 * Lorentz-parameters of the current interaction
34685       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
34686      &                UMO,PPCM,EPROJ,PPROJ
34687 * diquark-breaking mechanism
34688       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
34689
34690 C
34691       PARAMETER (NTMHKK= 300)
34692       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
34693      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
34694      +(4,NTMHKK)
34695
34696 *KEEP,XSEADI.
34697       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
34698      +SSMIMQ,VVMTHR
34699 *KEEP,DPRIN.
34700       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
34701 C
34702 C                  GSQBS-2 diagram (split target diquark)
34703 C
34704 C
34705 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
34706 C     Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
34707 C
34708 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
34709 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
34710 C
34711 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
34712 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34713 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
34714 C
34715 C
34716 C
34717 C       Put new chains into COMMON /HKKTMP/
34718 C
34719       IIGLU1=NC1T-NC1P-1
34720       IIGLU2=NC2T-NC2P-1
34721       IGCOUN=0
34722 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
34723       CVQ=1.D0
34724       IREJ=0
34725 C     IF(IPIP.EQ.2)THEN
34726 C     WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
34727 C    *             'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
34728 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
34729 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
34730 C     ENDIF
34731 C
34732 C
34733 C
34734 C     determine x-values of NC1T diquark
34735       XDIQT=PHKK(4,NC1T)*2.D0/UMO
34736       XVQP=PHKK(4,NC1P)*2.D0/UMO
34737 C
34738 C     determine x-values of sea quark pair
34739 C
34740       IPCO=1
34741       ICOU=0
34742  2234 CONTINUE
34743       ICOU=ICOU+1
34744       IF(ICOU.GE.500)THEN
34745         IREJ=1
34746         IF(ISQ.EQ.3)IREJ=3
34747         IF(IPCO.GE.3)
34748      &     WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
34749         IPCO=0
34750         RETURN
34751       ENDIF
34752       IF(IPCO.GE.3)
34753      &     WRITE(LOUT,*)'MGSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
34754      * UMO, XDIQT,XVQP
34755       XSQ=0.D0
34756       XSAQ=0.D0
34757 **NEW
34758 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
34759       IF (IPIP.EQ.1) THEN
34760          XQMAX  = XDIQT/2.0D0
34761          XAQMAX = 2.D0*XVQP/3.0D0
34762       ELSE
34763          XQMAX  = 2.D0*XVQP/3.0D0
34764          XAQMAX = XDIQT/2.0D0
34765       ENDIF
34766       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
34767       ISAQ = 6+ISQ
34768 C     write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
34769 **
34770         IF(IPCO.GE.3)
34771      &     WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
34772       IF(IREJ.GE.1)THEN
34773         IF(IPCO.GE.3)
34774      &     WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
34775         IPCO=0
34776         RETURN
34777       ENDIF
34778       IF(IPIP.EQ.1)THEN
34779         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
34780       ELSEIF(IPIP.EQ.2)THEN
34781         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
34782       ENDIF
34783       IF(IPCO.GE.3)THEN
34784         WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
34785      *  XDIQT,XVQP,XSQ,XSAQ
34786       ENDIF
34787 C
34788 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
34789 C
34790 C     XSQ=0.D0
34791       IF(IPIP.EQ.1)THEN
34792         XDIQT=XDIQT-XSQ
34793         XVQP =XVQP -XSAQ
34794       ELSEIF(IPIP.EQ.2)THEN
34795         XDIQT=XDIQT-XSAQ
34796         XVQP =XVQP -XSQ
34797       ENDIF
34798       IF(IPCO.GE.3)
34799      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
34800 C
34801 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
34802 C
34803       XVTHRO=CVQ/UMO
34804       IVTHR=0
34805  3466 CONTINUE
34806       IF(IVTHR.EQ.10)THEN
34807         IREJ=1
34808         IF(ISQ.EQ.3)IREJ=3
34809         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
34810         IPCO=0
34811         RETURN
34812       ENDIF
34813       IVTHR=IVTHR+1
34814       XVTHR=XVTHRO/(201-IVTHR)
34815       UNOPRV=UNON
34816  380  CONTINUE
34817       IF(XVTHR.GT.0.66D0*XDIQT)THEN
34818         IREJ=1
34819         IF(ISQ.EQ.3)IREJ=3
34820         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR  large ',
34821      *  XVTHR
34822         IPCO=0
34823         RETURN
34824       ENDIF
34825       IF(DT_RNDM(V).LT.0.5D0)THEN
34826         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
34827         XVTQII=XDIQT-XVTQI
34828       ELSE
34829         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
34830         XVTQI=XDIQT-XVTQII
34831       ENDIF
34832       IF(IPCO.GE.3)THEN
34833         WRITE(LOUT,'(A,2E12.4)')'  MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
34834       ENDIF
34835 C
34836 C     Prepare 4 momenta of new chains and chain ends
34837 C
34838 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
34839 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
34840 C    +(4,NTMHKK)
34841 C
34842 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
34843 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34844 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
34845 C
34846 C     SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
34847 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
34848 C
34849       IF(IPIP.EQ.1)THEN
34850         XSQ1=XSQ
34851         XSAQ1=XSAQ
34852         ISQ1=ISQ
34853         ISAQ1=ISAQ
34854       ELSEIF(IPIP.EQ.2)THEN
34855         XSQ1=XSAQ
34856         XSAQ1=XSQ
34857         ISQ1=ISAQ
34858         ISAQ1=ISQ
34859       ENDIF
34860       KK11=IP21
34861 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
34862       KK21=IPP11
34863       KK22=IPP12
34864       XGIVE=0.D0
34865       IF(IPIP.EQ.1)THEN
34866         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
34867       ELSEIF(IPIP.EQ.2)THEN
34868         IDHKT(4+IIGLU1)   =ISAQ1
34869       ENDIF
34870       ISTHKT(4+IIGLU1)  =961
34871       JMOHKT(1,4+IIGLU1)=NC1P
34872       JMOHKT(2,4+IIGLU1)=0
34873       JDAHKT(1,4+IIGLU1)=6+IIGLU1
34874       JDAHKT(2,4+IIGLU1)=0
34875 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34876       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
34877       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
34878       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
34879       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
34880 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
34881       XXMIST=(PHKT(4,4+IIGLU1)**2-
34882      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
34883      *PHKT(1,4+IIGLU1)**2)
34884       IF(XXMIST.GT.0.D0)THEN
34885         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
34886       ELSE
34887         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
34888         XXMIST=ABS(XXMIST)
34889         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
34890       ENDIF
34891       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
34892       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
34893       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
34894       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
34895       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
34896       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
34897       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
34898       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
34899       IDHKT(5+IIGLU1)   =IP22
34900       ISTHKT(5+IIGLU1)  =962
34901       JMOHKT(1,5+IIGLU1)=NC1T
34902       JMOHKT(2,5+IIGLU1)=0
34903       JDAHKT(1,5+IIGLU1)=6+IIGLU1
34904       JDAHKT(2,5+IIGLU1)=0
34905       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
34906       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
34907       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
34908       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
34909 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
34910       XXMIST=(PHKT(4,5+IIGLU1)**2-
34911      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
34912      *PHKT(1,5+IIGLU1)**2)
34913       IF(XXMIST.GT.0.D0)THEN
34914         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
34915       ELSE
34916         WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
34917         XXMIST=ABS(XXMIST)
34918         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
34919       ENDIF
34920       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
34921       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
34922       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
34923       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
34924       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
34925       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
34926       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
34927       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
34928       IDHKT(6+IIGLU1)   =88888
34929       ISTHKT(6+IIGLU1)  =96
34930       JMOHKT(1,6+IIGLU1)=4+IIGLU1
34931       JMOHKT(2,6+IIGLU1)=5+IIGLU1
34932       JDAHKT(1,6+IIGLU1)=0
34933       JDAHKT(2,6+IIGLU1)=0
34934       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
34935       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
34936       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
34937       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
34938       PHKT(5,6+IIGLU1)
34939      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
34940      *            -PHKT(3,6+IIGLU1)**2)
34941       CHAMAL=CHAM1
34942       IF(IPIP.EQ.1)THEN
34943         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
34944       ELSEIF(IPIP.EQ.2)THEN
34945         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
34946       ENDIF
34947 C---------------------------------------------------
34948       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
34949         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
34950 C                    we drop chain 6 and give the energy to chain 3
34951           IDHKT(6+IIGLU1)=22888
34952           XGIVE=1.D0
34953 C         WRITE(6,*)' drop chain 6 xgive=1'
34954           GO TO 7788
34955         ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
34956 C                    we drop chain 6 and give the energy to chain 3
34957 C                    and change KK11 to IDHKT(5)
34958           IDHKT(6+IIGLU1)=22888
34959           XGIVE=1.D0
34960 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
34961           KK11=IDHKT(5+IIGLU1)
34962           GO TO 7788
34963         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
34964 C                    we drop chain 6 and give the energy to chain 3
34965 C                    and change KK21 to IDHKT(5+IIGLU1)
34966 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
34967           IDHKT(6+IIGLU1)=22888
34968           XGIVE=1.D0
34969 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
34970           KK21=IDHKT(5+IIGLU1)
34971           GO TO 7788
34972         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
34973 C                    we drop chain 6 and give the energy to chain 3
34974 C                    and change KK22 to IDHKT(5)
34975 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
34976           IDHKT(6+IIGLU1)=22888
34977           XGIVE=1.D0
34978 C         WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
34979           KK22=IDHKT(5+IIGLU1)
34980           GO TO 7788
34981         ENDIF
34982 C       IREJ=1
34983         IPCO=0
34984 C       RETURN
34985         GO TO 3466
34986       ENDIF
34987  7788 CONTINUE
34988 C---------------------------------------------------
34989       IF(IPIP.GE.3)THEN
34990       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
34991      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
34992      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
34993       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
34994      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
34995      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
34996       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
34997      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
34998      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
34999       ENDIF
35000       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
35001       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
35002       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
35003       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
35004       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
35005       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
35006       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
35007       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
35008 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
35009       IF(IPIP.EQ.1)THEN
35010         IDHKT(1)   =1000*KK21+100*KK22+3
35011         IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
35012         IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
35013         IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
35014       ELSEIF(IPIP.EQ.2)THEN
35015         IDHKT(1)   =1000*KK21+100*KK22-3
35016         IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
35017         IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
35018         IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
35019       ENDIF
35020       ISTHKT(1)  =961
35021       JMOHKT(1,1)=NC2P
35022       JMOHKT(2,1)=0
35023       JDAHKT(1,1)=3+IIGLU1
35024       JDAHKT(2,1)=0
35025 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
35026       PHKT(1,1)  =PHKK(1,NC2P)
35027      *+XGIVE*PHKT(1,4+IIGLU1)
35028       PHKT(2,1)  =PHKK(2,NC2P)
35029      *+XGIVE*PHKT(2,4+IIGLU1)
35030       PHKT(3,1)  =PHKK(3,NC2P)
35031      *+XGIVE*PHKT(3,4+IIGLU1)
35032       PHKT(4,1)  =PHKK(4,NC2P)
35033      *+XGIVE*PHKT(4,4+IIGLU1)
35034 C     PHKT(5,1)  =PHKK(5,NC2P)
35035       XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35036      *PHKT(1,1)**2
35037       IF(XXMIST.GT.0.D0)THEN
35038         PHKT(5,1)  =SQRT(XXMIST)
35039       ELSE
35040         WRITE(LOUT,*)'MGSQBS2',XXMIST
35041         XXMIST=ABS(XXMIST)
35042         PHKT(5,1)  =SQRT(XXMIST)
35043       ENDIF
35044       VHKT(1,1)  =VHKK(1,NC2P)
35045       VHKT(2,1)  =VHKK(2,NC2P)
35046       VHKT(3,1)  =VHKK(3,NC2P)
35047       VHKT(4,1)  =VHKK(4,NC2P)
35048       WHKT(1,1)  =WHKK(1,NC2P)
35049       WHKT(2,1)  =WHKK(2,NC2P)
35050       WHKT(3,1)  =WHKK(3,NC2P)
35051       WHKT(4,1)  =WHKK(4,NC2P)
35052 C     Add here IIGLU1 gluons to this chaina
35053       PG1=0.D0
35054       PG2=0.D0
35055       PG3=0.D0
35056       PG4=0.D0
35057       IF(IIGLU1.GE.1)THEN
35058       JJG=NC1P
35059       DO 61 IIG=2,2+IIGLU1-1
35060         KKG=JJG+IIG-1
35061         IDHKT(IIG)   =IDHKK(KKG)
35062         ISTHKT(IIG)  =921
35063         JMOHKT(1,IIG)=KKG
35064         JMOHKT(2,IIG)=0
35065         JDAHKT(1,IIG)=3+IIGLU1
35066         JDAHKT(2,IIG)=0
35067         PHKT(1,IIG)=PHKK(1,KKG)
35068         PG1=PG1+ PHKT(1,IIG)
35069         PHKT(2,IIG)=PHKK(2,KKG)
35070         PG2=PG2+ PHKT(2,IIG)
35071         PHKT(3,IIG)=PHKK(3,KKG)
35072         PG3=PG3+ PHKT(3,IIG)
35073         PHKT(4,IIG)=PHKK(4,KKG)
35074         PG4=PG4+ PHKT(4,IIG)
35075         PHKT(5,IIG)=PHKK(5,KKG)
35076         VHKT(1,IIG)  =VHKK(1,KKG)
35077         VHKT(2,IIG)  =VHKK(2,KKG)
35078         VHKT(3,IIG)  =VHKK(3,KKG)
35079         VHKT(4,IIG)  =VHKK(4,KKG)
35080         WHKT(1,IIG)  =WHKK(1,KKG)
35081         WHKT(2,IIG)  =WHKK(2,KKG)
35082         WHKT(3,IIG)  =WHKK(3,KKG)
35083         WHKT(4,IIG)  =WHKK(4,KKG)
35084    61 CONTINUE
35085       ENDIF
35086 C     IDHKT(2)   =IP21
35087       IDHKT(2+IIGLU1)   =KK11
35088       ISTHKT(2+IIGLU1)  =962
35089       JMOHKT(1,2+IIGLU1)=NC1T
35090       JMOHKT(2,2+IIGLU1)=0
35091       JDAHKT(1,2+IIGLU1)=3+IIGLU1
35092       JDAHKT(2,2+IIGLU1)=0
35093       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
35094 C    * +0.5D0*PHKK(1,NC2T)
35095      *+XGIVE*PHKT(1,5+IIGLU1)
35096       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
35097 C    *+0.5D0*PHKK(2,NC2T)
35098      *+XGIVE*PHKT(2,5+IIGLU1)
35099       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
35100 C    *+0.5D0*PHKK(3,NC2T)
35101      *+XGIVE*PHKT(3,5+IIGLU1)
35102       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
35103 C    *+0.5D0*PHKK(4,NC2T)
35104      *+XGIVE*PHKT(4,5+IIGLU1)
35105 C     PHKT(5,2)  =PHKK(5,NC1T)
35106       XXMIST=(PHKT(4,2+IIGLU1)**2-
35107      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35108      *PHKT(1,2+IIGLU1)**2)
35109       IF(XXMIST.GT.0.D0)THEN
35110         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
35111       ELSE
35112         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
35113         XXMIST=ABS(XXMIST)
35114         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
35115       ENDIF
35116       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
35117       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
35118       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
35119       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
35120       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
35121       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
35122       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
35123       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
35124       IDHKT(3+IIGLU1)   =88888
35125       ISTHKT(3+IIGLU1)  =96
35126       JMOHKT(1,3+IIGLU1)=1
35127       JMOHKT(2,3+IIGLU1)=2+IIGLU1
35128       JDAHKT(1,3+IIGLU1)=0
35129       JDAHKT(2,3+IIGLU1)=0
35130       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
35131       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
35132       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
35133       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
35134       PHKT(5,3+IIGLU1)
35135      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35136      *            -PHKT(3,3+IIGLU1)**2)
35137       IF(IPIP.EQ.3)THEN
35138       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
35139      * JDAHKT(1,1),
35140      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
35141       DO 71 IIG=2,2+IIGLU1-1
35142       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35143      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
35144      * JDAHKT(1,IIG),
35145      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35146    71 CONTINUE
35147       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
35148      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
35149      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
35150       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
35151      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
35152      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
35153       ENDIF
35154       CHAMAL=CHAB1
35155       IF(IPIP.EQ.1)THEN
35156         IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
35157       ELSEIF(IPIP.EQ.2)THEN
35158         IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
35159       ENDIF
35160       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
35161 C       IREJ=1
35162         IPCO=0
35163 C       RETURN
35164         GO TO 3466
35165       ENDIF
35166       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
35167       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
35168       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
35169       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
35170       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
35171       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
35172       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
35173       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
35174 C     IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+1
35175       IDHKT(7+IIGLU1)   =IP1
35176       ISTHKT(7+IIGLU1)  =961
35177       JMOHKT(1,7+IIGLU1)=NC1P
35178       JMOHKT(2,7+IIGLU1)=0
35179       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
35180       JDAHKT(2,7+IIGLU1)=0
35181       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
35182       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
35183       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
35184       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
35185 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
35186       XXMIST=(PHKT(4,7+IIGLU1)**2-
35187      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
35188      *PHKT(1,7+IIGLU1)**2)
35189       IF(XXMIST.GT.0.D0)THEN
35190         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
35191       ELSE
35192         WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
35193         XXMIST=ABS(XXMIST)
35194         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
35195       ENDIF
35196       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
35197       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
35198       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
35199       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
35200       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
35201       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
35202       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
35203       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
35204 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
35205 C     Insert here the IIGLU2 gluons
35206       PG1=0.D0
35207       PG2=0.D0
35208       PG3=0.D0
35209       PG4=0.D0
35210       IF(IIGLU2.GE.1)THEN
35211       JJG=NC2P
35212       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
35213         KKG=JJG+IIG-7-IIGLU1
35214         IDHKT(IIG)   =IDHKK(KKG)
35215         ISTHKT(IIG)  =921
35216         JMOHKT(1,IIG)=KKG
35217         JMOHKT(2,IIG)=0
35218         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
35219         JDAHKT(2,IIG)=0
35220         PHKT(1,IIG)=PHKK(1,KKG)
35221         PG1=PG1+ PHKT(1,IIG)
35222         PHKT(2,IIG)=PHKK(2,KKG)
35223         PG2=PG2+ PHKT(2,IIG)
35224         PHKT(3,IIG)=PHKK(3,KKG)
35225         PG3=PG3+ PHKT(3,IIG)
35226         PHKT(4,IIG)=PHKK(4,KKG)
35227         PG4=PG4+ PHKT(4,IIG)
35228         PHKT(5,IIG)=PHKK(5,KKG)
35229         VHKT(1,IIG)  =VHKK(1,KKG)
35230         VHKT(2,IIG)  =VHKK(2,KKG)
35231         VHKT(3,IIG)  =VHKK(3,KKG)
35232         VHKT(4,IIG)  =VHKK(4,KKG)
35233         WHKT(1,IIG)  =WHKK(1,KKG)
35234         WHKT(2,IIG)  =WHKK(2,KKG)
35235         WHKT(3,IIG)  =WHKK(3,KKG)
35236         WHKT(4,IIG)  =WHKK(4,KKG)
35237    81 CONTINUE
35238       ENDIF
35239       IF(IPIP.EQ.1)THEN
35240         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
35241         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
35242         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
35243         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
35244       ELSEIF(IPIP.EQ.2)THEN
35245 **NEW
35246 C       IDHKT(8)   =1000*IPP2+100*(-ISQ1+6)-3
35247         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
35248 **
35249         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
35250         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
35251         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
35252       ENDIF
35253       ISTHKT(8+IIGLU1+IIGLU2)  =962
35254       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
35255       JMOHKT(2,8+IIGLU1+IIGLU2)=0
35256       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
35257       JDAHKT(2,8+IIGLU1+IIGLU2)=0
35258 C     PHKT(1,8)  =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
35259 C     PHKT(2,8)  =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
35260 C     PHKT(3,8)  =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
35261 C     PHKT(4,8)  =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
35262       PHKT(1,8+IIGLU1+IIGLU2)  =
35263      * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
35264       PHKT(2,8+IIGLU1+IIGLU2)  =
35265      * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
35266       PHKT(3,8+IIGLU1+IIGLU2)  =
35267      * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
35268       PHKT(4,8+IIGLU1+IIGLU2)  =
35269      * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
35270 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
35271 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
35272       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
35273 C       IREJ=1
35274 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
35275         IPCO=0
35276 C       RETURN
35277         GO TO 3466
35278       ENDIF
35279 C     PHKT(5,8)  =PHKK(5,NC2T)
35280       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
35281      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
35282      *PHKT(1,8+IIGLU1+IIGLU2)**2)
35283       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
35284       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
35285       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
35286       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
35287       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
35288       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
35289       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
35290       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
35291       IDHKT(9+IIGLU1+IIGLU2)   =88888
35292       ISTHKT(9+IIGLU1+IIGLU2)  =96
35293       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
35294       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
35295       JDAHKT(1,9+IIGLU1+IIGLU2)=0
35296       JDAHKT(2,9+IIGLU1+IIGLU2)=0
35297       PHKT(1,9+IIGLU1+IIGLU2)
35298      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
35299       PHKT(2,9+IIGLU1+IIGLU2)
35300      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
35301       PHKT(3,9+IIGLU1+IIGLU2)
35302      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
35303       PHKT(4,9+IIGLU1+IIGLU2)
35304      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
35305       PHKT(5,9+IIGLU1+IIGLU2)
35306      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
35307      * PHKT(2,9+IIGLU1+IIGLU2)**2
35308      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
35309       IF(IPIP.GE.3)THEN
35310       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
35311      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
35312      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
35313       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
35314       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35315      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
35316      * JDAHKT(1,IIG),
35317      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35318    91 CONTINUE
35319       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
35320      * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
35321      *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
35322      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
35323       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
35324      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
35325      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
35326      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
35327       ENDIF
35328       CHAMAL=CHAB1
35329       IF(IPIP.EQ.1)THEN
35330         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
35331       ELSEIF(IPIP.EQ.2)THEN
35332         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
35333       ENDIF
35334       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
35335 C       IREJ=1
35336         IPCO=0
35337 C       RETURN
35338         GO TO 3466
35339       ENDIF
35340       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
35341       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
35342       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
35343       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
35344       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
35345       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
35346       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
35347       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
35348 C
35349       IPCO=0
35350       IGCOUN=9+IIGLU1+IIGLU2
35351        RETURN
35352        END
35353 C
35354 C
35355 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
35356       SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35357      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
35358 C
35359 C                  USQBS-1 diagram (split projectile diquark)
35360 C
35361       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35362       SAVE
35363
35364       PARAMETER ( LINP = 5 ,
35365      &            LOUT = 6 ,
35366      &            LDAT = 9 )
35367
35368 * event history
35369
35370       PARAMETER (NMXHKK=200000)
35371
35372       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35373      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35374      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35375 * extended event history
35376       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35377      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35378      &                IHIST(2,NMXHKK)
35379 * Lorentz-parameters of the current interaction
35380       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
35381      &                UMO,PPCM,EPROJ,PPROJ
35382 * diquark-breaking mechanism
35383       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
35384
35385 C
35386       PARAMETER (NTMHKK= 300)
35387       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35388      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35389      +(4,NTMHKK)
35390 *KEEP,XSEADI.
35391       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
35392      +SSMIMQ,VVMTHR
35393 *KEEP,DPRIN.
35394       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
35395       COMMON /EVFLAG/ NUMEV
35396 C
35397 C                  USQBS-1 diagram (split projectile diquark)
35398 C
35399 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
35400 C     Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
35401 C
35402 C     Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
35403 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
35404 C
35405 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
35406 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
35407 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
35408 C
35409 C       Put new chains into COMMON /HKKTMP/
35410 C
35411       IIGLU1=NC1T-NC1P-1
35412       IIGLU2=NC2T-NC2P-1
35413       IGCOUN=0
35414 C     WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
35415       CVQ=1.D0
35416       IREJ=0
35417       IF(IPIP.EQ.3)THEN
35418 C     IF(NUMEV.EQ.-324)THEN
35419       WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
35420      *             ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
35421      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35422      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
35423       ENDIF
35424 C
35425 C
35426 C
35427 C     determine x-values of NC1P diquark
35428       XDIQP=PHKK(4,NC1P)*2.D0/UMO
35429       XVQT=PHKK(4,NC1T)*2.D0/UMO
35430 C
35431 C     determine x-values of sea quark pair
35432 C
35433       IPCO=1
35434       ICOU=0
35435  2234 CONTINUE
35436       ICOU=ICOU+1
35437       IF(ICOU.GE.500)THEN
35438         IREJ=1
35439         IF(ISQ.EQ.3)IREJ=3
35440         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
35441         IPCO=0
35442         RETURN
35443       ENDIF
35444       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
35445      * UMO, XDIQP,XVQT
35446       XSQ=0.D0
35447       XSAQ=0.D0
35448 **NEW
35449 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
35450       IF (IPIP.EQ.1) THEN
35451          XQMAX  = XDIQP/2.0D0
35452          XAQMAX = 2.D0*XVQT/3.0D0
35453       ELSE
35454          XQMAX  = 2.D0*XVQT/3.0D0
35455          XAQMAX = XDIQP/2.0D0
35456       ENDIF
35457       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
35458       ISAQ = 6+ISQ
35459 C     write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
35460 **
35461       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35462       IF(IREJ.GE.1)THEN
35463         IF(IPCO.GE.3)
35464      &     WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35465         IPCO=0
35466         RETURN
35467       ENDIF
35468       IF(IPIP.EQ.1)THEN
35469         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
35470       ELSEIF(IPIP.EQ.2)THEN
35471         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
35472       ENDIF
35473       IF(IPCO.GE.3)THEN
35474         WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
35475      *  XDIQP,XVQT,XSQ,XSAQ
35476       ENDIF
35477 C
35478 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
35479 C
35480 C     XSQ=0.D0
35481       IF(IPIP.EQ.1)THEN
35482         XDIQP=XDIQP-XSQ
35483         XVQT =XVQT -XSAQ
35484       ELSEIF(IPIP.EQ.2)THEN
35485         XDIQP=XDIQP-XSAQ
35486         XVQT =XVQT -XSQ
35487       ENDIF
35488       IF(IPCO.GE.3)
35489      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
35490 C
35491 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
35492 C
35493       XVTHRO=CVQ/UMO
35494       IVTHR=0
35495  3466 CONTINUE
35496       IF(IVTHR.EQ.10)THEN
35497         IREJ=1
35498         IF(ISQ.EQ.3)IREJ=3
35499         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
35500         IPCO=0
35501         RETURN
35502       ENDIF
35503       IVTHR=IVTHR+1
35504       XVTHR=XVTHRO/(201-IVTHR)
35505       UNOPRV=UNON
35506  380  CONTINUE
35507       IF(XVTHR.GT.0.66D0*XDIQP)THEN
35508         IREJ=1
35509         IF(ISQ.EQ.3)IREJ=3
35510         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR  large ',
35511      *  XVTHR
35512         IPCO=0
35513         RETURN
35514       ENDIF
35515       IF(DT_RNDM(V).LT.0.5D0)THEN
35516         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
35517         XVPQII=XDIQP-XVPQI
35518       ELSE
35519         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
35520         XVPQI=XDIQP-XVPQII
35521       ENDIF
35522       IF(IPCO.GE.3)THEN
35523         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
35524       ENDIF
35525 C
35526 C     Prepare 4 momenta of new chains and chain ends
35527 C
35528 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35529 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35530 C    +(4,NTMHKK)
35531 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
35532 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
35533 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
35534       IF(IPIP.EQ.1)THEN
35535         XSQ1=XSQ
35536         XSAQ1=XSAQ
35537         ISQ1=ISQ
35538         ISAQ1=ISAQ
35539       ELSEIF(IPIP.EQ.2)THEN
35540         XSQ1=XSAQ
35541         XSAQ1=XSQ
35542         ISQ1=ISAQ
35543         ISAQ1=ISQ
35544       ENDIF
35545       IDHKT(1)   =IP11
35546       ISTHKT(1)  =931
35547       JMOHKT(1,1)=NC1P
35548       JMOHKT(2,1)=0
35549       JDAHKT(1,1)=3+IIGLU1
35550       JDAHKT(2,1)=0
35551 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
35552       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
35553       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
35554       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
35555       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
35556 C     PHKT(5,1)  =PHKK(5,NC1P)
35557       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35558      *PHKT(1,1)**2)
35559       IF(XMIST.GE.0.D0)THEN
35560       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35561      *PHKT(1,1)**2)
35562       ELSE
35563 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
35564        PHKT(5,1)=0.D0
35565       ENDIF
35566       VHKT(1,1)  =VHKK(1,NC1P)
35567       VHKT(2,1)  =VHKK(2,NC1P)
35568       VHKT(3,1)  =VHKK(3,NC1P)
35569       VHKT(4,1)  =VHKK(4,NC1P)
35570       WHKT(1,1)  =WHKK(1,NC1P)
35571       WHKT(2,1)  =WHKK(2,NC1P)
35572       WHKT(3,1)  =WHKK(3,NC1P)
35573       WHKT(4,1)  =WHKK(4,NC1P)
35574 C     Add here IIGLU1 gluons to this chaina
35575       PG1=0.D0
35576       PG2=0.D0
35577       PG3=0.D0
35578       PG4=0.D0
35579       IF(IIGLU1.GE.1)THEN
35580       JJG=NC1P
35581       DO 61 IIG=2,2+IIGLU1-1
35582         KKG=JJG+IIG-1
35583         IDHKT(IIG)   =IDHKK(KKG)
35584         ISTHKT(IIG)  =921
35585         JMOHKT(1,IIG)=KKG
35586         JMOHKT(2,IIG)=0
35587         JDAHKT(1,IIG)=3+IIGLU1
35588         JDAHKT(2,IIG)=0
35589         PHKT(1,IIG)=PHKK(1,KKG)
35590         PG1=PG1+ PHKT(1,IIG)
35591         PHKT(2,IIG)=PHKK(2,KKG)
35592         PG2=PG2+ PHKT(2,IIG)
35593         PHKT(3,IIG)=PHKK(3,KKG)
35594         PG3=PG3+ PHKT(3,IIG)
35595         PHKT(4,IIG)=PHKK(4,KKG)
35596         PG4=PG4+ PHKT(4,IIG)
35597         PHKT(5,IIG)=PHKK(5,KKG)
35598         VHKT(1,IIG)  =VHKK(1,KKG)
35599         VHKT(2,IIG)  =VHKK(2,KKG)
35600         VHKT(3,IIG)  =VHKK(3,KKG)
35601         VHKT(4,IIG)  =VHKK(4,KKG)
35602         WHKT(1,IIG) =WHKK(1,KKG)
35603         WHKT(2,IIG) =WHKK(2,KKG)
35604         WHKT(3,IIG) =WHKK(3,KKG)
35605         WHKT(4,IIG) =WHKK(4,KKG)
35606    61 CONTINUE
35607       ENDIF
35608       IDHKT(2+IIGLU1)   =IPP2
35609       ISTHKT(2+IIGLU1)  =932
35610       JMOHKT(1,2+IIGLU1)=NC2T
35611       JMOHKT(2,2+IIGLU1)=0
35612       JDAHKT(1,2+IIGLU1)=3+IIGLU1
35613       JDAHKT(2,2+IIGLU1)=0
35614       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
35615       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
35616       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
35617       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
35618 C     PHKT(5,2+IIGLU1)  =PHKK(5,NC2T)
35619       XMIST=(PHKT(4,2+IIGLU1)**2-
35620      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35621      *PHKT(1,2+IIGLU1)**2)
35622       IF(XMIST.GT.0.D0)THEN
35623       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
35624      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35625      *PHKT(1,2+IIGLU1)**2)
35626       ELSE
35627 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
35628         PHKT(5,2+IIGLU1)=0.D0
35629       ENDIF
35630       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
35631       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
35632       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
35633       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
35634       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
35635       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
35636       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
35637       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
35638       IDHKT(3+IIGLU1)   =88888
35639       ISTHKT(3+IIGLU1)  =94
35640       JMOHKT(1,3+IIGLU1)=1
35641       JMOHKT(2,3+IIGLU1)=2+IIGLU1
35642       JDAHKT(1,3+IIGLU1)=0
35643       JDAHKT(2,3+IIGLU1)=0
35644       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
35645       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
35646       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
35647       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
35648       XMIST
35649      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35650      *            -PHKT(3,3+IIGLU1)**2)
35651       IF(XMIST.GE.0.D0)THEN
35652       PHKT(5,3+IIGLU1)
35653      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35654      *            -PHKT(3,3+IIGLU1)**2)
35655       ELSE
35656 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
35657        PHKT(5,1)=0.D0
35658       ENDIF
35659       IF(IPIP.GE.3)THEN
35660 C     IF(NUMEV.EQ.-324)THEN
35661       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
35662      * JMOHKT(2,1),JDAHKT(1,1),
35663      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
35664       DO 71 IIG=2,2+IIGLU1-1
35665       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35666      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
35667      * JDAHKT(1,IIG),
35668      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35669    71 CONTINUE
35670       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
35671      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
35672      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
35673       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
35674      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
35675      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
35676       ENDIF
35677       CHAMAL=CHAM1
35678       IF(IPIP.EQ.1)THEN
35679         IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
35680       ELSEIF(IPIP.EQ.2)THEN
35681         IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
35682       ENDIF
35683       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
35684 C       IREJ=1
35685         IPCO=0
35686 C       RETURN
35687 C       WRITE(6,*)' MUSQBS1 jump back from chain 3'
35688         GO TO 3466
35689       ENDIF
35690       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
35691       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
35692       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
35693       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
35694       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
35695       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
35696       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
35697       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
35698       IDHKT(4+IIGLU1)   =IP12
35699       ISTHKT(4+IIGLU1)  =931
35700       JMOHKT(1,4+IIGLU1)=NC1P
35701       JMOHKT(2,4+IIGLU1)=0
35702       JDAHKT(1,4+IIGLU1)=6+IIGLU1
35703       JDAHKT(2,4+IIGLU1)=0
35704 C   create  chain   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
35705       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
35706       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
35707       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
35708       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
35709 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
35710       XMIST  =(PHKT(4,4+IIGLU1)**2-
35711      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
35712      *PHKT(1,4+IIGLU1)**2)
35713       IF(XMIST.GT.0.D0)THEN
35714       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
35715      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
35716      *PHKT(1,4+IIGLU1)**2)
35717       ELSE
35718 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
35719         PHKT(5,4+IIGLU1)=0.D0
35720       ENDIF
35721       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
35722       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
35723       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
35724       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
35725       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
35726       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
35727       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
35728       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
35729       IF(IPIP.EQ.1)THEN
35730         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
35731       ELSEIF(IPIP.EQ.2)THEN
35732         IDHKT(5+IIGLU1)   =ISAQ1
35733       ENDIF
35734       ISTHKT(5+IIGLU1)  =932
35735       JMOHKT(1,5+IIGLU1)=NC1T
35736       JMOHKT(2,5+IIGLU1)=0
35737       JDAHKT(1,5+IIGLU1)=6+IIGLU1
35738       JDAHKT(2,5+IIGLU1)=0
35739       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
35740       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
35741       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
35742       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
35743 C     IF( PHKT(4,5).EQ.0.D0)THEN
35744 C       IREJ=1
35745 CIPCO=0
35746 CRETURN
35747 C     ENDIF
35748 C     PHKT(5,5)  =PHKK(5,NC1T)
35749       XMIST=(PHKT(4,5+IIGLU1)**2-
35750      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
35751      *PHKT(1,5+IIGLU1)**2)
35752       IF(XMIST.GT.0.D0)THEN
35753       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
35754      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
35755      *PHKT(1,5+IIGLU1)**2)
35756       ELSE
35757 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
35758         PHKT(5,5+IIGLU1)=0.D0
35759       ENDIF
35760       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
35761       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
35762       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
35763       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
35764       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
35765       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
35766       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
35767       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
35768       IDHKT(6+IIGLU1)   =88888
35769       ISTHKT(6+IIGLU1)  =94
35770       JMOHKT(1,6+IIGLU1)=4+IIGLU1
35771       JMOHKT(2,6+IIGLU1)=5+IIGLU1
35772       JDAHKT(1,6+IIGLU1)=0
35773       JDAHKT(2,6+IIGLU1)=0
35774       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
35775       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
35776       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
35777       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
35778       XMIST
35779      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
35780      *            -PHKT(3,6+IIGLU1)**2)
35781       IF(XMIST.GE.0.D0)THEN
35782       PHKT(5,6+IIGLU1)
35783      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
35784      *            -PHKT(3,6+IIGLU1)**2)
35785       ELSE
35786 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
35787        PHKT(5,1)=0.D0
35788       ENDIF
35789 C     IF(IPIP.EQ.3)THEN
35790       CHAMAL=CHAM1
35791       IF(IPIP.EQ.1)THEN
35792         IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
35793       ELSEIF(IPIP.EQ.2)THEN
35794         IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
35795       ENDIF
35796       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
35797 C       IREJ=1
35798         IPCO=0
35799 C       RETURN
35800 C       WRITE(6,*)' MGSQBS1 jump back from chain 6',
35801 C    *  CHAMAL,PHKT(5,6+IIGLU1)
35802         GO TO 3466
35803       ENDIF
35804       IF(IPIP.GE.3)THEN
35805 C     IF(NUMEV.EQ.-324)THEN
35806       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
35807      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
35808      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
35809       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
35810      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
35811      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
35812       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
35813      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
35814      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
35815       ENDIF
35816       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
35817       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
35818       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
35819       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
35820       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
35821       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
35822       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
35823       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
35824       IF(IPIP.EQ.1)THEN
35825         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+3
35826         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
35827         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
35828         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
35829       ELSEIF(IPIP.EQ.2)THEN
35830         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
35831         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
35832         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
35833         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
35834 C       WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
35835       ENDIF
35836       ISTHKT(7+IIGLU1)  =931
35837       JMOHKT(1,7+IIGLU1)=NC2P
35838       JMOHKT(2,7+IIGLU1)=0
35839       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
35840       JDAHKT(2,7+IIGLU1)=0
35841 C    create chain     9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
35842       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
35843       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
35844       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
35845       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
35846 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
35847 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
35848       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
35849 C       IREJ=1
35850 C       WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
35851         IPCO=0
35852 C       RETURN
35853         GO TO 3466
35854       ENDIF
35855 C     PHKT(5,7)  =PHKK(5,NC2P)
35856       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
35857      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
35858      *PHKT(1,7+IIGLU1)**2)
35859       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
35860       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
35861       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
35862       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
35863       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
35864       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
35865       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
35866       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
35867 C     Insert here the IIGLU2 gluons
35868       PG1=0.D0
35869       PG2=0.D0
35870       PG3=0.D0
35871       PG4=0.D0
35872       IF(IIGLU2.GE.1)THEN
35873       JJG=NC2P
35874       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
35875         KKG=JJG+IIG-7-IIGLU1
35876         IDHKT(IIG)   =IDHKK(KKG)
35877         ISTHKT(IIG)  =921
35878         JMOHKT(1,IIG)=KKG
35879         JMOHKT(2,IIG)=0
35880         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
35881         JDAHKT(2,IIG)=0
35882         PHKT(1,IIG)=PHKK(1,KKG)
35883         PG1=PG1+ PHKT(1,IIG)
35884         PHKT(2,IIG)=PHKK(2,KKG)
35885         PG2=PG2+ PHKT(2,IIG)
35886         PHKT(3,IIG)=PHKK(3,KKG)
35887         PG3=PG3+ PHKT(3,IIG)
35888         PHKT(4,IIG)=PHKK(4,KKG)
35889         PG4=PG4+ PHKT(4,IIG)
35890         PHKT(5,IIG)=PHKK(5,KKG)
35891         VHKT(1,IIG)  =VHKK(1,KKG)
35892         VHKT(2,IIG)  =VHKK(2,KKG)
35893         VHKT(3,IIG)  =VHKK(3,KKG)
35894         VHKT(4,IIG)  =VHKK(4,KKG)
35895         WHKT(1,IIG)  =WHKK(1,KKG)
35896         WHKT(2,IIG) =WHKK(2,KKG)
35897         WHKT(3,IIG) =WHKK(3,KKG)
35898         WHKT(4,IIG) =WHKK(4,KKG)
35899    81 CONTINUE
35900       ENDIF
35901       IDHKT(8+IIGLU1+IIGLU2)   =IP2
35902       ISTHKT(8+IIGLU1+IIGLU2)  =932
35903       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
35904       JMOHKT(2,8+IIGLU1+IIGLU2)=0
35905       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
35906       JDAHKT(2,8+IIGLU1+IIGLU2)=0
35907       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
35908       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
35909       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
35910       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
35911 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
35912       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
35913      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
35914      *PHKT(1,8+IIGLU1+IIGLU2)**2)
35915       IF(XMIST.GT.0.D0)THEN
35916       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
35917      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
35918      *PHKT(1,8+IIGLU1+IIGLU2)**2)
35919       ELSE
35920 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
35921         PHKT(5,8+IIGLU1+IIGLU2)=0.D0
35922       ENDIF
35923       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
35924       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
35925       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
35926       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
35927       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
35928       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
35929       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
35930       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
35931       IDHKT(9+IIGLU1+IIGLU2)   =88888
35932       ISTHKT(9+IIGLU1+IIGLU2)  =94
35933       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
35934       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
35935       JDAHKT(1,9+IIGLU1+IIGLU2)=0
35936       JDAHKT(2,9+IIGLU1+IIGLU2)=0
35937       PHKT(1,9+IIGLU1+IIGLU2)
35938      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
35939       PHKT(2,9+IIGLU1+IIGLU2)
35940      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
35941       PHKT(3,9+IIGLU1+IIGLU2)
35942      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
35943       PHKT(4,9+IIGLU1+IIGLU2)
35944      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
35945       XMIST
35946      *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
35947      * -PHKT(2,9+IIGLU1+IIGLU2)**2
35948      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
35949       IF(XMIST.GE.0.D0)THEN
35950       PHKT(5,9+IIGLU1+IIGLU2)
35951      *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
35952      * -PHKT(2,9+IIGLU1+IIGLU2)**2
35953      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
35954       ELSE
35955 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
35956        PHKT(5,1)=0.D0
35957       ENDIF
35958       IF(IPIP.GE.3)THEN
35959 C     IF(NUMEV.EQ.-324)THEN
35960       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
35961      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
35962      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
35963       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
35964       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35965      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
35966      * JDAHKT(1,IIG),
35967      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35968    91 CONTINUE
35969       WRITE(LOUT,*)8+IIGLU1+IIGLU2,
35970      * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
35971      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
35972      *JDAHKT(1,8+IIGLU1+IIGLU2),
35973      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
35974       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
35975      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
35976      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
35977      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
35978       ENDIF
35979       CHAMAL=CHAB1
35980       IF(IPIP.EQ.1)THEN
35981         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
35982       ELSEIF(IPIP.EQ.2)THEN
35983         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
35984       ENDIF
35985       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
35986 C       IREJ=1
35987         IPCO=0
35988 C       RETURN
35989 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
35990 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
35991         GO TO 3466
35992       ENDIF
35993       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
35994       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
35995       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
35996       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
35997       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
35998       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
35999       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
36000       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
36001 C
36002       IPCO=0
36003       IGCOUN=9+IIGLU1+IIGLU2
36004        RETURN
36005        END
36006 C
36007 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36008       SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36009      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
36010 C
36011 C                  GSQBS-1 diagram (split projectile diquark)
36012 C
36013       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36014       SAVE
36015
36016       PARAMETER ( LINP = 5 ,
36017      &            LOUT = 6 ,
36018      &            LDAT = 9 )
36019
36020 * event history
36021
36022       PARAMETER (NMXHKK=200000)
36023
36024       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36025      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36026      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36027 * extended event history
36028       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36029      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36030      &                IHIST(2,NMXHKK)
36031 * Lorentz-parameters of the current interaction
36032       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
36033      &                UMO,PPCM,EPROJ,PPROJ
36034 * diquark-breaking mechanism
36035       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36036
36037 C
36038       PARAMETER (NTMHKK= 300)
36039       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36040      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36041      +(4,NTMHKK)
36042 *KEEP,XSEADI.
36043       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
36044      +SSMIMQ,VVMTHR
36045 *KEEP,DPRIN.
36046       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
36047 C
36048 C                  GSQBS-1 diagram (split projectile diquark)
36049 C
36050 C
36051 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
36052 C     Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
36053 C
36054 C     Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
36055 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
36056 C
36057 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
36058 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
36059 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
36060 C
36061 C       Put new chains into COMMON /HKKTMP/
36062 C
36063       IIGLU1=NC1T-NC1P-1
36064       IIGLU2=NC2T-NC2P-1
36065       IGCOUN=0
36066 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
36067       CVQ=1.D0
36068       NNNC1=IDHKK(NC1)/1000
36069       MMMC1=IDHKK(NC1)-NNNC1*1000
36070       KKKC1=ISTHKK(NC1)
36071       NNNC2=IDHKK(NC2)/1000
36072       MMMC2=IDHKK(NC2)-NNNC2*1000
36073       KKKC2=ISTHKK(NC2)
36074       IREJ=0
36075       IF(IPIP.EQ.3)THEN
36076       WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
36077      *             ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
36078      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36079      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
36080       ENDIF
36081 C
36082 C
36083 C
36084 C     determine x-values of NC1P diquark
36085       XDIQP=PHKK(4,NC1P)*2.D0/UMO
36086       XVQT=PHKK(4,NC1T)*2.D0/UMO
36087 C
36088 C     determine x-values of sea quark pair
36089 C
36090       IPCO=1
36091       ICOU=0
36092  2234 CONTINUE
36093       ICOU=ICOU+1
36094       IF(ICOU.GE.500)THEN
36095         IREJ=1
36096         IF(ISQ.EQ.3)IREJ=3
36097         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
36098       IPCO=0
36099         RETURN
36100       ENDIF
36101       IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
36102      * UMO, XDIQP,XVQT
36103       XSQ=0.D0
36104       XSAQ=0.D0
36105 **NEW
36106 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
36107       IF (IPIP.EQ.1) THEN
36108          XQMAX  = XDIQP/2.0D0
36109          XAQMAX = 2.D0*XVQT/3.0D0
36110       ELSE
36111          XQMAX  = 2.D0*XVQT/3.0D0
36112          XAQMAX = XDIQP/2.0D0
36113       ENDIF
36114       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
36115       ISAQ = 6+ISQ
36116 C     write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
36117 **
36118         IF(IPCO.GE.3)
36119      &     WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36120       IF(IREJ.GE.1)THEN
36121         IF(IPCO.GE.3)
36122      &     WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36123       IPCO=0
36124         RETURN
36125       ENDIF
36126       IF(IPIP.EQ.1)THEN
36127         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
36128       ELSEIF(IPIP.EQ.2)THEN
36129         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
36130       ENDIF
36131       IF(IPCO.GE.3)THEN
36132         WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
36133      *  XDIQP,XVQT,XSQ,XSAQ
36134       ENDIF
36135 C
36136 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
36137 C
36138 C     XSQ=0.D0
36139       IF(IPIP.EQ.1)THEN
36140         XDIQP=XDIQP-XSQ
36141 **NEW
36142 C       IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
36143 **
36144         XVQT =XVQT -XSAQ
36145       ELSEIF(IPIP.EQ.2)THEN
36146         XDIQP=XDIQP-XSAQ
36147         XVQT =XVQT -XSQ
36148       ENDIF
36149       IF(IPCO.GE.3)
36150      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
36151 C
36152 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
36153 C
36154       XVTHRO=CVQ/UMO
36155       IVTHR=0
36156  3466 CONTINUE
36157       IF(IVTHR.EQ.10)THEN
36158         IREJ=1
36159         IF(ISQ.EQ.3)IREJ=3
36160         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
36161       IPCO=0
36162         RETURN
36163       ENDIF
36164       IVTHR=IVTHR+1
36165       XVTHR=XVTHRO/(201-IVTHR)
36166       UNOPRV=UNON
36167  380  CONTINUE
36168       IF(XVTHR.GT.0.66D0*XDIQP)THEN
36169         IREJ=1
36170         IF(ISQ.EQ.3)IREJ=3
36171         IF(IPCO.GE.3)
36172      &     WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR  large ',
36173      *  XVTHR
36174       IPCO=0
36175         RETURN
36176       ENDIF
36177       IF(DT_RNDM(V).LT.0.5D0)THEN
36178         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
36179         XVPQII=XDIQP-XVPQI
36180       ELSE
36181         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
36182         XVPQI=XDIQP-XVPQII
36183       ENDIF
36184       IF(IPCO.GE.3)THEN
36185         WRITE(LOUT,'(A,4E12.4)')'  MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
36186      *  XVTHR,XDIQP,XVPQI,XVPQII
36187       ENDIF
36188 C
36189 C     Prepare 4 momenta of new chains and chain ends
36190 C
36191 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36192 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36193 C    +(4,NTMHKK)
36194 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
36195 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
36196 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
36197       IF(IPIP.EQ.1)THEN
36198         XSQ1=XSQ
36199         XSAQ1=XSAQ
36200         ISQ1=ISQ
36201         ISAQ1=ISAQ
36202       ELSEIF(IPIP.EQ.2)THEN
36203         XSQ1=XSAQ
36204         XSAQ1=XSQ
36205         ISQ1=ISAQ
36206         ISAQ1=ISQ
36207       ENDIF
36208       KK11=IP11
36209 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
36210       KK21= IPP21
36211       KK22= IPP22
36212       XGIVE=0.D0
36213       IDHKT(4+IIGLU1)   =IP12
36214       ISTHKT(4+IIGLU1)  =921
36215       JMOHKT(1,4+IIGLU1)=NC1P
36216       JMOHKT(2,4+IIGLU1)=0
36217       JDAHKT(1,4+IIGLU1)=6+IIGLU1
36218       JDAHKT(2,4+IIGLU1)=0
36219 **NEW
36220       IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
36221      &    (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
36222 **
36223       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
36224       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
36225       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
36226       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
36227 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
36228       XXMIST=(PHKT(4,4+IIGLU1)**2-
36229      *              PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36230      *              PHKT(1,4+IIGLU1)**2)
36231       IF(XXMIST.GT.0.D0)THEN
36232         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
36233       ELSE
36234         WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
36235         XXMIST=ABS(XXMIST)
36236         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
36237       ENDIF
36238       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
36239       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
36240       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
36241       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
36242       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
36243       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
36244       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
36245       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
36246       IF(IPIP.EQ.1)THEN
36247         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
36248       ELSEIF(IPIP.EQ.2)THEN
36249         IDHKT(5+IIGLU1)   =ISAQ1
36250       ENDIF
36251       ISTHKT(5+IIGLU1)  =922
36252       JMOHKT(1,5+IIGLU1)=NC1T
36253       JMOHKT(2,5+IIGLU1)=0
36254       JDAHKT(1,5+IIGLU1)=6+IIGLU1
36255       JDAHKT(2,5+IIGLU1)=0
36256 **NEW
36257       IF ((XSAQ1.LT.0.0D0).OR.(XVQT  .LT.0.0D0))
36258      &    WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
36259 **
36260       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
36261       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
36262       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
36263       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
36264 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
36265       XMIST=(PHKT(4,5+IIGLU1)**2-
36266      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36267      *PHKT(1,5+IIGLU1)**2)
36268       IF(XMIST.GT.0.D0)THEN
36269       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
36270      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36271      *PHKT(1,5+IIGLU1)**2)
36272       ELSE
36273 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36274         PHKT(5,5+IIGLU1)=0.D0
36275       ENDIF
36276       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
36277       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
36278       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
36279       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
36280       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
36281       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
36282       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
36283       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
36284       IDHKT(6+IIGLU1)   =88888
36285 C     IDHKT(6)   =1000*NNNC1+MMMC1
36286       ISTHKT(6+IIGLU1)  =93
36287 C     ISTHKT(6)  =KKKC1
36288       JMOHKT(1,6+IIGLU1)=4+IIGLU1
36289       JMOHKT(2,6+IIGLU1)=5+IIGLU1
36290       JDAHKT(1,6+IIGLU1)=0
36291       JDAHKT(2,6+IIGLU1)=0
36292       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36293       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36294       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36295       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36296       PHKT(5,6+IIGLU1)
36297      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36298      *            -PHKT(3,6+IIGLU1)**2)
36299       CHAMAL=CHAM1
36300       IF(IPIP.EQ.1)THEN
36301         IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
36302       ELSEIF(IPIP.EQ.2)THEN
36303         IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
36304       ENDIF
36305       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36306         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
36307 C                    we drop chain 6 and give the energy to chain 3
36308           IDHKT(6+IIGLU1)=33888
36309           XGIVE=1.D0
36310 C         WRITE(6,*)' drop chain 6 xgive=1'
36311           GO TO 7788
36312         ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
36313 C                    we drop chain 6 and give the energy to chain 3
36314 C                    and change KK11 to IDHKT(4)
36315           IDHKT(6+IIGLU1)=33888
36316           XGIVE=1.D0
36317 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
36318           KK11=IDHKT(4+IIGLU1)
36319           GO TO 7788
36320         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
36321 C                    we drop chain 6 and give the energy to chain 3
36322 C                    and change KK21 to IDHKT(4)
36323 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
36324           IDHKT(6+IIGLU1)=33888
36325           XGIVE=1.D0
36326 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
36327           KK21=IDHKT(4+IIGLU1)
36328           GO TO 7788
36329         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
36330 C                    we drop chain 6 and give the energy to chain 3
36331 C                    and change KK22 to IDHKT(4)
36332 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
36333           IDHKT(6+IIGLU1)=33888
36334           XGIVE=1.D0
36335 C         WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
36336           KK22=IDHKT(4+IIGLU1)
36337           GO TO 7788
36338         ENDIF
36339 C       IREJ=1
36340         IPCO=0
36341 C       RETURN
36342 C       WRITE(6,*)' MGSQBS1 jump back from chain 6'
36343         GO TO 3466
36344       ENDIF
36345  7788 CONTINUE
36346       IF(IPIP.GE.3)THEN
36347       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36348      * JMOHKT(1,4+IIGLU1),
36349      * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36350      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36351       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36352      * JMOHKT(1,5+IIGLU1),
36353      * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36354      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36355       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36356      * JMOHKT(1,6+IIGLU1),
36357      * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36358      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36359       ENDIF
36360       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
36361       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
36362       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
36363       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
36364       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
36365       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
36366       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
36367       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
36368 C     IDHKT(1)   =IP11
36369       IDHKT(1)   =KK11
36370       ISTHKT(1)  =921
36371       JMOHKT(1,1)=NC1P
36372       JMOHKT(2,1)=0
36373       JDAHKT(1,1)=3+IIGLU1
36374       JDAHKT(2,1)=0
36375       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
36376 C    * +0.5D0*PHKK(1,NC2P)
36377      *+XGIVE*PHKT(1,4+IIGLU1)
36378       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
36379 C    * +0.5D0*PHKK(2,NC2P)
36380      *+XGIVE*PHKT(2,4+IIGLU1)
36381       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
36382 C    * +0.5D0*PHKK(3,NC2P)
36383      *+XGIVE*PHKT(3,4+IIGLU1)
36384       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
36385 C    * +0.5D0*PHKK(4,NC2P)
36386      *+XGIVE*PHKT(4,4+IIGLU1)
36387 C     PHKT(5,1)  =PHKK(5,NC1P)
36388       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
36389      *PHKT(1,1)**2)
36390       IF(XMIST.GE.0.D0)THEN
36391       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
36392      *PHKT(1,1)**2)
36393       ELSE
36394 C      WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
36395        PHKT(5,1)=0.D0
36396       ENDIF
36397       VHKT(1,1)  =VHKK(1,NC1P)
36398       VHKT(2,1)  =VHKK(2,NC1P)
36399       VHKT(3,1)  =VHKK(3,NC1P)
36400       VHKT(4,1)  =VHKK(4,NC1P)
36401       WHKT(1,1)  =WHKK(1,NC1P)
36402       WHKT(2,1)  =WHKK(2,NC1P)
36403       WHKT(3,1)  =WHKK(3,NC1P)
36404       WHKT(4,1)  =WHKK(4,NC1P)
36405 C     Add here IIGLU1 gluons to this chaina
36406       PG1=0.D0
36407       PG2=0.D0
36408       PG3=0.D0
36409       PG4=0.D0
36410       IF(IIGLU1.GE.1)THEN
36411       JJG=NC1P
36412       DO 61 IIG=2,2+IIGLU1-1
36413         KKG=JJG+IIG-1
36414         IDHKT(IIG)   =IDHKK(KKG)
36415         ISTHKT(IIG)  =921
36416         JMOHKT(1,IIG)=KKG
36417         JMOHKT(2,IIG)=0
36418         JDAHKT(1,IIG)=3+IIGLU1
36419         JDAHKT(2,IIG)=0
36420         PHKT(1,IIG)=PHKK(1,KKG)
36421         PG1=PG1+ PHKT(1,IIG)
36422         PHKT(2,IIG)=PHKK(2,KKG)
36423         PG2=PG2+ PHKT(2,IIG)
36424         PHKT(3,IIG)=PHKK(3,KKG)
36425         PG3=PG3+ PHKT(3,IIG)
36426         PHKT(4,IIG)=PHKK(4,KKG)
36427         PG4=PG4+ PHKT(4,IIG)
36428         PHKT(5,IIG)=PHKK(5,KKG)
36429         VHKT(1,IIG)  =VHKK(1,KKG)
36430         VHKT(2,IIG)  =VHKK(2,KKG)
36431         VHKT(3,IIG)  =VHKK(3,KKG)
36432         VHKT(4,IIG)  =VHKK(4,KKG)
36433         WHKT(1,IIG)  =WHKK(1,KKG)
36434         WHKT(2,IIG)  =WHKK(2,KKG)
36435         WHKT(3,IIG)  =WHKK(3,KKG)
36436         WHKT(4,IIG)  =WHKK(4,KKG)
36437    61 CONTINUE
36438       ENDIF
36439 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
36440       IF(IPIP.EQ.1)THEN
36441         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22+3
36442         IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
36443         IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
36444         IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
36445       ELSEIF(IPIP.EQ.2)THEN
36446         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22-3
36447         IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
36448         IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
36449         IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
36450       ENDIF
36451       ISTHKT(2+IIGLU1)  =922
36452       JMOHKT(1,2+IIGLU1)=NC2T
36453       JMOHKT(2,2+IIGLU1)=0
36454       JDAHKT(1,2+IIGLU1)=3+IIGLU1
36455       JDAHKT(2,2+IIGLU1)=0
36456       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
36457      *+XGIVE*PHKT(1,5+IIGLU1)
36458       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
36459      *+XGIVE*PHKT(2,5+IIGLU1)
36460       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
36461      *+XGIVE*PHKT(3,5+IIGLU1)
36462       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
36463      *+XGIVE*PHKT(4,5+IIGLU1)
36464 C     PHKT(5,2)  =PHKK(5,NC2T)
36465       XMIST=(PHKT(4,2+IIGLU1)**2-
36466      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
36467      *PHKT(1,2+IIGLU1)**2)
36468       IF(XMIST.GT.0.D0)THEN
36469       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
36470      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
36471      *PHKT(1,2+IIGLU1)**2)
36472       ELSE
36473 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
36474       PHKT(5,2+IIGLU1)=0.D0
36475       ENDIF
36476       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
36477       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
36478       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
36479       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
36480       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
36481       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
36482       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
36483       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
36484       IDHKT(3+IIGLU1)   =88888
36485 C     IDHKT(3)   =1000*NNNC1+MMMC1+10
36486       ISTHKT(3+IIGLU1)  =93
36487 C     ISTHKT(3)  =KKKC1
36488       JMOHKT(1,3+IIGLU1)=1
36489       JMOHKT(2,3+IIGLU1)=2+IIGLU1
36490       JDAHKT(1,3+IIGLU1)=0
36491       JDAHKT(2,3+IIGLU1)=0
36492       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
36493       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
36494       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
36495       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
36496       PHKT(5,3+IIGLU1)
36497      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
36498      *            -PHKT(3,3+IIGLU1)**2)
36499       IF(IPIP.GE.3)THEN
36500       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
36501      * JDAHKT(1,1),
36502      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
36503       DO 71 IIG=2,2+IIGLU1-1
36504       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36505      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
36506      * JDAHKT(1,IIG),
36507      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36508    71 CONTINUE
36509       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
36510      &             IDHKT(2),JMOHKT(1,2+IIGLU1),
36511      * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
36512      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
36513       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
36514      * JMOHKT(1,3+IIGLU1),
36515      * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
36516      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
36517       ENDIF
36518       CHAMAL=CHAB1
36519 **NEW
36520 C     IF(IPIP.EQ.1)THEN
36521 C       IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
36522 C     ELSEIF(IPIP.EQ.2)THEN
36523 C       IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
36524 C     ENDIF
36525       IF(IPIP.EQ.1)THEN
36526         IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
36527       ELSEIF(IPIP.EQ.2)THEN
36528         IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
36529       ENDIF
36530 **
36531       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
36532 C       IREJ=1
36533         IPCO=0
36534 C       RETURN
36535 C       WRITE(6,*)' MGSQBS1 jump back from chain 3'
36536         GO TO 3466
36537       ENDIF
36538       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
36539       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
36540       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
36541       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
36542       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
36543       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
36544       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
36545       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
36546       IF(IPIP.EQ.1)THEN
36547         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ1+3
36548         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
36549         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
36550         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
36551       ELSEIF(IPIP.EQ.2)THEN
36552         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
36553         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
36554         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
36555         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
36556 C       WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
36557       ENDIF
36558       ISTHKT(7+IIGLU1)  =921
36559       JMOHKT(1,7+IIGLU1)=NC2P
36560       JMOHKT(2,7+IIGLU1)=0
36561       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36562       JDAHKT(2,7+IIGLU1)=0
36563 C     PHKT(1,7)  =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
36564 C     PHKT(2,7)  =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
36565 C     PHKT(3,7)  =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
36566 C     PHKT(4,7+IIGLU1)  =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
36567 **NEW
36568       IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
36569      &    WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
36570 **
36571       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
36572       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
36573       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
36574       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
36575 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
36576 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
36577       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
36578 C       IREJ=1
36579 C       WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
36580         IPCO=0
36581 C       RETURN
36582         GO TO 3466
36583       ENDIF
36584 C     PHKT(5,7)  =PHKK(5,NC2P)
36585       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
36586      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36587      *PHKT(1,7+IIGLU1)**2)
36588       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
36589       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
36590       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
36591       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
36592       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
36593       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
36594       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
36595       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
36596 C     Insert here the IIGLU2 gluons
36597       PG1=0.D0
36598       PG2=0.D0
36599       PG3=0.D0
36600       PG4=0.D0
36601       IF(IIGLU2.GE.1)THEN
36602       JJG=NC2P
36603       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36604         KKG=JJG+IIG-7-IIGLU1
36605         IDHKT(IIG)   =IDHKK(KKG)
36606         ISTHKT(IIG)  =921
36607         JMOHKT(1,IIG)=KKG
36608         JMOHKT(2,IIG)=0
36609         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36610         JDAHKT(2,IIG)=0
36611         PHKT(1,IIG)=PHKK(1,KKG)
36612         PG1=PG1+ PHKT(1,IIG)
36613         PHKT(2,IIG)=PHKK(2,KKG)
36614         PG2=PG2+ PHKT(2,IIG)
36615         PHKT(3,IIG)=PHKK(3,KKG)
36616         PG3=PG3+ PHKT(3,IIG)
36617         PHKT(4,IIG)=PHKK(4,KKG)
36618         PG4=PG4+ PHKT(4,IIG)
36619         PHKT(5,IIG)=PHKK(5,KKG)
36620         VHKT(1,IIG)  =VHKK(1,KKG)
36621         VHKT(2,IIG)  =VHKK(2,KKG)
36622         VHKT(3,IIG)  =VHKK(3,KKG)
36623         VHKT(4,IIG)  =VHKK(4,KKG)
36624         WHKT(1,IIG)  =WHKK(1,KKG)
36625         WHKT(2,IIG)  =WHKK(2,KKG)
36626         WHKT(3,IIG)  =WHKK(3,KKG)
36627         WHKT(4,IIG)  =WHKK(4,KKG)
36628    81 CONTINUE
36629       ENDIF
36630       IDHKT(8+IIGLU1+IIGLU2)   =IP2
36631       ISTHKT(8+IIGLU1+IIGLU2)  =922
36632       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
36633       JMOHKT(2,8+IIGLU1+IIGLU2)=0
36634       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36635       JDAHKT(2,8+IIGLU1+IIGLU2)=0
36636 **NEW
36637       IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
36638      &    WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
36639 **
36640       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
36641       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
36642       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
36643       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
36644 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
36645       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
36646      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36647      *PHKT(1,8+IIGLU1+IIGLU2)**2)
36648       IF(XMIST.GT.0.D0)THEN
36649       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36650      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36651      *PHKT(1,8+IIGLU1+IIGLU2)**2)
36652       ELSE
36653 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
36654       PHKT(5,8+IIGLU1+IIGLU2)=0.D0
36655       ENDIF
36656       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
36657       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
36658       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
36659       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
36660       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
36661       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
36662       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
36663       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
36664       IDHKT(9+IIGLU1+IIGLU2)   =88888
36665 C     IDHKT(9)   =1000*NNNC2+MMMC2+10
36666       ISTHKT(9+IIGLU1+IIGLU2)  =93
36667 C     ISTHKT(9)  =KKKC2
36668       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36669       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36670       JDAHKT(1,9+IIGLU1+IIGLU2)=0
36671       JDAHKT(2,9+IIGLU1+IIGLU2)=0
36672       PHKT(1,9+IIGLU1+IIGLU2)  =PHKT(1,7+IIGLU1)
36673      * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
36674       PHKT(2,9+IIGLU1+IIGLU2)  =PHKT(2,7+IIGLU1)
36675      * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
36676       PHKT(3,9+IIGLU1+IIGLU2)  =PHKT(3,7+IIGLU1)
36677      * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
36678       PHKT(4,9+IIGLU1+IIGLU2)  =PHKT(4,7+IIGLU1)
36679      * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
36680       PHKT(5,9+IIGLU1+IIGLU2)
36681      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
36682      * PHKT(2,9+IIGLU1+IIGLU2)**2
36683      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
36684       IF(IPIP.GE.3)THEN
36685       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36686      * JMOHKT(1,7+IIGLU1),
36687      * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36688      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36689       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36690       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36691      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
36692      * JDAHKT(1,IIG),
36693      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36694    91 CONTINUE
36695       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36696      * IDHKT(8+IIGLU1+IIGLU2),
36697      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
36698      * JDAHKT(1,8+IIGLU1+IIGLU2),
36699      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36700       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36701      * IDHKT(9+IIGLU1+IIGLU2),
36702      * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
36703      * JDAHKT(1,9+IIGLU1+IIGLU2),
36704      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36705       ENDIF
36706       CHAMAL=CHAB1
36707       IF(IPIP.EQ.1)THEN
36708         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
36709       ELSEIF(IPIP.EQ.2)THEN
36710         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
36711       ENDIF
36712       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
36713 C       IREJ=1
36714         IPCO=0
36715 C       RETURN
36716 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
36717 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
36718         GO TO 3466
36719       ENDIF
36720       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
36721       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
36722       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
36723       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
36724       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
36725       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
36726       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
36727       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
36728 C
36729       IGCOUN=9+IIGLU1+IIGLU2
36730       IPCO=0
36731        RETURN
36732        END
36733 C
36734 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36735 C
36736       SUBROUTINE HKKHKT(I,J)
36737       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36738       SAVE
36739
36740 * event history
36741
36742       PARAMETER (NMXHKK=200000)
36743
36744       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36745      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36746      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36747 * extended event history
36748       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36749      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36750      &                IHIST(2,NMXHKK)
36751
36752       PARAMETER (NTMHKK= 300)
36753       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36754      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36755      +(4,NTMHKK)
36756 C
36757       ISTHKK(I)  =ISTHKT(J)
36758       IDHKK(I)   =IDHKT(J)
36759 C     IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
36760       IF(IDHKK(I).EQ.88888)THEN
36761 C       JMOHKK(1,I)=I-2
36762 C       JMOHKK(2,I)=I-1
36763         JMOHKK(1,I)=I-(J-JMOHKT(1,J))
36764         JMOHKK(2,I)=I-(J-JMOHKT(2,J))
36765       ELSE
36766         JMOHKK(1,I)=JMOHKT(1,J)
36767         JMOHKK(2,I)=JMOHKT(2,J)
36768       ENDIF
36769       JDAHKK(1,I)=JDAHKT(1,J)
36770       JDAHKK(2,I)=JDAHKT(2,J)
36771 C       IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
36772 C       JDAHKK(1,I)=I+2
36773 C     ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
36774 C       JDAHKK(1,I)=I+1
36775 C     ENDIF
36776       IF(JDAHKT(1,J).GT.0)THEN
36777         JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
36778       ENDIF
36779       PHKK(1,I)  =PHKT(1,J)
36780       PHKK(2,I)  =PHKT(2,J)
36781       PHKK(3,I)  =PHKT(3,J)
36782       PHKK(4,I)  =PHKT(4,J)
36783       PHKK(5,I)  =PHKT(5,J)
36784       VHKK(1,I)  =VHKT(1,J)
36785       VHKK(2,I)  =VHKT(2,J)
36786       VHKK(3,I)  =VHKT(3,J)
36787       VHKK(4,I)  =VHKT(4,J)
36788       WHKK(1,I)  =WHKT(1,J)
36789       WHKK(2,I)  =WHKT(2,J)
36790       WHKK(3,I)  =WHKT(3,J)
36791       WHKK(4,I)  =WHKT(4,J)
36792       RETURN
36793       END
36794 *
36795 *===dbreak=============================================================*
36796 *
36797 CDECK  ID>, DT_DBREAK
36798       SUBROUTINE DT_DBREAK(MODE)
36799
36800 ************************************************************************
36801 * This is the steering subroutine for the different diquark breaking   *
36802 * mechanisms.                                                          *
36803 *                                                                      *
36804 * MODE = 1  breaking of projectile diquark in qq-q chain using         *
36805 *           a sea quark (q-qq chain) of the same projectile            *
36806 *      = 2  breaking of target     diquark in q-qq chain using         *
36807 *           a sea quark (qq-q chain) of the same target                *
36808 *      = 3  breaking of projectile diquark in qq-q chain using         *
36809 *           a sea quark (q-aq chain) of the same projectile            *
36810 *      = 4  breaking of target     diquark in q-qq chain using         *
36811 *           a sea quark (aq-q chain) of the same target                *
36812 *      = 5  breaking of projectile anti-diquark in aqaq-aq chain using *
36813 *           a sea anti-quark (aq-aqaq chain) of the same projectile    *
36814 *      = 6  breaking of target     anti-diquark in aq-aqaq chain using *
36815 *           a sea anti-quark (aqaq-aq chain) of the same target        *
36816 *      = 7  breaking of projectile anti-diquark in aqaq-aq chain using *
36817 *           a sea anti-quark (aq-q chain) of the same projectile       *
36818 *      = 8  breaking of target     anti-diquark in aq-aqaq chain using *
36819 *           a sea anti-quark (q-aq chain) of the same target           *
36820 *                                                                      *
36821 * Original version by J. Ranft.                                        *
36822 * This version dated 17.5.00  is written by S. Roesler.                *
36823 ************************************************************************
36824
36825       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36826       SAVE
36827
36828       PARAMETER ( LINP = 5 ,
36829      &            LOUT = 6 ,
36830      &            LDAT = 9 )
36831
36832 * event history
36833
36834       PARAMETER (NMXHKK=200000)
36835
36836       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36837      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36838      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36839 * extended event history
36840       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36841      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36842      &                IHIST(2,NMXHKK)
36843 * flags for input different options
36844       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
36845       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
36846      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
36847 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
36848       PARAMETER (MAXCHN=10000)
36849       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
36850 * diquark-breaking mechanism
36851       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36852 * flags for particle decays
36853       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
36854      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
36855      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
36856
36857 *
36858 * chain identifiers
36859 * ( 1 = q-aq,   2 = aq-q,   3 = q-qq,   4 = qq-q,
36860 *   5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
36861       DIMENSION IDCHN1(8),IDCHN2(8)
36862       DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
36863       DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
36864 *
36865 * parton identifiers
36866 * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
36867 *   +-51/52 = unitarity-sea, +-61/62 = gluons )
36868       DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
36869       DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
36870      &             31, 31, 31, 31, 31, 31, 31, 31,
36871      &             41, 41, 41, 41, 51, 51, 51, 51/
36872       DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
36873      &             32, 32, 32, 32, 32, 32, 32, 32,
36874      &             42, 42, 42, 42, 52, 52, 52, 52/
36875       DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
36876      &             51, 31, 41, 41, 31, 31, 31, 31,
36877      &              0, 41, 51, 51, 51, 51, 51, 51/
36878       DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
36879      &             32, 52, 42, 42, 32, 32, 32, 32,
36880      &             42,  0, 52, 52, 52, 52, 52, 52/
36881
36882       IF (NCHAIN.LE.0) RETURN
36883       DO 1 I=1,NCHAIN
36884          IDX1 = IDXCHN(1,I)
36885          IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
36886          IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
36887          IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
36888      &       .AND.
36889      &        ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
36890      &                                    (IS1P.EQ.ISP1P(MODE,3)))
36891      &       .AND.
36892      &        ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
36893      &                                    (IS1T.EQ.ISP1T(MODE,3)))
36894      &      ) THEN
36895             DO 2 J=1,NCHAIN
36896                IDX2 = IDXCHN(1,J)
36897                IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
36898                IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
36899                IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
36900      &             .AND.
36901      &              ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
36902      &                                      .OR.(IS2P.EQ.ISP2P(MODE,3)))
36903      &             .AND.
36904      &              ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
36905      &                                      .OR.(IS2T.EQ.ISP2T(MODE,3)))
36906      &            ) THEN
36907 *   find mother nucleons of the diquark to be splitted and of the
36908 *   sea-quark and reject this combination if it is not the same
36909                   IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
36910      &                (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
36911                      IANCES = 1
36912                   ELSE
36913                      IANCES = 2
36914                   ENDIF
36915                   IDXMO1 = JMOHKK(IANCES,IDX1)
36916     4             CONTINUE
36917                   IF ((JMOHKK(1,IDXMO1).NE.0).AND.
36918      &                (JMOHKK(2,IDXMO1).NE.0)) THEN
36919                      IANC = IANCES
36920                   ELSE
36921                      IANC = 1
36922                   ENDIF
36923                   IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
36924                      IDXMO1 = JMOHKK(IANC,IDXMO1)
36925                      GOTO 4
36926                   ENDIF
36927                   IDXMO2 = JMOHKK(IANCES,IDX2)
36928     5             CONTINUE
36929                   IF ((JMOHKK(1,IDXMO2).NE.0).AND.
36930      &                (JMOHKK(2,IDXMO2).NE.0)) THEN
36931                      IANC = IANCES
36932                   ELSE
36933                      IANC = 1
36934                   ENDIF
36935                   IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
36936                      IDXMO2 = JMOHKK(IANC,IDXMO2)
36937                      GOTO 5
36938                   ENDIF
36939                   IF (IDXMO1.NE.IDXMO2) GOTO 2
36940 *   quark content of projectile parton
36941                   IP1   = IDHKK(JMOHKK(1,IDX1))
36942                   IP11  = IP1/1000
36943                   IP12  = (IP1-1000*IP11)/100
36944                   IP2   = IDHKK(JMOHKK(2,IDX1))
36945                   IP21  = IP2/1000
36946                   IP22  = (IP2-1000*IP21)/100
36947 *   quark content of target parton
36948                   IT1  = IDHKK(JMOHKK(1,IDX2))
36949                   IT11 = IT1/1000
36950                   IT12 = (IT1-1000*IT11)/100
36951                   IT2  = IDHKK(JMOHKK(2,IDX2))
36952                   IT21 = IT2/1000
36953                   IT22 = (IT2-1000*IT21)/100
36954 *   split diquark and form new chains
36955                   IF (MODE.EQ.1) THEN
36956                      IF (IT1.EQ.4) GOTO 2
36957                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36958      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36959      &                         IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
36960                   ELSEIF (MODE.EQ.2) THEN
36961                      IF (IT2.EQ.4) GOTO 2
36962                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36963      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36964      &                         IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
36965                   ELSEIF (MODE.EQ.3) THEN
36966                      IF (IT1.EQ.4) GOTO 2
36967                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36968      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36969      &                         IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
36970                   ELSEIF (MODE.EQ.4) THEN
36971                      IF (IT2.EQ.4) GOTO 2
36972                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36973      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36974      &                         IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
36975                   ELSEIF (MODE.EQ.5) THEN
36976                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36977      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36978      &                         IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
36979                   ELSEIF (MODE.EQ.6) THEN
36980                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36981      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36982      &                         IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
36983                   ELSEIF (MODE.EQ.7) THEN
36984                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36985      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36986      &                         IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
36987                   ELSEIF (MODE.EQ.8) THEN
36988                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36989      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36990      &                         IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
36991                   ENDIF
36992                   IF (IREJ.GE.1) THEN
36993                      if ((ipq.lt.0).or.(ipq.ge.4))
36994      &                  write(LOUT,*) 'ipq !!!',ipq,mode
36995                      DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
36996 *   accept or reject new chains corresponding to PDBSEA
36997                   ELSE
36998                      IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
36999                         ACC   = DBRKA(1,MODE)+DBRKA(2,MODE)
37000                         REJ   = DBRKR(1,MODE)+DBRKR(2,MODE)
37001                      ELSEIF (IPQ.EQ.3) THEN
37002                         ACC   = DBRKA(3,MODE)
37003                         REJ   = DBRKR(3,MODE)
37004                      ELSE
37005                         WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
37006                         STOP
37007                      ENDIF
37008                      IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
37009                         DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
37010                         IACC = 1
37011                      ELSE
37012                         DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
37013                         IACC = 0
37014                      ENDIF
37015 *   new chains have been accepted and are now copied into HKKEVT
37016                      IF (IACC.EQ.1) THEN
37017                         IF (LEMCCK) THEN
37018                            CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
37019      &                                    PHKK(3,IDX1),PHKK(4,IDX1),
37020      &                                    1,IDUM1,IDUM2)
37021                            CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
37022      &                                    PHKK(3,IDX2),PHKK(4,IDX2),
37023      &                                    2,IDUM1,IDUM2)
37024                         ENDIF
37025                         IDHKK(IDX1) = 99888
37026                         IDHKK(IDX2) = 99888
37027                         IDXCHN(2,I) = -1
37028                         IDXCHN(2,J) = -1
37029                         DO 3 K=1,IGCOUN
37030                            NHKK = NHKK+1
37031                            CALL HKKHKT(NHKK,K)
37032                            IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
37033                               PX = -PHKK(1,NHKK)
37034                               PY = -PHKK(2,NHKK)
37035                               PZ = -PHKK(3,NHKK)
37036                               PE = -PHKK(4,NHKK)
37037                               CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
37038                            ENDIF
37039     3                   CONTINUE
37040                         IF (LEMCCK) THEN
37041                            CHKLEV = 0.1D0
37042                            CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
37043      &                                                             IREJ)
37044                            IF (IREJ.NE.0) CALL DT_EVTOUT(4)
37045                         ENDIF
37046                         GOTO 1
37047                      ENDIF
37048                   ENDIF
37049                ENDIF
37050     2       CONTINUE
37051          ENDIF
37052     1 CONTINUE
37053       RETURN
37054       END
37055 *
37056 *===cqpair=============================================================*
37057 *
37058 CDECK  ID>, DT_CQPAIR
37059       SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
37060
37061 ************************************************************************
37062 * This subroutine Creates a Quark-antiquark PAIR from the sea.         *
37063 *                                                                      *
37064 *   XQMAX   maxium energy fraction of quark (input)                    *
37065 *   XAQMAX  maxium energy fraction of antiquark (input)                *
37066 *   XQ      energy fraction of quark (output)                          *
37067 *   XAQ     energy fraction of antiquark (output)                      *
37068 *   IFLV    quark flavour (- antiquark flavor) (output)                *
37069 *                                                                      *
37070 * This version dated 14.5.00  is written by S. Roesler.                *
37071 ************************************************************************
37072
37073       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37074       SAVE
37075
37076       PARAMETER ( LINP = 5 ,
37077      &            LOUT = 6 ,
37078      &            LDAT = 9 )
37079
37080 * Lorentz-parameters of the current interaction
37081       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37082      &                UMO,PPCM,EPROJ,PPROJ
37083
37084 *
37085       IREJ = 0
37086       XQ   = 0.0D0
37087       XAQ  = 0.0D0
37088 *
37089 * sample quark flavour
37090 *
37091 *  set seasq here (the one from DTCHAI should be used in the future)
37092       SEASQ = 0.5D0
37093       IFLV  = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
37094 *
37095 * sample energy fractions of sea pair
37096 * we first sample the energy fraction of a gluon and then split the gluon
37097 *
37098 *  maximum energy fraction of the gluon forced via input
37099       XGMAXI = XQMAX+XAQMAX
37100 *  minimum energy fraction of the gluon
37101       XTHR1 = 4.0D0 /UMO**2
37102       XTHR2 = 0.54D0/UMO**1.5D0
37103       XGMIN = MAX(XTHR1,XTHR2)
37104 *  maximum energy fraction of the gluon
37105       XGMAX = 0.3D0
37106       XGMAX = MIN(XGMAXI,XGMAX)
37107       IF (XGMIN.GE.XGMAX) THEN
37108          IREJ = 1
37109          RETURN
37110       ENDIF
37111 *
37112 *  sample energy fraction of the gluon
37113       NLOOP = 0
37114     1 CONTINUE
37115       NLOOP = NLOOP+1
37116       IF (NLOOP.GE.50) THEN
37117          IREJ = 1
37118          RETURN
37119       ENDIF
37120       XGLUON = DT_SAMSQX(XGMIN,XGMAX)
37121       EGLUON = XGLUON*UMO/2.0D0
37122 *
37123 *  split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
37124       ZMIN = MIN(0.1D0,0.5D0/EGLUON)
37125       ZMAX = 1.0D0-ZMIN
37126       RZ   = DT_RNDM(ZMAX)
37127       XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
37128       RQ   = DT_RNDM(ZMAX)
37129       IF (RQ.LT.0.5D0) THEN
37130          XQ  = XGLUON*XHLP
37131          XAQ = XGLUON-XQ
37132       ELSE
37133          XAQ = XGLUON*XHLP
37134          XQ  = XGLUON-XAQ
37135       ENDIF
37136       IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1
37137
37138       RETURN
37139       END