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 '(DIMPAR)'
  59       INCLUDE '(PAREVT)'
  60       INCLUDE '(EVAPAR)'
  61       INCLUDE '(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/ppLHC.inp'
 262       OPEN(UNIT=7,FILE=FILNAM,STATUS='OLD')
 263       OPEN(UNIT=14,FILE="nuclear.bin",STATUS='OLD')
 264 *     OPEN(UNIT=6,FILE="dpm.out",STATUS='UNKNOWN')
 265
 266       READ(7,'(A78)',END=9999) CLINE
 267
 268       IF (CLINE(1:1).EQ.'*') THEN
 269 * comment-line
 270 C         WRITE(LOUT,'(A78)') CLINE
 271          GOTO 10
 272       ENDIF
 273 C     READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM
 274 C1000 FORMAT(A10,6E10.0,A8)
 275       DO 1008 I=1,6
 276          WHAT(I) = ZERO
 277  1008 CONTINUE
 278       READ(CLINE,1006,END=9999) CODEWD,CWHAT,SDUM
 279  1006 FORMAT(A10,A60,A8)
 280       READ(CWHAT,*,END=1007) (WHAT(I),I=1,6)
 281  1007 CONTINUE
 282       WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM
 283  1001 FORMAT(A10,6G10.3,A8)
 284
 285   900 CONTINUE
 286
 287 * check for valid control card and get card index
 288       ICW = 0
 289       DO 11 I=1,MXCARD
 290          IF (CODEWD.EQ.CODE(I)) ICW = I
 291    11 CONTINUE
 292       IF (ICW.EQ.0) THEN
 293          WRITE(LOUT,1002) CODEWD
 294  1002    FORMAT(/,1X,'---> ',A10,': invalid control-card !',/)
 295          GOTO 10
 296       ENDIF
 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
5633             IDHKK(NHKK)  = IDT_IPDGHA(ID)
5634             IDBAM(NHKK)  = ID
5635             PHKK(4,NHKK) = AAM(ID)
5636             PHKK(5,NHKK) = AAM(ID)
5637
5638 C     * VDM assumption
5639 C            IF (IDHKK(NHKK).EQ.22) THEN
5640 C               PHKK(4,NHKK) = AAM(33)
5641 C               PHKK(5,NHKK) = AAM(33)
5642 C            ENDIF
5643             IF (MODE.EQ.1) THEN
5644                IPOSP(I)  = NHKK
5645                KKPROJ(I) = ID
5646                PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5647             ELSE
5648                IPOST(I)  = NHKK
5649                KKTARG(I) = ID
5650             ENDIF
5651          ENDIF
5652          DO 4 K=1,3
5653             VHKK(K,NHKK) = COORD(K,I)*FM2MM
5654             WHKK(K,NHKK) = COORD(K,I)*FM2MM
5655     4    CONTINUE
5656          IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5657          IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5658          VHKK(4,NHKK) = 0.0D0
5659          WHKK(4,NHKK) = 0.0D0
5660     2 CONTINUE
5661
5662 * balance Fermi-momenta
5663       IF (NMASS.GE.2) THEN
5664          DO 5 I=1,NMASS
5665             NC = NC+1
5666             DO 6 K=1,3
5667                PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5668     6       CONTINUE
5669             PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5670      &                        PHKK(2,NC)**2+PHKK(3,NC)**2)
5671     5    CONTINUE
5672       ENDIF
5673
5674       RETURN
5675       END
5676 *
5677 *===fer4m==============================================================*
5678 *
5679 CDECK  ID>, DT_FER4M
5680       SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
5681
5682 ************************************************************************
5683 * Sampling of nucleon Fermi-momenta from distributions at T=0.         *
5684 *                                   processed by S. Roesler, 17.10.95  *
5685 ************************************************************************
5686
5687       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5688       SAVE
5689
5690       PARAMETER ( LINP = 5 ,
5691      &            LOUT = 6 ,
5692      &            LDAT = 9 )
5693
5694       LOGICAL LSTART
5695
5696 * particle properties (BAMJET index convention)
5697       CHARACTER*8  ANAME
5698       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5699      &                IICH(210),IIBAR(210),K1(210),K2(210)
5700 * nuclear potential
5701       LOGICAL LFERMI
5702       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5703      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5704      &                ETACOU(2),ICOUL,LFERMI
5705
5706       DATA LSTART /.TRUE./
5707
5708       ILOOP = 0
5709       IF (LFERMI) THEN
5710          IF (LSTART) THEN
5711             WRITE(LOUT,1000)
5712  1000       FORMAT(/,1X,'FER4M:   sampling of Fermi-momenta activated')
5713             LSTART = .FALSE.
5714          ENDIF
5715     1    CONTINUE
5716          CALL DT_DFERMI(PABS)
5717          PABS = PFERM*PABS
5718 C        IF (PABS.GE.PBIND) THEN
5719 C           ILOOP = ILOOP+1
5720 C           IF (MOD(ILOOP,500).EQ.0) THEN
5721 C              WRITE(LOUT,1001) PABS,PBIND,ILOOP
5722 C1001          FORMAT(1X,'FER4M:    Fermi-mom. corr. for binding',
5723 C    &                ' energy ',2E12.3,I6)
5724 C           ENDIF
5725 C           GOTO 1
5726 C        ENDIF
5727          CALL DT_DPOLI(POLC,POLS)
5728          CALL DT_DSFECF(SFE,CFE)
5729          CXTA = POLS*CFE
5730          CYTA = POLS*SFE
5731          CZTA = POLC
5732          ET   = SQRT(PABS*PABS+AAM(KT)**2)
5733          PXT  = CXTA*PABS
5734          PYT  = CYTA*PABS
5735          PZT  = CZTA*PABS
5736       ELSE
5737          ET   = AAM(KT)
5738          PXT  = 0.0D0
5739          PYT  = 0.0D0
5740          PZT  = 0.0D0
5741       ENDIF
5742
5743       RETURN
5744       END
5745 *
5746 *===nuc2cm=============================================================*
5747 *
5748 CDECK  ID>, DT_NUC2CM
5749       SUBROUTINE DT_NUC2CM
5750
5751 ************************************************************************
5752 * Lorentz-transformation of all wounded nucleons from Lab. to nucl.-   *
5753 * nucl. cms. (This subroutine replaces NUCMOM.)                        *
5754 * This version dated 15.01.95 is written by S. Roesler                 *
5755 ************************************************************************
5756
5757       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5758       SAVE
5759
5760       PARAMETER ( LINP = 5 ,
5761      &            LOUT = 6 ,
5762      &            LDAT = 9 )
5763
5764       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
5765
5766 * event history
5767
5768       PARAMETER (NMXHKK=200000)
5769
5770       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5771      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5772      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5773 * extended event history
5774       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5775      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5776      &                IHIST(2,NMXHKK)
5777 * statistics
5778       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5779      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5780      &                ICEVTG(8,0:30)
5781 * properties of photon/lepton projectiles
5782       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5783 * particle properties (BAMJET index convention)
5784       CHARACTER*8  ANAME
5785       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5786      &                IICH(210),IIBAR(210),K1(210),K2(210)
5787 * Glauber formalism: collision properties
5788       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5789      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5790 **temporary
5791 * statistics: Glauber-formalism
5792       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5793 **
5794
5795       ICWP = 0
5796       ICWT = 0
5797       NWTACC = 0
5798       NWAACC = 0
5799       NWBACC = 0
5800
5801       NPOINT(1) = NHKK+1
5802       NEND      = NHKK
5803       DO 1 I=1,NEND
5804          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
5805             IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
5806             IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
5807             MODE = ISTHKK(I)-9
5808 C            IF (IDHKK(I).EQ.22) THEN
5809 C* VDM assumption
5810 C               PEIN = AAM(33)
5811 C               IDB  = 33
5812 C            ELSE
5813 C               PEIN = PHKK(4,I)
5814 C               IDB  = IDBAM(I)
5815 C            ENDIF
5816 C            CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
5817 C     &           PX,PY,PZ,PE,IDB,MODE)
5818             IF (PHKK(5,I).GT.ZERO) THEN
5819                CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
5820      &              PX,PY,PZ,PE,IDBAM(I),MODE)
5821             ELSE
5822                PX = PGAMM(1)
5823                PY = PGAMM(2)
5824                PZ = PGAMM(3)
5825                PE = PGAMM(4)
5826             ENDIF
5827             IST = ISTHKK(I)-2
5828             ID  = IDHKK(I)
5829 C* VDM assumption
5830 C            IF (ID.EQ.22) ID = 113
5831             CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
5832             IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
5833             IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
5834          ENDIF
5835     1 CONTINUE
5836
5837       NWTACC = MAX(NWAACC,NWBACC)
5838       ICDPR  = ICDPR+ICWP
5839       ICDTA  = ICDTA+ICWT
5840 **temporary
5841       IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
5842          CALL DT_EVTOUT(4)
5843          STOP
5844       ENDIF
5845
5846       RETURN
5847       END
5848 *
5849 *===splptn=============================================================*
5850 *
5851 CDECK  ID>, DT_SPLPTN
5852       SUBROUTINE DT_SPLPTN(NN)
5853
5854 ************************************************************************
5855 * SamPLing of ParToN momenta and flavors.                              *
5856 * This version dated 15.01.95 is written by S. Roesler                 *
5857 ************************************************************************
5858
5859       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5860       SAVE
5861
5862       PARAMETER ( LINP = 5 ,
5863      &            LOUT = 6 ,
5864      &            LDAT = 9 )
5865
5866 * Lorentz-parameters of the current interaction
5867       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5868      &                UMO,PPCM,EPROJ,PPROJ
5869
5870 * sample flavors of sea-quarks
5871       CALL DT_SPLFLA(NN,1)
5872
5873 * sample x-values of partons at chain ends
5874       ECM = UMO
5875       CALL DT_XKSAMP(NN,ECM)
5876
5877 * samle flavors
5878       CALL DT_SPLFLA(NN,2)
5879
5880       RETURN
5881       END
5882 *
5883 *===splfla=============================================================*
5884 *
5885 CDECK  ID>, DT_SPLFLA
5886       SUBROUTINE DT_SPLFLA(NN,MODE)
5887
5888 ************************************************************************
5889 * SamPLing of FLAvors of partons at chain ends.                        *
5890 * This subroutine replaces FLKSAA/FLKSAM.                              *
5891 *            NN            number of nucleon-nucleon interactions      *
5892 *            MODE = 1      sea-flavors                                 *
5893 *                 = 2      valence-flavors                             *
5894 * Based on the original version written by J. Ranft/H.-J. Moehring.    *
5895 * This version dated 16.01.95 is written by S. Roesler                 *
5896 ************************************************************************
5897
5898       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5899       SAVE
5900
5901       PARAMETER ( LINP = 5 ,
5902      &            LOUT = 6 ,
5903      &            LDAT = 9 )
5904
5905       PARAMETER ( MAXNCL = 260,
5906
5907      &            MAXVQU = MAXNCL,
5908      &            MAXSQU = 20*MAXVQU,
5909      &            MAXINT = MAXVQU+MAXSQU)
5910 * flavors of partons (DTUNUC 1.x)
5911       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5912      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5913      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5914      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5915      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5916      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5917      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5918 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5919       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5920      &                IXPV,IXPS,IXTV,IXTS,
5921      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
5922      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
5923      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
5924      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
5925      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
5926      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
5927      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
5928      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
5929 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5930       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5931      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5932 * particle properties (BAMJET index convention)
5933       CHARACTER*8  ANAME
5934       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5935      &                IICH(210),IIBAR(210),K1(210),K2(210)
5936 * various options for treatment of partons (DTUNUC 1.x)
5937 * (chain recombination, Cronin,..)
5938       LOGICAL LCO2CR,LINTPT
5939       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
5940      &                LCO2CR,LINTPT
5941
5942       IF (MODE.EQ.1) THEN
5943 * sea-flavors
5944          DO 1 I=1,NN
5945             IPSQ(I)  = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5946             IPSAQ(I) = -IPSQ(I)
5947     1    CONTINUE
5948          DO 2 I=1,NN
5949             ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5950             ITSAQ(I)= -ITSQ(I)
5951     2    CONTINUE
5952       ELSEIF (MODE.EQ.2) THEN
5953 * valence flavors
5954          DO 3 I=1,IXPV
5955             CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
5956     3    CONTINUE
5957          DO 4 I=1,IXTV
5958             CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
5959     4    CONTINUE
5960       ENDIF
5961
5962       RETURN
5963       END
5964 *
5965 *===getptn=============================================================*
5966 *
5967 CDECK  ID>, DT_GETPTN
5968       SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
5969
5970 ************************************************************************
5971 * This subroutine collects partons at chain ends from temporary        *
5972 * commons and puts them into DTEVT1.                                   *
5973 * This version dated 15.01.95 is written by S. Roesler                 *
5974 ************************************************************************
5975
5976       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5977       SAVE
5978
5979       PARAMETER ( LINP = 5 ,
5980      &            LOUT = 6 ,
5981      &            LDAT = 9 )
5982
5983       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
5984
5985       LOGICAL LCHK
5986
5987       PARAMETER ( MAXNCL = 260,
5988
5989      &            MAXVQU = MAXNCL,
5990      &            MAXSQU = 20*MAXVQU,
5991      &            MAXINT = MAXVQU+MAXSQU)
5992 * event history
5993
5994       PARAMETER (NMXHKK=200000)
5995
5996       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5997      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5998      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5999 * extended event history
6000       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6001      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6002      &                IHIST(2,NMXHKK)
6003 * flags for input different options
6004       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6005       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6006      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6007 * auxiliary common for chain system storage (DTUNUC 1.x)
6008       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
6009 * statistics
6010       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6011      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6012      &                ICEVTG(8,0:30)
6013 * flags for diffractive interactions (DTUNUC 1.x)
6014       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6015 * x-values of partons (DTUNUC 1.x)
6016       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
6017      &                XTVQ(MAXVQU),XTVD(MAXVQU),
6018      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
6019      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
6020 * flavors of partons (DTUNUC 1.x)
6021       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6022      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6023      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
6024      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6025      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
6026      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6027      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
6028 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6029       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6030      &                IXPV,IXPS,IXTV,IXTS,
6031      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
6032      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
6033      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
6034      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
6035      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
6036      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
6037      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
6038      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
6039 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6040       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6041      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6042
6043       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
6044
6045       DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
6046
6047       IREJ      = 0
6048       NCSY      = 0
6049       NPOINT(2) = NHKK+1
6050
6051 * sea-sea chains
6052       DO 10 I=1,NSS
6053          IF (ISKPCH(1,I).EQ.99) GOTO 10
6054          ICCHAI(1,1) = ICCHAI(1,1)+2
6055          IDXP = INTSS1(I)
6056          IDXT = INTSS2(I)
6057          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6058          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6059          DO 11 K=1,4
6060             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6061             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6062             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6063             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6064    11    CONTINUE
6065          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6066      &                                  +(PP1(3)+PT1(3))**2)
6067          ECH   = PP1(4)+PT1(4)
6068          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6069          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6070      &                                  +(PP2(3)+PT2(3))**2)
6071          ECH   = PP2(4)+PT2(4)
6072          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6073          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6074             AM1 = SQRT(AM1)
6075             AM2 = SQRT(AM2)
6076             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6077 C              WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6078  5000          FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6079             ENDIF
6080          ELSE
6081             WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6082          ENDIF
6083          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6084          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6085          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6086          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6087          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6088      &                                                    0,0,1)
6089          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6090      &                                                    0,0,1)
6091          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6092      &                                                    0,0,1)
6093          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6094      &                                                    0,0,1)
6095          NCSY = NCSY+1
6096    10 CONTINUE
6097
6098 * disea-sea chains
6099       DO 20 I=1,NDS
6100          IF (ISKPCH(2,I).EQ.99) GOTO 20
6101          ICCHAI(1,2) = ICCHAI(1,2)+2
6102          IDXP = INTDS1(I)
6103          IDXT = INTDS2(I)
6104          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6105          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6106          DO 21 K=1,4
6107             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6108             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6109             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6110             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6111    21    CONTINUE
6112          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6113      &                                  +(PP1(3)+PT1(3))**2)
6114          ECH   = PP1(4)+PT1(4)
6115          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6116          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6117      &                                  +(PP2(3)+PT2(3))**2)
6118          ECH   = PP2(4)+PT2(4)
6119          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6120          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6121             AM1 = SQRT(AM1)
6122             AM2 = SQRT(AM2)
6123             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6124 C              WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6125  5001          FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6126             ENDIF
6127          ELSE
6128             WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6129          ENDIF
6130          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6131          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6132          IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6133          IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6134          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6135      &                                                    0,0,2)
6136          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6137      &                                                    0,0,2)
6138          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6139      &                                                    0,0,2)
6140          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6141      &                                                    0,0,2)
6142          NCSY = NCSY+1
6143    20 CONTINUE
6144
6145 * sea-disea chains
6146       DO 30 I=1,NSD
6147          IF (ISKPCH(3,I).EQ.99) GOTO 30
6148          ICCHAI(1,3) = ICCHAI(1,3)+2
6149          IDXP = INTSD1(I)
6150          IDXT = INTSD2(I)
6151          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6152          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6153          DO 31 K=1,4
6154             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6155             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6156             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6157             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6158    31    CONTINUE
6159          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6160      &                                  +(PP1(3)+PT1(3))**2)
6161          ECH   = PP1(4)+PT1(4)
6162          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6163          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6164      &                                  +(PP2(3)+PT2(3))**2)
6165          ECH   = PP2(4)+PT2(4)
6166          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6167          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6168             AM1 = SQRT(AM1)
6169             AM2 = SQRT(AM2)
6170             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6171 C              WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6172  5002          FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6173             ENDIF
6174          ELSE
6175             WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6176          ENDIF
6177          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6178          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6179          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6180          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6181          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6182      &                                                    0,0,3)
6183          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6184      &                                                    0,0,3)
6185          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6186      &                                                    0,0,3)
6187          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6188      &                                                    0,0,3)
6189          NCSY = NCSY+1
6190    30 CONTINUE
6191
6192 * disea-valence chains
6193       DO 50 I=1,NDV
6194          IF (ISKPCH(5,I).EQ.99) GOTO 50
6195          ICCHAI(1,5) = ICCHAI(1,5)+2
6196          IDXP = INTDV1(I)
6197          IDXT = INTDV2(I)
6198          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6199          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6200          DO 51 K=1,4
6201             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6202             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6203             PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6204             PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6205    51    CONTINUE
6206          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6207      &                                  +(PP1(3)+PT1(3))**2)
6208          ECH   = PP1(4)+PT1(4)
6209          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6210          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6211      &                                  +(PP2(3)+PT2(3))**2)
6212          ECH   = PP2(4)+PT2(4)
6213          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6214          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6215             AM1 = SQRT(AM1)
6216             AM2 = SQRT(AM2)
6217             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6218 C              WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6219  5003          FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6220             ENDIF
6221          ELSE
6222             WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6223          ENDIF
6224          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6225          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6226          IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6227          IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6228          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6229      &                                                    0,0,5)
6230          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6231      &                                                    0,0,5)
6232          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6233      &                                                    0,0,5)
6234          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6235      &                                                    0,0,5)
6236          NCSY = NCSY+1
6237    50 CONTINUE
6238
6239 * valence-sea chains
6240       DO 60 I=1,NVS
6241          IF (ISKPCH(6,I).EQ.99) GOTO 60
6242          ICCHAI(1,6) = ICCHAI(1,6)+2
6243          IDXP = INTVS1(I)
6244          IDXT = INTVS2(I)
6245          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6246          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6247          DO 61 K=1,4
6248             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6249             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6250             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6251             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6252    61    CONTINUE
6253          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6254          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6255          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6256          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6257          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6258          IF (LCHK) THEN
6259             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6260      &                                                       0,0,6)
6261             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6262      &                                                       0,0,6)
6263             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6264      &                                                       0,0,6)
6265             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6266      &                                                       0,0,6)
6267             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6268      &                                     +(PP1(3)+PT1(3))**2)
6269             ECH   = PP1(4)+PT1(4)
6270             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6271             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6272      &                                     +(PP2(3)+PT2(3))**2)
6273             ECH   = PP2(4)+PT2(4)
6274             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6275          ELSE
6276             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6277      &                                                       0,0,6)
6278             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6279      &                                                       0,0,6)
6280             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6281      &                                                       0,0,6)
6282             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6283      &                                                       0,0,6)
6284             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6285      &                                     +(PP1(3)+PT2(3))**2)
6286             ECH   = PP1(4)+PT2(4)
6287             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6288             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6289      &                                     +(PP2(3)+PT1(3))**2)
6290             ECH   = PP2(4)+PT1(4)
6291             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6292          ENDIF
6293          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6294             AM1 = SQRT(AM1)
6295             AM2 = SQRT(AM2)
6296             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6297 C              WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6298  5004          FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6299             ENDIF
6300          ELSE
6301             WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6302          ENDIF
6303          NCSY = NCSY+1
6304    60 CONTINUE
6305
6306 * sea-valence chains
6307       DO 40 I=1,NSV
6308          IF (ISKPCH(4,I).EQ.99) GOTO 40
6309          ICCHAI(1,4) = ICCHAI(1,4)+2
6310          IDXP = INTSV1(I)
6311          IDXT = INTSV2(I)
6312          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6313          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6314          DO 41 K=1,4
6315             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6316             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6317             PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6318             PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6319    41    CONTINUE
6320          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6321      &                                  +(PP1(3)+PT1(3))**2)
6322          ECH   = PP1(4)+PT1(4)
6323          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6324          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6325      &                                  +(PP2(3)+PT2(3))**2)
6326          ECH   = PP2(4)+PT2(4)
6327          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6328          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6329             AM1 = SQRT(AM1)
6330             AM2 = SQRT(AM2)
6331             IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6332 C              WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6333  5005          FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6334             ENDIF
6335          ELSE
6336             WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6337          ENDIF
6338          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6339          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6340          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6341          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6342          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6343      &                                                    0,0,4)
6344          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6345      &                                                    0,0,4)
6346          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6347      &                                                    0,0,4)
6348          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6349      &                                                    0,0,4)
6350          NCSY = NCSY+1
6351    40 CONTINUE
6352
6353 * valence-disea chains
6354       DO 70 I=1,NVD
6355          IF (ISKPCH(7,I).EQ.99) GOTO 70
6356          ICCHAI(1,7) = ICCHAI(1,7)+2
6357          IDXP = INTVD1(I)
6358          IDXT = INTVD2(I)
6359          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6360          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6361          DO 71 K=1,4
6362             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6363             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6364             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6365             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6366    71    CONTINUE
6367          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6368          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6369          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6370          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6371          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6372          IF (LCHK) THEN
6373             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6374      &                                                       0,0,7)
6375             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6376      &                                                       0,0,7)
6377             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6378      &                                                       0,0,7)
6379             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6380      &                                                       0,0,7)
6381             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6382      &                                     +(PP1(3)+PT1(3))**2)
6383             ECH   = PP1(4)+PT1(4)
6384             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6385             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6386      &                                     +(PP2(3)+PT2(3))**2)
6387             ECH   = PP2(4)+PT2(4)
6388             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6389          ELSE
6390             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6391      &                                                       0,0,7)
6392             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6393      &                                                       0,0,7)
6394             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6395      &                                                       0,0,7)
6396             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6397      &                                                       0,0,7)
6398             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6399      &                                     +(PP1(3)+PT2(3))**2)
6400             ECH   = PP1(4)+PT2(4)
6401             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6402             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6403      &                                     +(PP2(3)+PT1(3))**2)
6404             ECH   = PP2(4)+PT1(4)
6405             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6406          ENDIF
6407          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6408             AM1 = SQRT(AM1)
6409             AM2 = SQRT(AM2)
6410             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6411 C              WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6412  5006          FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6413             ENDIF
6414          ELSE
6415             WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6416          ENDIF
6417          NCSY = NCSY+1
6418    70 CONTINUE
6419
6420 * valence-valence chains
6421       DO 80 I=1,NVV
6422          IF (ISKPCH(8,I).EQ.99) GOTO 80
6423          ICCHAI(1,8) = ICCHAI(1,8)+2
6424          IDXP = INTVV1(I)
6425          IDXT = INTVV2(I)
6426          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6427          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6428          DO 81 K=1,4
6429             PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6430             PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6431             PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6432             PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6433    81    CONTINUE
6434          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6435          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6436          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6437          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6438
6439 * check for diffractive event
6440          IDIFF = 0
6441          IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6442      &        (IP.EQ.1).AND.(NN.EQ.1)) THEN
6443             DO 800 K=1,4
6444                PP(K) = PP1(K)+PP2(K)
6445                PT(K) = PT1(K)+PT2(K)
6446   800       CONTINUE
6447             ISTCK = NHKK
6448             CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6449      &                  IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6450 C           IF (IREJ1.NE.0) GOTO 9999
6451             IF (IREJ1.NE.0) THEN
6452                IDIFF = 0
6453                NHKK  = ISTCK
6454             ENDIF
6455          ELSE
6456             IDIFF = 0
6457          ENDIF
6458
6459          IF (IDIFF.EQ.0) THEN
6460 *   valence-valence chain system
6461             CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6462             IF (LCHK) THEN
6463 *    baryon-baryon
6464                CALL DT_EVTPUT(-21,IFP1,MOP,0,
6465      &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6466                CALL DT_EVTPUT(-22,IFT1,MOT,0,
6467      &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6468                CALL DT_EVTPUT(-21,IFP2,MOP,0,
6469      &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6470                CALL DT_EVTPUT(-22,IFT2,MOT,0,
6471      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6472                PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6473      &                                        +(PP1(3)+PT1(3))**2)
6474                ECH   = PP1(4)+PT1(4)
6475                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6476                PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6477      &                                        +(PP2(3)+PT2(3))**2)
6478                ECH   = PP2(4)+PT2(4)
6479                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6480             ELSE
6481 *    antibaryon-baryon
6482                CALL DT_EVTPUT(-21,IFP1,MOP,0,
6483      &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6484                CALL DT_EVTPUT(-22,IFT2,MOT,0,
6485      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6486                CALL DT_EVTPUT(-21,IFP2,MOP,0,
6487      &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6488                CALL DT_EVTPUT(-22,IFT1,MOT,0,
6489      &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6490                PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6491      &                                        +(PP1(3)+PT2(3))**2)
6492                ECH   = PP1(4)+PT2(4)
6493                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6494                PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6495      &                                        +(PP2(3)+PT1(3))**2)
6496                ECH   = PP2(4)+PT1(4)
6497                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6498             ENDIF
6499             IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6500                AM1 = SQRT(AM1)
6501                AM2 = SQRT(AM2)
6502                IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6503 C                 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6504  5007             FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6505                ENDIF
6506             ELSE
6507                WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6508             ENDIF
6509             NCSY = NCSY+1
6510          ENDIF
6511    80 CONTINUE
6512       IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6513
6514 * energy-momentum & flavor conservation check
6515       IF (ABS(IDIFF).NE.1) THEN
6516          IF (IDIFF.NE.0) THEN
6517             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6518      &                                              1,3,10,IREJ)
6519          ELSE
6520             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6521      &                                              1,3,10,IREJ)
6522          ENDIF
6523          IF (IREJ.NE.0) THEN
6524             CALL DT_EVTOUT(4)
6525             STOP
6526          ENDIF
6527       ENDIF
6528
6529       RETURN
6530
6531  9999 CONTINUE
6532       IREJ  = 1
6533       RETURN
6534       END
6535 *
6536 *===chkcsy=============================================================*
6537 *
6538 CDECK  ID>, DT_CHKCSY
6539       SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6540
6541 ************************************************************************
6542 * CHeCk Chain SYstem for consistency of partons at chain ends.         *
6543 *            ID1,ID2        PDG-numbers of partons at chain ends       *
6544 *            LCHK = .true.  consistent chain                           *
6545 *                 = .false. inconsistent chain                         *
6546 * This version dated 18.01.95 is written by S. Roesler                 *
6547 ************************************************************************
6548
6549       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6550       SAVE
6551
6552       PARAMETER ( LINP = 5 ,
6553      &            LOUT = 6 ,
6554      &            LDAT = 9 )
6555
6556       LOGICAL LCHK
6557
6558       LCHK = .TRUE.
6559
6560 * q-aq chain
6561       IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6562          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6563 * q-qq, aq-aqaq chain
6564       ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6565      &        ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6566          IF (ID1*ID2.LT.0) LCHK = .FALSE.
6567 * qq-aqaq chain
6568       ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6569          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6570       ENDIF
6571
6572       RETURN
6573       END
6574 *
6575 *===eventa=============================================================*
6576 *
6577 CDECK  ID>, DT_EVENTA
6578       SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6579
6580 ************************************************************************
6581 * Treatment of nucleon-nucleon interactions in a two-chain             *
6582 * approximation.                                                       *
6583 *  (input) ID       BAMJET-index of projectile hadron (in case of      *
6584 *                   h-K scattering)                                    *
6585 *          IP/IT    mass number of projectile/target nucleus           *
6586 *          NCSY     number of two chain systems                        *
6587 *          IREJ     rejection flag                                     *
6588 * This version dated 15.01.95 is written by S. Roesler                 *
6589 ************************************************************************
6590
6591       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6592       SAVE
6593
6594       PARAMETER ( LINP = 5 ,
6595      &            LOUT = 6 ,
6596      &            LDAT = 9 )
6597
6598       PARAMETER (TINY10=1.0D-10)
6599
6600 * event history
6601
6602       PARAMETER (NMXHKK=200000)
6603
6604       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6605      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6606      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6607 * extended event history
6608       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6609      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6610      &                IHIST(2,NMXHKK)
6611 * rejection counter
6612       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6613      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6614      &                IREXCI(3),IRDIFF(2),IRINC
6615 * flags for diffractive interactions (DTUNUC 1.x)
6616       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6617 * particle properties (BAMJET index convention)
6618       CHARACTER*8  ANAME
6619       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6620      &                IICH(210),IIBAR(210),K1(210),K2(210)
6621 * flags for input different options
6622       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6623       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6624      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6625 * various options for treatment of partons (DTUNUC 1.x)
6626 * (chain recombination, Cronin,..)
6627       LOGICAL LCO2CR,LINTPT
6628       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6629      &                LCO2CR,LINTPT
6630
6631       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
6632
6633       IREJ      = 0
6634       NPOINT(3) = NHKK+1
6635
6636 * skip following treatment for low-mass diffraction
6637       IF (ABS(IFLAGD).EQ.1) THEN
6638          NPOINT(3) = NPOINT(2)
6639          GOTO 5
6640       ENDIF
6641
6642 * multiple scattering of chain ends
6643       IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
6644       IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
6645
6646       NC = NPOINT(2)
6647 * get a two-chain system from DTEVT1
6648       DO 3 I=1,NCSY
6649          IFP1 = IDHKK(NC)
6650          IFT1 = IDHKK(NC+1)
6651          IFP2 = IDHKK(NC+2)
6652          IFT2 = IDHKK(NC+3)
6653          DO 4 K=1,4
6654             PP1(K) = PHKK(K,NC)
6655             PT1(K) = PHKK(K,NC+1)
6656             PP2(K) = PHKK(K,NC+2)
6657             PT2(K) = PHKK(K,NC+3)
6658     4    CONTINUE
6659          MOP1 = NC
6660          MOT1 = NC+1
6661          MOP2 = NC+2
6662          MOT2 = NC+3
6663          CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
6664      &               IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
6665          IF (IREJ1.GT.0) THEN
6666             IRHHA = IRHHA+1
6667             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
6668             GOTO 9999
6669          ENDIF
6670          NC = NC+4
6671     3 CONTINUE
6672
6673 * meson/antibaryon projectile:
6674 * sample single-chain valence-valence systems (Reggeon contrib.)
6675       IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
6676          IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
6677       ENDIF
6678
6679       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6680 * check DTEVT1 for remaining resonance mass corrections
6681          CALL DT_EVTRES(IREJ1)
6682          IF (IREJ1.GT.0) THEN
6683             IRRES(1) = IRRES(1)+1
6684             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
6685             GOTO 9999
6686          ENDIF
6687       ENDIF
6688
6689 * assign p_t to two-"chain" systems consisting of two resonances only
6690 * since only entries for chains will be affected, this is obsolete
6691 * in case of JETSET-fragmetation
6692       CALL DT_RESPT
6693
6694 * combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
6695       IF (LCO2CR) CALL DT_COM2CR
6696
6697     5 CONTINUE
6698
6699 * fragmentation of the complete event
6700 **uncomment for internal phojet-fragmentation
6701 C     CALL DT_EVTFRA(IREJ1)
6702       CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
6703       IF (IREJ1.GT.0) THEN
6704          IRFRAG = IRFRAG+1
6705          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
6706          GOTO 9999
6707       ENDIF
6708
6709 * decay of possible resonances (should be obsolete)
6710       CALL DT_DECAY1
6711
6712       RETURN
6713
6714  9999 CONTINUE
6715       IREVT = IREVT+1
6716       IREJ  = 1
6717       RETURN
6718       END
6719 *
6720 *===getcsy=============================================================*
6721 *
6722 CDECK  ID>, DT_GETCSY
6723       SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
6724      &                  IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
6725
6726 ************************************************************************
6727 * This version dated 15.01.95 is written by S. Roesler                 *
6728 ************************************************************************
6729
6730       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6731       SAVE
6732
6733       PARAMETER ( LINP = 5 ,
6734      &            LOUT = 6 ,
6735      &            LDAT = 9 )
6736
6737       PARAMETER (TINY10=1.0D-10)
6738
6739 * event history
6740
6741       PARAMETER (NMXHKK=200000)
6742
6743       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6744      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6745      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6746 * extended event history
6747       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6748      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6749      &                IHIST(2,NMXHKK)
6750 * rejection counter
6751       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6752      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6753      &                IREXCI(3),IRDIFF(2),IRINC
6754 * flags for input different options
6755       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6756       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6757      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6758 * flags for diffractive interactions (DTUNUC 1.x)
6759       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6760
6761       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
6762      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
6763
6764       IREJ  = 0
6765
6766 * get quark content of partons
6767       DO 1 I=1,2
6768          IFP1(I) = 0
6769          IFP2(I) = 0
6770          IFT1(I) = 0
6771          IFT2(I) = 0
6772     1 CONTINUE
6773       IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
6774       IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
6775       IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
6776       IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
6777       IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
6778       IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
6779       IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
6780       IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
6781
6782 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
6783       IDCH1 = 2
6784       IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
6785       IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
6786       IDCH2 = 2
6787       IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
6788       IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
6789
6790 * store initial configuration for energy-momentum cons. check
6791       IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
6792
6793 * sample intrinsic p_t at chain-ends
6794       CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
6795      &            PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
6796      &            AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
6797       IF (IREJ1.NE.0) THEN
6798          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
6799          IRPT = IRPT+1
6800          GOTO 9999
6801       ENDIF
6802
6803 C      IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6804 C         IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
6805 C* check second chain for resonance
6806 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6807 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
6808 C            IF (IREJ1.NE.0) GOTO 9999
6809 C            IF (IDR2.NE.0) THEN
6810 C               CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6811 C     &                     AMCH2,AMCH2N,AMCH1,IREJ1)
6812 C               IF (IREJ1.NE.0) GOTO 9999
6813 C            ENDIF
6814 C* check first chain for resonance
6815 C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6816 C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
6817 C            IF (IREJ1.NE.0) GOTO 9999
6818 C            IF (IDR1.NE.0) IDR1 = 100*IDR1
6819 C         ELSE
6820 C* check first chain for resonance
6821 C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6822 C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
6823 C            IF (IREJ1.NE.0) GOTO 9999
6824 C            IF (IDR1.NE.0) THEN
6825 C               CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6826 C     &                     AMCH1,AMCH1N,AMCH2,IREJ1)
6827 C               IF (IREJ1.NE.0) GOTO 9999
6828 C            ENDIF
6829 C* check second chain for resonance
6830 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6831 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
6832 C            IF (IREJ1.NE.0) GOTO 9999
6833 C            IF (IDR2.NE.0) IDR2 = 100*IDR2
6834 C         ENDIF
6835 C      ENDIF
6836
6837       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6838 * check chains for resonances
6839          CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6840      &               AMCH1,AMCH1N,IDCH1,IREJ1)
6841          IF (IREJ1.NE.0) GOTO 9999
6842          CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6843      &               AMCH2,AMCH2N,IDCH2,IREJ1)
6844          IF (IREJ1.NE.0) GOTO 9999
6845 * change kinematics corresponding to resonance-masses
6846          IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
6847             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6848      &                                 AMCH1,AMCH1N,AMCH2,IREJ1)
6849             IF (IREJ1.GT.0) GOTO 9999
6850             IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6851             CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6852      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
6853             IF (IREJ1.NE.0) GOTO 9999
6854             IF (IDR2.NE.0) IDR2 = 100*IDR2
6855          ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
6856             CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6857      &                                 AMCH2,AMCH2N,AMCH1,IREJ1)
6858             IF (IREJ1.GT.0) GOTO 9999
6859             IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6860             CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6861      &                  AMCH1,AMCH1N,IDCH1,IREJ1)
6862             IF (IREJ1.NE.0) GOTO 9999
6863             IF (IDR1.NE.0) IDR1 = 100*IDR1
6864          ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
6865             AMDIF1 = ABS(AMCH1-AMCH1N)
6866             AMDIF2 = ABS(AMCH2-AMCH2N)
6867             IF (AMDIF2.LT.AMDIF1) THEN
6868                CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6869      &                                    AMCH2,AMCH2N,AMCH1,IREJ1)
6870                IF (IREJ1.GT.0) GOTO 9999
6871                IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6872                CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
6873      &                     IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
6874                IF (IREJ1.NE.0) GOTO 9999
6875                IF (IDR1.NE.0) IDR1 = 100*IDR1
6876             ELSE
6877                CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6878      &                                    AMCH1,AMCH1N,AMCH2,IREJ1)
6879                IF (IREJ1.GT.0) GOTO 9999
6880                IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6881                CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
6882      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
6883                IF (IREJ1.NE.0) GOTO 9999
6884                IF (IDR2.NE.0) IDR2 = 100*IDR2
6885             ENDIF
6886          ENDIF
6887       ENDIF
6888
6889 * store final configuration for energy-momentum cons. check
6890       IF (LEMCCK) THEN
6891          CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
6892          CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
6893          IF (IREJ1.NE.0) GOTO 9999
6894       ENDIF
6895
6896 * put partons and chains into DTEVT1
6897       DO 10 I=1,4
6898          PCH1(I) = PP1(I)+PT1(I)
6899          PCH2(I) = PP2(I)+PT2(I)
6900    10 CONTINUE
6901       CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
6902      &                                      PP1(3),PP1(4),0,0,0)
6903       CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
6904      &                                      PT1(3),PT1(4),0,0,0)
6905       KCH = 100+IDCH(MOP1)*10+1
6906       CALL DT_EVTPUT(KCH,88888,-2,-1,
6907      &           PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
6908       CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
6909      &                                      PP2(3),PP2(4),0,0,0)
6910       CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
6911      &                                      PT2(3),PT2(4),0,0,0)
6912       KCH = KCH+1
6913       CALL DT_EVTPUT(KCH,88888,-2,-1,
6914      &           PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
6915
6916       RETURN
6917
6918  9999 CONTINUE
6919       IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
6920 * "cancel" sea-sea chains
6921          CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
6922          IF (IREJ1.NE.0) GOTO 9998
6923 **sr 16.5. flag for EVENTB
6924          IREJ = -1
6925          RETURN
6926       ENDIF
6927  9998 CONTINUE
6928       IREJ = 1
6929       RETURN
6930       END
6931 *
6932 *===chkine=============================================================*
6933 *
6934 CDECK  ID>, DT_CHKINE
6935       SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
6936      &                  AMCH1,AMCH1N,AMCH2,IREJ)
6937
6938 ************************************************************************
6939 * This subroutine replaces CORMOM.                                     *
6940 * This version dated 05.01.95 is written by S. Roesler                 *
6941 ************************************************************************
6942
6943       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6944       SAVE
6945
6946       PARAMETER ( LINP = 5 ,
6947      &            LOUT = 6 ,
6948      &            LDAT = 9 )
6949
6950       PARAMETER (TINY10=1.0D-10)
6951
6952 * flags for input different options
6953       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6954       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6955      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6956 * rejection counter
6957       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6958      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6959      &                IREXCI(3),IRDIFF(2),IRINC
6960
6961       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
6962      &          PP1I(4),PP2I(4),PT1I(4),PT2I(4)
6963
6964       IREJ  = 0
6965       JMSHL = IMSHL
6966
6967       SCALE  = AMCH1N/MAX(AMCH1,TINY10)
6968       DO 10 I=1,4
6969          PP1(I) = PP1I(I)
6970          PP2(I) = PP2I(I)
6971          PT1(I) = PT1I(I)
6972          PT2(I) = PT2I(I)
6973          PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
6974          PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
6975          PP1(I) = SCALE*PP1(I)
6976          PT1(I) = SCALE*PT1(I)
6977    10 CONTINUE
6978       IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
6979      &    (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
6980
6981       ECH = PP2(4)+PT2(4)
6982       PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
6983      &                               (PP2(3)+PT2(3))**2 )
6984       AMCH22 = (ECH-PCH)*(ECH+PCH)
6985       IF (AMCH22.LT.0.0D0) THEN
6986          IF (IOULEV(1).GT.0)
6987      &      WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
6988          GOTO 9997
6989       ENDIF
6990
6991       AMCH1 = AMCH1N
6992       AMCH2 = SQRT(AMCH22)
6993
6994 * put partons again on mass shell
6995    13 CONTINUE
6996       XM1 = 0.0D0
6997       XM2 = 0.0D0
6998       IF (JMSHL.EQ.1) THEN
6999
7000          XM1 = PYMASS(IFP1)
7001          XM2 = PYMASS(IFT1)
7002
7003       ENDIF
7004       CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
7005       IF (IREJ1.NE.0) THEN
7006          IF (JMSHL.EQ.0) GOTO 9998
7007          JMSHL = 0
7008          GOTO 13
7009       ENDIF
7010       JMSHL = IMSHL
7011       DO 11 I=1,4
7012          PP1(I) = P1(I)
7013          PT1(I) = P2(I)
7014    11 CONTINUE
7015    14 CONTINUE
7016       XM1 = 0.0D0
7017       XM2 = 0.0D0
7018       IF (JMSHL.EQ.1) THEN
7019
7020          XM1 = PYMASS(IFP2)
7021          XM2 = PYMASS(IFT2)
7022
7023       ENDIF
7024       CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
7025       IF (IREJ1.NE.0) THEN
7026          IF (JMSHL.EQ.0) GOTO 9998
7027          JMSHL = 0
7028          GOTO 14
7029       ENDIF
7030       DO 12 I=1,4
7031          PP2(I) = P1(I)
7032          PT2(I) = P2(I)
7033    12 CONTINUE
7034       DO 15 I=1,4
7035          PP1I(I) = PP1(I)
7036          PP2I(I) = PP2(I)
7037          PT1I(I) = PT1(I)
7038          PT2I(I) = PT2(I)
7039    15 CONTINUE
7040       RETURN
7041
7042  9997 IRCHKI(1) = IRCHKI(1)+1
7043 **sr
7044 C     GOTO 9999
7045       IREJ = -1
7046       RETURN
7047 **
7048  9998 IRCHKI(2) = IRCHKI(2)+1
7049
7050  9999 CONTINUE
7051       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
7052       IREJ = 1
7053       RETURN
7054       END
7055 *
7056 *===ch2res=============================================================*
7057 *
7058 CDECK  ID>, DT_CH2RES
7059       SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7060      &                  AM,AMN,IMODE,IREJ)
7061
7062 ************************************************************************
7063 * Check chains for resonance production.                               *
7064 * This subroutine replaces COMCMA/COBCMA/COMCM2                        *
7065 *    input:                                                            *
7066 *          IF1,2,3,4    input flavors (q,aq in any order)              *
7067 *          AM           chain mass                                     *
7068 *          MODE = 1     check q-aq chain for meson-resonance           *
7069 *               = 2     check q-qq, aq-aqaq chain for baryon-resonance *
7070 *               = 3     check qq-aqaq chain for lower mass cut         *
7071 *    output:                                                           *
7072 *          IDR = 0      no resonances found                            *
7073 *              = -1     pseudoscalar meson/octet baryon                *
7074 *              = 1      vector-meson/decuplet baryon                   *
7075 *          IDXR         BAMJET-index of corresponding resonance        *
7076 *          AMN          mass of corresponding resonance                *
7077 *                                                                      *
7078 *          IREJ         rejection flag                                 *
7079 * This version dated 06.01.95 is written by S. Roesler                 *
7080 ************************************************************************
7081
7082       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7083       SAVE
7084
7085       PARAMETER ( LINP = 5 ,
7086      &            LOUT = 6 ,
7087      &            LDAT = 9 )
7088
7089 * particle properties (BAMJET index convention)
7090       CHARACTER*8  ANAME
7091       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7092      &                IICH(210),IIBAR(210),K1(210),K2(210)
7093 * quark-content to particle index conversion (DTUNUC 1.x)
7094       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7095      &                IA08(6,21),IA10(6,21)
7096 * rejection counter
7097       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7098      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7099      &                IREXCI(3),IRDIFF(2),IRINC
7100 * flags for input different options
7101       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7102       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7103      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7104
7105       DIMENSION IF(4),JF(4)
7106
7107 **sr 4.7. test
7108 C     DATA AMLOM,AMLOB /0.08D0,0.2D0/
7109       DATA AMLOM,AMLOB /0.1D0,0.7D0/
7110 **
7111 C     DATA AMLOM,AMLOB /0.001D0,0.001D0/
7112
7113       MODE = ABS(IMODE)
7114
7115       IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7116          WRITE(LOUT,1000) MODE
7117  1000    FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7118      &          1X,'        program stopped')
7119          STOP
7120       ENDIF
7121
7122       AMX  = AM
7123       IREJ = 0
7124       IDR  = 0
7125       IDXR = 0
7126       AMN  = AMX
7127       IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7128       IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7129
7130       IF(1) = IF1
7131       IF(2) = IF2
7132       IF(3) = IF3
7133       IF(4) = IF4
7134       NF = 0
7135       DO 100 I=1,4
7136          IF (IF(I).NE.0) THEN
7137             NF = NF+1
7138             JF(NF) = IF(I)
7139          ENDIF
7140   100 CONTINUE
7141       IF (NF.LE.MODE) THEN
7142          WRITE(LOUT,1001) MODE,IF
7143  1001    FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7144      &   I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7145          GOTO 9999
7146       ENDIF
7147
7148       GOTO (1,2,3) MODE
7149
7150 * check for meson resonance
7151     1 CONTINUE
7152       IFQ  = JF(1)
7153       IFAQ = ABS(JF(2))
7154       IF (JF(2).GT.0) THEN
7155          IFQ  = JF(2)
7156          IFAQ = ABS(JF(1))
7157       ENDIF
7158       IFPS = IMPS(IFAQ,IFQ)
7159       IFV  = IMVE(IFAQ,IFQ)
7160       AMPS = AAM(IFPS)
7161       AMV  = AAM(IFV)
7162       AMHI = AMV+0.3D0
7163       IF (AMX.LT.AMV) THEN
7164          IF (AMX.LT.AMPS) THEN
7165             IF (IMODE.GT.0) THEN
7166                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7167             ELSE
7168                IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7169             ENDIF
7170             LOMRES = LOMRES+1
7171          ENDIF
7172 *    replace chain by pseudoscalar meson
7173          IDR  = -1
7174          IDXR = IFPS
7175          AMN  = AMPS
7176       ELSEIF (AMX.LT.AMHI) THEN
7177 *    replace chain by vector-meson
7178          IDR  = 1
7179          IDXR = IFV
7180          AMN  = AMV
7181       ENDIF
7182       RETURN
7183
7184 * check for baryon resonance
7185     2 CONTINUE
7186       CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7187       AM8  = AAM(JB8)
7188       AM10 = AAM(JB10)
7189       AMHI = AM10+0.3D0
7190       IF (AMX.LT.AM10) THEN
7191          IF (AMX.LT.AM8) THEN
7192             IF (IMODE.GT.0) THEN
7193                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7194             ELSE
7195                IF (AMX.LT.0.8D0*AM8) GOTO 9999
7196             ENDIF
7197             LOBRES = LOBRES+1
7198          ENDIF
7199 *    replace chain by oktet baryon
7200          IDR  = -1
7201          IDXR = JB8
7202          AMN  = AM8
7203       ELSEIF (AMX.LT.AMHI) THEN
7204          IDR  = 1
7205          IDXR = JB10
7206          AMN  = AM10
7207       ENDIF
7208       RETURN
7209
7210 * check qq-aqaq for lower mass cut
7211     3 CONTINUE
7212 *   empirical definition of AMHI to allow for (b-antib)-pair prod.
7213       AMHI = 2.5D0
7214       IF (AMX.LT.AMHI) GOTO 9999
7215       RETURN
7216
7217  9999 CONTINUE
7218       IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7219      &    WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7220       IREJ = 1
7221       IRRES(2) = IRRES(2)+1
7222       RETURN
7223       END
7224 *
7225 *===rjseac=============================================================*
7226 *
7227 CDECK  ID>, DT_RJSEAC
7228       SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7229
7230 ************************************************************************
7231 * ReJection of SEA-sea Chains.                                         *
7232 *         MOP1/2       entries of projectile sea-partons in DTEVT1     *
7233 *         MOT1/2       entries of projectile sea-partons in DTEVT1     *
7234 * This version dated 16.01.95 is written by S. Roesler                 *
7235 ************************************************************************
7236
7237       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7238       SAVE
7239
7240       PARAMETER ( LINP = 5 ,
7241      &            LOUT = 6 ,
7242      &            LDAT = 9 )
7243
7244       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7245
7246 * event history
7247
7248       PARAMETER (NMXHKK=200000)
7249
7250       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7251      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7252      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7253 * extended event history
7254       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7255      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7256      &                IHIST(2,NMXHKK)
7257 * statistics
7258       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7259      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7260      &                ICEVTG(8,0:30)
7261
7262       DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7263
7264       IREJ = 0
7265
7266 * projectile sea q-aq-pair
7267 *    indices of sea-pair
7268       IDXSEA(1,1) = MOP1
7269       IDXSEA(1,2) = MOP2
7270 *    index of mother-nucleon
7271       IDXNUC(1)   = JMOHKK(1,MOP1)
7272 *    status of valence quarks to be corrected
7273       ISTVAL(1)   = -21
7274
7275 * target sea q-aq-pair
7276 *    indices of sea-pair
7277       IDXSEA(2,1) = MOT1
7278       IDXSEA(2,2) = MOT2
7279 *    index of mother-nucleon
7280       IDXNUC(2)   = JMOHKK(1,MOT1)
7281 *    status of valence quarks to be corrected
7282       ISTVAL(2)   = -22
7283
7284       DO 1 N=1,2
7285          IDONE = 0
7286          DO 2 I=NPOINT(2),NHKK
7287             IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7288      &          (JMOHKK(1,I).EQ.IDXNUC(N)))   THEN
7289 * valence parton found
7290 *    inrease 4-momentum by sea 4-momentum
7291                DO 3 K=1,4
7292                   PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7293      &                                  PHKK(K,IDXSEA(N,2))
7294     3          CONTINUE
7295                PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7296      &                              PHKK(2,I)**2-PHKK(3,I)**2))
7297 *    "cancel" sea-pair
7298                DO 4 J=1,2
7299                   ISTHKK(IDXSEA(N,J))   = 100
7300                   IDHKK(IDXSEA(N,J))    = 0
7301                   JMOHKK(1,IDXSEA(N,J)) = 0
7302                   JMOHKK(2,IDXSEA(N,J)) = 0
7303                   JDAHKK(1,IDXSEA(N,J)) = 0
7304                   JDAHKK(2,IDXSEA(N,J)) = 0
7305                   DO 5 K=1,4
7306                      PHKK(K,IDXSEA(N,J)) = ZERO
7307                      VHKK(K,IDXSEA(N,J)) = ZERO
7308                      WHKK(K,IDXSEA(N,J)) = ZERO
7309     5             CONTINUE
7310                   PHKK(5,IDXSEA(N,J)) = ZERO
7311     4          CONTINUE
7312                IDONE = 1
7313             ENDIF
7314     2    CONTINUE
7315          IF (IDONE.NE.1) THEN
7316             WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7317  1000       FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7318      &                '-record!',/,1X,'        sea-quark pairs   ',
7319      &                2I5,4X,2I5,'   could not be canceled!')
7320             GOTO 9999
7321          ENDIF
7322     1 CONTINUE
7323       ICRJSS = ICRJSS+1
7324       RETURN
7325
7326  9999 CONTINUE
7327       IREJ = 1
7328       RETURN
7329       END
7330 *
7331 *===vv2sch=============================================================*
7332 *
7333 CDECK  ID>, DT_VV2SCH
7334       SUBROUTINE DT_VV2SCH
7335
7336 ************************************************************************
7337 * Change Valence-Valence chain systems to Single CHain systems for     *
7338 * hadron-nucleus collisions with meson or antibaryon projectile.       *
7339 * (Reggeon contribution)                                               *
7340 * The single chain system is approximately treated as one chain and a  *
7341 * meson at rest.                                                       *
7342 * This version dated 18.01.95 is written by S. Roesler                 *
7343 ************************************************************************
7344
7345       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7346       SAVE
7347
7348       PARAMETER ( LINP = 5 ,
7349      &            LOUT = 6 ,
7350      &            LDAT = 9 )
7351
7352       PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7353
7354       LOGICAL LSTART
7355
7356 * event history
7357
7358       PARAMETER (NMXHKK=200000)
7359
7360       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7361      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7362      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7363 * extended event history
7364       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7365      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7366      &                IHIST(2,NMXHKK)
7367 * flags for input different options
7368       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7369       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7370      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7371 * statistics
7372       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7373      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7374      &                ICEVTG(8,0:30)
7375
7376       DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7377      &          PCH2(4)
7378
7379       DATA LSTART /.TRUE./
7380
7381       IFSC  = 0
7382       IF (LSTART) THEN
7383          WRITE(LOUT,1000)
7384  1000    FORMAT(/,1X,'VV2SCH:  Reggeon contribution to valance-',
7385      &          'valence chains treated')
7386          LSTART = .FALSE.
7387       ENDIF
7388
7389       NSTOP = NHKK
7390
7391 * get index of first chain
7392       DO 1 I=NPOINT(3),NHKK
7393          IF (IDHKK(I).EQ.88888) THEN
7394             NC = I
7395             GOTO 2
7396          ENDIF
7397     1 CONTINUE
7398
7399     2 CONTINUE
7400       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7401      &                        .AND.(NC.LT.NSTOP)) THEN
7402 * get valence-valence chains
7403          IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7404 *   get "mother"-hadron indices
7405             MO1   = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7406             MO2   = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7407             KPROJ = IDT_ICIHAD(IDHKK(MO1))
7408             KTARG = IDT_ICIHAD(IDHKK(MO2))
7409 *   Lab momentum of projectile hadron
7410             CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7411             PTOT  = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7412      &                                  PHKK(3,MO1)**2)
7413
7414             SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7415             IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7416                ICVV2S = ICVV2S+1
7417 *   single chain requested
7418 *      get flavors of chain-end partons
7419                MO(1) = JMOHKK(1,NC)
7420                MO(2) = JMOHKK(2,NC)
7421                MO(3) = JMOHKK(1,NC+3)
7422                MO(4) = JMOHKK(2,NC+3)
7423                DO 3 I=1,4
7424                   IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7425                   IF(I,2) = 0
7426                   IF (ABS(IDHKK(MO(I))).GE.1000)
7427      &               IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7428     3          CONTINUE
7429 *      which one is the q-aq chain?
7430 *        N1,N1+1 - DTEVT1-entries for q-aq system
7431 *        N2,N2+1 - DTEVT1-entries for the other chain
7432                IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7433                   K1 = 1
7434                   K2 = 3
7435                   N1 = NC-2
7436                   N2 = NC+1
7437                ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7438                   K1 = 3
7439                   K2 = 1
7440                   N1 = NC+1
7441                   N2 = NC-2
7442                ELSE
7443                   GOTO 10
7444                ENDIF
7445                DO 4 K=1,4
7446                   PP1(K) = PHKK(K,N1)
7447                   PT1(K) = PHKK(K,N1+1)
7448                   PP2(K) = PHKK(K,N2)
7449                   PT2(K) = PHKK(K,N2+1)
7450     4          CONTINUE
7451                AMCH1 = PHKK(5,N1+2)
7452                AMCH2 = PHKK(5,N2+2)
7453 *      get meson-identity corresponding to flavors of q-aq chain
7454                ITMP   = IRESRJ
7455                IRESRJ = 0
7456                CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7457      &                     ZERO,AMCH1N,1,IDUM)
7458                IRESRJ = ITMP
7459 *      change kinematics of chains
7460                CALL DT_CHKINE(PP1,IDHKK(N1),  PP2,IDHKK(N2),
7461      &                     PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7462      &                     AMCH1,AMCH1N,AMCH2,IREJ1)
7463                IF (IREJ1.NE.0) GOTO 10
7464 *      check second chain for resonance
7465                IDCHAI = 2
7466                IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7467                CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7468      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7469                IF (IREJ1.NE.0) GOTO 10
7470                IF (IDR2.NE.0) IDR2 = 100*IDR2
7471 *      add partons and chains to DTEVT1
7472                DO 5 K=1,4
7473                   PCH1(K) = PP1(K)+PT1(K)
7474                   PCH2(K) = PP2(K)+PT2(K)
7475     5          CONTINUE
7476                CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7477      &                                             PP1(3),PP1(4),0,0,0)
7478                CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7479      &                                      PT1(2),PT1(3),PT1(4),0,0,0)
7480                KCH = ISTHKK(N1+2)+100
7481                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7482      &                     PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7483                IDHKK(N1+2) = 22222
7484                CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7485      &                                             PP2(3),PP2(4),0,0,0)
7486                CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7487      &                                      PT2(2),PT2(3),PT2(4),0,0,0)
7488                KCH = ISTHKK(N2+2)+100
7489                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7490      &                     PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7491                IDHKK(N2+2) = 22222
7492             ENDIF
7493          ENDIF
7494       ELSE
7495          GOTO 11
7496       ENDIF
7497    10 CONTINUE
7498       NC = NC+6
7499       GOTO 2
7500
7501    11 CONTINUE
7502
7503       RETURN
7504       END
7505 *
7506 *=== phnsch ===========================================================*
7507 *
7508 CDECK  ID>, DT_PHNSCH
7509       DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7510
7511 *----------------------------------------------------------------------*
7512 *                                                                      *
7513 *     Probability for Hadron Nucleon Single CHain interactions:        *
7514 *                                                                      *
7515 *     Created on 30 december 1993  by    Alfredo Ferrari & Paola Sala  *
7516 *                                                   Infn - Milan       *
7517 *                                                                      *
7518 *     Last change on 04-jan-94     by    Alfredo Ferrari               *
7519 *                                                                      *
7520 *             modified by J.R.for use in DTUNUC  6.1.94                *
7521 *                                                                      *
7522 *     Input variables:                                                 *
7523 *                      Kp = hadron projectile index (Part numbering    *
7524 *                           scheme)                                    *
7525 *                   Ktarg = target nucleon index (1=proton, 8=neutron) *
7526 *                    Plab = projectile laboratory momentum (GeV/c)     *
7527 *     Output variable:                                                 *
7528 *                  Phnsch = probability per single chain (particle     *
7529 *                           exchange) interactions                     *
7530 *                                                                      *
7531 *----------------------------------------------------------------------*
7532
7533       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7534       SAVE
7535
7536       PARAMETER ( LUNOUT = 6  )
7537       PARAMETER ( LUNERR = 6  )
7538       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
7539       PARAMETER ( ZERZER = 0.D+00 )
7540       PARAMETER ( ONEONE = 1.D+00 )
7541       PARAMETER ( TWOTWO = 2.D+00 )
7542       PARAMETER ( FIVFIV = 5.D+00 )
7543       PARAMETER ( HLFHLF = 0.5D+00 )
7544
7545       PARAMETER ( NALLWP = 39   )
7546       PARAMETER ( IDMAXP = 210  )
7547
7548       DIMENSION ICHRGE(39),AM(39)
7549
7550 * particle properties (BAMJET index convention)
7551       CHARACTER*8  ANAME
7552       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7553      &                IICH(210),IIBAR(210),K1(210),K2(210)
7554
7555       DIMENSION KPTOIP(210)
7556 * auxiliary common for reggeon exchange (DTUNUC 1.x)
7557       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7558      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7559      &                IQTCHR(-6:6),MQUARK(3,39)
7560
7561       DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7562       DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7563       SAVE SGTCOE, IHLP
7564       SAVE IQFSC1, IQFSC2, IQBSC1, IQBSC2
7565       EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7566       EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7567       EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7568
7569 * Conversion from part to paprop numbering
7570       DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7571      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7572      & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7573
7574 *  1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7575       DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7576      &    2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7577 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7578       DATA  SGTCO1  /
7579 * 1st reaction: gamma p total
7580      &0.147 D+00, ZERZER  , ZERZER   , 0.0022D+00, -0.0170D+00,
7581 * 2nd reaction: gamma d total
7582      &0.300 D+00, ZERZER  , ZERZER   , 0.0095D+00, -0.057 D+00,
7583 * 3rd reaction: pi+ p total
7584      &16.4  D+00, 19.3D+00, -0.42D+00, 0.19  D+00, ZERZER     ,
7585 * 4th reaction: pi- p total
7586      &33.0  D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03  D+00,
7587 * 5th reaction: pi+/- d total
7588      &56.8  D+00, 42.2D+00, -1.45D+00, 0.65  D+00, -5.39  D+00,
7589 * 6th reaction: K+ p total
7590      &18.1  D+00, ZERZER  , ZERZER   , 0.26  D+00, -1.0   D+00,
7591 * 7th reaction: K+ n total
7592      &18.7  D+00, ZERZER  , ZERZER   , 0.21  D+00, -0.89  D+00,
7593 * 8th reaction: K+ d total
7594      &34.2  D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99  D+00,
7595 * 9th reaction: K- p total
7596      &32.1  D+00, ZERZER  , ZERZER   , 0.66  D+00, -5.6   D+00,
7597 * 10th reaction: K- n total
7598      &25.2  D+00, ZERZER  , ZERZER   , 0.38  D+00, -2.9   D+00/
7599 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7600       DATA  SGTCO2  /
7601 * 11th reaction: K- d total
7602      &57.6  D+00, ZERZER  , ZERZER   , 1.17  D+00, -9.5   D+00,
7603 * 12th reaction: p p total
7604      &48.0  D+00, ZERZER  , ZERZER   , 0.522 D+00, -4.51  D+00,
7605 * 13th reaction: p n total
7606      &47.30 D+00, ZERZER  , ZERZER   , 0.513 D+00, -4.27  D+00,
7607 * 14th reaction: p d total
7608      &91.3  D+00, ZERZER  , ZERZER   , 1.05  D+00, -8.8   D+00,
7609 * 15th reaction: pbar p total
7610      &38.4  D+00, 77.6D+00, -0.64D+00, 0.26  D+00, -1.2   D+00,
7611 * 16th reaction: pbar n total
7612      &ZERZER    ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7   D+00,
7613 * 17th reaction: pbar d total
7614      &112.  D+00, 125.D+00, -1.08D+00, 1.14  D+00, -12.4  D+00,
7615 * 18th reaction: Lamda p total
7616      &30.4  D+00, ZERZER  , ZERZER   , ZERZER    , 1.6    D+00/
7617 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
7618       DATA SGTCO3  /
7619 * 19th reaction: pi+ p elastic
7620      &ZERZER    , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER     ,
7621 * 20th reaction: pi- p elastic
7622      &1.76  D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER     ,
7623 * 21st reaction: K+ p elastic
7624      &5.0   D+00, 8.1 D+00, -1.8 D+00, 0.16  D+00, -1.3   D+00,
7625 * 22nd reaction: K- p elastic
7626      &7.3   D+00, ZERZER  , ZERZER   , 0.29  D+00, -2.40  D+00,
7627 * 23rd reaction: p p elastic
7628      &11.9  D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85  D+00,
7629 * 24th reaction: p d elastic
7630      &16.1  D+00, ZERZER  , ZERZER   , 0.32  D+00, -3.4   D+00,
7631 * 25th reaction: pbar p elastic
7632      &10.2  D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28  D+00,
7633 * 26th reaction: pbar p elastic bis
7634      &10.6  D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41  D+00,
7635 * 27th reaction: pbar n elastic
7636      &36.5  D+00, ZERZER  , ZERZER   , ZERZER    , -11.9  D+00,
7637 * 28th reaction: Lamda p elastic
7638      &12.3  D+00, ZERZER  , ZERZER   , ZERZER    , -2.4   D+00,
7639 * 29th reaction: K- p ela bis
7640      &7.24  D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35  D+00,
7641 * 30th reaction: pi- p cx
7642      &ZERZER    ,0.912D+00, -1.22D+00, ZERZER    , ZERZER     ,
7643 * 31st reaction: K- p cx
7644      &ZERZER    , 3.39D+00, -1.75D+00, ZERZER    , ZERZER     ,
7645 * 32nd reaction: K+ n cx
7646      &ZERZER    , 7.18D+00, -2.01D+00, ZERZER    , ZERZER     ,
7647 * 33rd reaction: pbar p cx
7648      &ZERZER    , 18.8D+00, -2.01D+00, ZERZER    , ZERZER     /
7649 *
7650 *  +-------------------------------------------------------------------*
7651          ICHRGE(KTARG)=IICH(KTARG)
7652          AM    (KTARG)=AAM (KTARG)
7653 *  |  Check for pi0 (d-dbar)
7654       IF ( KP .NE. 26 ) THEN
7655          IP  = KPTOIP (KP)
7656          IF(IP.EQ.0)IP=1
7657          ICHRGE(IP)=IICH(KP)
7658          AM    (IP)=AAM (KP)
7659 *  |
7660 *  +-------------------------------------------------------------------*
7661 *  |
7662       ELSE
7663          IP = 23
7664          ICHRGE(IP)=0
7665       END IF
7666 *  |
7667 *  +-------------------------------------------------------------------*
7668 *  +-------------------------------------------------------------------*
7669 *  |  No such interactions for baryon-baryon
7670       IF ( IIBAR (KP) .GT. 0 ) THEN
7671          DT_PHNSCH = ZERZER
7672          RETURN
7673 *  |
7674 *  +-------------------------------------------------------------------*
7675 *  |  No "annihilation" diagram possible for K+ p/n
7676       ELSE IF ( IP .EQ. 15 ) THEN
7677          DT_PHNSCH = ZERZER
7678          RETURN
7679 *  |
7680 *  +-------------------------------------------------------------------*
7681 *  |  No "annihilation" diagram possible for K0 p/n
7682       ELSE IF ( IP .EQ. 24 ) THEN
7683          DT_PHNSCH = ZERZER
7684          RETURN
7685 *  |
7686 *  +-------------------------------------------------------------------*
7687 *  |  No "annihilation" diagram possible for Omebar p/n
7688       ELSE IF ( IP .GE. 38 ) THEN
7689          DT_PHNSCH = ZERZER
7690          RETURN
7691       END IF
7692 *  |
7693 *  +-------------------------------------------------------------------*
7694 *  +-------------------------------------------------------------------*
7695 *  |  If the momentum is larger than 50 GeV/c, compute the single
7696 *  |  chain probability at 50 GeV/c and extrapolate to the present
7697 *  |  momentum according to 1/sqrt(s)
7698 *  |  sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
7699 *  |  P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
7700 *  |  sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
7701 *  |  sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
7702 *  |                        x sqrt(s/s(50))
7703 *  |  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
7704       IF ( PLAB .GT. 50.D+00 ) THEN
7705          PLA    = 50.D+00
7706          AMPSQ  = AM (IP)**2
7707          AMTSQ  = AM (KTARG)**2
7708          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
7709          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7710          EPROJ  = SQRT ( PLA**2 + AMPSQ )
7711          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7712          UMORAT = SQRT ( UMOSQ / UMO50 )
7713 *  |
7714 *  +-------------------------------------------------------------------*
7715 *  |  P < 3 GeV/c
7716       ELSE IF ( PLAB .LT. 3.D+00 ) THEN
7717          PLA    = 3.D+00
7718          AMPSQ  = AM (IP)**2
7719          AMTSQ  = AM (KTARG)**2
7720          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
7721          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7722          EPROJ  = SQRT ( PLA**2 + AMPSQ )
7723          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7724          UMORAT = SQRT ( UMOSQ / UMO50 )
7725 *  |
7726 *  +-------------------------------------------------------------------*
7727 *  |  P < 50 GeV/c
7728       ELSE
7729          PLA    = PLAB
7730          UMORAT = ONEONE
7731       END IF
7732 *  |
7733 *  +-------------------------------------------------------------------*
7734       ALGPLA = LOG (PLA)
7735 *  +-------------------------------------------------------------------*
7736 *  |  Pions:
7737       IF ( IHLP (IP) .EQ. 2 ) THEN
7738          ACOF = SGTCOE (1,3)
7739          BCOF = SGTCOE (2,3)
7740          ENNE = SGTCOE (3,3)
7741          CCOF = SGTCOE (4,3)
7742          DCOF = SGTCOE (5,3)
7743 *  |  Compute the pi+ p total cross section:
7744          SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7745      &          + DCOF * ALGPLA
7746          ACOF = SGTCOE (1,19)
7747          BCOF = SGTCOE (2,19)
7748          ENNE = SGTCOE (3,19)
7749          CCOF = SGTCOE (4,19)
7750          DCOF = SGTCOE (5,19)
7751 *  |  Compute the pi+ p elastic cross section:
7752          SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7753      &          + DCOF * ALGPLA
7754 *  |  Compute the pi+ p inelastic cross section:
7755          SPPPIN = SPPPTT - SPPPEL
7756          ACOF = SGTCOE (1,4)
7757          BCOF = SGTCOE (2,4)
7758          ENNE = SGTCOE (3,4)
7759          CCOF = SGTCOE (4,4)
7760          DCOF = SGTCOE (5,4)
7761 *  |  Compute the pi- p total cross section:
7762          SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7763      &          + DCOF * ALGPLA
7764          ACOF = SGTCOE (1,20)
7765          BCOF = SGTCOE (2,20)
7766          ENNE = SGTCOE (3,20)
7767          CCOF = SGTCOE (4,20)
7768          DCOF = SGTCOE (5,20)
7769 *  |  Compute the pi- p elastic cross section:
7770          SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7771      &          + DCOF * ALGPLA
7772 *  |  Compute the pi- p inelastic cross section:
7773          SPMPIN = SPMPTT - SPMPEL
7774          SIGDIA = SPMPIN - SPPPIN
7775 *  |  +----------------------------------------------------------------*
7776 *  |  |  Charged pions: besides isospin consideration it is supposed
7777 *  |  |                 that (pi+ n)el is almost equal to (pi- p)el
7778 *  |  |                 and  (pi+ p)el "    "     "    "  (pi- n)el
7779 *  |  |                 and all are almost equal among each others
7780 *  |  |                 (reasonable above 5 GeV/c)
7781          IF ( ICHRGE (IP) .NE. 0 ) THEN
7782             KHELP = KTARG / 8
7783             JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
7784             ACOF = SGTCOE (1,JREAC)
7785             BCOF = SGTCOE (2,JREAC)
7786             ENNE = SGTCOE (3,JREAC)
7787             CCOF = SGTCOE (4,JREAC)
7788             DCOF = SGTCOE (5,JREAC)
7789 *  |  |  Compute the total cross section:
7790             SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7791      &             + DCOF * ALGPLA
7792             JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
7793             ACOF = SGTCOE (1,JREAC)
7794             BCOF = SGTCOE (2,JREAC)
7795             ENNE = SGTCOE (3,JREAC)
7796             CCOF = SGTCOE (4,JREAC)
7797             DCOF = SGTCOE (5,JREAC)
7798 *  |  |  Compute the elastic cross section:
7799             SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7800      &             + DCOF * ALGPLA
7801 *  |  |  Compute the inelastic cross section:
7802             SHNCIN = SHNCTT - SHNCEL
7803 *  |  |  Number of diagrams:
7804             NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
7805 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7806             IQFSC1 = 1 + IP - 13
7807             IQFSC2 = 0
7808             IQBSC1 = 1 + KHELP
7809             IQBSC2 = 1 + IP - 13
7810 *  |  |
7811 *  |  +----------------------------------------------------------------*
7812 *  |  |  pi0: besides isospin consideration it is supposed that the
7813 *  |  |       elastic cross section is not very different from
7814 *  |  |       pi+ p and/or pi- p (reasonable above 5 GeV/c)
7815          ELSE
7816             KHELP  = KTARG / 8
7817             K2HLP  = ( KP - 23 ) / 3
7818 *  |  |  Number of diagrams:
7819 *  |  |  For u ubar (k2hlp=0):
7820 *           NDIAGR = 2 - KHELP
7821 *  |  |  For d dbar (k2hlp=1):
7822 *           NDIAGR = 2 + KHELP - K2HLP
7823             NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
7824             SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
7825 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7826             IQFSC1 = 1 + K2HLP
7827             IQFSC2 = 0
7828             IQBSC1 = 1 + KHELP
7829             IQBSC2 = 2 - K2HLP
7830          END IF
7831 *  |  |
7832 *  |  +----------------------------------------------------------------*
7833 *  |                                                   end pi's
7834 *  +-------------------------------------------------------------------*
7835 *  |  Kaons:
7836       ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
7837          ACOF = SGTCOE (1,6)
7838          BCOF = SGTCOE (2,6)
7839          ENNE = SGTCOE (3,6)
7840          CCOF = SGTCOE (4,6)
7841          DCOF = SGTCOE (5,6)
7842 *  |  Compute the K+ p total cross section:
7843          SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7844      &          + DCOF * ALGPLA
7845          ACOF = SGTCOE (1,21)
7846          BCOF = SGTCOE (2,21)
7847          ENNE = SGTCOE (3,21)
7848          CCOF = SGTCOE (4,21)
7849          DCOF = SGTCOE (5,21)
7850 *  |  Compute the K+ p elastic cross section:
7851          SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7852      &          + DCOF * ALGPLA
7853 *  |  Compute the K+ p inelastic cross section:
7854          SKPPIN = SKPPTT - SKPPEL
7855          ACOF = SGTCOE (1,9)
7856          BCOF = SGTCOE (2,9)
7857          ENNE = SGTCOE (3,9)
7858          CCOF = SGTCOE (4,9)
7859          DCOF = SGTCOE (5,9)
7860 *  |  Compute the K- p total cross section:
7861          SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7862      &          + DCOF * ALGPLA
7863          ACOF = SGTCOE (1,22)
7864          BCOF = SGTCOE (2,22)
7865          ENNE = SGTCOE (3,22)
7866          CCOF = SGTCOE (4,22)
7867          DCOF = SGTCOE (5,22)
7868 *  |  Compute the K- p elastic cross section:
7869          SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7870      &          + DCOF * ALGPLA
7871 *  |  Compute the K- p inelastic cross section:
7872          SKMPIN = SKMPTT - SKMPEL
7873          SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
7874 *  |  +----------------------------------------------------------------*
7875 *  |  |  Charged Kaons: actually only K-
7876          IF ( ICHRGE (IP) .NE. 0 ) THEN
7877             KHELP = KTARG / 8
7878 *  |  |  +-------------------------------------------------------------*
7879 *  |  |  |  Proton target:
7880             IF ( KHELP .EQ. 0 ) THEN
7881                SHNCIN = SKMPIN
7882 *  |  |  |  Number of diagrams:
7883                NDIAGR = 2
7884 *  |  |  |
7885 *  |  |  +-------------------------------------------------------------*
7886 *  |  |  |  Neutron target: besides isospin consideration it is supposed
7887 *  |  |  |              that (K- n)el is almost equal to (K- p)el
7888 *  |  |  |              (reasonable above 5 GeV/c)
7889             ELSE
7890                ACOF = SGTCOE (1,10)
7891                BCOF = SGTCOE (2,10)
7892                ENNE = SGTCOE (3,10)
7893                CCOF = SGTCOE (4,10)
7894                DCOF = SGTCOE (5,10)
7895 *  |  |  |  Compute the total cross section:
7896                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7897      &                + DCOF * ALGPLA
7898 *  |  |  |  Compute the elastic cross section:
7899                SHNCEL = SKMPEL
7900 *  |  |  |  Compute the inelastic cross section:
7901                SHNCIN = SHNCTT - SHNCEL
7902 *  |  |  |  Number of diagrams:
7903                NDIAGR = 1
7904             END IF
7905 *  |  |  |
7906 *  |  |  +-------------------------------------------------------------*
7907 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7908             IQFSC1 = 3
7909             IQFSC2 = 0
7910             IQBSC1 = 1 + KHELP
7911             IQBSC2 = 2
7912 *  |  |
7913 *  |  +----------------------------------------------------------------*
7914 *  |  |  K0's: (actually only K0bar)
7915          ELSE
7916             KHELP  = KTARG / 8
7917 *  |  |  +-------------------------------------------------------------*
7918 *  |  |  |  Proton target: (K0bar p)in supposed to be given by
7919 *  |  |  |                 (K- p)in - Sig_diagr
7920             IF ( KHELP .EQ. 0 ) THEN
7921                SHNCIN = SKMPIN - SIGDIA
7922 *  |  |  |  Number of diagrams:
7923                NDIAGR = 1
7924 *  |  |  |
7925 *  |  |  +-------------------------------------------------------------*
7926 *  |  |  |  Neutron target: (K0bar n)in supposed to be given by
7927 *  |  |  |                 (K- n)in + Sig_diagr
7928 *  |  |  |              besides isospin consideration it is supposed
7929 *  |  |  |              that (K- n)el is almost equal to (K- p)el
7930 *  |  |  |              (reasonable above 5 GeV/c)
7931             ELSE
7932                ACOF = SGTCOE (1,10)
7933                BCOF = SGTCOE (2,10)
7934                ENNE = SGTCOE (3,10)
7935                CCOF = SGTCOE (4,10)
7936                DCOF = SGTCOE (5,10)
7937 *  |  |  |  Compute the total cross section:
7938                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7939      &                + DCOF * ALGPLA
7940 *  |  |  |  Compute the elastic cross section:
7941                SHNCEL = SKMPEL
7942 *  |  |  |  Compute the inelastic cross section:
7943                SHNCIN = SHNCTT - SHNCEL + SIGDIA
7944 *  |  |  |  Number of diagrams:
7945                NDIAGR = 2
7946             END IF
7947 *  |  |  |
7948 *  |  |  +-------------------------------------------------------------*
7949 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7950             IQFSC1 = 3
7951             IQFSC2 = 0
7952             IQBSC1 = 1
7953             IQBSC2 = 1 + KHELP
7954          END IF
7955 *  |  |
7956 *  |  +----------------------------------------------------------------*
7957 *  |                                                   end Kaon's
7958 *  +-------------------------------------------------------------------*
7959 *  |  Antinucleons:
7960       ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
7961 *  |  For momenta between 3 and 5 GeV/c the use of tabulated data
7962 *  |  should be implemented!
7963          ACOF = SGTCOE (1,15)
7964          BCOF = SGTCOE (2,15)
7965          ENNE = SGTCOE (3,15)
7966          CCOF = SGTCOE (4,15)
7967          DCOF = SGTCOE (5,15)
7968 *  |  Compute the pbar p total cross section:
7969          SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7970      &          + DCOF * ALGPLA
7971          IF ( PLA .LT. FIVFIV ) THEN
7972             JREAC = 26
7973          ELSE
7974             JREAC = 25
7975          END IF
7976          ACOF = SGTCOE (1,JREAC)
7977          BCOF = SGTCOE (2,JREAC)
7978          ENNE = SGTCOE (3,JREAC)
7979          CCOF = SGTCOE (4,JREAC)
7980          DCOF = SGTCOE (5,JREAC)
7981 *  |  Compute the pbar p elastic cross section:
7982          SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7983      &          + DCOF * ALGPLA
7984 *  |  Compute the pbar p inelastic cross section:
7985          SAPPIN = SAPPTT - SAPPEL
7986          ACOF = SGTCOE (1,12)
7987          BCOF = SGTCOE (2,12)
7988          ENNE = SGTCOE (3,12)
7989          CCOF = SGTCOE (4,12)
7990          DCOF = SGTCOE (5,12)
7991 *  |  Compute the p p total cross section:
7992          SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7993      &          + DCOF * ALGPLA
7994          ACOF = SGTCOE (1,23)
7995          BCOF = SGTCOE (2,23)
7996          ENNE = SGTCOE (3,23)
7997          CCOF = SGTCOE (4,23)
7998          DCOF = SGTCOE (5,23)
7999 *  |  Compute the p p elastic cross section:
8000          SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8001      &          + DCOF * ALGPLA
8002 *  |  Compute the K- p inelastic cross section:
8003          SPPINE = SPPTOT - SPPELA
8004          SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
8005          KHELP  = KTARG / 8
8006 *  |  +----------------------------------------------------------------*
8007 *  |  |  Pbar:
8008          IF ( ICHRGE (IP) .NE. 0 ) THEN
8009             NDIAGR = 5 - KHELP
8010 *  |  |  +-------------------------------------------------------------*
8011 *  |  |  |  Proton target:
8012             IF ( KHELP .EQ. 0 ) THEN
8013 *  |  |  |  Number of diagrams:
8014                SHNCIN = SAPPIN
8015                PUUBAR = 0.8D+00
8016 *  |  |  |
8017 *  |  |  +-------------------------------------------------------------*
8018 *  |  |  |  Neutron target: it is supposed that (ap n)el is almost equal
8019 *  |  |  |                  to (ap p)el (reasonable above 5 GeV/c)
8020             ELSE
8021                ACOF = SGTCOE (1,16)
8022                BCOF = SGTCOE (2,16)
8023                ENNE = SGTCOE (3,16)
8024                CCOF = SGTCOE (4,16)
8025                DCOF = SGTCOE (5,16)
8026 *  |  |  |  Compute the total cross section:
8027                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8028      &                + DCOF * ALGPLA
8029 *  |  |  |  Compute the elastic cross section:
8030                SHNCEL = SAPPEL
8031 *  |  |  |  Compute the inelastic cross section:
8032                SHNCIN = SHNCTT - SHNCEL
8033                PUUBAR = HLFHLF
8034             END IF
8035 *  |  |  |
8036 *  |  |  +-------------------------------------------------------------*
8037 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8038 *  |  |  there are different possibilities, make a random choiche:
8039             IQFSC1 = -1
8040             RNCHEN = DT_RNDM(PUUBAR)
8041             IF ( RNCHEN .LT. PUUBAR ) THEN
8042                IQFSC2 = -2
8043             ELSE
8044                IQFSC2 = -1
8045             END IF
8046             IQBSC1 = -IQFSC1 + KHELP
8047             IQBSC2 = -IQFSC2
8048 *  |  |
8049 *  |  +----------------------------------------------------------------*
8050 *  |  |  nbar:
8051          ELSE
8052             NDIAGR = 4 + KHELP
8053 *  |  |  +-------------------------------------------------------------*
8054 *  |  |  |  Proton target: (nbar p)in supposed to be given by
8055 *  |  |  |                 (pbar p)in - Sig_diagr
8056             IF ( KHELP .EQ. 0 ) THEN
8057                SHNCIN = SAPPIN - SIGDIA
8058                PDDBAR = HLFHLF
8059 *  |  |  |
8060 *  |  |  +-------------------------------------------------------------*
8061 *  |  |  |  Neutron target: (nbar n)el is supposed to be equal to
8062 *  |  |  |                  (pbar p)el (reasonable above 5 GeV/c)
8063             ELSE
8064 *  |  |  |  Compute the total cross section:
8065                SHNCTT = SAPPTT
8066 *  |  |  |  Compute the elastic cross section:
8067                SHNCEL = SAPPEL
8068 *  |  |  |  Compute the inelastic cross section:
8069                SHNCIN = SHNCTT - SHNCEL
8070                PDDBAR = 0.8D+00
8071             END IF
8072 *  |  |  |
8073 *  |  |  +-------------------------------------------------------------*
8074 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8075 *  |  |  there are different possibilities, make a random choiche:
8076             IQFSC1 = -2
8077             RNCHEN = DT_RNDM(RNCHEN)
8078             IF ( RNCHEN .LT. PDDBAR ) THEN
8079                IQFSC2 = -1
8080             ELSE
8081                IQFSC2 = -2
8082             END IF
8083             IQBSC1 = -IQFSC1 + KHELP - 1
8084             IQBSC2 = -IQFSC2
8085          END IF
8086 *  |  |
8087 *  |  +----------------------------------------------------------------*
8088 *  |
8089 *  +-------------------------------------------------------------------*
8090 *  |  Others: not yet implemented
8091       ELSE
8092          SIGDIA = ZERZER
8093          SHNCIN = ONEONE
8094          NDIAGR = 0
8095          DT_PHNSCH = ZERZER
8096          RETURN
8097       END IF
8098 *  |                                                   end others
8099 *  +-------------------------------------------------------------------*
8100       DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8101       IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8102      &       + IQECHR (IQBSC2)
8103       IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8104      &       + IQBCHR (IQBSC2)
8105       IQECHC = IQECHC / 3
8106       IQBCHC = IQBCHC / 3
8107       IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8108      &       + IQSCHR (IQBSC2)
8109       IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8110      &       + IQSCHR (MQUARK(3,IP))
8111 *  +-------------------------------------------------------------------*
8112 *  |  Consistency check:
8113       IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8114          WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8115      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8116          WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8117      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8118          DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8119          DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8120       END IF
8121 *  |
8122 *  +-------------------------------------------------------------------*
8123 *  +-------------------------------------------------------------------*
8124 *  |  Consistency check:
8125       IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8126      &     .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8127          WRITE (LUNOUT,*)
8128      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8129      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8130          WRITE (LUNERR,*)
8131      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8132      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8133       END IF
8134 *  |
8135 *  +-------------------------------------------------------------------*
8136 *  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8137       IF ( UMORAT .GT. ONEPLS )
8138      &   DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8139      &                                 - ONEONE ) * UMORAT + ONEONE )
8140       RETURN
8141 *
8142       ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8143       DT_SCHQUA = ONEONE
8144       JQFSC1 = IQFSC1
8145       JQFSC2 = IQFSC2
8146       JQBSC1 = IQBSC1
8147       JQBSC2 = IQBSC2
8148 *=== End of function Phnsch ===========================================*
8149       RETURN
8150       END
8151 *
8152 *===respt==============================================================*
8153 *
8154 CDECK  ID>, DT_RESPT
8155       SUBROUTINE DT_RESPT
8156
8157 ************************************************************************
8158 * Check DTEVT1 for two-resonance systems and sample intrinsic p_t.     *
8159 * This version dated 18.01.95 is written by S. Roesler                 *
8160 ************************************************************************
8161
8162       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8163       SAVE
8164
8165       PARAMETER ( LINP = 5 ,
8166      &            LOUT = 6 ,
8167      &            LDAT = 9 )
8168
8169       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8170
8171 * event history
8172
8173       PARAMETER (NMXHKK=200000)
8174
8175       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8176      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8177      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8178 * extended event history
8179       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8180      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8181      &                IHIST(2,NMXHKK)
8182
8183 * get index of first chain
8184       DO 1 I=NPOINT(3),NHKK
8185          IF (IDHKK(I).EQ.88888) THEN
8186             NC = I
8187             GOTO 2
8188          ENDIF
8189     1 CONTINUE
8190
8191     2 CONTINUE
8192       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8193 C        WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8194 * skip VV-,SS- systems
8195          IF ((IDCH(NC  ).NE.1).AND.(IDCH(NC  ).NE.8).AND.
8196      &       (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8197 * check if both "chains" are resonances
8198             IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8199                CALL DT_SAPTRE(NC,NC+3)
8200             ENDIF
8201          ENDIF
8202       ELSE
8203          GOTO 3
8204       ENDIF
8205       NC = NC+6
8206       GOTO 2
8207
8208     3 CONTINUE
8209
8210       RETURN
8211       END
8212 *
8213 *===evtres=============================================================*
8214 *
8215 CDECK  ID>, DT_EVTRES
8216       SUBROUTINE DT_EVTRES(IREJ)
8217
8218 ************************************************************************
8219 * This version dated 14.12.94 is written by S. Roesler                 *
8220 ************************************************************************
8221
8222       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8223       SAVE
8224
8225       PARAMETER ( LINP = 5 ,
8226      &            LOUT = 6 ,
8227      &            LDAT = 9 )
8228
8229       PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8230
8231 * event history
8232
8233       PARAMETER (NMXHKK=200000)
8234
8235       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8236      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8237      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8238 * extended event history
8239       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8240      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8241      &                IHIST(2,NMXHKK)
8242 * flags for input different options
8243       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8244       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8245      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8246 * particle properties (BAMJET index convention)
8247       CHARACTER*8  ANAME
8248       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8249      &                IICH(210),IIBAR(210),K1(210),K2(210)
8250
8251       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8252
8253       IREJ = 0
8254
8255       DO 1 I=NPOINT(3),NHKK
8256          IF (ABS(IDRES(I)).GE.100) THEN
8257             AMMX = 0.0D0
8258             DO 2 J=NPOINT(3),NHKK
8259                IF (IDHKK(J).EQ.88888) THEN
8260                   IF (PHKK(5,J).GT.AMMX) THEN
8261                      AMMX = PHKK(5,J)
8262                      IMMX = J
8263                   ENDIF
8264                ENDIF
8265     2       CONTINUE
8266             IF (IDRES(IMMX).NE.0) THEN
8267                IF (IOULEV(3).GT.0) THEN
8268                   WRITE(LOUT,'(1X,A)')
8269      &               'EVTRES: no chain for correc. found'
8270 C                 GOTO 6
8271                   GOTO 9999
8272                ELSE
8273                   GOTO 9999
8274                ENDIF
8275             ENDIF
8276             IMO11  = JMOHKK(1,I)
8277             IMO12  = JMOHKK(2,I)
8278             IF (PHKK(3,IMO11).LT.0.0D0) THEN
8279                IMO11 = JMOHKK(2,I)
8280                IMO12 = JMOHKK(1,I)
8281             ENDIF
8282             IMO21  = JMOHKK(1,IMMX)
8283             IMO22  = JMOHKK(2,IMMX)
8284             IF (PHKK(3,IMO21).LT.0.0D0) THEN
8285                IMO21 = JMOHKK(2,IMMX)
8286                IMO22 = JMOHKK(1,IMMX)
8287             ENDIF
8288             AMCH1  = PHKK(5,I)
8289             AMCH1N = AAM(IDXRES(I))
8290
8291             IFPR1 = IDHKK(IMO11)
8292             IFPR2 = IDHKK(IMO21)
8293             IFTA1 = IDHKK(IMO12)
8294             IFTA2 = IDHKK(IMO22)
8295             DO 4 J=1,4
8296                PP1(J) = PHKK(J,IMO11)
8297                PP2(J) = PHKK(J,IMO21)
8298                PT1(J) = PHKK(J,IMO12)
8299                PT2(J) = PHKK(J,IMO22)
8300     4       CONTINUE
8301 * store initial configuration for energy-momentum cons. check
8302             IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8303 * correct kinematics of second chain
8304             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8305      &                  AMCH1,AMCH1N,AMCH2,IREJ1)
8306             IF (IREJ1.NE.0) GOTO 9999
8307 * check now this chain for resonance mass
8308             IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8309             IFP(2) = 0
8310             IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8311             IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8312             IFT(2) = 0
8313             IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8314             IDCH2 = 2
8315             IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8316             IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8317             CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8318      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
8319             IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8320                IF (IOULEV(1).GT.0)
8321      &            WRITE(LOUT,*) ' correction for resonance not poss.'
8322 **sr test
8323 C              GOTO 1
8324 C              GOTO 9999
8325 **
8326             ENDIF
8327 * store final configuration for energy-momentum cons. check
8328             IF (LEMCCK) THEN
8329                CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8330                CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8331                IF (IREJ1.NE.0) GOTO 9999
8332             ENDIF
8333             DO 5 J=1,4
8334                PHKK(J,IMO11) = PP1(J)
8335                PHKK(J,IMO21) = PP2(J)
8336                PHKK(J,IMO12) = PT1(J)
8337                PHKK(J,IMO22) = PT2(J)
8338     5       CONTINUE
8339 * correct entries of chains
8340             DO 3 K=1,4
8341                PHKK(K,I)    = PHKK(K,IMO11)+PHKK(K,IMO12)
8342                PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8343     3       CONTINUE
8344             AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8345             AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8346      &            PHKK(3,IMMX)**2
8347 * ?? the following should now be obsolete
8348 **sr test
8349 C           IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8350             IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8351 **
8352                WRITE(LOUT,'(1X,A,4G10.3)')
8353      &          'EVTRES: inonsistent mass-corr.',AM1,AM2
8354 C              GOTO 9999
8355                GOTO 1
8356             ENDIF
8357             PHKK(5,I)    = SQRT(AM1)
8358             PHKK(5,IMMX) = SQRT(AM2)
8359             IDRES(I)     = IDRES(I)/100
8360             IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8361      &          (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8362                WRITE(LOUT,'(1X,A,4G10.3)')
8363      &          'EVTRES: inconsistent chain-masses',
8364      &          PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8365                GOTO 9999
8366             ENDIF
8367          ENDIF
8368     1 CONTINUE
8369     6 CONTINUE
8370       RETURN
8371
8372  9999 CONTINUE
8373       IREJ = 1
8374       RETURN
8375       END
8376 *
8377 *===getspt=============================================================*
8378 *
8379 CDECK  ID>, DT_GETSPT
8380       SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8381      &                  PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8382      &                  AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8383
8384 ************************************************************************
8385 * This version dated 12.12.94 is written by S. Roesler                 *
8386 ************************************************************************
8387
8388       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8389       SAVE
8390
8391       PARAMETER ( LINP = 5 ,
8392      &            LOUT = 6 ,
8393      &            LDAT = 9 )
8394
8395       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8396
8397 * various options for treatment of partons (DTUNUC 1.x)
8398 * (chain recombination, Cronin,..)
8399       LOGICAL LCO2CR,LINTPT
8400       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8401      &                LCO2CR,LINTPT
8402 * flags for input different options
8403       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8404       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8405      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8406 * flags for diffractive interactions (DTUNUC 1.x)
8407       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8408
8409       DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8410      &          PT2(4),PT2I(4),P1(4),P2(4),
8411      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8412      &          PTOTI(4),PTOTF(4),DIFF(4)
8413
8414       IC   = 0
8415       IREJ = 0
8416 C     B33P = 4.0D0
8417 C     B33T = 4.0D0
8418 C     IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8419 C     IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8420       REDU = 1.0D0
8421 C     B33P = 3.5D0
8422 C     B33T = 3.5D0
8423       B33P = 4.0D0
8424       B33T = 4.0D0
8425       IF (IDIFF.NE.0) THEN
8426          B33P = 16.0D0
8427          B33T = 16.0D0
8428       ENDIF
8429
8430       DO 1 I=1,4
8431          PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8432          PP1(I)   = PP1I(I)
8433          PP2(I)   = PP2I(I)
8434          PT1(I)   = PT1I(I)
8435          PT2(I)   = PT2I(I)
8436     1 CONTINUE
8437 * get initial chain masses
8438       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8439      &                               +(PP1(3)+PT1(3))**2)
8440       ECH   = PP1(4)+PT1(4)
8441       AM1   = (ECH+PTOCH)*(ECH-PTOCH)
8442       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8443      &                               +(PP2(3)+PT2(3))**2)
8444       ECH   = PP2(4)+PT2(4)
8445       AM2   = (ECH+PTOCH)*(ECH-PTOCH)
8446       IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8447          IF (IOULEV(1).GT.0)
8448      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8449      &                              AM1,AM2
8450          GOTO 9999
8451       ENDIF
8452       AM1  = SQRT(AM1)
8453       AM2  = SQRT(AM2)
8454       AM1N = ZERO
8455       AM2N = ZERO
8456
8457       MODE = 0
8458 C      IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8459 C        MODE = 0
8460 C      ELSE
8461 C         MODE = 1
8462 C         IF (AM1.LT.0.6) THEN
8463 C            B33P = 10.0D0
8464 C         ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8465 CC           B33P = 4.0D0
8466 C         ENDIF
8467 C         IF (AM2.LT.0.6) THEN
8468 C            B33T = 10.0D0
8469 C         ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8470 CC           B33T = 4.0D0
8471 C         ENDIF
8472 C      ENDIF
8473
8474 * check chain masses for very low mass chains
8475 C     CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8476 C    &            AM1,DUM,-IDCH1,IREJ1)
8477 C     CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8478 C    &            AM2,DUM,-IDCH2,IREJ2)
8479 C     IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8480 C        B33P = 20.0D0
8481 C        B33T = 20.0D0
8482 C     ENDIF
8483
8484       JMSHL = IMSHL
8485
8486     2 CONTINUE
8487       IC = IC+1
8488       IF (MOD(IC,15).EQ.0) B33P  = 2.0D0*B33P
8489       IF (MOD(IC,15).EQ.0) B33T  = 2.0D0*B33T
8490       IF (MOD(IC,18).EQ.0) REDU  = 0.0D0
8491 C     IF (MOD(IC,19).EQ.0) JMSHL = 0
8492       IF (MOD(IC,20).EQ.0) GOTO 7
8493 C        WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8494 C        RETURN
8495 C        GOTO 9999
8496 C     ENDIF
8497
8498 * get transverse momentum
8499       IF (LINTPT) THEN
8500          ES   = -2.0D0/(B33P**2)
8501      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8502          HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8503          HPSP = HPSP*REDU
8504          ES   = -2.0D0/(B33T**2)
8505      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8506          HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8507          HPST = HPST*REDU
8508       ELSE
8509          HPSP = ZERO
8510          HPST = ZERO
8511       ENDIF
8512       CALL DT_DSFECF(SFE1,CFE1)
8513       CALL DT_DSFECF(SFE2,CFE2)
8514       IF (MODE.EQ.0) THEN
8515          PP1(1) = PP1I(1)+HPSP*CFE1
8516          PP1(2) = PP1I(2)+HPSP*SFE1
8517          PP2(1) = PP2I(1)-HPSP*CFE1
8518          PP2(2) = PP2I(2)-HPSP*SFE1
8519          PT1(1) = PT1I(1)+HPST*CFE2
8520          PT1(2) = PT1I(2)+HPST*SFE2
8521          PT2(1) = PT2I(1)-HPST*CFE2
8522          PT2(2) = PT2I(2)-HPST*SFE2
8523       ELSE
8524          PP1(1) = PP1I(1)+HPSP*CFE1
8525          PP1(2) = PP1I(2)+HPSP*SFE1
8526          PT1(1) = PT1I(1)-HPSP*CFE1
8527          PT1(2) = PT1I(2)-HPSP*SFE1
8528          PP2(1) = PP2I(1)+HPST*CFE2
8529          PP2(2) = PP2I(2)+HPST*SFE2
8530          PT2(1) = PT2I(1)-HPST*CFE2
8531          PT2(2) = PT2I(2)-HPST*SFE2
8532       ENDIF
8533
8534 * put partons on mass shell
8535       XMP1 = 0.0D0
8536       XMT1 = 0.0D0
8537       IF (JMSHL.EQ.1) THEN
8538
8539          XMP1 = PYMASS(IFPR1)
8540          XMT1 = PYMASS(IFTA1)
8541
8542       ENDIF
8543       CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8544       IF (IREJ1.NE.0) GOTO 2
8545       DO 3 I=1,4
8546          PTOTF(I) = P1(I)+P2(I)
8547          PP1(I)   = P1(I)
8548          PT1(I)   = P2(I)
8549     3 CONTINUE
8550       XMP2 = 0.0D0
8551       XMT2 = 0.0D0
8552       IF (JMSHL.EQ.1) THEN
8553
8554          XMP2 = PYMASS(IFPR2)
8555          XMT2 = PYMASS(IFTA2)
8556
8557       ENDIF
8558       CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8559       IF (IREJ1.NE.0) GOTO 2
8560       DO 4 I=1,4
8561          PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8562          PP2(I)   = P1(I)
8563          PT2(I)   = P2(I)
8564     4 CONTINUE
8565
8566 * check consistency
8567       DO 5 I=1,4
8568          DIFF(I) = PTOTI(I)-PTOTF(I)
8569     5 CONTINUE
8570       IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8571      &    (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8572          WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8573          GOTO 9999
8574       ENDIF
8575       PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8576       AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8577       PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8578       AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8579       PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8580       AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8581       PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8582       AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8583       IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8584      &    (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8585      &                                                           THEN
8586          WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8587      &     'GETSPT: inconsistent masses',
8588      &     AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8589 * sr 22.11.00: commented. It should only have inconsistent masses for
8590 * ultrahigh energies due to rounding problems
8591 C        GOTO 9999
8592       ENDIF
8593
8594 * get chain masses
8595       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8596      &                               +(PP1(3)+PT1(3))**2)
8597       ECH   = PP1(4)+PT1(4)
8598       AM1N  = (ECH+PTOCH)*(ECH-PTOCH)
8599       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8600      &                               +(PP2(3)+PT2(3))**2)
8601       ECH   = PP2(4)+PT2(4)
8602       AM2N  = (ECH+PTOCH)*(ECH-PTOCH)
8603       IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
8604          IF (IOULEV(1).GT.0)
8605      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
8606      &                              AM1N,AM2N
8607          GOTO 2
8608       ENDIF
8609       AM1N = SQRT(AM1N)
8610       AM2N = SQRT(AM2N)
8611
8612 * check chain masses for very low mass chains
8613       CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8614      &            AM1N,DUM,-IDCH1,IREJ1)
8615       IF (IREJ1.NE.0) GOTO 2
8616       CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8617      &            AM2N,DUM,-IDCH2,IREJ2)
8618       IF (IREJ2.NE.0) GOTO 2
8619
8620     7 CONTINUE
8621       IF (AM1N.GT.ZERO) THEN
8622          AM1 = AM1N
8623          AM2 = AM2N
8624       ENDIF
8625       DO 6 I=1,4
8626          PP1I(I)   = PP1(I)
8627          PP2I(I)   = PP2(I)
8628          PT1I(I)   = PT1(I)
8629          PT2I(I)   = PT2(I)
8630     6 CONTINUE
8631
8632       RETURN
8633
8634  9999 CONTINUE
8635       IREJ = 1
8636       RETURN
8637       END
8638 *
8639 *===saptre=============================================================*
8640 *
8641 CDECK  ID>, DT_SAPTRE
8642       SUBROUTINE DT_SAPTRE(IDX1,IDX2)
8643
8644 ************************************************************************
8645 * p-t sampling for two-resonance systems. ("BAMJET-like" method)       *
8646 *        IDX1,IDX2       indices of resonances ("chains") in DTEVT1    *
8647 * Adopted from the original SAPTRE written by J. Ranft.                *
8648 * This version dated 18.01.95 is written by S. Roesler                 *
8649 ************************************************************************
8650
8651       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8652       SAVE
8653
8654       PARAMETER ( LINP = 5 ,
8655      &            LOUT = 6 ,
8656      &            LDAT = 9 )
8657
8658       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8659
8660 * event history
8661
8662       PARAMETER (NMXHKK=200000)
8663
8664       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8665      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8666      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8667 * extended event history
8668       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8669      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8670      &                IHIST(2,NMXHKK)
8671 * flags for input different options
8672       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8673       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8674      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8675
8676       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
8677
8678       DATA B3 /4.0D0/
8679
8680       ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
8681       ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
8682       ESMAX  = MIN(ESMAX1,ESMAX2)
8683       IF (ESMAX.LE.0.05D0) RETURN
8684
8685       HMA    = PHKK(5,IDX1)
8686       DO 1 K=1,4
8687          PA1(K) = PHKK(K,IDX1)
8688          PA2(K) = PHKK(K,IDX2)
8689     1 CONTINUE
8690
8691       IF (LEMCCK) THEN
8692          CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
8693          CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
8694       ENDIF
8695
8696       EXEB   = 0.0D0
8697       IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
8698       BEXP   = HMA*(1.0D0-EXEB)/B3
8699       AXEXP  = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
8700       WA     = AXEXP/(BEXP+AXEXP)
8701       XAB    = DT_RNDM(WA)
8702    10 CONTINUE
8703 * ES is the transverse kinetic energy
8704       IF (XAB.LT.WA)THEN
8705         X  = DT_RNDM(WA)
8706         Y  = DT_RNDM(WA)
8707         ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
8708       ELSE
8709         X  = DT_RNDM(Y)
8710         ES = ABS(-LOG(X+TINY7)/B3)
8711       ENDIF
8712       IF (ES.GT.ESMAX) GOTO 10
8713       ES  = ES+HMA
8714 * transverse momentum
8715       HPS = SQRT((ES-HMA)*(ES+HMA))
8716
8717       CALL DT_DSFECF(SFE,CFE)
8718       HPX = HPS*CFE
8719       HPY = HPS*SFE
8720       PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
8721       PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
8722       IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
8723
8724 C     PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
8725 C     PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
8726       PA1(1) = PA1(1)+HPX
8727       PA1(2) = PA1(2)+HPY
8728       PA2(1) = PA2(1)-HPX
8729       PA2(2) = PA2(2)-HPY
8730
8731 * put resonances on mass-shell again
8732       XM1 = PHKK(5,IDX1)
8733       XM2 = PHKK(5,IDX2)
8734       CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
8735       IF (IREJ1.NE.0) RETURN
8736
8737       IF (LEMCCK) THEN
8738          CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
8739          CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
8740          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
8741          IF (IREJ1.NE.0) RETURN
8742       ENDIF
8743
8744       DO 2 K=1,4
8745          PHKK(K,IDX1) = P1(K)
8746          PHKK(K,IDX2) = P2(K)
8747     2 CONTINUE
8748
8749       RETURN
8750       END
8751 *
8752 *===cronin=============================================================*
8753 *
8754 CDECK  ID>, DT_CRONIN
8755       SUBROUTINE DT_CRONIN(INCL)
8756
8757 ************************************************************************
8758 * Cronin-Effect. Multiple scattering of partons at chain ends.         *
8759 *             INCL = 1     multiple sc. in projectile                  *
8760 *                  = 2     multiple sc. in target                      *
8761 * This version dated 05.01.96 is written by S. Roesler.                *
8762 ************************************************************************
8763
8764       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8765       SAVE
8766
8767       PARAMETER ( LINP = 5 ,
8768      &            LOUT = 6 ,
8769      &            LDAT = 9 )
8770
8771       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8772
8773 * event history
8774
8775       PARAMETER (NMXHKK=200000)
8776
8777       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8778      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8779      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8780 * extended event history
8781       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8782      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8783      &                IHIST(2,NMXHKK)
8784 * rejection counter
8785       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8786      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8787      &                IREXCI(3),IRDIFF(2),IRINC
8788 * Glauber formalism: collision properties
8789       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8790      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8791
8792       DIMENSION R(3),PIN(4),POUT(4),DEV(4)
8793
8794       DO 1 K=1,4
8795          DEV(K) = ZERO
8796     1 CONTINUE
8797
8798       DO 2 I=NPOINT(2),NHKK
8799          IF (ISTHKK(I).LT.0) THEN
8800 * get z-position of the chain
8801             R(1) = VHKK(1,I)*1.0D12
8802             IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
8803             R(2) = VHKK(2,I)*1.0D12
8804             IDXNU = JMOHKK(1,I)
8805             IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
8806      &                             IDXNU = JMOHKK(1,I-1)
8807             IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
8808      &                             IDXNU = JMOHKK(1,I+1)
8809             R(3) = VHKK(3,IDXNU)*1.0D12
8810 * position of target parton the chain is connected to
8811             DO 3 K=1,4
8812                PIN(K) = PHKK(K,I)
8813     3       CONTINUE
8814 * multiple scattering of parton with DTEVT1-index I
8815             CALL DT_CROMSC(PIN,R,POUT,INCL)
8816 **testprint
8817 C           IF (NEVHKK.EQ.5) THEN
8818 C              AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
8819 C              AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
8820 C              AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
8821 C              AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
8822 C              WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
8823 C              WRITE(6,'(A,4E15.5)')'PIN:       ',PIN
8824 C              WRITE(6,'(A,4E15.5)')'POUT:      ',POUT
8825 C           ENDIF
8826 **
8827 * increase accumulator by energy-momentum difference
8828             DO 4 K=1,4
8829                DEV(K)    = DEV(K)+POUT(K)-PIN(K)
8830                PHKK(K,I) = POUT(K)
8831     4       CONTINUE
8832             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8833      &                           PHKK(2,I)**2-PHKK(3,I)**2))
8834          ENDIF
8835     2 CONTINUE
8836
8837 * dump accumulator to momenta of valence partons
8838       NVAL = 0
8839       ETOT = 0.0D0
8840       DO 5 I=NPOINT(2),NHKK
8841          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8842             NVAL = NVAL+1
8843             ETOT = ETOT+PHKK(4,I)
8844          ENDIF
8845     5 CONTINUE
8846 C     WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
8847  1000 FORMAT(1X,'CRONIN :  number of val. partons ',I4,/,
8848      &       9X,4E12.4)
8849       DO 6 I=NPOINT(2),NHKK
8850          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8851             E = PHKK(4,I)
8852             DO 7 K=1,4
8853 C              PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
8854                PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
8855     7       CONTINUE
8856             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8857      &                           PHKK(2,I)**2-PHKK(3,I)**2))
8858          ENDIF
8859     6 CONTINUE
8860
8861       RETURN
8862       END
8863 *
8864 *===cromsc=============================================================*
8865 *
8866 CDECK  ID>, DT_CROMSC
8867       SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
8868
8869 ************************************************************************
8870 * Cronin-Effect. Multiple scattering of one parton passing through     *
8871 * nuclear matter.                                                      *
8872 *            PIN(4)       input 4-momentum of parton                   *
8873 *            POUT(4)      4-momentum of parton after mult. scatt.      *
8874 *            R(3)         spatial position of parton in target nucleus *
8875 *            INCL = 1     multiple sc. in projectile                   *
8876 *                 = 2     multiple sc. in target                       *
8877 * This is a revised version of the original version written by J. Ranft*
8878 * This version dated 17.01.95 is written by S. Roesler.                *
8879 ************************************************************************
8880
8881       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8882       SAVE
8883
8884       PARAMETER ( LINP = 5 ,
8885      &            LOUT = 6 ,
8886      &            LDAT = 9 )
8887
8888       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8889
8890       LOGICAL LSTART
8891
8892 * rejection counter
8893       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8894      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8895      &                IREXCI(3),IRDIFF(2),IRINC
8896 * Glauber formalism: collision properties
8897       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8898      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8899 * various options for treatment of partons (DTUNUC 1.x)
8900 * (chain recombination, Cronin,..)
8901       LOGICAL LCO2CR,LINTPT
8902       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8903      &                LCO2CR,LINTPT
8904
8905       DIMENSION PIN(4),POUT(4),R(3)
8906
8907       DATA LSTART /.TRUE./
8908
8909       IRCRON(1) = IRCRON(1)+1
8910
8911       IF (LSTART) THEN
8912          WRITE(LOUT,1000) CRONCO
8913  1000    FORMAT(/,1X,'CROMSC:  multiple scattering of chain ends',
8914      &          ' treated',/,10X,'with parameter CRONCO = ',F5.2)
8915          LSTART = .FALSE.
8916       ENDIF
8917
8918       NCBACK = 0
8919       RNCL   = RPROJ
8920       IF (INCL.EQ.2) RNCL = RTARG
8921
8922 * Lorentz-transformation into Lab.
8923       MODE = -(INCL+1)
8924       CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
8925
8926       PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
8927       IF (PTOT.LE.8.0D0) GOTO 9997
8928
8929 * direction cosines of parton before mult. scattering
8930       COSX = PIN(1)/PTOT
8931       COSY = PIN(2)/PTOT
8932       COSZ = PZ/PTOT
8933
8934       RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
8935       IF (RTESQ.GE.-TINY3) GOTO 9999
8936
8937 * calculate distance (DIST) from R to surface of nucleus (radius RNCL)
8938 * in the direction of particle motion
8939
8940       A    = COSX*R(1)+COSY*R(2)+COSZ*R(3)
8941       TMP  = A**2-RTESQ
8942       IF (TMP.LT.ZERO) GOTO 9998
8943       DIST = -A+SQRT(TMP)
8944
8945 * multiple scattering angle
8946       THETO = CRONCO*SQRT(DIST)/PTOT
8947       IF (THETO.GT.0.1D0) THETO=0.1D0
8948
8949     1 CONTINUE
8950 * Gaussian sampling of spatial angle
8951       CALL DT_RANNOR(R1,R2)
8952       THETA = ABS(R1*THETO)
8953       IF (THETA.GT.0.3D0) GOTO 9997
8954       CALL DT_DSFECF(SFE,CFE)
8955       COSTH = COS(THETA)
8956       SINTH = SIN(THETA)
8957
8958 * new direction cosines
8959       CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
8960      &                               COSXN,COSYN,COSZN)
8961
8962       POUT(1) = COSXN*PTOT
8963       POUT(2) = COSYN*PTOT
8964       PZ      = COSZN*PTOT
8965 * Lorentz-transformation into nucl.-nucl. cms
8966       MODE = INCL+1
8967       CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
8968
8969 C     IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
8970 C     IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
8971       IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
8972          THETO = THETO/2.0D0
8973          NCBACK = NCBACK+1
8974          IF (MOD(NCBACK,200).EQ.0) THEN
8975             WRITE(LOUT,1001) THETO,PIN,POUT
8976  1001       FORMAT(1X,'CROMSC: inconsistent scattering angle ',
8977      &             E12.4,/,1X,'        PIN :',4E12.4,/,
8978      &             1X,'       POUT:',4E12.4)
8979             GOTO 9997
8980          ENDIF
8981          GOTO 1
8982       ENDIF
8983
8984       RETURN
8985
8986  9997 IRCRON(2) = IRCRON(2)+1
8987       GOTO 9999
8988  9998 IRCRON(3) = IRCRON(3)+1
8989
8990  9999 CONTINUE
8991       DO 100 K=1,4
8992          POUT(K) = PIN(K)
8993   100 CONTINUE
8994       RETURN
8995       END
8996 *
8997 *===com2sr=============================================================*
8998 *
8999 CDECK  ID>, DT_COM2CR
9000       SUBROUTINE DT_COM2CR
9001
9002 ************************************************************************
9003 * COMbine q-aq chains to Color Ropes (qq-aqaq).                        *
9004 *        CUTOF      parameter determining minimum number of not        *
9005 *                   combined q-aq chains                               *
9006 * This subroutine replaces KKEVCC etc.                                 *
9007 * This version dated 11.01.95 is written by S. Roesler.                *
9008 ************************************************************************
9009
9010       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9011       SAVE
9012
9013       PARAMETER ( LINP = 5 ,
9014      &            LOUT = 6 ,
9015      &            LDAT = 9 )
9016
9017 * event history
9018
9019       PARAMETER (NMXHKK=200000)
9020
9021       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9022      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9023      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9024 * extended event history
9025       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9026      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9027      &                IHIST(2,NMXHKK)
9028 * statistics
9029       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9030      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9031      &                ICEVTG(8,0:30)
9032 * various options for treatment of partons (DTUNUC 1.x)
9033 * (chain recombination, Cronin,..)
9034       LOGICAL LCO2CR,LINTPT
9035       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9036      &                LCO2CR,LINTPT
9037
9038       DIMENSION IDXQA(248),IDXAQ(248)
9039
9040       ICCHAI(1,9) = ICCHAI(1,9)+1
9041       NQA = 0
9042       NAQ = 0
9043 * scan DTEVT1 for q-aq, aq-q chains
9044       DO 10 I=NPOINT(3),NHKK
9045 * skip "chains" which are resonances
9046          IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
9047             MO1 = JMOHKK(1,I)
9048             MO2 = JMOHKK(2,I)
9049             IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
9050 * q-aq, aq-q chain found, keep index
9051                IF (IDHKK(MO1).GT.0) THEN
9052                   NQA = NQA+1
9053                   IDXQA(NQA) = I
9054                ELSE
9055                   NAQ = NAQ+1
9056                   IDXAQ(NAQ) = I
9057                ENDIF
9058             ENDIF
9059          ENDIF
9060    10 CONTINUE
9061
9062 * minimum number of q-aq chains requested for the same projectile/
9063 * target
9064       NCHMIN = IDT_NPOISS(CUTOF)
9065
9066 * combine q-aq chains of the same projectile
9067       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
9068 * combine q-aq chains of the same target
9069       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
9070 * combine aq-q chains of the same projectile
9071       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
9072 * combine aq-q chains of the same target
9073       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
9074
9075       RETURN
9076       END
9077 *
9078 *===scn4cr=============================================================*
9079 *
9080 CDECK  ID>, DT_SCN4CR
9081       SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9082
9083 ************************************************************************
9084 * SCan q-aq chains for Color Ropes.                                    *
9085 * This version dated 11.01.95 is written by S. Roesler.                *
9086 ************************************************************************
9087
9088       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9089       SAVE
9090
9091       PARAMETER ( LINP = 5 ,
9092      &            LOUT = 6 ,
9093      &            LDAT = 9 )
9094
9095 * event history
9096
9097       PARAMETER (NMXHKK=200000)
9098
9099       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9100      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9101      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9102 * extended event history
9103       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9104      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9105      &                IHIST(2,NMXHKK)
9106
9107       DIMENSION IDXCH(248),IDXJN(248)
9108
9109       DO 1 I=1,NCH
9110          IF (IDXCH(I).GT.0) THEN
9111             NJOIN = 1
9112             IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9113             IDXJN(NJOIN) = I
9114             IF (I.LT.NCH) THEN
9115                DO 2 J=I+1,NCH
9116                   IF (IDXCH(J).GT.0) THEN
9117                      IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9118                      IF (IDXMO.EQ.IDXMO1) THEN
9119                         NJOIN = NJOIN+1
9120                         IDXJN(NJOIN) = J
9121                      ENDIF
9122                   ENDIF
9123     2          CONTINUE
9124             ENDIF
9125             IF (NJOIN.GE.NCHMIN+2) THEN
9126                NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9127                DO 3 J=1,2*NJ,2
9128                   CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9129                   IF (IREJ1.NE.0) GOTO 3
9130                   IDXCH(IDXJN(J))   = 0
9131                   IDXCH(IDXJN(J+1)) = 0
9132     3          CONTINUE
9133             ENDIF
9134          ENDIF
9135     1 CONTINUE
9136
9137       RETURN
9138       END
9139 *
9140 *===join===============================================================*
9141 *
9142 CDECK  ID>, DT_JOIN
9143       SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9144
9145 ************************************************************************
9146 * This subroutine joins two q-aq chains to one qq-aqaq chain.          *
9147 *     IDX1, IDX2       DTEVT1 indices of chains to be joined           *
9148 * This version dated 11.01.95 is written by S. Roesler.                *
9149 ************************************************************************
9150
9151       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9152       SAVE
9153
9154       PARAMETER ( LINP = 5 ,
9155      &            LOUT = 6 ,
9156      &            LDAT = 9 )
9157
9158 * event history
9159
9160       PARAMETER (NMXHKK=200000)
9161
9162       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9163      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9164      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9165 * extended event history
9166       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9167      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9168      &                IHIST(2,NMXHKK)
9169 * flags for input different options
9170       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9171       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9172      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9173 * statistics
9174       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9175      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9176      &                ICEVTG(8,0:30)
9177
9178       DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9179
9180       IREJ   = 0
9181
9182       IDX(1) = IDX1
9183       IDX(2) = IDX2
9184       DO 1 I=1,2
9185          DO 2 J=1,2
9186             MO(I,J) = JMOHKK(J,IDX(I))
9187             ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9188     2    CONTINUE
9189     1 CONTINUE
9190
9191 * check consistency
9192       IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9193      &    (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9194      &    ((ID(1,1)*ID(2,1)).LT.0).OR.
9195      &    ((ID(1,2)*ID(2,2)).LT.0)) THEN
9196          WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9197      &                    MO(2,2)
9198  1000    FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9199      &             2I5,' chain ',I4,':',2I5)
9200       ENDIF
9201
9202 * join chains
9203       DO 3 K=1,4
9204          PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9205          PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9206     3 CONTINUE
9207       IF1  = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9208       IF2  = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9209       IST1 = ISTHKK(MO(1,1))
9210       IST2 = ISTHKK(MO(1,2))
9211
9212 * put partons again on mass shell
9213       XM1 = 0.0D0
9214       XM2 = 0.0D0
9215       IF (IMSHL.EQ.1) THEN
9216
9217          XM1 = PYMASS(IF1)
9218          XM2 = PYMASS(IF2)
9219
9220       ENDIF
9221       CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9222       IF (IREJ1.NE.0) GOTO 9999
9223       DO 4 I=1,4
9224          PP(I) = P1(I)
9225          PT(I) = P2(I)
9226     4 CONTINUE
9227
9228 * store new partons in DTEVT1
9229       CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9230      &                                                       0,0,0)
9231       CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9232      &                                                       0,0,0)
9233       DO 5 K=1,4
9234          PCH(K) = PP(K)+PT(K)
9235     5 CONTINUE
9236
9237 * check new chain for lower mass limit
9238       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9239          AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9240          CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9241      &               AMCH,AMCHN,3,IREJ1)
9242          IF (IREJ1.NE.0) THEN
9243             NHKK = NHKK-2
9244             GOTO 9999
9245          ENDIF
9246       ENDIF
9247
9248       ICCHAI(2,9) = ICCHAI(2,9)+1
9249 * store new chain in DTEVT1
9250       KCH = 191
9251       CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9252       IDHKK(IDX(1)) = 22222
9253       IDHKK(IDX(2)) = 22222
9254 * special treatment for space-time coordinates
9255       DO 6 K=1,4
9256          VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9257          WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9258     6 CONTINUE
9259       RETURN
9260
9261  9999 CONTINUE
9262       IREJ = 1
9263       RETURN
9264       END
9265 *
9266 *===xsglau=============================================================*
9267 *
9268 CDECK  ID>, DT_XSGLAU
9269       SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9270
9271 ************************************************************************
9272 * Total, elastic, quasi-elastic, inelastic cross sections according to *
9273 * Glauber's approach.                                                  *
9274 *  NA / NB     mass numbers of proj./target nuclei                     *
9275 *  JJPROJ      bamjet-index of projectile (=1 in case of proj.nucleus) *
9276 *  XI,Q2I,ECMI kinematical variables x, Q^2, E_cm                      *
9277 *  IE,IQ       indices of energy and virtuality (the latter for gamma  *
9278 *              projectiles only)                                       *
9279 *  NIDX        index of projectile/target nucleus                      *
9280 * This version dated 17.3.98  is written by S. Roesler                 *
9281 ************************************************************************
9282
9283       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9284       SAVE
9285
9286       PARAMETER ( LINP = 5 ,
9287      &            LOUT = 6 ,
9288      &            LDAT = 9 )
9289
9290       COMPLEX*16 CZERO,CONE,CTWO
9291       CHARACTER*12 CFILE
9292       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9293      &           ONETHI=ONE/THREE,TINY25=1.0D-25)
9294       PARAMETER (TWOPI  = 6.283185307179586454D+00,
9295      &           PI     = TWOPI/TWO,
9296      &           GEV2MB = 0.38938D0,
9297      &           GEV2FM = 0.1972D0,
9298      &           ALPHEM = ONE/137.0D0,
9299 * proton mass
9300      &           AMP    = 0.938D0,
9301      &           AMP2   = AMP**2,
9302 * approx. nucleon radius
9303      &           RNUCLE = 1.12D0)
9304
9305 * particle properties (BAMJET index convention)
9306       CHARACTER*8  ANAME
9307       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9308      &                IICH(210),IIBAR(210),K1(210),K2(210)
9309
9310       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9311
9312       PARAMETER ( MAXNCL = 260,
9313
9314      &            MAXVQU = MAXNCL,
9315      &            MAXSQU = 20*MAXVQU,
9316      &            MAXINT = MAXVQU+MAXSQU)
9317 * Glauber formalism: parameters
9318       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9319      &                BMAX(NCOMPX),BSTEP(NCOMPX),
9320      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9321      &                NSITEB,NSTATB
9322 * Glauber formalism: cross sections
9323       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9324      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9325      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9326      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9327      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9328      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9329      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9330      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9331      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9332      &                BSLOPE,NEBINI,NQBINI
9333 * Glauber formalism: flags and parameters for statistics
9334       LOGICAL LPROD
9335       CHARACTER*8 CGLB
9336       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9337 * nucleon-nucleon event-generator
9338       CHARACTER*8 CMODEL
9339       LOGICAL LPHOIN
9340       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9341 * VDM parameter for photon-nucleus interactions
9342       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9343 * parameters for hA-diffraction
9344       COMMON /DTDIHA/ DIBETA,DIALPH
9345
9346       COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9347      &           OMPP11,OMPP12,OMPP21,OMPP22,
9348      &           DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9349      &           PPTMP1,PPTMP2
9350       COMPLEX*16 C,CA,CI
9351       DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9352      &          COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9353      &          BPROD(KSITEB)
9354
9355       PARAMETER (NPOINT=16)
9356       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9357
9358       LOGICAL LFIRST,LOPEN
9359       DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9360
9361       NTARG = ABS(NIDX)
9362 * for quasi-elastic neutrino scattering set projectile to proton
9363 * it should not have an effect since the whole Glauber-formalism is
9364 * not needed for these interactions..
9365       IF (MCGENE.EQ.4) THEN
9366          IJPROJ = 1
9367       ELSE
9368          IJPROJ = JJPROJ
9369       ENDIF
9370
9371       IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9372          I = INDEX(CGLB,' ')
9373          IF (I.EQ.0) THEN
9374             CFILE = CGLB//'.glb'
9375             OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9376          ELSEIF (I.GT.1) THEN
9377             CFILE = CGLB(1:I-1)//'.glb'
9378             OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9379          ELSE
9380             STOP 'XSGLAU 1'
9381          ENDIF
9382          LOPEN = .TRUE.
9383       ENDIF
9384
9385       CZERO  = DCMPLX(ZERO,ZERO)
9386       CONE   = DCMPLX(ONE,ZERO)
9387       CTWO   = DCMPLX(TWO,ZERO)
9388       NEBINI = IE
9389       NQBINI = IQ
9390
9391 * re-define kinematics
9392       S  = ECMI**2
9393       Q2 = Q2I
9394       X  = XI
9395 *  g(Q2=0)-A, h-A, A-A scattering
9396       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9397          Q2 = 0.0001D0
9398          X  = Q2/(S+Q2-AMP2)
9399 *  g(Q2>0)-A scattering
9400       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9401          X  = Q2/(S+Q2-AMP2)
9402       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9403          Q2 = (S-AMP2)*X/(ONE-X)
9404       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9405          S  = Q2*(ONE-X)/X+AMP2
9406       ELSE
9407          WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9408          STOP
9409       ENDIF
9410       ECMNN(IE) = SQRT(S)
9411       Q2G(IQ)   = Q2
9412       XNU = (S+Q2-AMP2)/(TWO*AMP)
9413
9414 * parameters determining statistics in evaluating Glauber-xsection
9415       NSTATB = JSTATB
9416       NSITEB = JBINSB
9417       IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9418
9419 * set up interaction geometry (common /DTGLAM/)
9420 *  projectile/target radii
9421       RPRNCL = DT_RNCLUS(NA)
9422       RTANCL = DT_RNCLUS(NB)
9423       IF (IJPROJ.EQ.7) THEN
9424          RASH(1) = ZERO
9425          RBSH(NTARG) = RTANCL
9426          BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9427       ELSE
9428          IF (NIDX.LE.-1) THEN
9429             RASH(1)     = RPRNCL
9430             RBSH(NTARG) = RTANCL
9431             BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9432          ELSE
9433             RASH(NTARG) = RPRNCL
9434             RBSH(1)     = RTANCL
9435             BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9436          ENDIF
9437       ENDIF
9438 *  maximum impact-parameter
9439       BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9440
9441 * slope, rho ( Re(f(0))/Im(f(0)) )
9442       IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9443          IF (MCGENE.EQ.2) THEN
9444             ZERO1 = ZERO
9445             CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9446      &                                                   BSLOPE,0)
9447          ELSE
9448             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9449          ENDIF
9450          IF (ECMNN(IE).LE.3.0D0) THEN
9451             ROSH = -0.43D0
9452          ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9453             ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9454          ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9455             ROSH = 0.1D0
9456          ENDIF
9457       ELSEIF (IJPROJ.EQ.7) THEN
9458          ROSH = 0.1D0
9459       ELSE
9460          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9461          ROSH   = 0.01D0
9462       ENDIF
9463
9464 * projectile-nucleon xsection (in fm)
9465       IF (IJPROJ.EQ.7) THEN
9466          SIGSH = DT_SIGVP(X,Q2)/10.0D0
9467       ELSE
9468          ELAB  = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9469          PLAB  = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9470 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9471          DUMZER = ZERO
9472          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9473          SIGSH = SIGSH/10.0D0
9474       ENDIF
9475
9476 * parameters for projectile diffraction (hA scattering only)
9477       IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9478      &                               .AND.(DIBETA.GE.ZERO)) THEN
9479          ZERO1 = ZERO
9480          CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9481 C        DIBETA = SDIF1/STOT
9482          DIBETA = 0.2D0
9483          DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9484          IF (DIBETA.LE.ZERO) THEN
9485             ALPGAM = ONE
9486          ELSE
9487             ALPGAM = DIALPH/DIGAMM
9488          ENDIF
9489          FACDI1 = ONE-ALPGAM
9490          FACDI2 = ONE+ALPGAM
9491          FACDI  = SQRT(FACDI1*FACDI2)
9492          WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9493       ELSE
9494          DIBETA = -1.0D0
9495          DIALPH = ZERO
9496          DIGAMM = ZERO
9497          FACDI1 = ZERO
9498          FACDI2 = 2.0D0
9499          FACDI  = ZERO
9500       ENDIF
9501
9502 * initializations
9503       DO 10 I=1,NSITEB
9504          BSITE( 0,IQ,NTARG,I) = ZERO
9505          BSITE(IE,IQ,NTARG,I) = ZERO
9506          BPROD(I) = ZERO
9507    10 CONTINUE
9508       STOT  = ZERO
9509       STOT2 = ZERO
9510       SELA  = ZERO
9511       SELA2 = ZERO
9512       SQEP  = ZERO
9513       SQEP2 = ZERO
9514       SQET  = ZERO
9515       SQET2 = ZERO
9516       SQE2  = ZERO
9517       SQE22 = ZERO
9518       SPRO  = ZERO
9519       SPRO2 = ZERO
9520       SDEL  = ZERO
9521       SDEL2 = ZERO
9522       SDQE  = ZERO
9523       SDQE2 = ZERO
9524       FACN   = ONE/DBLE(NSTATB)
9525
9526       IPNT = 0
9527       RPNT = ZERO
9528
9529 *  initialize Gauss-integration for photon-proj.
9530       JPOINT = 1
9531       IF (IJPROJ.EQ.7) THEN
9532          IF (INTRGE(1).EQ.1) THEN
9533             AMLO2 = (3.0D0*AAM(13))**2
9534          ELSEIF (INTRGE(1).EQ.2) THEN
9535             AMLO2 = AAM(33)**2
9536          ELSE
9537             AMLO2 = AAM(96)**2
9538          ENDIF
9539          IF (INTRGE(2).EQ.1) THEN
9540             AMHI2 = S/TWO
9541          ELSEIF (INTRGE(2).EQ.2) THEN
9542             AMHI2 = S/4.0D0
9543          ELSE
9544             AMHI2 = S
9545          ENDIF
9546          AMHI20 = (ECMNN(IE)-AMP)**2
9547          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9548          XAMLO = LOG( AMLO2+Q2 )
9549          XAMHI = LOG( AMHI2+Q2 )
9550 **PHOJET105a
9551 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9552 **PHOJET112
9553
9554          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9555
9556 **
9557          JPOINT = NPOINT
9558 * ratio direct/total photon-nucleon xsection
9559          CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
9560       ENDIF
9561
9562 * read pre-initialized profile-function from file
9563       IF (IOGLB.EQ.1) THEN
9564          READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
9565          IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
9566             WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
9567      &                             NA,NB,NSTATB,NSITEB
9568  1000       FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
9569      &             ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
9570      &             ' (NA,NB,NSTATB,NSITEB) ',4I10)
9571             STOP
9572          ENDIF
9573          IF (LFIRST) WRITE(LOUT,1001) CFILE
9574  1001    FORMAT(/,' XSGLAU: impact parameter distribution read from ',
9575      &          'file ',A12,/)
9576          READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
9577      &                         XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
9578      &                         XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9579          READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
9580      &                         XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
9581      &                         XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9582          NLINES = INT(DBLE(NSITEB)/7.0D0)
9583          IF (NLINES.GT.0) THEN
9584             DO 21 I=1,NLINES
9585                ISTART = 7*I-6
9586                READ(LDAT,'(7E11.4)')
9587      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9588    21       CONTINUE
9589          ENDIF
9590          ISTART = 7*NLINES+1
9591          IF (ISTART.LE.NSITEB) THEN
9592             READ(LDAT,'(7E11.4)')
9593      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9594          ENDIF
9595          LFIRST = .FALSE.
9596          GOTO 100
9597 * variable projectile/target/energy runs:
9598 * read pre-initialized profile-functions from file
9599       ELSEIF (IOGLB.EQ.100) THEN
9600          CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
9601          GOTO 100
9602       ENDIF
9603
9604 * cross sections averaged over NSTATB nucleon configurations
9605       DO 11 IS=1,NSTATB
9606 C        IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
9607          STOTN = ZERO
9608          SELAN = ZERO
9609          SQEPN = ZERO
9610          SQETN = ZERO
9611          SQE2N = ZERO
9612          SPRON = ZERO
9613          SDELN = ZERO
9614          SDQEN = ZERO
9615
9616          IF (NIDX.LE.-1) THEN
9617             CALL DT_CONUCL(COOP1,NA,RASH(1),0)
9618             CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
9619             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9620                CALL DT_CONUCL(COOP2,NA,RASH(1),0)
9621                CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
9622             ENDIF
9623          ELSE
9624             CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
9625             CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
9626             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9627                CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
9628                CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
9629             ENDIF
9630          ENDIF
9631
9632 *  integration over impact parameter B
9633          DO 12 IB=1,NSITEB-1
9634             STOTB = ZERO
9635             SELAB = ZERO
9636             SQEPB = ZERO
9637             SQETB = ZERO
9638             SQE2B = ZERO
9639             SPROB = ZERO
9640             SDIR  = ZERO
9641             SDELB = ZERO
9642             SDQEB = ZERO
9643             B     = DBLE(IB)*BSTEP(NTARG)
9644             FACB  = 10.0D0*TWOPI*B*BSTEP(NTARG)
9645
9646 *   integration over M_V^2 for photon-proj.
9647             DO 14 IM=1,JPOINT
9648                PP11(1) = CONE
9649                PP12(1) = CONE
9650                PP21(1) = CONE
9651                PP22(1) = CONE
9652                IF (IJPROJ.EQ.7) THEN
9653                   DO 13 K=2,NB
9654                      PP11(K) = CONE
9655                      PP12(K) = CONE
9656                      PP21(K) = CONE
9657                      PP22(K) = CONE
9658    13             CONTINUE
9659                ENDIF
9660                SHI  = ZERO
9661                FACM = ONE
9662                DCOH = 1.0D10
9663
9664                IF (IJPROJ.EQ.7) THEN
9665                   AMV2 = EXP(ABSZX(IM))-Q2
9666                   AMV  = SQRT(AMV2)
9667                   IF (AMV2.LT.16.0D0) THEN
9668                      R = TWO
9669                   ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
9670                      R = 10.0D0/3.0D0
9671                   ELSE
9672                      R = 11.0D0/3.0D0
9673                   ENDIF
9674 *    define M_V dependent properties of nucleon scattering amplitude
9675 *     V_M-nucleon xsection
9676                   SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
9677                   SIGMV  = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
9678 *     slope-parametrisation a la Kaidalov
9679                   BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
9680      &                           +0.25D0*LOG(S/(AMV2+Q2)))
9681 *    coherence length
9682                   IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
9683 *    integration weight factor
9684                   FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
9685      &                  R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
9686                ENDIF
9687                GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
9688                GAM = GSH
9689                IF (IJPROJ.EQ.7) THEN
9690                   RCA = GAM*SIGMV/TWOPI
9691                ELSE
9692                   RCA = GAM*SIGSH/TWOPI
9693                ENDIF
9694                FCA = -ROSH*RCA
9695                CA  = DCMPLX(RCA,FCA)
9696                CI  = CONE
9697
9698                DO 15 INA=1,NA
9699                   KK1  = 1
9700                   INT1 = 1
9701                   KK2  = 1
9702                   INT2 = 1
9703                   DO 16 INB=1,NB
9704 *    photon-projectile: check for supression by coherence length
9705                      IF (IJPROJ.EQ.7) THEN
9706                         IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
9707                            KK1  = INB
9708                            INT1 = INT1+1
9709                         ENDIF
9710                         IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
9711                            KK2  = INB
9712                            INT2 = INT2+1
9713                         ENDIF
9714                      ENDIF
9715
9716                      X11 = B+COOT1(1,INB)-COOP1(1,INA)
9717                      Y11 =   COOT1(2,INB)-COOP1(2,INA)
9718                      XY11 = GAM*(X11*X11+Y11*Y11)
9719                      IF (XY11.LE.15.0D0) THEN
9720                         C = CONE-CA*EXP(-XY11)
9721                         AR = DBLE(PP11(INT1))
9722                         AI = DIMAG(PP11(INT1))
9723                         IF (ABS(AR).LT.TINY25) AR = ZERO
9724                         IF (ABS(AI).LT.TINY25) AI = ZERO
9725                         PP11(INT1) = DCMPLX(AR,AI)
9726                         PP11(INT1) = PP11(INT1)*C
9727                         AR  = DBLE(C)
9728                         AI  = DIMAG(C)
9729                         SHI = SHI+LOG(AR*AR+AI*AI)
9730                      ENDIF
9731                      IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9732                         X12 = B+COOT2(1,INB)-COOP1(1,INA)
9733                         Y12 =   COOT2(2,INB)-COOP1(2,INA)
9734                         XY12 = GAM*(X12*X12+Y12*Y12)
9735                         IF (XY12.LE.15.0D0) THEN
9736                            C = CONE-CA*EXP(-XY12)
9737                            AR = DBLE(PP12(INT2))
9738                            AI = DIMAG(PP12(INT2))
9739                            IF (ABS(AR).LT.TINY25) AR = ZERO
9740                            IF (ABS(AI).LT.TINY25) AI = ZERO
9741                            PP12(INT2) = DCMPLX(AR,AI)
9742                            PP12(INT2) = PP12(INT2)*C
9743                         ENDIF
9744                         X21 = B+COOT1(1,INB)-COOP2(1,INA)
9745                         Y21 =   COOT1(2,INB)-COOP2(2,INA)
9746                         XY21 = GAM*(X21*X21+Y21*Y21)
9747                         IF (XY21.LE.15.0D0) THEN
9748                            C = CONE-CA*EXP(-XY21)
9749                            AR = DBLE(PP21(INT1))
9750                            AI = DIMAG(PP21(INT1))
9751                            IF (ABS(AR).LT.TINY25) AR = ZERO
9752                            IF (ABS(AI).LT.TINY25) AI = ZERO
9753                            PP21(INT1) = DCMPLX(AR,AI)
9754                            PP21(INT1) = PP21(INT1)*C
9755                         ENDIF
9756                         X22 = B+COOT2(1,INB)-COOP2(1,INA)
9757                         Y22 =   COOT2(2,INB)-COOP2(2,INA)
9758                         XY22 = GAM*(X22*X22+Y22*Y22)
9759                         IF (XY22.LE.15.0D0) THEN
9760                            C = CONE-CA*EXP(-XY22)
9761                            AR = DBLE(PP22(INT2))
9762                            AI = DIMAG(PP22(INT2))
9763                            IF (ABS(AR).LT.TINY25) AR = ZERO
9764                            IF (ABS(AI).LT.TINY25) AI = ZERO
9765                            PP22(INT2) = DCMPLX(AR,AI)
9766                            PP22(INT2) = PP22(INT2)*C
9767                         ENDIF
9768                      ENDIF
9769    16             CONTINUE
9770    15          CONTINUE
9771
9772                OMPP11 = CZERO
9773                OMPP21 = CZERO
9774                DIPP11 = CZERO
9775                DIPP21 = CZERO
9776                DO 17 K=1,INT1
9777                   IF (PP11(K).EQ.CZERO) THEN
9778                      PPTMP1 = CZERO
9779                      PPTMP2 = CZERO
9780                   ELSE
9781                      PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
9782                      PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
9783                   ENDIF
9784                   AVDIPP = 0.5D0*
9785      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9786                   OMPP11 = OMPP11+AVDIPP
9787 C                 OMPP11 = OMPP11+(CONE-PP11(K))
9788                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9789                   DIPP11 = DIPP11+AVDIPP
9790                   IF (PP21(K).EQ.CZERO) THEN
9791                      PPTMP1 = CZERO
9792                      PPTMP2 = CZERO
9793                   ELSE
9794                      PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
9795                      PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
9796                   ENDIF
9797                   AVDIPP = 0.5D0*
9798      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9799                   OMPP21 = OMPP21+AVDIPP
9800 C                 OMPP21 = OMPP21+(CONE-PP21(K))
9801                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9802                   DIPP21 = DIPP21+AVDIPP
9803    17          CONTINUE
9804                OMPP12 = CZERO
9805                OMPP22 = CZERO
9806                DIPP12 = CZERO
9807                DIPP22 = CZERO
9808                DO 18 K=1,INT2
9809                   IF (PP12(K).EQ.CZERO) THEN
9810                      PPTMP1 = CZERO
9811                      PPTMP2 = CZERO
9812                   ELSE
9813                      PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
9814                      PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
9815                   ENDIF
9816                   AVDIPP = 0.5D0*
9817      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9818                   OMPP12 = OMPP12+AVDIPP
9819 C                 OMPP12 = OMPP12+(CONE-PP12(K))
9820                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9821                   DIPP12 = DIPP12+AVDIPP
9822                   IF (PP22(K).EQ.CZERO) THEN
9823                      PPTMP1 = CZERO
9824                      PPTMP2 = CZERO
9825                   ELSE
9826                      PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
9827                      PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
9828                   ENDIF
9829                   AVDIPP = 0.5D0*
9830      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9831                   OMPP22 = OMPP22+AVDIPP
9832 C                 OMPP22 = OMPP22+(CONE-PP22(K))
9833                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9834                   DIPP22 = DIPP22+AVDIPP
9835    18          CONTINUE
9836
9837                SPROM = ONE-EXP(SHI)
9838                SPROB = SPROB+FACM*SPROM
9839                IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9840                   STOTM = DBLE(OMPP11+OMPP22)
9841                   SELAM = DBLE(OMPP11*DCONJG(OMPP22))
9842                   SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
9843                   SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
9844                   SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
9845                   SDELM = DBLE(DIPP11*DCONJG(DIPP22))
9846                   SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
9847                   STOTB = STOTB+FACM*STOTM
9848                   SELAB = SELAB+FACM*SELAM
9849                   SDELB = SDELB+FACM*SDELM
9850                   IF (NB.GT.1) THEN
9851                      SQEPB = SQEPB+FACM*SQEPM
9852                      SDQEB = SDQEB+FACM*SDQEM
9853                   ENDIF
9854                   IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
9855                   IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
9856                   IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
9857                ENDIF
9858
9859    14       CONTINUE
9860
9861             STOTN = STOTN+FACB*STOTB
9862             SELAN = SELAN+FACB*SELAB
9863             SQEPN = SQEPN+FACB*SQEPB
9864             SQETN = SQETN+FACB*SQETB
9865             SQE2N = SQE2N+FACB*SQE2B
9866             SPRON = SPRON+FACB*SPROB
9867             SDELN = SDELN+FACB*SDELB
9868             SDQEN = SDQEN+FACB*SDQEB
9869
9870             IF (IJPROJ.EQ.7) THEN
9871                BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
9872             ELSE
9873                IF (DIBETA.GT.ZERO) THEN
9874                   BPROD(IB+1)= BPROD(IB+1)
9875      &                        +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
9876                ELSE
9877                   BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
9878                ENDIF
9879             ENDIF
9880
9881    12    CONTINUE
9882
9883          STOT  = STOT +FACN*STOTN
9884          STOT2 = STOT2+FACN*STOTN**2
9885          SELA  = SELA +FACN*SELAN
9886          SELA2 = SELA2+FACN*SELAN**2
9887          SQEP  = SQEP +FACN*SQEPN
9888          SQEP2 = SQEP2+FACN*SQEPN**2
9889          SQET  = SQET +FACN*SQETN
9890          SQET2 = SQET2+FACN*SQETN**2
9891          SQE2  = SQE2 +FACN*SQE2N
9892          SQE22 = SQE22+FACN*SQE2N**2
9893          SPRO  = SPRO +FACN*SPRON
9894          SPRO2 = SPRO2+FACN*SPRON**2
9895          SDEL  = SDEL +FACN*SDELN
9896          SDEL2 = SDEL2+FACN*SDELN**2
9897          SDQE  = SDQE +FACN*SDQEN
9898          SDQE2 = SDQE2+FACN*SDQEN**2
9899
9900    11 CONTINUE
9901
9902 * final cross sections
9903 * 1) total
9904       XSTOT(IE,IQ,NTARG) = STOT
9905       IF (IJPROJ.EQ.7)
9906      &   XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
9907 * 2) elastic
9908       XSELA(IE,IQ,NTARG) = SELA
9909 * 3) quasi-el.: A+B-->A+X (excluding 2)
9910       XSQEP(IE,IQ,NTARG) = SQEP
9911 * 4) quasi-el.: A+B-->X+B (excluding 2)
9912       XSQET(IE,IQ,NTARG) = SQET
9913 * 5) quasi-el.: A+B-->X (excluding 2-4)
9914       XSQE2(IE,IQ,NTARG) = SQE2
9915 * 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
9916       IF (SDEL.GT.ZERO) THEN
9917          XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
9918       ELSE
9919          XSPRO(IE,IQ,NTARG) = SPRO
9920       ENDIF
9921 * 7) projectile diffraction (el. scatt. off target)
9922       XSDEL(IE,IQ,NTARG) = SDEL
9923 * 8) projectile diffraction (quasi-el. scatt. off target)
9924       XSDQE(IE,IQ,NTARG) = SDQE
9925 *  stat. errors
9926       XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
9927       XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
9928       XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
9929       XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
9930       XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
9931       XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
9932       XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
9933       XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
9934
9935       IF (IJPROJ.EQ.7) THEN
9936          BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
9937      &          -XSQEP(IE,IQ,NTARG)
9938       ELSE
9939          BNORM = XSPRO(IE,IQ,NTARG)
9940       ENDIF
9941       DO 19 I=2,NSITEB
9942          BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
9943          IF ((IE.EQ.1).AND.(IQ.EQ.1))
9944      &      BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
9945    19 CONTINUE
9946
9947 * write profile function data into file
9948       IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
9949          WRITE(LDAT,'(5I10,1P,E15.5)')
9950      &      IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
9951          WRITE(LDAT,'(1P,6E12.5)')
9952      &      XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
9953      &      XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9954          WRITE(LDAT,'(1P,6E12.5)')
9955      &      XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
9956      &      XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9957          NLINES = INT(DBLE(NSITEB)/7.0D0)
9958          IF (NLINES.GT.0) THEN
9959             DO 20 I=1,NLINES
9960                ISTART = 7*I-6
9961                WRITE(LDAT,'(1P,7E11.4)')
9962      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9963    20       CONTINUE
9964          ENDIF
9965          ISTART = 7*NLINES+1
9966          IF (ISTART.LE.NSITEB) THEN
9967             WRITE(LDAT,'(1P,7E11.4)')
9968      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9969          ENDIF
9970       ENDIF
9971
9972   100 CONTINUE
9973
9974 C     IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
9975
9976       RETURN
9977       END
9978 *
9979 *===getbxs=============================================================*
9980 *
9981 CDECK  ID>, DT_GETBXS
9982       SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
9983
9984 ************************************************************************
9985 * Biasing in impact parameter space.                                   *
9986 *     XSFRAC = 0 :  BLO    - minimum impact parameter  (input)         *
9987 *                   BHI    - maximum impact parameter  (input)         *
9988 *                   XSFRAC - fraction of cross section corresponding   *
9989 *                            to impact parameter range (BLO,BHI)       *
9990 *                                                      (output)        *
9991 *     XSFRAC > 0 :  XSFRAC - fraction of cross section (input)         *
9992 *                   BHI    - maximum impact parameter giving requested *
9993 *                            fraction of cross section in impact       *
9994 *                            parameter range (0,BMAX)  (output)        *
9995 * This version dated 17.03.00  is written by S. Roesler                *
9996 ************************************************************************
9997
9998       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9999       SAVE
10000
10001       PARAMETER ( LINP = 5 ,
10002      &            LOUT = 6 ,
10003      &            LDAT = 9 )
10004
10005       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10006
10007 * Glauber formalism: parameters
10008       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10009      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10010      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10011      &                NSITEB,NSTATB
10012
10013       NTARG = ABS(NIDX)
10014       IF (XSFRAC.LE.0.0D0) THEN
10015          ILO    = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
10016          IHI    = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
10017          IF (ILO.GE.IHI) THEN
10018             XSFRAC = 0.0D0
10019             RETURN
10020          ENDIF
10021          IF (ILO.EQ.NSITEB-1) THEN
10022             FRCLO = BSITE(0,1,NTARG,NSITEB)
10023          ELSE
10024             FRCLO = BSITE(0,1,NTARG,ILO+1)
10025      &              +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
10026      &              *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
10027          ENDIF
10028          IF (IHI.EQ.NSITEB-1) THEN
10029             FRCHI = BSITE(0,1,NTARG,NSITEB)
10030          ELSE
10031             FRCHI = BSITE(0,1,NTARG,IHI+1)
10032      &              +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
10033      &              *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
10034          ENDIF
10035          XSFRAC = FRCHI-FRCLO
10036       ELSE
10037          BLO = 0.0D0
10038          BHI = BMAX(NTARG)
10039          DO 1 I=1,NSITEB-1
10040             IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
10041                FAC = (XSFRAC              -BSITE(0,1,NTARG,I))/
10042      &               (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
10043                BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
10044                GOTO 2
10045             ENDIF
10046     1    CONTINUE
10047     2    CONTINUE
10048       ENDIF
10049
10050       RETURN
10051       END
10052 *
10053 *===conucl=============================================================*
10054 *
10055 CDECK  ID>, DT_CONUCL
10056       SUBROUTINE DT_CONUCL(X,N,R,MODE)
10057
10058 ************************************************************************
10059 * Calculation of coordinates of nucleons within nuclei.                *
10060 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
10061 *        N / R    number of nucleons / radius of nucleus   (input)     *
10062 *        MODE = 0 coordinates not sorted                               *
10063 *             = 1 coordinates sorted with increasing X(3,i)            *
10064 *             = 2 coordinates sorted with decreasing X(3,i)            *
10065 * This version dated 26.10.95 is revised by S. Roesler                 *
10066 ************************************************************************
10067
10068       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10069       SAVE
10070
10071       PARAMETER ( LINP = 5 ,
10072      &            LOUT = 6 ,
10073      &            LDAT = 9 )
10074
10075       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10076      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10077
10078       PARAMETER (TWOPI = 6.283185307179586454D+00 )
10079
10080       PARAMETER (NSRT=10)
10081       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10082       DIMENSION X(3,N),XTMP(3,260)
10083
10084       CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10085
10086       IF ((MODE.NE.0).AND.((N.EQ.3).OR.(N.GT.4))) THEN
10087          K = 0
10088          DO 1 I=1,NSRT
10089             IF (MODE.EQ.2) THEN
10090                ISRT = NSRT+1-I
10091             ELSE
10092                ISRT = I
10093             ENDIF
10094             K1 = K
10095             DO 2 J=1,ICSRT(ISRT)
10096                K = K+1
10097                X(1,K) = XTMP(1,IDXSRT(ISRT,J))
10098                X(2,K) = XTMP(2,IDXSRT(ISRT,J))
10099                X(3,K) = XTMP(3,IDXSRT(ISRT,J))
10100     2       CONTINUE
10101             IF (ICSRT(ISRT).GT.1) THEN
10102                I0 = K1+1
10103                I1 = K
10104                CALL DT_SORT(X,N,I0,I1,MODE)
10105             ENDIF
10106     1    CONTINUE
10107       ELSEIF ((MODE.NE.0).AND.((N.EQ.2).OR.(N.EQ.4))) THEN
10108          DO 3 I=1,N
10109             X(1,I) = XTMP(1,I)
10110             X(2,I) = XTMP(2,I)
10111             X(3,I) = XTMP(3,I)
10112     3    CONTINUE
10113          CALL DT_SORT(X,N,1,N,MODE)
10114       ELSE
10115          DO 4 I=1,N
10116             X(1,I) = XTMP(1,I)
10117             X(2,I) = XTMP(2,I)
10118             X(3,I) = XTMP(3,I)
10119     4    CONTINUE
10120       ENDIF
10121
10122       RETURN
10123       END
10124 *
10125 *===coordi=============================================================*
10126 *
10127 CDECK  ID>, DT_COORDI
10128       SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10129
10130 ************************************************************************
10131 * Calculation of coordinates of nucleons within nuclei.                *
10132 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
10133 *        N / R    number of nucleons / radius of nucleus   (input)     *
10134 * Based on the original version by Shmakov et al.                      *
10135 * This version dated 26.10.95 is revised by S. Roesler                 *
10136 ************************************************************************
10137
10138       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10139       SAVE
10140
10141       PARAMETER ( LINP = 5 ,
10142      &            LOUT = 6 ,
10143      &            LDAT = 9 )
10144
10145       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10146      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10147
10148       PARAMETER (TWOPI = 6.283185307179586454D+00 )
10149
10150       LOGICAL LSTART
10151
10152       PARAMETER (NSRT=10)
10153       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10154       DIMENSION X(3,260),WD(4),RD(3)
10155
10156       DATA PDIF/0.545D0/,R2MIN/0.16D0/
10157       DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10158       DATA RD /2.09D0, 0.935D0, 0.697D0/
10159
10160       X1SUM = ZERO
10161       X2SUM = ZERO
10162       X3SUM = ZERO
10163
10164       IF (N.EQ.1) THEN
10165          X(1,1) = ZERO
10166          X(2,1) = ZERO
10167          X(3,1) = ZERO
10168       ELSEIF (N.EQ.2) THEN
10169          EPS = DT_RNDM(RD(1))
10170          DO 30 I=1,3
10171             IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10172    30    CONTINUE
10173    40    CONTINUE
10174          DO 50 J=1,3
10175             CALL DT_RANNOR(X1,X2)
10176             X(J,1) = RD(I)*X1
10177             X(J,2) = -X(J,1)
10178    50    CONTINUE
10179       ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10180          SIGMA = R/SQRTWO
10181          LSTART = .TRUE.
10182          CALL DT_RANNOR(X3,X4)
10183          DO 100 I=1,N
10184             CALL DT_RANNOR(X1,X2)
10185             X(1,I) = SIGMA*X1
10186             X(2,I) = SIGMA*X2
10187             IF (LSTART) GOTO 80
10188             X(3,I) = SIGMA*X4
10189             CALL DT_RANNOR(X3,X4)
10190             GOTO 90
10191    80       CONTINUE
10192             X(3,I) = SIGMA*X3
10193    90       CONTINUE
10194             LSTART = .NOT.LSTART
10195             X1SUM = X1SUM+X(1,I)
10196             X2SUM = X2SUM+X(2,I)
10197             X3SUM = X3SUM+X(3,I)
10198   100    CONTINUE
10199          X1SUM = X1SUM/DBLE(N)
10200          X2SUM = X2SUM/DBLE(N)
10201          X3SUM = X3SUM/DBLE(N)
10202          DO 101 I=1,N
10203             X(1,I) = X(1,I)-X1SUM
10204             X(2,I) = X(2,I)-X2SUM
10205             X(3,I) = X(3,I)-X3SUM
10206   101    CONTINUE
10207       ELSE
10208
10209 * maximum nuclear radius for coordinate sampling
10210          RMAX = R+4.605D0*PDIF
10211
10212 * initialize pre-sorting
10213          DO 121 I=1,NSRT
10214             ICSRT(I) = 0
10215   121    CONTINUE
10216          DR = TWO*RMAX/DBLE(NSRT)
10217
10218 * sample coordinates for N nucleons
10219          DO 140 I=1,N
10220   120       CONTINUE
10221             RAD = RMAX*(DT_RNDM(DR))**ONETHI
10222             F   = DT_DENSIT(N,RAD,R)
10223             IF (DT_RNDM(RAD).GT.F) GOTO 120
10224 *   theta, phi uniformly distributed
10225             CT  = ONE-TWO*DT_RNDM(F)
10226             ST  = SQRT((ONE-CT)*(ONE+CT))
10227             CALL DT_DSFECF(SFE,CFE)
10228             X(1,I) = RAD*ST*CFE
10229             X(2,I) = RAD*ST*SFE
10230             X(3,I) = RAD*CT
10231 *   ensure that distance between two nucleons is greater than R2MIN
10232             IF (I.LT.2) GOTO 122
10233             I1 = I-1
10234             DO 130 I2=1,I1
10235                DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10236      &                 (X(3,I)-X(3,I2))**2
10237                IF (DIST2.LE.R2MIN) GOTO 120
10238   130       CONTINUE
10239   122       CONTINUE
10240 *   save index according to z-bin
10241             IDXZ        = INT( (X(3,I)+RMAX)/DR )+1
10242             ICSRT(IDXZ) = ICSRT(IDXZ)+1
10243             IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10244             X1SUM = X1SUM+X(1,I)
10245             X2SUM = X2SUM+X(2,I)
10246             X3SUM = X3SUM+X(3,I)
10247   140    CONTINUE
10248          X1SUM = X1SUM/DBLE(N)
10249          X2SUM = X2SUM/DBLE(N)
10250          X3SUM = X3SUM/DBLE(N)
10251          DO 141 I=1,N
10252             X(1,I) = X(1,I)-X1SUM
10253             X(2,I) = X(2,I)-X2SUM
10254             X(3,I) = X(3,I)-X3SUM
10255   141    CONTINUE
10256
10257       ENDIF
10258
10259       RETURN
10260       END
10261 *
10262 *===densit=============================================================*
10263 *
10264 CDECK  ID>, DT_DENSIT
10265       DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10266
10267       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10268       SAVE
10269
10270       PARAMETER ( LINP = 5 ,
10271      &            LOUT = 6 ,
10272      &            LDAT = 9 )
10273
10274       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10275       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10276      &           PI    = TWOPI/TWO)
10277
10278       DIMENSION R0(18),FNORM(18)
10279       DATA R0 /  ZERO,   ZERO,   ZERO,   ZERO, 2.12D0,
10280      &         2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10281      &         2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10282      &         2.72D0, 2.66D0, 2.79D0/
10283       DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10284      &            .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10285      &            .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10286      &            .1214D+01,.1265D+01,.1318D+01/
10287       DATA PDIF /0.545D0/
10288
10289       DT_DENSIT = ZERO
10290 * shell model
10291       IF (NA.LE.4) THEN
10292          STOP 'DT_DENSIT-0'
10293       ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10294          R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10295          DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10296      &            *EXP(-(R/R1)**2)/FNORM(NA)
10297 * Woods-Saxon
10298       ELSEIF (NA.GT.18) THEN
10299          DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10300       ENDIF
10301
10302       RETURN
10303       END
10304 *
10305 *===rnclus=============================================================*
10306 *
10307 CDECK  ID>, DT_RNCLUS
10308       DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10309
10310 ************************************************************************
10311 * Nuclear radius for nucleus with mass number N.                       *
10312 * This version dated 26.9.00  is written by S. Roesler                 *
10313 ************************************************************************
10314
10315       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10316       SAVE
10317
10318       PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10319
10320 * nucleon radius
10321       PARAMETER (RNUCLE = 1.12D0)
10322
10323 * nuclear radii for selected nuclei
10324       DIMENSION RADNUC(18)
10325       DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10326      &               2.58D0,2.71D0,2.66D0,2.71D0/
10327
10328       IF (N.LE.18) THEN
10329          IF (RADNUC(N).GT.0.0D0) THEN
10330             DT_RNCLUS = RADNUC(N)
10331          ELSE
10332             DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10333          ENDIF
10334       ELSE
10335          DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10336       ENDIF
10337
10338       RETURN
10339       END
10340 *
10341 *===dentst=============================================================*
10342 *
10343 C      PROGRAM DT_DENTST
10344 CDECK  ID>, DT_DENTST
10345       SUBROUTINE DT_DENTST
10346
10347       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10348       SAVE
10349
10350       OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10351       OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10352
10353       RMIN  = 0.0D0
10354       RMAX  = 8.0D0
10355       NBINS = 500.0D0
10356       DR    = (RMAX-RMIN)/DBLE(NBINS)
10357       DO 1 IA=5,18
10358          FMAX = 0.0D0
10359          DO 2 IR=1,NBINS+1
10360             R = RMIN+DBLE(IR-1)*DR
10361             F = DT_DENSIT(IA,R,R)
10362             IF (F.GT.FMAX) FMAX = F
10363             WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10364     2    CONTINUE
10365          WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10366     1 CONTINUE
10367
10368       CLOSE(40)
10369       CLOSE(41)
10370
10371       END
10372 *
10373 *===shmaki=============================================================*
10374 *
10375 CDECK  ID>, DT_SHMAKI
10376       SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10377
10378 ************************************************************************
10379 * Initialisation of Glauber formalism. This subroutine has to be       *
10380 * called once (in case of target emulsions as often as many different  *
10381 * target nuclei are considered) before events are sampled.             *
10382 *         NA / NCA   mass number/charge of projectile nucleus          *
10383 *         NB / NCB   mass number/charge of target     nucleus          *
10384 *         IJP        identity of projectile (hadrons/leptons/photons)  *
10385 *         PPN        projectile momentum (for projectile nuclei:       *
10386 *                    momentum per nucleon) in target rest system       *
10387 *         MODE = 0   Glauber formalism invoked                         *
10388 *              = 1   fitted results are loaded from data-file          *
10389 *              = 99  NTARG is forced to be 1                           *
10390 *                    (used in connection with GLAUBERI-card only)      *
10391 * This version dated 22.03.96 is based on the original SHMAKI-routine  *
10392 * and revised by S. Roesler.                                           *
10393 ************************************************************************
10394
10395       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10396       SAVE
10397
10398       PARAMETER ( LINP = 5 ,
10399      &            LOUT = 6 ,
10400      &            LDAT = 9 )
10401
10402       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10403      &           THREE=3.0D0)
10404
10405       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10406
10407 * Glauber formalism: parameters
10408       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10409      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10410      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10411      &                NSITEB,NSTATB
10412 * Lorentz-parameters of the current interaction
10413       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10414      &                UMO,PPCM,EPROJ,PPROJ
10415 * properties of photon/lepton projectiles
10416       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10417 * kinematical cuts for lepton-nucleus interactions
10418       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10419      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10420 * Glauber formalism: cross sections
10421       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10422      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10423      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10424      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10425      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10426      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10427      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10428      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10429      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10430      &                BSLOPE,NEBINI,NQBINI
10431 * cuts for variable energy runs
10432       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10433 * nucleon-nucleon event-generator
10434       CHARACTER*8 CMODEL
10435       LOGICAL LPHOIN
10436       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10437 * Glauber formalism: flags and parameters for statistics
10438       LOGICAL LPROD
10439       CHARACTER*8 CGLB
10440       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10441
10442       DATA NTARG,ICOUT,IVEOUT /0,0,0/
10443
10444 C     CALL DT_HISHAD
10445 C     STOP
10446
10447       NTARG = NTARG+1
10448       IF (MODE.EQ.99) NTARG = 1
10449       NIDX = -NTARG
10450       IF (MODE.EQ.-1) NIDX = NTARG
10451
10452       IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10453       IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10454  1000    FORMAT(//,1X,'SHMAKI:    Glauber formalism (Shmakov et. al) -',
10455      &          ' initialization',/,12X,'--------------------------',
10456      &          '-------------------------',/)
10457
10458       IF (MODE.EQ.2) THEN
10459          CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10460          CALL DT_SHFAST(MODE,PPN,IBACK)
10461          STOP ' Glauber pre-initialization done'
10462       ENDIF
10463       IF (MODE.EQ.1) THEN
10464          CALL DT_PROFBI(NA,NB,PPN,NTARG)
10465       ELSE
10466          IBACK = 1
10467          IF (MODE.EQ.3)  CALL DT_SHFAST(MODE,PPN,IBACK)
10468          IF (IBACK.EQ.1) THEN
10469 * lepton-nucleus (variable energy runs)
10470             IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10471      &          (IJP.EQ.10).OR.(IJP.EQ.11))   THEN
10472                IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10473      &            WRITE(LOUT,1002) NB,NCB
10474  1002          FORMAT(1X,'variable energy run:     projectile-id:  7',
10475      &                '    target A/Z: ',I3,' /',I3,/,/,8X,
10476      &                'E_cm (GeV)    Q^2 (GeV^2)',
10477      &                '    Sigma_tot (mb)     Sigma_in (mb)',/,7X,
10478      &                '--------------------------------',
10479      &                '------------------------------')
10480                AECMLO = LOG10(MIN(UMO,ECMLI))
10481                AECMHI = LOG10(MIN(UMO,ECMHI))
10482                IESTEP = NEB-1
10483                DAECM  = (AECMHI-AECMLO)/DBLE(IESTEP)
10484                IF (AECMLO.EQ.AECMHI) IESTEP = 0
10485                DO 1 I=1,IESTEP+1
10486                   ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10487                   IF (Q2HI.GT.0.1D0) THEN
10488                      IF (Q2LI.LT.0.01D0) THEN
10489                         CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10490                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10491      &                     WRITE(LOUT,1003)
10492      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10493                         Q2LI = 0.01D0
10494                         IBIN = 2
10495                      ELSE
10496                         IBIN = 1
10497                      ENDIF
10498                      IQSTEP = NQB-IBIN
10499                      AQ2LO  = LOG10(Q2LI)
10500                      AQ2HI  = LOG10(Q2HI)
10501                      DAQ2   = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10502                      DO 2 J=IBIN,IQSTEP+IBIN
10503                         Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10504                         CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10505                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10506      &                     WRITE(LOUT,1003) ECMNN(I),
10507      &                     Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10508     2                CONTINUE
10509                   ELSE
10510                      CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10511                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10512      &                  WRITE(LOUT,1003)
10513      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10514                   ENDIF
10515  1003             FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10516     1          CONTINUE
10517                IVEOUT = 1
10518             ELSE
10519 * hadron/photon/nucleus-nucleus
10520                IF ((ABS(VAREHI).GT.ZERO).AND.
10521      &             (ABS(VAREHI).GT.ABS(VARELO))) THEN
10522                   IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10523                      WRITE(LOUT,1004) NA,NB,NCB
10524  1004                FORMAT(1X,'variable energy run:    projectile-id:',
10525      &                      I3,'    target A/Z: ',I3,' /',I3,/)
10526                      WRITE(LOUT,1005)
10527  1005                FORMAT('  E_cm (GeV)  E_Lab (GeV)  sig_tot^pp (mb)'
10528      &                      ,'  Sigma_tot (mb)  Sigma_prod (mb)',/,
10529      &                      ' -------------------------------------',
10530      &                      '--------------------------------------')
10531                   ENDIF
10532                   AECMLO = LOG10(VARCLO)
10533                   AECMHI = LOG10(VARCHI)
10534                   IESTEP = NEB-1
10535                   DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10536                   IF (AECMLO.EQ.AECMHI) IESTEP = 0
10537                   DO 3 I=1,IESTEP+1
10538                      ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10539                      AMP = 0.938D0
10540                      AMT = 0.938D0
10541                      AMP2 = AMP**2
10542                      AMT2 = AMT**2
10543                      ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
10544                      PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
10545                      CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
10546                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10547      &                 WRITE(LOUT,1006)
10548      &                 ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10549  1006             FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
10550     3             CONTINUE
10551                   IVEOUT = 1
10552                ELSE
10553                   CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10554                ENDIF
10555             ENDIF
10556          ENDIF
10557       ENDIF
10558
10559       IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
10560      &    (IOGLB.NE.100)) THEN
10561          WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
10562      &                    BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
10563  1001    FORMAT(38X,'projectile',
10564      &          '      target',/,1X,'Mass number / charge',
10565      &          17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
10566      &          'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
10567      &          'Parameters of elastic scattering amplitude:',/,5X,
10568      &          'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
10569      &          F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
10570      &          'statistics at each b-step',4X,I5,/,/,1X,
10571      &          'Prod. cross section  ',5X,F10.4,' mb',/)
10572       ENDIF
10573
10574       RETURN
10575       END
10576 *
10577 *===profbi=============================================================*
10578 *
10579 CDECK  ID>, DT_PROFBI
10580       SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
10581
10582 ************************************************************************
10583 * Integral over profile function (to be used for impact-parameter      *
10584 * sampling during event generation).                                   *
10585 * Fitted results are used.                                             *
10586 *         NA / NB    mass numbers of proj./target nuclei               *
10587 *         PPN        projectile momentum (for projectile nuclei:       *
10588 *                    momentum per nucleon) in target rest system       *
10589 *         NTARG      index of target material (i.e. kind of nucleus)   *
10590 * This version dated 31.05.95 is revised by S. Roesler                 *
10591 ************************************************************************
10592
10593       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10594       SAVE
10595
10596       PARAMETER ( LINP = 5 ,
10597      &            LOUT = 6 ,
10598      &            LDAT = 9 )
10599
10600       SAVE
10601
10602       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
10603
10604       LOGICAL LSTART
10605       CHARACTER CNAME*80
10606
10607       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10608
10609 * Glauber formalism: parameters
10610       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10611      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10612      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10613      &                NSITEB,NSTATB
10614 * Glauber formalism: cross sections
10615       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10616      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10617      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10618      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10619      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10620      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10621      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10622      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10623      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10624      &                BSLOPE,NEBINI,NQBINI
10625
10626       PARAMETER (NGLMAX=8000)
10627       DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
10628      &          GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
10629
10630       DATA LSTART /.TRUE./
10631
10632       IF (LSTART) THEN
10633 * read fit-parameters from file
10634          OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
10635          I = 0
10636     1    CONTINUE
10637          READ(47,'(A80)') CNAME
10638          IF (CNAME.EQ.'STOP') GOTO 2
10639          I = I+1
10640          READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
10641      &                 GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
10642      &                 GLAFIT(4,I),GLAFIT(5,I)
10643          IF (I+1.GT.NGLMAX) THEN
10644             WRITE(LOUT,1000)
10645  1000       FORMAT(1X,'PROFBI:    warning! array size exceeded - ',
10646      &             'program stopped')
10647             STOP
10648          ENDIF
10649          GOTO 1
10650     2    CONTINUE
10651          NGLPAR = I
10652          LSTART = .FALSE.
10653       ENDIF
10654
10655       NNA = NA
10656       NNB = NB
10657       IF (NA.GT.NB) THEN
10658          NNA = NB
10659          NNB = NA
10660       ENDIF
10661       IDXGLA = 0
10662       DO 3 J=1,NGLPAR
10663          IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
10664             IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
10665             DO 4 K=1,J-1
10666                IPOINT = J-K
10667                IF (J.EQ.NGLPAR) IPOINT = J+1-K
10668                IF ((NNA.GT.NGLIP(IPOINT)).OR.
10669      &             (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
10670                   IF (IPOINT.EQ.1) IPOINT = 0
10671                   NATMP = NGLIP(IPOINT+1)
10672                   IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
10673                      IDXGLA = IPOINT+1
10674                      GOTO 6
10675                   ELSE
10676                      J1BEG = IPOINT+1
10677                      J1END = J
10678 C                    IF (J.EQ.NGLPAR) THEN
10679 C                       J1BEG = IPOINT
10680 C                       J1END = J
10681 C                    ENDIF
10682                      DO 5 J1=J1BEG,J1END
10683                         IF (NGLIP(J1).EQ.NATMP) THEN
10684                            IF (PPN.LT.GLAPPN(J1)) THEN
10685                               IDXGLA = J1
10686                               GOTO 6
10687                            ENDIF
10688                         ELSE
10689                            IDXGLA = J1-1
10690                            GOTO 6
10691                         ENDIF
10692     5                CONTINUE
10693                      IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
10694      &                  IDXGLA = NGLPAR
10695                   ENDIF
10696                ENDIF
10697     4       CONTINUE
10698          ENDIF
10699     3 CONTINUE
10700
10701     6 CONTINUE
10702       IF (IDXGLA.EQ.0) THEN
10703          WRITE(LOUT,1001) NNA,NNB,PPN
10704  1001    FORMAT(1X,'PROFBI:   configuration (NA,NB,PPN = ',
10705      &          2I4,F6.0,') not found ')
10706          STOP
10707       ENDIF
10708
10709 * no interpolation yet available
10710       XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
10711
10712       BSITE(1,1,NTARG,1) = ZERO
10713       DO 10 I=2,NSITEB
10714          XX = DBLE(I)
10715          POLY  = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
10716      &           GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
10717      &           GLAFIT(5,IDXGLA)*XX**4
10718          IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
10719          BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
10720          IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
10721    10 CONTINUE
10722
10723       RETURN
10724       END
10725 *
10726 *===glaube=============================================================*
10727 *
10728 CDECK  ID>, DT_GLAUBE
10729       SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
10730
10731 ************************************************************************
10732 * Calculation of configuartion of interacting nucleons for one event.  *
10733 *    NA / NB    mass numbers of proj./target nuclei           (input)  *
10734 *    B          impact parameter                              (output) *
10735 *    INTT       total number of wounded nucleons                 "     *
10736 *    INTA / INTB number of wounded nucleons in proj. / target    "     *
10737 *    JS / JT(i) number of collisions proj. / target nucleon i is       *
10738 *                                                   involved  (output) *
10739 *    NIDX       index of projectile/target material             (input)*
10740 * This is an update of the original routine SHMAKO by J.Ranft/HJM      *
10741 * This version dated 22.03.96 is revised by S. Roesler                 *
10742 ************************************************************************
10743
10744       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10745       SAVE
10746
10747       PARAMETER ( LINP = 5 ,
10748      &            LOUT = 6 ,
10749      &            LDAT = 9 )
10750
10751       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
10752      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
10753
10754       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10755
10756       PARAMETER ( MAXNCL = 260,
10757
10758      &            MAXVQU = MAXNCL,
10759      &            MAXSQU = 20*MAXVQU,
10760      &            MAXINT = MAXVQU+MAXSQU)
10761 * Glauber formalism: parameters
10762       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10763      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10764      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10765      &                NSITEB,NSTATB
10766 * Glauber formalism: cross sections
10767       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10768      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10769      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10770      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10771      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10772      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10773      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10774      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10775      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10776      &                BSLOPE,NEBINI,NQBINI
10777 * Lorentz-parameters of the current interaction
10778       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10779      &                UMO,PPCM,EPROJ,PPROJ
10780 * properties of photon/lepton projectiles
10781       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10782 * Glauber formalism: collision properties
10783       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
10784      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
10785 * Glauber formalism: flags and parameters for statistics
10786       LOGICAL LPROD
10787       CHARACTER*8 CGLB
10788       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10789
10790       DIMENSION JS(MAXNCL),JT(MAXNCL)
10791
10792       NTARG = ABS(NIDX)
10793
10794 * get actual energy from /DTLTRA/
10795       ECMNOW = UMO
10796       Q2     = VIRT
10797 *
10798 * new patch for pre-initialized variable projectile/target/energy runs
10799       IF (IOGLB.EQ.100) THEN
10800          CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
10801 *
10802 * variable energy run, interpolate profile function
10803       ELSE
10804          I1   = 1
10805          I2   = 1
10806          RATE = ONE
10807          IF (NEBINI.GT.1) THEN
10808             IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
10809                I1   = NEBINI
10810                I2   = NEBINI
10811                RATE = ONE
10812             ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
10813                DO 1 I=2,NEBINI
10814                   IF (ECMNOW.LT.ECMNN(I)) THEN
10815                      I1   = I-1
10816                      I2   = I
10817                      RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
10818                      GOTO 2
10819                   ENDIF
10820     1          CONTINUE
10821     2          CONTINUE
10822             ENDIF
10823          ENDIF
10824          J1   = 1
10825          J2   = 1
10826          RATQ = ONE
10827          IF (NQBINI.GT.1) THEN
10828             IF (Q2.GE.Q2G(NQBINI)) THEN
10829                J1   = NQBINI
10830                J2   = NQBINI
10831                RATQ = ONE
10832             ELSEIF (Q2.GT.Q2G(1)) THEN
10833                DO 3 I=2,NQBINI
10834                   IF (Q2.LT.Q2G(I)) THEN
10835                      J1   = I-1
10836                      J2   = I
10837                      RATQ = LOG10(     Q2/MAX(Q2G(J1),TINY14))/
10838      &                      LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
10839 C                    RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
10840                      GOTO 4
10841                   ENDIF
10842     3          CONTINUE
10843     4          CONTINUE
10844             ENDIF
10845          ENDIF
10846
10847          DO 5 I=1,KSITEB
10848             BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
10849      &         RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10850      &         RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10851      &         RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
10852      &                    BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
10853     5    CONTINUE
10854       ENDIF
10855
10856       CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
10857       IF (NIDX.LE.-1) THEN
10858          RPROJ = RASH(1)
10859          RTARG = RBSH(NTARG)
10860       ELSE
10861          RPROJ = RASH(NTARG)
10862          RTARG = RBSH(1)
10863       ENDIF
10864
10865       RETURN
10866       END
10867 *
10868 *===diagr==============================================================*
10869 *
10870 CDECK  ID>, DT_DIAGR
10871       SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
10872      &                                                         NIDX)
10873
10874 ************************************************************************
10875 * Based on the original version by Shmakov et al.                      *
10876 * This version dated 21.04.95 is revised by S. Roesler                 *
10877 ************************************************************************
10878
10879       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10880       SAVE
10881
10882       PARAMETER ( LINP = 5 ,
10883      &            LOUT = 6 ,
10884      &            LDAT = 9 )
10885
10886       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10887       PARAMETER (TWOPI  = 6.283185307179586454D+00,
10888      &           PI     = TWOPI/TWO,
10889      &           GEV2MB = 0.38938D0,
10890      &           GEV2FM = 0.1972D0,
10891      &           ALPHEM = ONE/137.0D0,
10892 * proton mass
10893      &           AMP    = 0.938D0,
10894      &           AMP2   = AMP**2,
10895 * rho0 mass
10896      &           AMRHO0 = 0.77D0)
10897
10898       COMPLEX*16 C,CA,CI
10899
10900       PARAMETER ( MAXNCL = 260,
10901
10902      &            MAXVQU = MAXNCL,
10903      &            MAXSQU = 20*MAXVQU,
10904      &            MAXINT = MAXVQU+MAXSQU)
10905 * particle properties (BAMJET index convention)
10906       CHARACTER*8  ANAME
10907       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
10908      &                IICH(210),IIBAR(210),K1(210),K2(210)
10909
10910       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10911
10912 * emulsion treatment
10913       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
10914      &                NCOMPO,IEMUL
10915 * Glauber formalism: parameters
10916       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10917      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10918      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10919      &                NSITEB,NSTATB
10920 * Glauber formalism: cross sections
10921       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10922      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10923      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10924      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10925      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10926      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10927      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10928      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10929      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10930      &                BSLOPE,NEBINI,NQBINI
10931 * VDM parameter for photon-nucleus interactions
10932       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
10933 * nucleon-nucleon event-generator
10934       CHARACTER*8 CMODEL
10935       LOGICAL LPHOIN
10936       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10937 **PHOJET105a
10938 C     COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10939 **PHOJET112
10940 C  obsolete cut-off information
10941       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
10942       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10943 **
10944 * coordinates of nucleons
10945       COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
10946 * interface between Glauber formalism and DPM
10947       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
10948      &                INTER1(MAXINT),INTER2(MAXINT)
10949 * statistics: Glauber-formalism
10950       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
10951 * n-n cross section fluctuations
10952       PARAMETER (NBINS = 1000)
10953       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
10954
10955       DIMENSION JS(MAXNCL),JT(MAXNCL),
10956      &          JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
10957      &          JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
10958       DIMENSION NWA(0:210),NWB(0:210)
10959
10960       LOGICAL LFIRST
10961       DATA LFIRST /.TRUE./
10962
10963       DATA NTARGO,ICNT /0,0/
10964
10965       NTARG = ABS(NIDX)
10966
10967       IF (LFIRST) THEN
10968          LFIRST = .FALSE.
10969          IF (NCOMPO.EQ.0) THEN
10970             NCALL  = 0
10971             NWAMAX = NA
10972             NWBMAX = NB
10973             DO 17 I=0,210
10974                NWA(I) = 0
10975                NWB(I) = 0
10976    17       CONTINUE
10977          ENDIF
10978       ENDIF
10979       IF (NTARG.EQ.-1) THEN
10980          IF (NCOMPO.EQ.0) THEN
10981             WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
10982             WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
10983      &                                NCALL,NWAMAX,NWBMAX
10984             DO 18 I=1,MAX(NWAMAX,NWBMAX)
10985                WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
10986      &                          I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
10987      &                            NWB(I),DBLE(NWB(I))/DBLE(NCALL)
10988    18       CONTINUE
10989          ENDIF
10990          RETURN
10991       ENDIF
10992
10993       DCOH   = 1.0D10
10994       IPNT   = 0
10995
10996       SQ2  = Q2
10997       IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
10998       S   = ECMNOW**2
10999       X   = SQ2/(S+SQ2-AMP2)
11000       XNU = (S+SQ2-AMP2)/(TWO*AMP)
11001 * photon projectiles: recalculate photon-nucleon amplitude
11002       IF (IJPROJ.EQ.7) THEN
11003    15    CONTINUE
11004 *  VDM assumption: mass of V-meson
11005          AMV2   = DT_SAM2(SQ2,ECMNOW)
11006          AMV    = SQRT(AMV2)
11007          IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
11008 *  check for pointlike interaction
11009          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
11010 **sr 27.10.
11011 C        SIGSH  = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11012          SIGSH  = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11013 **
11014          ROSH   = 0.1D0
11015          BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
11016      &                   +0.25D0*LOG(S/(AMV2+SQ2)))
11017 *  coherence length
11018          IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
11019       ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
11020          IF (MCGENE.EQ.2) THEN
11021             ZERO1 = ZERO
11022             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
11023      &                                                BSLOPE,0)
11024          ELSE
11025             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
11026          ENDIF
11027          IF (ECMNOW.LE.3.0D0) THEN
11028             ROSH = -0.43D0
11029          ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
11030             ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
11031          ELSEIF (ECMNOW.GT.50.0D0) THEN
11032             ROSH = 0.1D0
11033          ENDIF
11034          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11035          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11036          IF (MCGENE.EQ.2) THEN
11037             ZERO1 = ZERO
11038             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
11039      &                                                  BDUM,0)
11040             SIGSH = SIGSH/10.0D0
11041          ELSE
11042 C           SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11043             DUMZER = ZERO
11044             CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11045             SIGSH = SIGSH/10.0D0
11046          ENDIF
11047       ELSE
11048          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
11049          ROSH   = 0.01D0
11050          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11051          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11052 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11053          DUMZER = ZERO
11054          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11055          SIGSH = SIGSH/10.0D0
11056       ENDIF
11057       GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
11058       GAM = GSH
11059       RCA = GAM*SIGSH/TWOPI
11060       FCA = -ROSH*RCA
11061       CA  = DCMPLX(RCA,FCA)
11062       CI  = DCMPLX(ONE,ZERO)
11063
11064    16 CONTINUE
11065 * impact parameter
11066       IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
11067
11068       NTRY = 0
11069     3 CONTINUE
11070       NTRY = NTRY+1
11071 * initializations
11072       JNT  = 0
11073       DO 1 I=1,NA
11074          JS(I) = 0
11075     1 CONTINUE
11076       DO 2 I=1,NB
11077          JT(I) = 0
11078     2 CONTINUE
11079       IF (IJPROJ.EQ.7) THEN
11080          DO 8 I=1,MAXNCL
11081             JS0(I) = 0
11082             JNT0(I)= 0
11083             DO 9 J=1,NB
11084                JT0(I,J) = 0
11085     9       CONTINUE
11086     8    CONTINUE
11087       ENDIF
11088
11089 * nucleon configuration
11090 C     IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11091       IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11092 C        CALL DT_CONUCL(PKOO,NA,RASH,2)
11093 C        CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
11094          IF (NIDX.LE.-1) THEN
11095             CALL DT_CONUCL(PKOO,NA,RASH(1),0)
11096             CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
11097          ELSE
11098             CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11099             CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11100          ENDIF
11101          NTARGO = NTARG
11102       ENDIF
11103       ICNT = ICNT+1
11104
11105 * LEPTO: pick out one struck nucleon
11106       IF (MCGENE.EQ.3) THEN
11107          JNT     = 1
11108          JS(1)   = 1
11109          IDX     = INT(DT_RNDM(X)*NB)+1
11110          JT(IDX) = 1
11111          B       = ZERO
11112          GOTO 19
11113       ENDIF
11114
11115       DO 4 INA=1,NA
11116 * cross section fluctuations
11117          AFLUC = ONE
11118          IF (IFLUCT.EQ.1) THEN
11119             IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11120             AFLUC = FLUIXX(IFLUK)
11121          ENDIF
11122          KK1  = 1
11123          KINT = 1
11124          DO 5 INB=1,NB
11125 * photon-projectile: check for supression by coherence length
11126             IF (IJPROJ.EQ.7) THEN
11127                IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11128                   KK1  = INB
11129                   KINT = KINT+1
11130                ENDIF
11131             ENDIF
11132             QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11133             QQ2 =   TKOO(2,INB)-PKOO(2,INA)
11134             XY  = GAM*(QQ1*QQ1+QQ2*QQ2)
11135             IF (XY.LE.15.0D0) THEN
11136                C  = CI-CA*AFLUC*EXP(-XY)
11137                AR = DBLE(C)
11138                AI = DIMAG(C)
11139                P  = AR*AR+AI*AI
11140                IF (DT_RNDM(XY).GE.P) THEN
11141                   JNT = JNT+1
11142                   IF (IJPROJ.EQ.7) THEN
11143                      JNT0(KINT) = JNT0(KINT)+1
11144                      IF (JNT0(KINT).GT.MAXNCL) THEN
11145                         WRITE(LOUT,1001) MAXNCL
11146  1001                   FORMAT(1X,
11147      &                        'DIAGR:  no. of requested interactions',
11148      &                        ' exceeds array dimensions ',I4)
11149                         STOP
11150                      ENDIF
11151                      JS0(KINT)      = JS0(KINT)+1
11152                      JT0(KINT,INB)  = JT0(KINT,INB)+1
11153                      JI1(KINT,JNT0(KINT)) = INA
11154                      JI2(KINT,JNT0(KINT)) = INB
11155                   ELSE
11156                      IF (JNT.GT.MAXINT) THEN
11157                         WRITE(LOUT,1000) JNT, MAXINT
11158  1000                   FORMAT(1X,
11159      &                        'DIAGR:  no. of requested interactions ('
11160      &                        ,I4,') exceeds array dimensions (',I4,')')
11161                         STOP
11162                      ENDIF
11163                      JS(INA) = JS(INA)+1
11164                      JT(INB) = JT(INB)+1
11165                      INTER1(JNT) = INA
11166                      INTER2(JNT) = INB
11167                   ENDIF
11168                ENDIF
11169             ENDIF
11170     5    CONTINUE
11171     4 CONTINUE
11172
11173       IF (JNT.EQ.0) THEN
11174          IF (NTRY.LT.500) THEN
11175             GOTO 3
11176          ELSE
11177 C           WRITE(6,*) ' new impact parameter required (old= ',B,')'
11178             GOTO 16
11179          ENDIF
11180       ENDIF
11181
11182       IDIREC = 0
11183       IF (IJPROJ.EQ.7) THEN
11184          K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11185    10    CONTINUE
11186          IF (JNT0(K).EQ.0) THEN
11187             K = K+1
11188             IF (K.GT.KINT) K = 1
11189             GOTO 10
11190          ENDIF
11191 * supress Glauber-cascade by direct photon processes
11192          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11193          IF (IPNT.GT.0) THEN
11194             JNT   = 1
11195             JS(1) = 1
11196             DO 11 INB=1,NB
11197                JT(INB) = JT0(K,INB)
11198                IF (JT(INB).GT.0) GOTO 12
11199    11       CONTINUE
11200    12       CONTINUE
11201             INTER1(1) = 1
11202             INTER2(1) = INB
11203             IDIREC    = IPNT
11204          ELSE
11205             JNT   = JNT0(K)
11206             JS(1) = JS0(K)
11207             DO 13 INB=1,NB
11208                JT(INB) = JT0(K,INB)
11209    13       CONTINUE
11210             DO 14 I=1,JNT
11211                INTER1(I) = JI1(K,I)
11212                INTER2(I) = JI2(K,I)
11213    14       CONTINUE
11214          ENDIF
11215       ENDIF
11216
11217    19 CONTINUE
11218       INTA = 0
11219       INTB = 0
11220       DO 6 I=1,NA
11221         IF (JS(I).NE.0) INTA=INTA+1
11222     6 CONTINUE
11223       DO 7 I=1,NB
11224         IF (JT(I).NE.0) INTB=INTB+1
11225     7 CONTINUE
11226       ICWPG = INTA
11227       ICWTG = INTB
11228       ICIG  = JNT
11229       IPGLB = IPGLB+INTA
11230       ITGLB = ITGLB+INTB
11231       NGLB = NGLB+1
11232
11233       IF (NCOMPO.EQ.0) THEN
11234          NCALL = NCALL+1
11235          NWA(INTA) = NWA(INTA)+1
11236          NWB(INTB) = NWB(INTB)+1
11237       ENDIF
11238
11239       RETURN
11240       END
11241 *
11242 *===modb===============================================================*
11243 *
11244 CDECK  ID>, DT_MODB
11245       SUBROUTINE DT_MODB(B,NIDX)
11246
11247 ************************************************************************
11248 * Sampling of impact parameter of collision.                           *
11249 *    B          impact parameter    (output)                           *
11250 *    NIDX       index of projectile/target material             (input)*
11251 * Based on the original version by Shmakov et al.                      *
11252 * This version dated 21.04.95 is revised by S. Roesler                 *
11253 ************************************************************************
11254
11255       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11256       SAVE
11257
11258       PARAMETER ( LINP = 5 ,
11259      &            LOUT = 6 ,
11260      &            LDAT = 9 )
11261
11262       PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11263
11264       LOGICAL LEFT,LFIRST
11265
11266 * central particle production, impact parameter biasing
11267       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11268
11269       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11270
11271 * Glauber formalism: parameters
11272       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11273      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11274      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11275      &                NSITEB,NSTATB
11276 * Glauber formalism: cross sections
11277       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11278      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11279      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11280      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11281      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11282      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11283      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11284      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11285      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11286      &                BSLOPE,NEBINI,NQBINI
11287
11288       DATA LFIRST /.TRUE./
11289
11290       NTARG = ABS(NIDX)
11291       IF (NIDX.LE.-1) THEN
11292          RA = RASH(1)
11293          RB = RBSH(NTARG)
11294       ELSE
11295          RA = RASH(NTARG)
11296          RB = RBSH(1)
11297       ENDIF
11298
11299       IF (ICENTR.EQ.2) THEN
11300          IF (RA.EQ.RB) THEN
11301             BB = DT_RNDM(B)*(0.3D0*RA)**2
11302             B  = SQRT(BB)
11303          ELSEIF(RA.LT.RB)THEN
11304             BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11305             B  = SQRT(BB)
11306          ELSEIF(RA.GT.RB)THEN
11307             BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11308             B  = SQRT(BB)
11309          ENDIF
11310       ELSE
11311     9    CONTINUE
11312          Y  = DT_RNDM(BB)
11313          I0 = 1
11314          I2 = NSITEB
11315    10    CONTINUE
11316          I1 = (I0+I2)/2
11317          LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11318      &          *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11319          IF (LEFT) GOTO 20
11320          I0 = I1
11321          GOTO 30
11322    20    CONTINUE
11323          I2 = I1
11324    30    CONTINUE
11325          IF (I2-I0-2) 40,50,60
11326    40    CONTINUE
11327          I1 = I2+1
11328          IF (I1.GT.NSITEB) I1 = I0-1
11329          GOTO 70
11330    50    CONTINUE
11331          I1 = I0+1
11332          GOTO 70
11333    60    CONTINUE
11334          GOTO 10
11335    70    CONTINUE
11336          X0 = DBLE(I0-1)*BSTEP(NTARG)
11337          X1 = DBLE(I1-1)*BSTEP(NTARG)
11338          X2 = DBLE(I2-1)*BSTEP(NTARG)
11339          Y0 = BSITE(0,1,NTARG,I0)
11340          Y1 = BSITE(0,1,NTARG,I1)
11341          Y2 = BSITE(0,1,NTARG,I2)
11342    80    CONTINUE
11343          B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11344      &       X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11345      &       X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11346 **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11347          B = B+0.5D0*BSTEP(NTARG)
11348          IF (B.LT.ZERO) B = X1
11349          IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11350          IF (ICENTR.LT.0) THEN
11351             IF (LFIRST) THEN
11352                LFIRST = .FALSE.
11353                IF (ICENTR.LE.-100) THEN
11354                   BIMIN  = 0.0D0
11355                ELSE
11356                   XSFRAC = 0.0D0
11357                ENDIF
11358                CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11359                WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11360      &                          BIMIN,BIMAX,XSFRAC*100.0D0,
11361      &                          XSFRAC*XSPRO(1,1,NTARG)
11362  10000         FORMAT(/,1X,'DT_MODB:      Biasing in impact parameter',
11363      &                /,15X,'---------------------------'/,/,4X,
11364      &                'average radii of proj / targ :',F10.3,' fm /',
11365      &                F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11366      &                F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11367      &                F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11368      &                ' cross section :',F10.3,' %',/,5X,
11369      &                'corresponding cross section :',F10.3,' mb',/)
11370             ENDIF
11371             IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11372                B = BIMIN
11373             ELSE
11374                IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11375             ENDIF
11376          ENDIF
11377       ENDIF
11378
11379       RETURN
11380       END
11381 *
11382 *===shfast=============================================================*
11383 *
11384 CDECK  ID>, DT_SHFAST
11385       SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11386
11387       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11388       SAVE
11389
11390       PARAMETER ( LINP = 5 ,
11391      &            LOUT = 6 ,
11392      &            LDAT = 9 )
11393
11394       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11395      &           ONE=1.0D0,TWO=2.0D0)
11396
11397       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11398
11399 * Glauber formalism: parameters
11400       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11401      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11402      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11403      &                NSITEB,NSTATB
11404 * properties of interacting particles
11405       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11406 * Glauber formalism: cross sections
11407       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11408      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11409      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11410      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11411      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11412      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11413      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11414      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11415      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11416      &                BSLOPE,NEBINI,NQBINI
11417
11418       IBACK = 0
11419
11420       IF (MODE.EQ.2) THEN
11421          OPEN(47,FILE='shmakov.out',STATUS='UNKNOWN')
11422          WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11423  1000    FORMAT(1X,8I5,E15.5)
11424          WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11425  1001    FORMAT(1X,4E15.5)
11426          WRITE(47,1002) SIGSH,ROSH,GSH
11427  1002    FORMAT(1X,3E15.5)
11428          DO 10 I=1,100
11429             WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11430    10    CONTINUE
11431          WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11432  1003    FORMAT(1X,2I10,3E15.5)
11433          CLOSE(47)
11434       ELSE
11435          OPEN(47,FILE='shmakov.out',STATUS='UNKNOWN')
11436          READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11437          IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11438      &       (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11439      &       .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11440      &       (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11441             READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11442             READ(47,1002) SIGSH,ROSH,GSH
11443             DO 11 I=1,100
11444                READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11445    11       CONTINUE
11446             READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11447          ELSE
11448             IBACK = 1
11449          ENDIF
11450          CLOSE(47)
11451       ENDIF
11452
11453       RETURN
11454       END
11455 *
11456 *===poilik=============================================================*
11457 *
11458 CDECK  ID>, DT_POILIK
11459       SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11460
11461       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11462       SAVE
11463
11464       PARAMETER ( LINP = 5 ,
11465      &            LOUT = 6 ,
11466      &            LDAT = 9 )
11467
11468       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11469       PARAMETER (NE = 8)
11470
11471 **PHOJET105a
11472 C     CHARACTER*8 MDLNA
11473 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11474 C     PARAMETER (IEETAB=10)
11475 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11476 **PHOJET110
11477 C  model switches and parameters
11478       CHARACTER*8 MDLNA
11479       INTEGER ISWMDL,IPAMDL
11480       DOUBLE PRECISION PARMDL
11481       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11482 C  energy-interpolation table
11483       INTEGER IEETA2
11484       PARAMETER ( IEETA2 = 20 )
11485       INTEGER ISIMAX
11486       DOUBLE PRECISION SIGTAB,SIGECM
11487       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11488 **
11489 * VDM parameter for photon-nucleus interactions
11490       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11491 **sr 22.7.97
11492
11493       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11494
11495 * Glauber formalism: cross sections
11496       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11497      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11498      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11499      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11500      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11501      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11502      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11503      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11504      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11505      &                BSLOPE,NEBINI,NQBINI
11506 **
11507
11508       DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
11509
11510       IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
11511
11512 * load cross sections from interpolation table
11513       IP = 1
11514       IF(ECM.LE.SIGECM(IP,1)) THEN
11515         I1 = 1
11516         I2 = 1
11517       ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
11518         DO 50 I=2,ISIMAX
11519           IF(ECM.LE.SIGECM(IP,I)) GOTO 200
11520   50    CONTINUE
11521  200    CONTINUE
11522         I1 = I-1
11523         I2 = I
11524       ELSE
11525         WRITE(LOUT,'(/1X,A,2E12.3)')
11526      &    'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
11527         I1 = ISIMAX
11528         I2 = ISIMAX
11529       ENDIF
11530       FAC2 = ZERO
11531       IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
11532      &                     /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
11533       FAC1 = ONE-FAC2
11534
11535       SIGANO = DT_SANO(ECM)
11536
11537 * cross section dependence on photon virtuality
11538       FSUP1 = ZERO
11539       DO  150 I=1,3
11540          FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
11541      &                             /(ONE+VIRT/PARMDL(30+I))**2
11542  150  CONTINUE
11543       FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
11544       FAC1  = FAC1*FSUP1
11545       FAC2  = FAC2*FSUP1
11546       FSUP2 = ONE
11547
11548       ECMOLD = ECM
11549       Q2OLD  = VIRT
11550
11551     3 CONTINUE
11552
11553 C     SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
11554       CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
11555       IF (ISHAD(1).EQ.1) THEN
11556          SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
11557       ELSE
11558          SIGDIR = ZERO
11559       ENDIF
11560       SIGANO = FSUP1*FSUP2*SIGANO
11561       SIGTOT = SIGTOT-SIGDIR-SIGANO
11562       SIGDIR = SIGDIR/(FSUP1*FSUP2)
11563       SIGANO = SIGANO/(FSUP1*FSUP2)
11564       SIGTOT = SIGTOT+SIGDIR+SIGANO
11565
11566       RR = DT_RNDM(SIGTOT)
11567       IF (RR.LT.SIGDIR/SIGTOT) THEN
11568          IPNT = 1
11569       ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
11570      &        (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
11571          IPNT = 2
11572       ELSE
11573          IPNT = 0
11574       ENDIF
11575       RPNT = (SIGDIR+SIGANO)/SIGTOT
11576 C     WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
11577 C     WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
11578 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
11579 C     WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
11580       IF (MODE.EQ.1) RETURN
11581
11582 **sr 22.7.97
11583       K1   = 1
11584       K2   = 1
11585       RATE = ZERO
11586       IF (ECM.GE.ECMNN(NEBINI)) THEN
11587          K1   = NEBINI
11588          K2   = NEBINI
11589          RATE = ONE
11590       ELSEIF (ECM.GT.ECMNN(1)) THEN
11591          DO 10 I=2,NEBINI
11592             IF (ECM.LT.ECMNN(I)) THEN
11593                K1   = I-1
11594                K2   = I
11595                RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
11596                GOTO 11
11597             ENDIF
11598    10    CONTINUE
11599    11    CONTINUE
11600       ENDIF
11601       J1   = 1
11602       J2   = 1
11603       RATQ = ZERO
11604       IF (NQBINI.GT.1) THEN
11605          IF (VIRT.GE.Q2G(NQBINI)) THEN
11606             J1   = NQBINI
11607             J2   = NQBINI
11608             RATQ = ONE
11609          ELSEIF (VIRT.GT.Q2G(1)) THEN
11610             DO 12 I=2,NQBINI
11611                IF (VIRT.LT.Q2G(I)) THEN
11612                   J1   = I-1
11613                   J2   = I
11614                   RATQ = LOG10(   VIRT/MAX(Q2G(J1),TINY14))/
11615      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11616                   GOTO 13
11617                ENDIF
11618    12       CONTINUE
11619    13       CONTINUE
11620          ENDIF
11621       ENDIF
11622       SGA = XSPRO(K1,J1,NTARG)+
11623      &      RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
11624      &      RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
11625      &      RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
11626      &                 XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
11627       SDI = DBLE(NB)*SIGDIR
11628       SAN = DBLE(NB)*SIGANO
11629       SPL = SDI+SAN
11630       RR = DT_RNDM(SPL)
11631       IF (RR.LT.SDI/SGA) THEN
11632          IPNT = 1
11633       ELSEIF ((RR.GE.SDI/SGA).AND.
11634      &        (RR.LT.SPL/SGA)) THEN
11635          IPNT = 2
11636       ELSE
11637          IPNT = 0
11638       ENDIF
11639       RPNT = SPL/SGA
11640 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
11641 **
11642
11643       RETURN
11644       END
11645 *
11646 *===glbini=============================================================*
11647 *
11648 CDECK  ID>, DT_GLBINI
11649       SUBROUTINE DT_GLBINI(WHAT)
11650
11651 ************************************************************************
11652 * Pre-initialization of profile function                               *
11653 * This version dated 28.11.00 is written by S. Roesler.                *
11654 ************************************************************************
11655
11656       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11657       SAVE
11658
11659       PARAMETER ( LINP = 5 ,
11660      &            LOUT = 6 ,
11661      &            LDAT = 9 )
11662
11663       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
11664
11665       LOGICAL LCMS
11666
11667 * particle properties (BAMJET index convention)
11668       CHARACTER*8  ANAME
11669       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11670      &                IICH(210),IIBAR(210),K1(210),K2(210)
11671 * properties of interacting particles
11672       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11673
11674       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11675
11676 * emulsion treatment
11677       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11678      &                NCOMPO,IEMUL
11679 * Glauber formalism: flags and parameters for statistics
11680       LOGICAL LPROD
11681       CHARACTER*8 CGLB
11682       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11683 * number of data sets other than protons and nuclei
11684 * at the moment = 2 (pions and kaons)
11685       PARAMETER (MAXOFF=2)
11686       DIMENSION IJPINI(5),IOFFST(25)
11687       DATA IJPINI / 13, 15,  0,  0,  0/
11688 * Glauber data-set to be used for hadron projectiles
11689 * (0=proton, 1=pion, 2=kaon)
11690       DATA (IOFFST(K),K=1,25) /
11691      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11692      &  0, 0, 1, 2, 2/
11693 * Acceptance interval for target nucleus mass
11694       PARAMETER (KBACC = 6)
11695
11696       PARAMETER (MAXMSS = 100)
11697       DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
11698       DIMENSION WHAT(6)
11699
11700       DATA JPEACH,JPSTEP / 18, 5 /
11701
11702 * temporary patch until fix has been implemented in phojet:
11703 *  maximum energy for pion projectile
11704       DATA ECMXPI / 100000.0D0 /
11705 *
11706 *--------------------------------------------------------------------------
11707 * general initializations
11708 *
11709 *  steps in projectile mass number for initialization
11710       IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
11711       IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
11712 *
11713 *  energy range and binning
11714       ELO  = ABS(WHAT(1))
11715       EHI  = ABS(WHAT(2))
11716       IF (ELO.GT.EHI) ELO = EHI
11717       NEBIN = MAX(INT(WHAT(3)),1)
11718       IF (ELO.EQ.EHI) NEBIN = 0
11719       LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
11720       IF (LCMS) THEN
11721          ECMINI = EHI
11722       ELSE
11723          ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
11724      &                 +2.0D0*AAM(IJTARG)*EHI)
11725       ENDIF
11726 *
11727 *  default arguments for Glauber-routine
11728       XI  = ZERO
11729       Q2I = ZERO
11730 *
11731 *  initialize nuclear parameters, etc.
11732
11733       CALL BERTTP
11734       CALL INCINI
11735
11736 *
11737 *  open Glauber-data output file
11738       IDX = INDEX(CGLB,' ')
11739       K   = 12
11740       IF (IDX.GT.1) K = IDX-1
11741       OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11742 *
11743 *--------------------------------------------------------------------------
11744 * Glauber-initialization for proton and nuclei projectiles
11745 *
11746 *  initialize phojet for proton-proton interactions
11747       ELAB = ZERO
11748       PLAB = ZERO
11749       CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11750       CALL DT_PHOINI
11751 *
11752 *  record projectile masses
11753       NASAV = 0
11754       NPROJ = MIN(IP,JPEACH)
11755       DO 10 KPROJ=1,NPROJ
11756          NASAV = NASAV+1
11757          IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11758          IASAV(NASAV) = KPROJ
11759    10 CONTINUE
11760       IF (IP.GT.JPEACH) THEN
11761          NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
11762          IF (NPROJ.EQ.0) THEN
11763             NASAV = NASAV+1
11764             IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11765             IASAV(NASAV) = IP
11766          ELSE
11767             DO 11 IPROJ=1,NPROJ
11768                KPROJ = JPEACH+IPROJ*JPSTEP
11769                NASAV = NASAV+1
11770                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11771                IASAV(NASAV) = KPROJ
11772    11       CONTINUE
11773             IF (KPROJ.LT.IP) THEN
11774                NASAV = NASAV+1
11775                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11776                IASAV(NASAV) = IP
11777             ENDIF
11778          ENDIF
11779       ENDIF
11780 *
11781 *  record target masses
11782       NBSAV = 0
11783       NTARG = 1
11784       IF (NCOMPO.GT.0) NTARG = NCOMPO
11785       DO 12 ITARG=1,NTARG
11786          NBSAV = NBSAV+1
11787          IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
11788          IF (NCOMPO.GT.0) THEN
11789             IBSAV(NBSAV) = IEMUMA(ITARG)
11790          ELSE
11791             IBSAV(NBSAV) = IT
11792          ENDIF
11793    12 CONTINUE
11794 *
11795 *  print masses
11796       WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
11797  1000 FORMAT(I4,A,1P,2E13.5)
11798       NLINES = DBLE(NASAV)/18.0D0
11799       IF (NLINES.GT.0) THEN
11800          DO 13 I=1,NLINES
11801             IF (I.EQ.1) THEN
11802                WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
11803             ELSE
11804                WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
11805             ENDIF
11806    13    CONTINUE
11807       ENDIF
11808       I0 = 18*NLINES+1
11809       IF (I0.LE.NASAV) THEN
11810          IF (I0.EQ.1) THEN
11811             WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
11812          ELSE
11813             WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
11814          ENDIF
11815       ENDIF
11816       NLINES = DBLE(NBSAV)/18.0D0
11817       IF (NLINES.GT.0) THEN
11818          DO 14 I=1,NLINES
11819             IF (I.EQ.1) THEN
11820                WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
11821             ELSE
11822                WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
11823             ENDIF
11824    14    CONTINUE
11825       ENDIF
11826       I0 = 18*NLINES+1
11827       IF (I0.LE.NBSAV) THEN
11828          IF (I0.EQ.1) THEN
11829             WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
11830          ELSE
11831             WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
11832          ENDIF
11833       ENDIF
11834 *
11835 *  calculate Glauber-data for each energy and mass combination
11836 *
11837 *   loop over energy bins
11838       ELO = LOG10(ELO)
11839       EHI = LOG10(EHI)
11840       DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
11841       DO 1 IE=1,NEBIN+1
11842          E = ELO+DBLE(IE-1)*DEBIN
11843          E = 10**E
11844          IF (LCMS) THEN
11845             E   = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
11846             ECM = E
11847          ELSE
11848             PLAB = ZERO
11849             ECM  = ZERO
11850             E    = MAX(AAM(IJPROJ)+0.1D0,E)
11851             CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11852          ENDIF
11853 *
11854 *   loop over projectile and target masses
11855          DO 2 ITARG=1,NBSAV
11856             DO 3 IPROJ=1,NASAV
11857                CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
11858      &                                       XI,Q2I,ECM,1,1,-1)
11859     3       CONTINUE
11860     2    CONTINUE
11861 *
11862     1 CONTINUE
11863 *
11864 *--------------------------------------------------------------------------
11865 * Glauber-initialization for pion, kaon, ... projectiles
11866 *
11867       DO 6 IJ=1,MAXOFF
11868 *
11869 *  initialize phojet for this interaction
11870          ELAB = ZERO
11871          PLAB = ZERO
11872          IJPROJ = IJPINI(IJ)
11873          IP     = 1
11874          IPZ    = 1
11875 *
11876 *   temporary patch until fix has been implemented in phojet:
11877          IF (ECMINI.GT.ECMXPI) THEN
11878             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
11879          ELSE
11880             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11881          ENDIF
11882          CALL DT_PHOINI
11883 *
11884 *  calculate Glauber-data for each energy and mass combination
11885 *
11886 *   loop over energy bins
11887          DO 4 IE=1,NEBIN+1
11888             E = ELO+DBLE(IE-1)*DEBIN
11889             E = 10**E
11890             IF (LCMS) THEN
11891                E   = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
11892                ECM = E
11893             ELSE
11894                PLAB = ZERO
11895                ECM  = ZERO
11896                E    = MAX(AAM(IJPROJ)+TINY14,E)
11897                CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11898             ENDIF
11899 *
11900 *   loop over projectile and target masses
11901             DO 5 ITARG=1,NBSAV
11902                CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
11903     5       CONTINUE
11904 *
11905     4    CONTINUE
11906 *
11907     6 CONTINUE
11908
11909 *--------------------------------------------------------------------------
11910 * close output unit(s), etc.
11911 *
11912       CLOSE(LDAT)
11913
11914       RETURN
11915       END
11916 *
11917 *===glbset=============================================================*
11918 *
11919 CDECK  ID>, DT_GLBSET
11920       SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
11921 ************************************************************************
11922 * Interpolation of pre-initialized profile functions                   *
11923 * This version dated 28.11.00 is written by S. Roesler.                *
11924 ************************************************************************
11925
11926       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11927       SAVE
11928
11929       PARAMETER ( LINP = 5 ,
11930      &            LOUT = 6 ,
11931      &            LDAT = 9 )
11932
11933       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
11934
11935       LOGICAL LCMS,LREAD,LFRST1,LFRST2
11936
11937 * particle properties (BAMJET index convention)
11938       CHARACTER*8  ANAME
11939       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11940      &                IICH(210),IIBAR(210),K1(210),K2(210)
11941 * Glauber formalism: flags and parameters for statistics
11942       LOGICAL LPROD
11943       CHARACTER*8 CGLB
11944       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11945
11946       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11947
11948 * Glauber formalism: parameters
11949       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11950      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11951      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11952      &                NSITEB,NSTATB
11953 * Glauber formalism: cross sections
11954       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11955      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11956      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11957      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11958      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11959      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11960      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11961      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11962      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11963      &                BSLOPE,NEBINI,NQBINI
11964 * number of data sets other than protons and nuclei
11965 * at the moment = 2 (pions and kaons)
11966       PARAMETER (MAXOFF=2)
11967       DIMENSION IJPINI(5),IOFFST(25)
11968       DATA IJPINI / 13, 15,  0,  0,  0/
11969 * Glauber data-set to be used for hadron projectiles
11970 * (0=proton, 1=pion, 2=kaon)
11971       DATA (IOFFST(K),K=1,25) /
11972      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11973      &  0, 0, 1, 2, 2/
11974 * Acceptance interval for target nucleus mass
11975       PARAMETER (KBACC = 6)
11976 * emulsion treatment
11977       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11978      &                NCOMPO,IEMUL
11979
11980       PARAMETER (MAXSET=5000,
11981      &           MAXBIN=100)
11982       DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
11983       DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
11984      &          BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
11985      &          IAIDX(10)
11986
11987       DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
11988 *
11989 * read data from file
11990 *
11991       IF (MODE.EQ.0) THEN
11992
11993          IF (LREAD) RETURN
11994
11995          DO 1 I=1,MAXSET
11996             DO 2 J=1,6
11997                XSIG(I,J) = ZERO
11998                XERR(I,J) = ZERO
11999     2       CONTINUE
12000             DO 3 J=1,KSITEB
12001                BPROFL(I,J) = ZERO
12002     3       CONTINUE
12003     1    CONTINUE
12004          DO 4 I=1,MAXBIN
12005             IABIN(I) = 0
12006             IBBIN(I) = 0
12007     4    CONTINUE
12008          DO 5 I=1,KSITEB
12009             BPRO0(I) = ZERO
12010             BPRO1(I) = ZERO
12011             BPRO(I)  = ZERO
12012     5    CONTINUE
12013
12014          IDX = INDEX(CGLB,' ')
12015          K   = 12
12016          IF (IDX.GT.1) K = IDX-1
12017          OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12018          WRITE(LOUT,1000) CGLB(1:K)//'.glb'
12019  1000    FORMAT(/,' GLBSET: impact parameter distributions read from ',
12020      &          'file ',A12,/)
12021 *
12022 *  read binning information
12023          READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
12024 *  return lower energy threshold to Fluka-interface
12025          ELAB = ELO
12026          LCMS = ELO.LT.ZERO
12027          WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
12028          IF (LCMS) THEN
12029             WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
12030          ELSE
12031             WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
12032          ENDIF
12033  1001    FORMAT(2X,A5,'  E_lo = ',1P,E9.3,'  E_hi = ',1P,E9.3,4X,
12034      &          'No. of bins:',I5,/)
12035          ELO  = LOG10(ABS(ELO))
12036          EHI  = LOG10(ABS(EHI))
12037          DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
12038          WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
12039          READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
12040          IF (NABIN.LT.18) THEN
12041             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
12042          ELSE
12043             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
12044          ENDIF
12045          IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
12046          IF (NABIN.GT.18) THEN
12047             NLINES = DBLE(NABIN-18)/18.0D0
12048             IF (NLINES.GT.0) THEN
12049                DO 7 I=1,NLINES
12050                   I0 = 18*(I+1)-17
12051                   READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12052                   WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12053     7          CONTINUE
12054             ENDIF
12055             I0 = 18*(NLINES+1)+1
12056             IF (I0.LE.NABIN) THEN
12057                READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12058                WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12059             ENDIF
12060          ENDIF
12061          WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
12062          READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
12063          IF (NBBIN.LT.18) THEN
12064             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
12065          ELSE
12066             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
12067          ENDIF
12068          IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
12069          IF (NBBIN.GT.18) THEN
12070             NLINES = DBLE(NBBIN-18)/18.0D0
12071             IF (NLINES.GT.0) THEN
12072                DO 8 I=1,NLINES
12073                   I0 = 18*(I+1)-17
12074                   READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12075                   WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12076     8          CONTINUE
12077             ENDIF
12078             I0 = 18*(NLINES+1)+1
12079             IF (I0.LE.NBBIN) THEN
12080                READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12081                WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12082             ENDIF
12083          ENDIF
12084 *  number of data sets to follow in the Glauber data file
12085 *   this variable is used for checks of consistency of projectile
12086 *   and target mass configurations given in header of Glauber data
12087 *   file and the data-sets which follow in this file
12088          NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
12089 *
12090 *  read profile function data
12091          NSET  = 0
12092          NAIDX = 0
12093          IPOLD = 0
12094    10    CONTINUE
12095          NSET = NSET+1
12096          IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
12097          READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
12098  1002    FORMAT(5I10,E15.5)
12099          IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12100             NAIDX = NAIDX+1
12101             IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12102             IAIDX(NAIDX) = IP
12103             IPOLD = IP
12104          ENDIF
12105          READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12106          READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12107          NLINES = INT(DBLE(ISITEB)/7.0D0)
12108          IF (NLINES.GT.0) THEN
12109             DO 11 I=1,NLINES
12110                READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12111    11       CONTINUE
12112          ENDIF
12113          I0 = 7*NLINES+1
12114          IF (I0.LE.ISITEB)
12115      &      READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12116          GOTO 10
12117   100    CONTINUE
12118          NSET = NSET-1
12119          IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12120          WRITE(LOUT,'(/,1X,A)')
12121      &   ' projectiles other than protons and nuclei: (particle index)'
12122          IF (NAIDX.GT.0) THEN
12123             WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12124          ELSE
12125             WRITE(LOUT,'(6X,A)') 'none'
12126          ENDIF
12127 *
12128          CLOSE(LDAT)
12129          WRITE(LOUT,*)
12130          LREAD = .TRUE.
12131
12132          IF (NCOMPO.EQ.0) THEN
12133             DO 12 J=1,NBBIN
12134                NCOMPO = NCOMPO+1
12135                IEMUMA(NCOMPO) = IBBIN(J)
12136                IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12137                EMUFRA(NCOMPO) = 1.0D0
12138    12       CONTINUE
12139             IEMUL = 1
12140          ENDIF
12141 *
12142 * calculate profile function for certain set of parameters
12143 *
12144       ELSE
12145
12146 c        write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12147 *
12148 * check for type of projectile and set index-offset to entry in
12149 * Glauber data array correspondingly
12150          IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12151          IF (IOFFST(IDPROJ).EQ.-1) THEN
12152             STOP ' GLBSET: no data for this projectile !'
12153          ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12154             IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12155          ELSE
12156             IDXOFF = 0
12157          ENDIF
12158 *
12159 * get energy bin and interpolation factor
12160          IF (LCMS) THEN
12161             E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12162          ELSE
12163             E = ELAB
12164          ENDIF
12165          E = LOG10(E)
12166          IF (E.LT.ELO) THEN
12167             IF (LFRST1) THEN
12168                WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12169                LFRST1 = .FALSE.
12170             ENDIF
12171             E = ELO
12172          ENDIF
12173          IF (E.GT.EHI) THEN
12174             IF (LFRST2) THEN
12175                WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12176                LFRST2 = .FALSE.
12177             ENDIF
12178             E = EHI
12179          ENDIF
12180          IE0  = (E-ELO)/DEBIN+1
12181          IE1  = IE0+1
12182          FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12183 *
12184 * get target nucleus index
12185          KB = 0
12186          NBACC = KBACC
12187          DO 20 I=1,NBBIN
12188             NBDIFF = ABS(NB-IBBIN(I))
12189             IF (NB.EQ.IBBIN(I)) THEN
12190                KB = I
12191                GOTO 21
12192             ELSEIF (NBDIFF.LE.NBACC) THEN
12193                KB = I
12194                NBACC = NBDIFF
12195             ENDIF
12196    20    CONTINUE
12197          IF (KB.NE.0) GOTO 21
12198          WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12199          STOP
12200    21    CONTINUE
12201 *
12202 * get projectile nucleus bin and interpolation factor
12203          KA0 = 0
12204          KA1 = 0
12205          FACNA = 0
12206          IF (IDXOFF.GT.0) THEN
12207             KA0 = 1
12208             KA1 = 1
12209             KABIN = 1
12210          ELSE
12211             IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12212             DO 22 I=1,NABIN
12213                IF (NA.EQ.IABIN(I)) THEN
12214                   KA0 = I
12215                   KA1 = I
12216                   GOTO 23
12217                ELSEIF (NA.LT.IABIN(I)) THEN
12218                   KA0 = I-1
12219                   KA1 = I
12220                   GOTO 23
12221                ENDIF
12222    22       CONTINUE
12223             WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12224             STOP
12225    23       CONTINUE
12226             IF (KA0.NE.KA1)
12227      &         FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12228             KABIN = NABIN
12229          ENDIF
12230 *
12231 * interpolate profile functions for interactions ka0-kb and ka1-kb
12232 * for energy E separately
12233          IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12234          IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12235          IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12236          IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12237          DO 30 I=1,ISITEB
12238             BPRO0(I) = BPROFL(IDX0,I)
12239      &                 +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12240             BPRO1(I) = BPROFL(IDY0,I)
12241      &                 +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12242    30    CONTINUE
12243          RADB  = DT_RNCLUS(NB)
12244          BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12245          BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12246 *
12247 * interpolate cross sections for energy E and projectile mass
12248          DO 31 I=1,6
12249             XS0   = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12250             XS1   = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12251             XS(I) = XS0+FACNA*(XS1-XS0)
12252             XE0   = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12253             XE1   = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12254             XE(I) = XE0+FACNA*(XE1-XE0)
12255    31    CONTINUE
12256 *
12257 * interpolate between ka0 and ka1
12258          RADA = DT_RNCLUS(NA)
12259          BMX  = 2.0D0*(RADA+RADB)
12260          BSTP = BMX/DBLE(ISITEB-1)
12261          BPRO(1) = ZERO
12262          DO 32 I=1,ISITEB-1
12263             B = DBLE(I)*BSTP
12264 *
12265 *   calculate values of profile functions at B
12266             IDX0 = B/BSTP0+1
12267             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12268             IDX1 = MIN(IDX0+1,ISITEB)
12269             FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12270             BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12271             IDX0 = B/BSTP1+1
12272             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12273             IDX1 = MIN(IDX0+1,ISITEB)
12274             FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12275             BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12276 *
12277             BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12278    32    CONTINUE
12279 *
12280 * fill common dtglam
12281          NSITEB   = ISITEB
12282          RASH(1)  = RADA
12283          RBSH(1)  = RADB
12284          BMAX(1)  = BMX
12285          BSTEP(1) = BSTP
12286          DO 33 I=1,KSITEB
12287             BSITE(0,1,1,I) = BPRO(I)
12288    33    CONTINUE
12289 *
12290 * fill common dtglxs
12291          XSTOT(1,1,1) = XS(1)
12292          XSELA(1,1,1) = XS(2)
12293          XSQEP(1,1,1) = XS(3)
12294          XSQET(1,1,1) = XS(4)
12295          XSQE2(1,1,1) = XS(5)
12296          XSPRO(1,1,1) = XS(6)
12297          XETOT(1,1,1) = XE(1)
12298          XEELA(1,1,1) = XE(2)
12299          XEQEP(1,1,1) = XE(3)
12300          XEQET(1,1,1) = XE(4)
12301          XEQE2(1,1,1) = XE(5)
12302          XEPRO(1,1,1) = XE(6)
12303
12304       ENDIF
12305
12306       RETURN
12307       END
12308 *
12309 *===xksamp=============================================================*
12310 *
12311 CDECK  ID>, DT_XKSAMP
12312       SUBROUTINE DT_XKSAMP(NN,ECM)
12313
12314 ************************************************************************
12315 * Sampling of parton x-values and chain system for one interaction.    *
12316 *                                   processed by S. Roesler, 9.8.95    *
12317 ************************************************************************
12318
12319       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12320       SAVE
12321
12322       PARAMETER ( LINP = 5 ,
12323      &            LOUT = 6 ,
12324      &            LDAT = 9 )
12325
12326       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12327       SAVE
12328
12329       PARAMETER (
12330 * lower cuts for (valence-sea/sea-valence) chain masses
12331 *   antiquark-quark (u/d-sea quark)    (s-sea quark)
12332      &               AMIU = 0.5D0,      AMIS = 0.8D0,
12333 *   quark-diquark   (u/d-sea quark)    (s-sea quark)
12334      &               AMAU = 2.6D0,      AMAS = 2.6D0,
12335 * maximum lower valence-x threshold
12336      &           XVMAX  = 0.98D0,
12337 * fraction of sea-diquarks sampled out of sea-partons
12338 **test
12339 C    &           FRCDIQ = 0.9D0,
12340 **
12341 *
12342      &           SQMA   = 0.7D0,
12343 *
12344 * maximum number of trials to generate x's for the required number
12345 * of sea quark pairs for a given hadron
12346 C    &           NSEATY = 12
12347      &           NSEATY = 3
12348      &          )
12349
12350       LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12351
12352       PARAMETER ( MAXNCL = 260,
12353
12354      &            MAXVQU = MAXNCL,
12355      &            MAXSQU = 20*MAXVQU,
12356      &            MAXINT = MAXVQU+MAXSQU)
12357 * event history
12358
12359       PARAMETER (NMXHKK=200000)
12360
12361       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12362      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12363      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12364 * particle properties (BAMJET index convention)
12365       CHARACTER*8  ANAME
12366       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12367      &                IICH(210),IIBAR(210),K1(210),K2(210)
12368 * interface between Glauber formalism and DPM
12369       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12370      &                INTER1(MAXINT),INTER2(MAXINT)
12371 * properties of interacting particles
12372       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12373 * threshold values for x-sampling (DTUNUC 1.x)
12374       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12375      &                SSMIMQ,VVMTHR
12376 * x-values of partons (DTUNUC 1.x)
12377       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12378      &                XTVQ(MAXVQU),XTVD(MAXVQU),
12379      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
12380      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
12381 * flavors of partons (DTUNUC 1.x)
12382       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12383      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12384      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
12385      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12386      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
12387      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12388      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
12389 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12390       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12391      &                IXPV,IXPS,IXTV,IXTS,
12392      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
12393      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
12394      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
12395      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
12396      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
12397      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
12398      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
12399      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
12400 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12401       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12402      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12403 * auxiliary common for chain system storage (DTUNUC 1.x)
12404       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12405 * flags for input different options
12406       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12407       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12408      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12409 * various options for treatment of partons (DTUNUC 1.x)
12410 * (chain recombination, Cronin,..)
12411       LOGICAL LCO2CR,LINTPT
12412       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12413      &                LCO2CR,LINTPT
12414
12415       DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12416      &          INTLO(MAXINT)
12417
12418 * (1) initializations
12419 *-----------------------------------------------------------------------
12420
12421 **test
12422       IF (ECM.LT.4.5D0) THEN
12423 C        FRCDIQ = 0.6D0
12424          FRCDIQ = 0.4D0
12425       ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12426 C        FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12427          FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12428       ELSE
12429 C        FRCDIQ = 0.9D0
12430          FRCDIQ = 0.7D0
12431       ENDIF
12432 **
12433       DO 30 I=1,MAXSQU
12434          ZUOSP(I) = .FALSE.
12435          ZUOST(I) = .FALSE.
12436          IF (I.LE.MAXVQU) THEN
12437             ZUOVP(I) = .FALSE.
12438             ZUOVT(I) = .FALSE.
12439          ENDIF
12440    30 CONTINUE
12441
12442 * lower thresholds for x-selection
12443 *  sea-quarks       (default: CSEA=0.2)
12444       IF (ECM.LT.10.0D0) THEN
12445 **!!test
12446          XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12447 C        XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12448          NSEA  = NSEATY
12449 C        XSTHR = ONE/ECM**2
12450       ELSE
12451 **sr 30.3.98
12452 C        XSTHR = CSEA/ECM
12453          XSTHR = CSEA/ECM**2
12454 C        XSTHR = ONE/ECM**2
12455 **
12456          IF ((IP.GE.150).AND.(IT.GE.150))
12457      &      XSTHR = 2.5D0/(ECM*SQRT(ECM))
12458          NSEA  = NSEATY
12459       ENDIF
12460 *                   (default: SSMIMA=0.14) used for sea-diquarks (?)
12461       XSSTHR = SSMIMA/ECM
12462       BSQMA  = SQMA/ECM
12463 *  valence-quarks   (default: CVQ=1.0)
12464       XVTHR  = CVQ/ECM
12465 *  valence-diquarks (default: CDQ=2.0)
12466       XDTHR  = CDQ/ECM
12467
12468 * maximum-x for sea-quarks
12469       XVCUT  = XVTHR+XDTHR
12470       IF (XVCUT.GT.XVMAX) THEN
12471          XVCUT = XVMAX
12472          XVTHR = XVCUT/3.0D0
12473          XDTHR = XVCUT-XVTHR
12474       ENDIF
12475       XXSEAM = ONE-XVCUT
12476 **sr 18.4. test: DPMJET
12477 C     XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
12478 C    &            - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
12479 C    &             -0.01*(1.D0+1.5D0*DT_RNDM(V3))
12480 **
12481 * maximum number of sea-pairs allowed kinematically
12482 C     NSMAX  = INT(OHALF*XXSEAM/XSTHR)
12483       RNSMAX = OHALF*XXSEAM/XSTHR
12484       IF (RNSMAX.GT.10000.0D0) THEN
12485          NSMAX = 10000
12486       ELSE
12487          NSMAX = INT(OHALF*XXSEAM/XSTHR)
12488       ENDIF
12489 * check kinematical limit for valence-x thresholds
12490 * (should be obsolete now)
12491       IF (XVCUT.GT.XVMAX) THEN
12492          WRITE(LOUT,1000) XVCUT,ECM
12493  1000    FORMAT(' XKSAMP:    kin. limit for valence-x',
12494      &          '  thresholds not allowed (',2E9.3,')')
12495 C        XVTHR = XVMAX-XDTHR
12496 C        IF (XVTHR.LT.ZERO) STOP
12497          STOP
12498       ENDIF
12499
12500 * set eta for valence-x sampling (BETREJ)
12501 *   (UNON per default, UNOM used for projectile mesons only)
12502       IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
12503          UNOPRV = UNOM
12504       ELSE
12505          UNOPRV = UNON
12506       ENDIF
12507
12508 * (2) select parton x-values of interacting projectile nucleons
12509 *-----------------------------------------------------------------------
12510
12511       IXPV = 0
12512       IXPS = 0
12513
12514       DO 100 IPP=1,IP
12515 *   get interacting projectile nucleon as sampled by Glauber
12516          IF (JSSH(IPP).NE.0) THEN
12517             IXSTMP = IXPS
12518             IXVTMP = IXPV
12519    99       CONTINUE
12520             IXPS   = IXSTMP
12521             IXPV   = IXVTMP
12522 *     JIPP is the actual number of sea-pairs sampled for this nucleon
12523             JIPP   = MIN(JSSH(IPP)-1,NSMAX)
12524    41       CONTINUE
12525             XXSEA  = ZERO
12526             IF (JIPP.GT.0) THEN
12527                XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
12528 *???
12529                IF (XSTHR.GE.XSMAX) THEN
12530                   JIPP = JIPP-1
12531                   GOTO 41
12532                ENDIF
12533
12534 *>>>get x-values of sea-quark pairs
12535                NSCOUN = 0
12536                PLW = 0.5D0
12537    40          CONTINUE
12538 *     accumulator for sea x-values
12539                XXSEA  = ZERO
12540                NSCOUN = NSCOUN+1
12541                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12542                IF (NSCOUN.GT.NSEA) THEN
12543 *     decrease the number of interactions after NSEA trials
12544                   JIPP   = JIPP-1
12545                   NSCOUN = 0
12546                ENDIF
12547                DO 70 ISQ=1,JIPP
12548 *     sea-quarks
12549                   IF (IPSQ(IXPS+1).LE.2) THEN
12550 **sr 8.4.98 (1/sqrt(x))
12551 C                    XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12552 C                    XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12553                      XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12554 **
12555                   ELSE
12556                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12557                         XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12558                      ELSE
12559 **sr 8.4.98 (1/sqrt(x))
12560 C                       XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12561 C                       XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12562                         XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12563 **
12564                      ENDIF
12565                   ENDIF
12566 *     sea-antiquarks
12567                   IF (IPSAQ(IXPS+1).GE.-2) THEN
12568 **sr 8.4.98 (1/sqrt(x))
12569 C                    XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12570 C                    XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12571                      XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12572 **
12573                   ELSE
12574                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12575                         XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12576                      ELSE
12577 **sr 8.4.98 (1/sqrt(x))
12578 C                       XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12579 C                       XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12580                         XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12581 **
12582                      ENDIF
12583                   ENDIF
12584                   XXSEA = XXSEA+XPSQI+XPSAQI
12585 *     check for maximum allowed sea x-value
12586                   IF (XXSEA.GE.XXSEAM) THEN
12587                      IXPS = IXPS-ISQ+1
12588                      GOTO 40
12589                   ENDIF
12590 *     accept this sea-quark pair
12591                   IXPS         = IXPS+1
12592                   XPSQ(IXPS)   = XPSQI
12593                   XPSAQ(IXPS)  = XPSAQI
12594                   IFROSP(IXPS) = IPP
12595                   ZUOSP(IXPS)  = .TRUE.
12596    70          CONTINUE
12597             ENDIF
12598
12599 *>>>get x-values of valence partons
12600 *     valence quark
12601             IF (XVTHR.GT.0.05D0) THEN
12602                XVHI  = ONE-XXSEA-XDTHR
12603                XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
12604             ELSE
12605    90          CONTINUE
12606                XPVQI = DT_DBETAR(OHALF,UNOPRV)
12607                IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
12608      &                                                     GOTO 90
12609             ENDIF
12610 *     valence diquark
12611             XPVDI = ONE-XPVQI-XXSEA
12612 *       reject according to x**1.5
12613             XDTMP = XPVDI**1.5D0
12614             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
12615 *     accept these valence partons
12616             IXPV         = IXPV+1
12617             XPVQ(IXPV)   = XPVQI
12618             XPVD(IXPV)   = XPVDI
12619             IFROVP(IXPV) = IPP
12620             ITOVP(IPP)   = IXPV
12621             ZUOVP(IXPV)  = .TRUE.
12622
12623          ENDIF
12624   100 CONTINUE
12625
12626 * (3) select parton x-values of interacting target nucleons
12627 *-----------------------------------------------------------------------
12628
12629       IXTV = 0
12630       IXTS = 0
12631
12632       DO 170 ITT=1,IT
12633 *   get interacting target nucleon as sampled by Glauber
12634          IF (JTSH(ITT).NE.0) THEN
12635             IXSTMP = IXTS
12636             IXVTMP = IXTV
12637   169       CONTINUE
12638             IXTS   = IXSTMP
12639             IXTV   = IXVTMP
12640 *     JITT is the actual number of sea-pairs sampled for this nucleon
12641             JITT   = MIN(JTSH(ITT)-1,NSMAX)
12642   111       CONTINUE
12643             XXSEA  = ZERO
12644             IF (JITT.GT.0) THEN
12645                XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
12646 *???
12647                IF (XSTHR.GE.XSMAX) THEN
12648                   JITT = JITT-1
12649                   GOTO 111
12650                ENDIF
12651
12652 *>>>get x-values of sea-quark pairs
12653                NSCOUN = 0
12654                PLW = 0.5D0
12655   110          CONTINUE
12656 *     accumulator for sea x-values
12657                XXSEA  = ZERO
12658                NSCOUN = NSCOUN+1
12659                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12660                IF (NSCOUN.GT.NSEA)THEN
12661 *     decrease the number of interactions after NSEA trials
12662                   JITT   = JITT-1
12663                   NSCOUN = 0
12664                ENDIF
12665                DO 140 ISQ=1,JITT
12666 *     sea-quarks
12667                   IF (ITSQ(IXTS+1).LE.2) THEN
12668 **sr 8.4.98 (1/sqrt(x))
12669 C                    XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12670 C                    XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12671                      XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12672 **
12673                   ELSE
12674                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12675                         XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12676                      ELSE
12677 **sr 8.4.98 (1/sqrt(x))
12678 C                       XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12679 C                       XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12680                         XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12681 **
12682                      ENDIF
12683                   ENDIF
12684 *     sea-antiquarks
12685                   IF (ITSAQ(IXTS+1).GE.-2) THEN
12686 **sr 8.4.98 (1/sqrt(x))
12687 C                    XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12688 C                    XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12689                      XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12690 **
12691                   ELSE
12692                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12693                         XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12694                      ELSE
12695 **sr 8.4.98 (1/sqrt(x))
12696 C                       XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12697 C                       XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12698                         XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12699 **
12700                      ENDIF
12701                   ENDIF
12702                   XXSEA = XXSEA+XTSQI+XTSAQI
12703 *     check for maximum allowed sea x-value
12704                   IF (XXSEA.GE.XXSEAM) THEN
12705                      IXTS = IXTS-ISQ+1
12706                      GOTO 110
12707                   ENDIF
12708 *     accept this sea-quark pair
12709                   IXTS         = IXTS+1
12710                   XTSQ(IXTS)   = XTSQI
12711                   XTSAQ(IXTS)  = XTSAQI
12712                   IFROST(IXTS) = ITT
12713                   ZUOST(IXTS)  = .TRUE.
12714   140          CONTINUE
12715             ENDIF
12716
12717 *>>>get x-values of valence partons
12718 *     valence quark
12719             IF (XVTHR.GT.0.05D0) THEN
12720                XVHI  = ONE-XXSEA-XDTHR
12721                XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
12722             ELSE
12723   160          CONTINUE
12724                XTVQI = DT_DBETAR(OHALF,UNON)
12725                IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
12726      &                                                    GOTO 160
12727             ENDIF
12728 *     valence diquark
12729             XTVDI = ONE-XTVQI-XXSEA
12730 *       reject according to x**1.5
12731             XDTMP = XTVDI**1.5D0
12732             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
12733 *     accept these valence partons
12734             IXTV         = IXTV+1
12735             XTVQ(IXTV)   = XTVQI
12736             XTVD(IXTV)   = XTVDI
12737             IFROVT(IXTV) = ITT
12738             ITOVT(ITT)   = IXTV
12739             ZUOVT(IXTV)  = .TRUE.
12740
12741          ENDIF
12742   170 CONTINUE
12743
12744 * (4) get valence-valence chains
12745 *-----------------------------------------------------------------------
12746
12747       NVV = 0
12748       DO 240 I=1,NN
12749          INTLO(I) = .TRUE.
12750          IPVAL    = ITOVP(INTER1(I))
12751          ITVAL    = ITOVT(INTER2(I))
12752          IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
12753             INTLO(I)      = .FALSE.
12754             ZUOVP(IPVAL)  = .FALSE.
12755             ZUOVT(ITVAL)  = .FALSE.
12756             NVV           = NVV+1
12757             ISKPCH(8,NVV) = 0
12758             INTVV1(NVV)   = IPVAL
12759             INTVV2(NVV)   = ITVAL
12760          ENDIF
12761   240 CONTINUE
12762
12763 * (5) get sea-valence chains
12764 *-----------------------------------------------------------------------
12765
12766       NSV = 0
12767       NDV = 0
12768       PLW = 0.5D0
12769       DO 270 I=1,NN
12770          IF (INTLO(I)) THEN
12771             IPVAL = ITOVP(INTER1(I))
12772             ITVAL = ITOVT(INTER2(I))
12773             DO 250 J=1,IXPS
12774                IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
12775      &                                ZUOVT(ITVAL)) THEN
12776                   ZUOSP(J)     = .FALSE.
12777                   ZUOVT(ITVAL) = .FALSE.
12778                   INTLO(I)     = .FALSE.
12779                   IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
12780 *   sample sea-diquark pair
12781                      CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
12782                      IF (IREJ1.EQ.0) GOTO 260
12783                   ENDIF
12784                   NSV           = NSV+1
12785                   ISKPCH(4,NSV) = 0
12786                   INTSV1(NSV)   = J
12787                   INTSV2(NSV)   = ITVAL
12788
12789 *>>>correct chain kinematics according to minimum chain masses
12790 *     the actual chain masses
12791                   AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
12792                   AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
12793 *     get lower mass cuts
12794                   IF (IPSQ(J).EQ.3) THEN
12795 *       q being s-quark
12796                      AMCHK1 = AMAS
12797                      AMCHK2 = AMIS
12798                   ELSE
12799 *       q being u/d-quark
12800                      AMCHK1 = AMAU
12801                      AMCHK2 = AMIU
12802                   ENDIF
12803 *       q-qq chain
12804 *         chain mass above minimum - resampling of sea-q x-value
12805                   IF (AMSVQ1.GT.AMCHK1) THEN
12806                      XPSQTH      = AMCHK1/(XTVD(ITVAL)*ECM**2)
12807 **sr 8.4.98 (1/sqrt(x))
12808 C                    XPSQXX      = DT_SAMPEX(XPSQTH,XPSQ(J))
12809 C                    XPSQXX      = DT_SAMSQX(XPSQTH,XPSQ(J))
12810                      XPSQXX      = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
12811 **
12812                      XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
12813                      XPSQ(J)     = XPSQXX
12814 *         chain mass below minimum - reset sea-q x-value and correct
12815 *                                    diquark-x of the same nucleon
12816                   ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12817                      XPSQW       = AMCHK1/(XTVD(ITVAL)*ECM**2)
12818                      DXPSQ       = XPSQW-XPSQ(J)
12819                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12820                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12821                         XPSQ(J)     = XPSQW
12822                      ENDIF
12823                   ENDIF
12824 *       aq-q chain
12825 *         chain mass below minimum - reset sea-aq x-value and correct
12826 *                                    diquark-x of the same nucleon
12827                   IF (AMSVQ2.LT.AMCHK2) THEN
12828                      XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
12829                      DXPSQ = XPSQW-XPSAQ(J)
12830                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12831                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12832                         XPSAQ(J)    = XPSQW
12833                      ENDIF
12834                   ENDIF
12835 *>>>end of chain mass correction
12836
12837                   GOTO 260
12838                ENDIF
12839   250       CONTINUE
12840          ENDIF
12841   260    CONTINUE
12842   270 CONTINUE
12843
12844 * (6) get valence-sea chains
12845 *-----------------------------------------------------------------------
12846
12847       NVS = 0
12848       NVD = 0
12849       DO 300 I=1,NN
12850          IF (INTLO(I)) THEN
12851             IPVAL = ITOVP(INTER1(I))
12852             ITVAL = ITOVT(INTER2(I))
12853             DO 280 J=1,IXTS
12854                IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
12855      &                  (IFROST(J).EQ.INTER2(I))) THEN
12856                   ZUOST(J)     = .FALSE.
12857                   ZUOVP(IPVAL) = .FALSE.
12858                   INTLO(I)     = .FALSE.
12859                   IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
12860 *   sample sea-diquark pair
12861                      CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
12862                      IF (IREJ1.EQ.0) GOTO 290
12863                   ENDIF
12864                   NVS           = NVS + 1
12865                   ISKPCH(6,NVS) = 0
12866                   INTVS1(NVS)   = IPVAL
12867                   INTVS2(NVS)   = J
12868
12869 *>>>correct chain kinematics according to minimum chain masses
12870 *     the actual chain masses
12871                   AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
12872                   AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
12873 *     get lower mass cuts
12874                   IF (ITSQ(J).EQ.3) THEN
12875 *       q being s-quark
12876                      AMCHK1 = AMIS
12877                      AMCHK2 = AMAS
12878                   ELSE
12879 *       q being u/d-quark
12880                      AMCHK1 = AMIU
12881                      AMCHK2 = AMAU
12882                   ENDIF
12883 *       q-aq chain
12884 *         chain mass below minimum - reset sea-aq x-value and correct
12885 *                                    diquark-x of the same nucleon
12886                   IF (AMVSQ1.LT.AMCHK1) THEN
12887                      XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
12888                      DXTSQ = XTSQW-XTSAQ(J)
12889                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12890                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12891                         XTSAQ(J)    = XTSQW
12892                      ENDIF
12893                   ENDIF
12894 *       qq-q chain
12895 *         chain mass above minimum - resampling of sea-q x-value
12896                   IF (AMVSQ2.GT.AMCHK2) THEN
12897                      XTSQTH      = AMCHK2/(XPVD(IPVAL)*ECM**2)
12898 **sr 8.4.98 (1/sqrt(x))
12899 C                    XTSQXX      = DT_SAMPEX(XTSQTH,XTSQ(J))
12900 C                    XTSQXX      = DT_SAMSQX(XTSQTH,XTSQ(J))
12901                      XTSQXX      = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
12902 **
12903                      XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
12904                      XTSQ(J)     = XTSQXX
12905 *         chain mass below minimum - reset sea-q x-value and correct
12906 *                                    diquark-x of the same nucleon
12907                   ELSEIF (AMVSQ2.LT.AMCHK2) THEN
12908                      XTSQW       = AMCHK2/(XPVD(IPVAL)*ECM**2)
12909                      DXTSQ       = XTSQW-XTSQ(J)
12910                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12911                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12912                         XTSQ(J)     = XTSQW
12913                      ENDIF
12914                   ENDIF
12915 *>>>end of chain mass correction
12916
12917                   GOTO 290
12918                ENDIF
12919   280       CONTINUE
12920          ENDIF
12921   290    CONTINUE
12922   300 CONTINUE
12923
12924 * (7) get sea-sea chains
12925 *-----------------------------------------------------------------------
12926
12927       NSS = 0
12928       NDS = 0
12929       NSD = 0
12930       DO 420 I=1,NN
12931          IF (INTLO(I)) THEN
12932             IPVAL = ITOVP(INTER1(I))
12933             ITVAL = ITOVT(INTER2(I))
12934 *   loop over target partons not yet matched
12935             DO 400 J=1,IXTS
12936                IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
12937 *   loop over projectile partons not yet matched
12938                   DO 390 JJ=1,IXPS
12939                      IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
12940                         ZUOSP(JJ)     = .FALSE.
12941                         ZUOST(J)      = .FALSE.
12942                         INTLO(I)      = .FALSE.
12943                         NSS           = NSS+1
12944                         ISKPCH(1,NSS) = 0
12945                         INTSS1(NSS)   = JJ
12946                         INTSS2(NSS)   = J
12947
12948 *---->chain recombination option
12949                         VALFRA        = DBLE(NVV/(NVV+IXPS+IXTS))
12950                         IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
12951      &                                                             THEN
12952 *       sea-sea chains may recombine with valence-valence chains
12953 *       only if they have the same projectile or target nucleon
12954                            DO 4201 IVV=1,NVV
12955                               IF (ISKPCH(8,IVV).NE.99) THEN
12956                                  IXVPR = INTVV1(IVV)
12957                                  IXVTA = INTVV2(IVV)
12958                                  IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
12959      &                               (INTER2(I).EQ.IFROVT(IXVTA))) THEN
12960 *         recombination possible, drop old v-v and s-s chains
12961                                     ISKPCH(1,NSS) = 99
12962                                     ISKPCH(8,IVV) = 99
12963
12964 *         (a) assign new s-v chains
12965 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
12966                                     IF (LSEADI.AND.
12967      &                                  (DT_RNDM(VALFRA).GT.FRCDIQ))
12968      &                                                             THEN
12969 *           sample sea-diquark pair
12970                                        CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
12971      &                                                      IREJ1)
12972                                        IF (IREJ1.EQ.0) GOTO 4202
12973                                     ENDIF
12974                                     NSV           = NSV+1
12975                                     ISKPCH(4,NSV) = 0
12976                                     INTSV1(NSV)   = JJ
12977                                     INTSV2(NSV)   = IXVTA
12978 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12979 *           the actual chain masses
12980                                     AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
12981      &                                                     *ECM**2
12982                                     AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
12983      &                                                     *ECM**2
12984 *           get lower mass cuts
12985                                     IF (IPSQ(JJ).EQ.3) THEN
12986 *             q being s-quark
12987                                        AMCHK1 = AMAS
12988                                        AMCHK2 = AMIS
12989                                     ELSE
12990 *             q being u/d-quark
12991                                        AMCHK1 = AMAU
12992                                        AMCHK2 = AMIU
12993                                     ENDIF
12994 *           q-qq chain
12995 *             chain mass above minimum - resampling of sea-q x-value
12996                                     IF (AMSVQ1.GT.AMCHK1) THEN
12997                                        XPSQTH      =
12998      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
12999 **sr 8.4.98 (1/sqrt(x))
13000                                        XPSQXX      =
13001      &                                    DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
13002 C    &                                    DT_SAMSQX(XPSQTH,XPSQ(JJ))
13003 C    &                                    DT_SAMPEX(XPSQTH,XPSQ(JJ))
13004 **
13005                                        XPVD(IPVAL) =
13006      &                                    XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
13007                                        XPSQ(JJ)    = XPSQXX
13008 *             chain mass below minimum - reset sea-q x-value and correct
13009 *                                        diquark-x of the same nucleon
13010                                     ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13011                                        XPSQW =
13012      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
13013                                        DXPSQ = XPSQW-XPSQ(JJ)
13014                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13015      &                                                            THEN
13016                                           XPVD(IPVAL) =
13017      &                                       XPVD(IPVAL)-DXPSQ
13018                                           XPSQ(JJ)    = XPSQW
13019                                        ENDIF
13020                                     ENDIF
13021 *           aq-q chain
13022 *             chain mass below minimum - reset sea-aq x-value and correct
13023 *                                        diquark-x of the same nucleon
13024                                     IF (AMSVQ2.LT.AMCHK2) THEN
13025                                        XPSQW =
13026      &                                    AMCHK2/(XTVQ(IXVTA)*ECM**2)
13027                                        DXPSQ = XPSQW-XPSAQ(JJ)
13028                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13029      &                                                            THEN
13030                                           XPVD(IPVAL) =
13031      &                                       XPVD(IPVAL)-DXPSQ
13032                                           XPSAQ(JJ)   = XPSQW
13033                                        ENDIF
13034                                     ENDIF
13035 *>>>>>>>>>>>end of chain mass correction
13036  4202                               CONTINUE
13037
13038 *         (b) assign new v-s chains
13039 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
13040                                     IF (LSEADI.AND.(
13041      &                                  DT_RNDM(AMSVQ2).GT.FRCDIQ))
13042      &                                                             THEN
13043 *           sample sea-diquark pair
13044                                        CALL DT_SAMSDQ(ECM,IXVPR,J,1,
13045      &                                                      IREJ1)
13046                                        IF (IREJ1.EQ.0) GOTO 4203
13047                                     ENDIF
13048                                     NVS           = NVS+1
13049                                     ISKPCH(6,NVS) = 0
13050                                     INTVS1(NVS)   = IXVPR
13051                                     INTVS2(NVS)   = J
13052 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13053 *           the actual chain masses
13054                                     AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
13055                                     AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
13056 *           get lower mass cuts
13057                                     IF (ITSQ(J).EQ.3) THEN
13058 *             q being s-quark
13059                                        AMCHK1 = AMIS
13060                                        AMCHK2 = AMAS
13061                                     ELSE
13062 *             q being u/d-quark
13063                                        AMCHK1 = AMIU
13064                                        AMCHK2 = AMAU
13065                                     ENDIF
13066 *           q-aq chain
13067 *             chain mass below minimum - reset sea-aq x-value and correct
13068 *                                        diquark-x of the same nucleon
13069                                     IF (AMVSQ1.LT.AMCHK1) THEN
13070                                        XTSQW =
13071      &                                    AMCHK1/(XPVQ(IXVPR)*ECM**2)
13072                                        DXTSQ = XTSQW-XTSAQ(J)
13073                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13074      &                                                            THEN
13075                                           XTVD(ITVAL) =
13076      &                                       XTVD(ITVAL)-DXTSQ
13077                                           XTSAQ(J)    = XTSQW
13078                                        ENDIF
13079                                     ENDIF
13080                                     IF (AMVSQ2.GT.AMCHK2) THEN
13081                                        XTSQTH      =
13082      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
13083 **sr 8.4.98 (1/sqrt(x))
13084                                        XTSQXX      =
13085      &                                    DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13086 C    &                                    DT_SAMSQX(XTSQTH,XTSQ(J))
13087 C    &                                    DT_SAMPEX(XTSQTH,XTSQ(J))
13088 **
13089                                        XTVD(ITVAL) =
13090      &                                    XTVD(ITVAL)+XTSQ(J)-XTSQXX
13091                                        XTSQ(J)     = XTSQXX
13092                                     ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13093                                        XTSQW =
13094      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
13095                                        DXTSQ = XTSQW-XTSQ(J)
13096                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13097      &                                                            THEN
13098                                           XTVD(ITVAL) =
13099      &                                       XTVD(ITVAL)-DXTSQ
13100                                           XTSQ(J)     = XTSQW
13101                                        ENDIF
13102                                     ENDIF
13103 *>>>>>>>>>end of chain mass correction
13104  4203                               CONTINUE
13105 *       jump out of s-s chain loop
13106                                     GOTO 420
13107                                  ENDIF
13108                               ENDIF
13109  4201                      CONTINUE
13110                         ENDIF
13111 *---->end of chain recombination option
13112
13113 *     sample sea-diquark pair (projectile)
13114                         IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13115                            CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13116                            IF (IREJ1.EQ.0) THEN
13117                               ISKPCH(1,NSS) = 99
13118                               GOTO 410
13119                            ENDIF
13120                         ENDIF
13121 *     sample sea-diquark pair (target)
13122                         IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13123                            CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13124                            IF (IREJ1.EQ.0) THEN
13125                               ISKPCH(1,NSS) = 99
13126                               GOTO 410
13127                            ENDIF
13128                         ENDIF
13129 *>>>>>correct chain kinematics according to minimum chain masses
13130 *     the actual chain masses
13131                         SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13132                         SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13133 *     check for lower mass cuts
13134                         IF ((SSMA1Q.LT.SSMIMQ).OR.
13135      &                      (SSMA2Q.LT.SSMIMQ)) THEN
13136                            IPVAL = ITOVP(INTER1(I))
13137                            ITVAL = ITOVT(INTER2(I))
13138                            IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13139      &                         (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13140 *       maximum allowed x values for sea quarks
13141                               XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13142      &                                           1.2D0*XSSTHR
13143                               XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13144      &                                           1.2D0*XSSTHR
13145 *       resampling of x values not possible - skip sea-sea chains
13146                               IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13147      &                            (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13148 *       resampling of x for projectile sea quark pair
13149                               ICOUS = 0
13150   310                         CONTINUE
13151                               ICOUS = ICOUS+1
13152                               IF (XSSTHR.GT.0.05D0) THEN
13153                                  XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13154      &                                                         XSPMAX)
13155                                  XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13156      &                                                         XSPMAX)
13157                               ELSE
13158   320                            CONTINUE
13159                                  XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13160                                  IF ((XPSQI.LT.XSSTHR).OR.
13161      &                               (XPSQI.GT.XSPMAX))  GOTO 320
13162   330                            CONTINUE
13163                                  XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13164                                  IF ((XPSAQI.LT.XSSTHR).OR.
13165      &                               (XPSAQI.GT.XSPMAX)) GOTO 330
13166                               ENDIF
13167 *       final test of remaining x for projectile diquark
13168                               XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13169      &                                            +XPSQ(JJ)+XPSAQ(JJ)
13170                               IF (XPVDCO.LE.XDTHR) THEN
13171 *!!!
13172 C                                IF (ICOUS.LT.5) GOTO 310
13173                                  IF (ICOUS.LT.0.5D0) GOTO 310
13174                                  GOTO 380
13175                               ENDIF
13176 *       resampling of x for target sea quark pair
13177                               ICOUS = 0
13178   350                         CONTINUE
13179                               ICOUS = ICOUS+1
13180                               IF (XSSTHR.GT.0.05D0) THEN
13181                                  XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13182      &                                                         XSTMAX)
13183                                  XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13184      &                                                         XSTMAX)
13185                               ELSE
13186   360                            CONTINUE
13187                                  XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13188                                  IF ((XTSQI.LT.XSSTHR).OR.
13189      &                               (XTSQI.GT.XSTMAX))  GOTO 360
13190   370                            CONTINUE
13191                                  XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13192                                  IF ((XTSAQI.LT.XSSTHR).OR.
13193      &                               (XTSAQI.GT.XSTMAX)) GOTO 370
13194                               ENDIF
13195 *       final test of remaining x for target diquark
13196                               XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13197      &                                            +XTSQ(J)+XTSAQ(J)
13198                               IF (XTVDCO.LT.XDTHR) THEN
13199                                  IF (ICOUS.LT.5) GOTO 350
13200                                  GOTO 380
13201                               ENDIF
13202                               XPVD(IPVAL) = XPVDCO
13203                               XTVD(ITVAL) = XTVDCO
13204                               XPSQ(JJ)    = XPSQI
13205                               XPSAQ(JJ)   = XPSAQI
13206                               XTSQ(J)     = XTSQI
13207                               XTSAQ(J)    = XTSAQI
13208 *>>>>>end of chain mass correction
13209                               GOTO 410
13210                            ENDIF
13211 *     come here to discard s-s interaction
13212 *     resampling of x values not allowed or unsuccessful
13213   380                      CONTINUE
13214                            INTLO(I)  = .FALSE.
13215                            ZUOST(J)  = .TRUE.
13216                            ZUOSP(JJ) = .TRUE.
13217                            NSS       = NSS-1
13218                         ENDIF
13219 *   consider next s-s interaction
13220                         GOTO 410
13221                      ENDIF
13222   390             CONTINUE
13223                ENDIF
13224   400       CONTINUE
13225          ENDIF
13226   410    CONTINUE
13227   420 CONTINUE
13228
13229 * correct x-values of valence quarks for non-matching sea quarks
13230       DO 430 I=1,IXPS
13231          IF (ZUOSP(I)) THEN
13232             IPVAL       = ITOVP(IFROSP(I))
13233             XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13234             XPSQ(I)     = ZERO
13235             XPSAQ(I)    = ZERO
13236             ZUOSP(I)    = .FALSE.
13237          ENDIF
13238   430 CONTINUE
13239       DO 440 I=1,IXTS
13240          IF (ZUOST(I)) THEN
13241             ITVAL       = ITOVT(IFROST(I))
13242             XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13243             XTSQ(I)     = ZERO
13244             XTSAQ(I)    = ZERO
13245             ZUOST(I)    = .FALSE.
13246          ENDIF
13247   440 CONTINUE
13248       DO 450 I=1,IXPV
13249          IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13250   450 CONTINUE
13251       DO 460 I=1,IXTV
13252          IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13253   460 CONTINUE
13254
13255       RETURN
13256       END
13257 *
13258 *===samsdq=============================================================*
13259 *
13260 CDECK  ID>, DT_SAMSDQ
13261       SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13262
13263 ************************************************************************
13264 * SAMpling of Sea-DiQuarks                                             *
13265 *              ECM        cm-energy of the nucleon-nucleon system      *
13266 *              IDX1,2     indices of x-values of the participating     *
13267 *                         partons (IDX2 is always the sea-q-pair to be *
13268 *                         changed to sea-qq-pair)                      *
13269 *              MODE       = 1  valence-q - sea-diq                     *
13270 *                         = 2  sea-diq   - valence-q                   *
13271 *                         = 3  sea-q     - sea-diq                     *
13272 *                         = 4  sea-diq   - sea-q                       *
13273 * Based on DIQVS, DIQSV, DIQSSD, DIQDSS.                               *
13274 * This version dated 17.10.95 is written by S. Roesler                 *
13275 ************************************************************************
13276
13277       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13278       SAVE
13279
13280       PARAMETER (ZERO=0.0D0)
13281
13282 * threshold values for x-sampling (DTUNUC 1.x)
13283       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13284      &                SSMIMQ,VVMTHR
13285 * various options for treatment of partons (DTUNUC 1.x)
13286 * (chain recombination, Cronin,..)
13287       LOGICAL LCO2CR,LINTPT
13288       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13289      &                LCO2CR,LINTPT
13290
13291       PARAMETER ( MAXNCL = 260,
13292
13293      &            MAXVQU = MAXNCL,
13294      &            MAXSQU = 20*MAXVQU,
13295      &            MAXINT = MAXVQU+MAXSQU)
13296 * x-values of partons (DTUNUC 1.x)
13297       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13298      &                XTVQ(MAXVQU),XTVD(MAXVQU),
13299      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
13300      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
13301 * flavors of partons (DTUNUC 1.x)
13302       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13303      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13304      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
13305      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13306      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
13307      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13308      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
13309 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13310       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13311      &                IXPV,IXPS,IXTV,IXTS,
13312      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
13313      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
13314      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
13315      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
13316      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
13317      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
13318      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
13319      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
13320 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13321       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13322      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13323 * auxiliary common for chain system storage (DTUNUC 1.x)
13324       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13325
13326       IREJ = 0
13327 *  threshold-x for valence diquarks
13328       XDTHR = CDQ/ECM
13329
13330       GOTO (1,2,3,4) MODE
13331
13332 *---------------------------------------------------------------------
13333 * proj. valence partons - targ. sea partons
13334 * get x-values and flavors for target sea-diquark pair
13335
13336     1 CONTINUE
13337       IDXVP = IDX1
13338       IDXST = IDX2
13339
13340 *  index of corr. val-diquark-x in target nucleon
13341       IDXVT = ITOVT(IFROST(IDXST))
13342 *  available x above diquark thresholds for valence- and sea-diquarks
13343       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13344
13345       IF (XXD.GE.ZERO) THEN
13346 *  x-values for the three diquarks of the target nucleon
13347          RR1    = DT_RNDM(XXD)
13348          RR2    = DT_RNDM(RR1)
13349          RR3    = DT_RNDM(RR2)
13350          SR123  = RR1+RR2+RR3
13351          XXTV   = XDTHR+RR1*XXD/SR123
13352          XXTSQ  = XDTHR+RR2*XXD/SR123
13353          XXTSAQ = XDTHR+RR3*XXD/SR123
13354       ELSE
13355          XXTV   = XTVD(IDXVT)
13356          XXTSQ  = XTSQ(IDXST)
13357          XXTSAQ = XTSAQ(IDXST)
13358       ENDIF
13359 *  flavor of the second quarks in the sea-diquark pair
13360       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13361       ITSAQ2(IDXST) = -ITSQ2(IDXST)
13362 *  check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13363       AM1    = XXTSQ *XPVQ(IDXVP)*ECM**2
13364       AM2    = XXTSAQ*XPVD(IDXVP)*ECM**2
13365       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13366 *    ss-asas pair
13367      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13368          IREJ = 1
13369          RETURN
13370       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13371 *    at least one strange quark
13372      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13373          IREJ = 1
13374          RETURN
13375       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13376          IREJ = 1
13377          RETURN
13378       ENDIF
13379 *  accept the new sea-diquark
13380       XTVD(IDXVT)   = XXTV
13381       XTSQ(IDXST)   = XXTSQ
13382       XTSAQ(IDXST)  = XXTSAQ
13383       NVD           = NVD+1
13384       INTVD1(NVD)   = IDXVP
13385       INTVD2(NVD)   = IDXST
13386       ISKPCH(7,NVD) = 0
13387       RETURN
13388
13389 *---------------------------------------------------------------------
13390 * proj. sea partons - targ. valence partons
13391 * get x-values and flavors for projectile sea-diquark pair
13392
13393     2 CONTINUE
13394       IDXSP = IDX2
13395       IDXVT = IDX1
13396
13397 *  index of corr. val-diquark-x in projectile nucleon
13398       IDXVP = ITOVP(IFROSP(IDXSP))
13399 *  available x above diquark thresholds for valence- and sea-diquarks
13400       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13401
13402       IF (XXD.GE.ZERO) THEN
13403 *  x-values for the three diquarks of the projectile nucleon
13404          RR1    = DT_RNDM(XXD)
13405          RR2    = DT_RNDM(RR1)
13406          RR3    = DT_RNDM(RR2)
13407          SR123  = RR1+RR2+RR3
13408          XXPV   = XDTHR+RR1*XXD/SR123
13409          XXPSQ  = XDTHR+RR2*XXD/SR123
13410          XXPSAQ = XDTHR+RR3*XXD/SR123
13411       ELSE
13412          XXPV   = XPVD(IDXVP)
13413          XXPSQ  = XPSQ(IDXSP)
13414          XXPSAQ = XPSAQ(IDXSP)
13415       ENDIF
13416 *  flavor of the second quarks in the sea-diquark pair
13417       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13418       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13419 *  check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13420       AM1    = XXPSQ *XTVQ(IDXVT)*ECM**2
13421       AM2    = XXPSAQ*XTVD(IDXVT)*ECM**2
13422       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13423 *    ss-asas pair
13424      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13425          IREJ = 1
13426          RETURN
13427       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13428 *    at least one strange quark
13429      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13430          IREJ = 1
13431          RETURN
13432       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13433          IREJ = 1
13434          RETURN
13435       ENDIF
13436 *  accept the new sea-diquark
13437       XPVD(IDXVP)   = XXPV
13438       XPSQ(IDXSP)   = XXPSQ
13439       XPSAQ(IDXSP)  = XXPSAQ
13440       NDV           = NDV+1
13441       INTDV1(NDV)   = IDXSP
13442       INTDV2(NDV)   = IDXVT
13443       ISKPCH(5,NDV) = 0
13444       RETURN
13445
13446 *---------------------------------------------------------------------
13447 * proj. sea partons - targ. sea partons
13448 * get x-values and flavors for target sea-diquark pair
13449
13450     3 CONTINUE
13451       IDXSP = IDX1
13452       IDXST = IDX2
13453
13454 *  index of corr. val-diquark-x in target nucleon
13455       IDXVT = ITOVT(IFROST(IDXST))
13456 *  available x above diquark thresholds for valence- and sea-diquarks
13457       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13458
13459       IF (XXD.GE.ZERO) THEN
13460 *  x-values for the three diquarks of the target nucleon
13461          RR1    = DT_RNDM(XXD)
13462          RR2    = DT_RNDM(RR1)
13463          RR3    = DT_RNDM(RR2)
13464          SR123  = RR1+RR2+RR3
13465          XXTV   = XDTHR+RR1*XXD/SR123
13466          XXTSQ  = XDTHR+RR2*XXD/SR123
13467          XXTSAQ = XDTHR+RR3*XXD/SR123
13468       ELSE
13469          XXTV   = XTVD(IDXVT)
13470          XXTSQ  = XTSQ(IDXST)
13471          XXTSAQ = XTSAQ(IDXST)
13472       ENDIF
13473 *  flavor of the second quarks in the sea-diquark pair
13474       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13475       ITSAQ2(IDXST) = -ITSQ2(IDXST)
13476 *  check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
13477       AM1    = XXTSQ *XPSQ(IDXSP)*ECM**2
13478       AM2    = XXTSAQ*XPSAQ(IDXSP)*ECM**2
13479       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13480 *    ss-asas pair
13481      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
13482          IREJ = 1
13483          RETURN
13484       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13485 *    at least one strange quark
13486      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
13487          IREJ = 1
13488          RETURN
13489       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13490          IREJ = 1
13491          RETURN
13492       ENDIF
13493 *  accept the new sea-diquark
13494       XTVD(IDXVT)   = XXTV
13495       XTSQ(IDXST)   = XXTSQ
13496       XTSAQ(IDXST)  = XXTSAQ
13497       NSD           = NSD+1
13498       INTSD1(NSD)   = IDXSP
13499       INTSD2(NSD)   = IDXST
13500       ISKPCH(3,NSD) = 0
13501       RETURN
13502
13503 *---------------------------------------------------------------------
13504 * proj. sea partons - targ. sea partons
13505 * get x-values and flavors for projectile sea-diquark pair
13506
13507     4 CONTINUE
13508       IDXSP = IDX2
13509       IDXST = IDX1
13510
13511 *  index of corr. val-diquark-x in projectile nucleon
13512       IDXVP = ITOVP(IFROSP(IDXSP))
13513 *  available x above diquark thresholds for valence- and sea-diquarks
13514       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13515
13516       IF (XXD.GE.ZERO) THEN
13517 *  x-values for the three diquarks of the projectile nucleon
13518          RR1    = DT_RNDM(XXD)
13519          RR2    = DT_RNDM(RR1)
13520          RR3    = DT_RNDM(RR2)
13521          SR123  = RR1+RR2+RR3
13522          XXPV   = XDTHR+RR1*XXD/SR123
13523          XXPSQ  = XDTHR+RR2*XXD/SR123
13524          XXPSAQ = XDTHR+RR3*XXD/SR123
13525       ELSE
13526          XXPV   = XPVD(IDXVP)
13527          XXPSQ  = XPSQ(IDXSP)
13528          XXPSAQ = XPSAQ(IDXSP)
13529       ENDIF
13530 *  flavor of the second quarks in the sea-diquark pair
13531       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13532       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13533 *  check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
13534       AM1    = XXPSQ *XTSQ(IDXST)*ECM**2
13535       AM2    = XXPSAQ*XTSAQ(IDXST)*ECM**2
13536       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13537 *    ss-asas pair
13538      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
13539          IREJ = 1
13540          RETURN
13541       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13542 *    at least one strange quark
13543      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
13544          IREJ = 1
13545          RETURN
13546       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13547          IREJ = 1
13548          RETURN
13549       ENDIF
13550 *  accept the new sea-diquark
13551       XPVD(IDXVP)   = XXPV
13552       XPSQ(IDXSP)   = XXPSQ
13553       XPSAQ(IDXSP)  = XXPSAQ
13554       NDS           = NDS+1
13555       INTDS1(NDS)   = IDXSP
13556       INTDS2(NDS)   = IDXST
13557       ISKPCH(2,NDS) = 0
13558       RETURN
13559       END
13560 *
13561 *===difevt=============================================================*
13562 *
13563 CDECK  ID>, DT_DIFEVT
13564       SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
13565      &                  IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
13566
13567 ************************************************************************
13568 * Interface to treatment of diffractive interactions.                  *
13569 *  (input)          IFP1/2        PDG-indizes of projectile partons    *
13570 *                                 (baryon: IFP2 - adiquark)            *
13571 *                   PP(4)         projectile 4-momentum                *
13572 *                   IFT1/2        PDG-indizes of target partons        *
13573 *                                 (baryon: IFT1 - adiquark)            *
13574 *                   PT(4)         target 4-momentum                    *
13575 *  (output)         JDIFF = 0     no diffraction                       *
13576 *                         = 1/-1  LMSD/LMDD                            *
13577 *                         = 2/-2  HMSD/HMDD                            *
13578 *                   NCSY          counter for two-chain systems        *
13579 *                                 dumped to DTEVT1                     *
13580 * This version dated 14.02.95 is written by S. Roesler                 *
13581 ************************************************************************
13582
13583       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13584       SAVE
13585
13586       PARAMETER ( LINP = 5 ,
13587      &            LOUT = 6 ,
13588      &            LDAT = 9 )
13589
13590       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
13591      &           OHALF=0.5D0)
13592
13593 * event history
13594
13595       PARAMETER (NMXHKK=200000)
13596
13597       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
13598      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
13599      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
13600 * extended event history
13601       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
13602      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
13603      &                IHIST(2,NMXHKK)
13604 * flags for diffractive interactions (DTUNUC 1.x)
13605       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
13606
13607       DIMENSION PP(4),PT(4)
13608
13609       LOGICAL LFIRST
13610       DATA LFIRST /.TRUE./
13611
13612       IREJ   = 0
13613       JDIFF  = 0
13614       IFLAGD = JDIFF
13615
13616 * cm. energy
13617       XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
13618      &          (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
13619 * identities of projectile hadron / target nucleon
13620       KPROJ = IDT_ICIHAD(IDHKK(MOP))
13621       KTARG = IDT_ICIHAD(IDHKK(MOT))
13622
13623 * single diffractive xsections
13624       CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
13625 * double diffractive xsections
13626 **!! no double diff yet
13627 C     CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
13628       DDTOT = 0.0D0
13629       DDHM  = 0.0D0
13630 **!!
13631 * total inelastic xsection
13632 C     SIGIN  = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
13633       DUMZER = ZERO
13634       CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
13635       SIGIN  = MAX(SIGTO-SIGEL,ZERO)
13636
13637 * fraction of diffractive processes
13638       FRADIF = (SDTOT+DDTOT)/SIGIN
13639
13640       IF (LFIRST) THEN
13641          WRITE(LOUT,1000) XM,SDTOT,SIGIN
13642  1000    FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
13643      &          F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
13644      &          F5.1,' mb',/)
13645          LFIRST = .FALSE.
13646       ENDIF
13647
13648       IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
13649      &    (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
13650 * diffractive interaction requested by x-section or by user
13651          FRASD  = SDTOT/(SDTOT+DDTOT)
13652          FRASDH = SDHM/SDTOT
13653 **sr needs to be specified!!
13654 C        FRADDH = DDHM/DDTOT
13655          FRADDH = 1.0D0
13656 **
13657          IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
13658 *   single diffraction
13659             KDIFF = 1
13660             IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
13661                KP = 2
13662                KT = 0
13663                IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
13664      &               ISINGD.NE.3) THEN
13665                   KP = 0
13666                   KT = 2
13667                ENDIF
13668             ELSE
13669                KP = 1
13670                KT = 0
13671                IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
13672      &               ISINGD.NE.3) THEN
13673                   KP = 0
13674                   KT = 1
13675                ENDIF
13676             ENDIF
13677          ELSE
13678 *   double diffraction
13679             KDIFF = -1
13680             IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
13681                KP = 2
13682                KT = 2
13683             ELSE
13684                KP = 1
13685                KT = 1
13686             ENDIF
13687          ENDIF
13688          CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13689      &               IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13690          IF (IREJ1.EQ.0) THEN
13691             IFLAGD = 2*KDIFF
13692             IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
13693          ELSE
13694             GOTO 9999
13695          ENDIF
13696       ENDIF
13697       JDIFF = IFLAGD
13698
13699       RETURN
13700
13701  9999 CONTINUE
13702       IREJ  = 1
13703       RETURN
13704       END
13705 *
13706 *===difkin=============================================================*
13707 *
13708 CDECK  ID>, DT_DIFFKI
13709       SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13710      &                  IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
13711
13712 ************************************************************************
13713 * Kinematics of diffractive nucleon-nucleon interaction.               *
13714 *          IFP1/2   PDG-indizes of projectile partons                  *
13715 *                   (baryon: IFP2 - adiquark)                          *
13716 *          PP(4)    projectile 4-momentum                              *
13717 *          IFT1/2   PDG-indizes of target partons                      *
13718 *                   (baryon: IFT1 - adiquark)                          *
13719 *          PT(4)    target 4-momentum                                  *
13720 *          KP   = 0 projectile quasi-elastically scattered             *
13721 *               = 1            excited to low-mass diff. state         *
13722 *               = 2            excited to high-mass diff. state        *
13723 *          KT   = 0 target     quasi-elastically scattered             *
13724 *               = 1            excited to low-mass diff. state         *
13725 *               = 2            excited to high-mass diff. state        *
13726 * This version dated 12.02.95 is written by S. Roesler                 *
13727 ************************************************************************
13728
13729       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13730       SAVE
13731
13732       PARAMETER ( LINP = 5 ,
13733      &            LOUT = 6 ,
13734      &            LDAT = 9 )
13735
13736       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
13737
13738       LOGICAL LSTART
13739
13740 * particle properties (BAMJET index convention)
13741       CHARACTER*8  ANAME
13742       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
13743      &                IICH(210),IIBAR(210),K1(210),K2(210)
13744 * flags for input different options
13745       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
13746       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
13747      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
13748 * rejection counter
13749       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
13750      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
13751      &                IREXCI(3),IRDIFF(2),IRINC
13752 * kinematics of diffractive interactions (DTUNUC 1.x)
13753       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13754      &                PPF(4),PTF(4),
13755      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13756      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13757
13758       DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
13759      &          PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
13760
13761       DATA LSTART /.TRUE./
13762
13763       IF (LSTART) THEN
13764          WRITE(LOUT,2000)
13765  2000    FORMAT(/,1X,'DIFEVT:  diffractive interactions treated ')
13766          LSTART = .FALSE.
13767       ENDIF
13768
13769       IREJ = 0
13770
13771 * initialize common /DTDIKI/
13772       CALL DT_DIFINI
13773 * store momenta of initial incoming particles for emc-check
13774       IF (LEMCCK) THEN
13775          CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
13776          CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
13777       ENDIF
13778
13779 * masses of initial particles
13780       XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
13781       XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
13782       IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
13783       XMP  = SQRT(XMP2)
13784       XMT  = SQRT(XMT2)
13785 * check quark-input (used to adjust coherence cond. for M-selection)
13786       IBP  = 0
13787       IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
13788       IBT  = 0
13789       IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
13790
13791 * parameter for Lorentz-transformation into nucleon-nucleon cms
13792       DO 3 K=1,4
13793          PITOT(K) = PP(K)+PT(K)
13794     3 CONTINUE
13795       XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
13796       IF (XMTOT2.LE.ZERO) THEN
13797          WRITE(LOUT,1000) XMTOT2
13798  1000    FORMAT(1X,'DIFEVT:   negative cm. energy!  ',
13799      &          'XMTOT2 = ',E12.3)
13800          GOTO 9999
13801       ENDIF
13802       XMTOT = SQRT(XMTOT2)
13803       DO 4 K=1,4
13804          BGTOT(K) = PITOT(K)/XMTOT
13805     4 CONTINUE
13806 * transformation of nucleons into cms
13807       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
13808      &            PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
13809       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
13810      &            PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
13811 * rotation angles
13812       COD = PP1(3)/PPTOT
13813 C     SID = SQRT((ONE-COD)*(ONE+COD))
13814       PPT = SQRT(PP1(1)**2+PP1(2)**2)
13815       SID = PPT/PPTOT
13816       COF = ONE
13817       SIF = ZERO
13818       IF(PPTOT*SID.GT.TINY10) THEN
13819          COF   = PP1(1)/(SID*PPTOT)
13820          SIF   = PP1(2)/(SID*PPTOT)
13821          ANORF = SQRT(COF*COF+SIF*SIF)
13822          COF   = COF/ANORF
13823          SIF   = SIF/ANORF
13824       ENDIF
13825 * check consistency
13826       DO 5 K=1,4
13827          DEV1(K) = ABS(PP1(K)+PT1(K))
13828     5 CONTINUE
13829       DEV1(4) = ABS(DEV1(4)-XMTOT)
13830       IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
13831      &    (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10))     THEN
13832          WRITE(LOUT,1001) DEV1
13833  1001    FORMAT(1X,'DIFEVT:   inconsitent Lorentz-transformation! ',
13834      &          /,8X,4E12.3)
13835          GOTO 9999
13836       ENDIF
13837
13838 * select x-fractions in high-mass diff. interactions
13839       IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
13840
13841 * select diffractive masses
13842 * - projectile
13843       IF (KP.EQ.1) THEN
13844          XMPF = DT_XMLMD(XMTOT)
13845          CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
13846          IF (IREJ1.GT.0) GOTO 9999
13847       ELSEIF (KP.EQ.2) THEN
13848          XMPF = DT_XMHMD(XMTOT,IBP,1)
13849       ELSE
13850          XMPF = XMP
13851       ENDIF
13852 * - target
13853       IF (KT.EQ.1) THEN
13854          XMTF = DT_XMLMD(XMTOT)
13855          CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
13856          IF (IREJ1.GT.0) GOTO 9999
13857       ELSEIF (KT.EQ.2) THEN
13858          XMTF = DT_XMHMD(XMTOT,IBT,2)
13859       ELSE
13860          XMTF = XMT
13861       ENDIF
13862
13863 * kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
13864       XMPF2 = XMPF**2
13865       XMTF2 = XMTF**2
13866       PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
13867       PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
13868
13869 * select momentum transfer (all t-values used here are <0)
13870 *   minimum absolute value to produce diffractive masses
13871       TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
13872       TT   = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
13873       IF (IREJ1.GT.0) GOTO 9999
13874
13875 * longitudinal momentum of excited/elastically scattered projectile
13876       PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
13877 * total transverse momentum due to t-selection
13878       PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
13879       IF (PPBLT2.LT.ZERO) THEN
13880          WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
13881  1002    FORMAT(1X,'DIFEVT:   inconsistent transverse momentum! ',
13882      &          E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
13883          GOTO 9999
13884       ENDIF
13885       CALL DT_DSFECF(SINPHI,COSPHI)
13886       PPBLT     = SQRT(PPBLT2)
13887       PPBLOB(1) = COSPHI*PPBLT
13888       PPBLOB(2) = SINPHI*PPBLT
13889
13890 * rotate excited/elastically scattered projectile into n-n cms.
13891       CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
13892      &                                                    XX,YY,ZZ)
13893       PPBLOB(1) = XX
13894       PPBLOB(2) = YY
13895       PPBLOB(3) = ZZ
13896
13897 * 4-momentum of excited/elastically scattered target and of exchanged
13898 * Pomeron
13899       DO 6 K=1,4
13900          IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
13901          PPOM1(K) = PP1(K)-PPBLOB(K)
13902     6 CONTINUE
13903       PTBLOB(4) = XMTOT-PPBLOB(4)
13904
13905 * Lorentz-transformation back into system of initial diff. collision
13906       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13907      &            PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
13908      &            PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
13909       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13910      &            PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
13911      &            PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
13912       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13913      &            PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
13914      &            PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
13915
13916 * store 4-momentum of elastically scattered particle (in single diff.
13917 * events)
13918       IF (KP.EQ.0) THEN
13919          DO 7 K=1,4
13920             PSC(K) = PPF(K)
13921     7    CONTINUE
13922       ELSEIF (KT.EQ.0) THEN
13923          DO 8 K=1,4
13924             PSC(K) = PTF(K)
13925     8    CONTINUE
13926       ENDIF
13927
13928 * check consistency of kinematical treatment so far
13929       IF (LEMCCK) THEN
13930          CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
13931          CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
13932          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
13933          IF (IREJ1.NE.0) GOTO 9999
13934       ENDIF
13935       DO 9 K=1,4
13936          DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
13937          DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
13938     9 CONTINUE
13939       IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
13940      &    (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
13941      &    (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
13942      &    (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5))     THEN
13943          WRITE(LOUT,1003) DEV1,DEV2
13944  1003    FORMAT(1X,'DIFEVT:   inconsitent kinematical treatment!  ',
13945      &          2(/,8X,4E12.3))
13946          GOTO 9999
13947       ENDIF
13948
13949 * kinematical treatment for low-mass diffraction
13950       CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
13951       IF (IREJ1.NE.0) GOTO 9999
13952
13953 * dump diffractive chains into DTEVT1
13954       CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13955       IF (IREJ1.NE.0) GOTO 9999
13956
13957       RETURN
13958
13959  9999 CONTINUE
13960       IRDIFF(1) = IRDIFF(1)+1
13961       IREJ      = 1
13962       RETURN
13963       END
13964 *
13965 *===xmhmd==============================================================*
13966 *
13967 CDECK  ID>, DT_XMHMD
13968       DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
13969
13970 ************************************************************************
13971 * Diffractive mass in high mass single/double diffractive events.      *
13972 * This version dated 11.02.95 is written by S. Roesler                 *
13973 ************************************************************************
13974
13975       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13976       SAVE
13977
13978       PARAMETER ( LINP = 5 ,
13979      &            LOUT = 6 ,
13980      &            LDAT = 9 )
13981
13982       PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
13983
13984 * kinematics of diffractive interactions (DTUNUC 1.x)
13985       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13986      &                PPF(4),PTF(4),
13987      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13988      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13989
13990 C     DATA XCOLOW /0.05D0/
13991       DATA XCOLOW /0.15D0/
13992
13993       DT_XMHMD = ZERO
13994       XH = XPH(2)
13995       IF (MODE.EQ.2) XH = XTH(2)
13996
13997 * minimum Pomeron-x for high-mass diffraction
13998 * (adjusted to get a smooth transition between HM and LM component)
13999       R = DT_RNDM(XH)
14000       XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
14001       IF (ECM.LE.300.0D0) THEN
14002          RR     = (1.0D0-EXP(-((ECM/140.0D0)**4)))
14003          XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
14004       ENDIF
14005 * maximum Pomeron-x for high-mass diffraction
14006 * (coherence condition, adjusted to fit to experimental data)
14007       IF (IB.NE.0) THEN
14008 *   baryon-diffraction
14009          XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
14010       ELSE
14011 *   meson-diffraction
14012          XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
14013       ENDIF
14014 * check boundaries
14015       IF (XDIMIN.GE.XDIMAX) THEN
14016          XDIMIN = OHALF*XDIMAX
14017       ENDIF
14018
14019       KLOOP = 0
14020     1 CONTINUE
14021       KLOOP = KLOOP+1
14022       IF (KLOOP.GT.20) RETURN
14023 * sample Pomeron-x from 1/x-distribution (critical Pomeron)
14024       XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
14025 * corr. diffr. mass
14026       DT_XMHMD = ECM*SQRT(XDIFF)
14027       IF (DT_XMHMD.LT.2.5D0) GOTO 1
14028
14029       RETURN
14030       END
14031 *
14032 *===xmlmd==============================================================*
14033 *
14034 CDECK  ID>, DT_XMLMD
14035       DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
14036
14037 ************************************************************************
14038 * Diffractive mass in high mass single/double diffractive events.      *
14039 * This version dated 11.02.95 is written by S. Roesler                 *
14040 ************************************************************************
14041
14042       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14043       SAVE
14044
14045       PARAMETER ( LINP = 5 ,
14046      &            LOUT = 6 ,
14047      &            LDAT = 9 )
14048
14049 * minimum Pomeron-x for low-mass diffraction
14050 C     AMO = 1.5D0
14051       AMO = 2.0D0
14052 * maximum Pomeron-x for low-mass diffraction
14053 * (adjusted to get a smooth transition between HM and LM component)
14054       R   = DT_RNDM(AMO)
14055       SAM = 1.0D0
14056       IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
14057       R   = DT_RNDM(AMO)*SAM
14058       AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
14059       AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
14060
14061 * selection of diffractive mass
14062 * (adjusted to get a smooth transition between HM and LM component)
14063       R   = DT_RNDM(AMU)
14064       IF (ECM.LE.50.0D0) THEN
14065          DT_XMLMD = AMO*(AMU/AMO)**R
14066       ELSE
14067          A = 0.7D0
14068          IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
14069          DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
14070       ENDIF
14071
14072       RETURN
14073       END
14074 *
14075 *===tdiff==============================================================*
14076 *
14077 CDECK  ID>, DT_TDIFF
14078       DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
14079
14080 ************************************************************************
14081 * t-selection for single/double diffractive interactions.              *
14082 *          ECM      cm. energy                                         *
14083 *          TMIN     minimum momentum transfer to produce diff. masses  *
14084 *          XM1/XM2  diffractively produced masses                      *
14085 *                   (for single diffraction XM2 is obsolete)           *
14086 *          K1/K2= 0 not excited                                        *
14087 *               = 1 low-mass excitation                                *
14088 *               = 2 high-mass excitation                               *
14089 * This version dated 11.02.95 is written by S. Roesler                 *
14090 ************************************************************************
14091
14092       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14093       SAVE
14094
14095       PARAMETER ( LINP = 5 ,
14096      &            LOUT = 6 ,
14097      &            LDAT = 9 )
14098
14099       PARAMETER (ZERO=0.0D0)
14100
14101       PARAMETER ( BTP0   = 3.7D0,
14102      &            ALPHAP = 0.24D0 )
14103
14104       IREJ   = 0
14105       NCLOOP = 0
14106       DT_TDIFF  = ZERO
14107
14108       IF (K1.GT.0) THEN
14109          XM1 = XM1I
14110          XM2 = XM2I
14111       ELSE
14112          XM1 = XM2I
14113       ENDIF
14114       XDI = (XM1/ECM)**2
14115       IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14116 * slope for single diffraction
14117          SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14118       ELSE
14119 * slope for double diffraction
14120          SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14121       ENDIF
14122
14123     1 CONTINUE
14124       NCLOOP = NCLOOP+1
14125       IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14126       Y = DT_RNDM(XDI)
14127       T = -LOG(1.0D0-Y)/SLOPE
14128       IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14129       DT_TDIFF = -ABS(T)
14130
14131       RETURN
14132
14133  9999 CONTINUE
14134       WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14135  1000 FORMAT(1X,'DT_TDIFF:   t-selection rejected!',/,
14136      &       1X,'ECM  = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14137      &       E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14138       IREJ = 1
14139       RETURN
14140       END
14141 *
14142 *===xvalhm=============================================================*
14143 *
14144 CDECK  ID>, DT_XVALHM
14145       SUBROUTINE DT_XVALHM(KP,KT)
14146
14147 ************************************************************************
14148 * Sampling of parton x-values in high-mass diffractive interactions.   *
14149 * This version dated 12.02.95 is written by S. Roesler                 *
14150 ************************************************************************
14151
14152       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14153       SAVE
14154
14155       PARAMETER ( LINP = 5 ,
14156      &            LOUT = 6 ,
14157      &            LDAT = 9 )
14158
14159       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14160
14161 * kinematics of diffractive interactions (DTUNUC 1.x)
14162       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14163      &                PPF(4),PTF(4),
14164      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14165      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14166 * various options for treatment of partons (DTUNUC 1.x)
14167 * (chain recombination, Cronin,..)
14168       LOGICAL LCO2CR,LINTPT
14169       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14170      &                LCO2CR,LINTPT
14171
14172       DATA UNON,XVQTHR /2.0D0,0.8D0/
14173
14174       IF (KP.EQ.2) THEN
14175 * x-fractions of projectile valence partons
14176     1    CONTINUE
14177          XPH(1) = DT_DBETAR(OHALF,UNON)
14178          IF (XPH(1).GE.XVQTHR) GOTO 1
14179          XPH(2) = ONE-XPH(1)
14180 * x-fractions of Pomeron q-aq-pair
14181          XPOLO = TINY2
14182          XPOHI = ONE-TINY2
14183          XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14184          XPPO(2) = ONE-XPPO(1)
14185 * flavors of Pomeron q-aq-pair
14186          IFLAV    = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14187          IFPPO(1) = IFLAV
14188          IFPPO(2) = -IFLAV
14189          IF (DT_RNDM(UNON).GT.OHALF) THEN
14190             IFPPO(1) = -IFLAV
14191             IFPPO(2) = IFLAV
14192          ENDIF
14193       ENDIF
14194
14195       IF (KT.EQ.2) THEN
14196 * x-fractions of projectile target partons
14197     2    CONTINUE
14198          XTH(1) = DT_DBETAR(OHALF,UNON)
14199          IF (XTH(1).GE.XVQTHR) GOTO 2
14200          XTH(2) = ONE-XTH(1)
14201 * x-fractions of Pomeron q-aq-pair
14202          XPOLO = TINY2
14203          XPOHI = ONE-TINY2
14204          XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14205          XTPO(2) = ONE-XTPO(1)
14206 * flavors of Pomeron q-aq-pair
14207          IFLAV    = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14208          IFTPO(1) = IFLAV
14209          IFTPO(2) = -IFLAV
14210          IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14211             IFTPO(1) = -IFLAV
14212             IFTPO(2) = IFLAV
14213          ENDIF
14214       ENDIF
14215
14216       RETURN
14217       END
14218 *
14219 *===lm2res=============================================================*
14220 *
14221 CDECK  ID>, DT_LM2RES
14222       SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14223
14224 ************************************************************************
14225 * Check low-mass diffractive excitation for resonance mass.            *
14226 *   (input)   IF1/2    PDG-indizes of valence partons                  *
14227 *   (in/out)  XM       diffractive mass requested/corrected            *
14228 *   (output)  IDR/IDXR id./BAMJET-index of resonance                   *
14229 * This version dated 12.02.95 is written by S. Roesler                 *
14230 ************************************************************************
14231
14232       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14233       SAVE
14234
14235       PARAMETER ( LINP = 5 ,
14236      &            LOUT = 6 ,
14237      &            LDAT = 9 )
14238
14239       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14240
14241 * kinematics of diffractive interactions (DTUNUC 1.x)
14242       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14243      &                PPF(4),PTF(4),
14244      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14245      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14246
14247       IREJ = 0
14248       IF1B = 0
14249       IF2B = 0
14250       XMI  = XM
14251
14252 * BAMJET indices of partons
14253       IF1A = IDT_IPDG2B(IF1,1,2)
14254       IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14255       IF2A = IDT_IPDG2B(IF2,1,2)
14256       IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14257
14258 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14259       IDCH = 2
14260       IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14261
14262 * check for resonance mass
14263       CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14264       IF (IREJ1.NE.0) GOTO 9999
14265
14266       XM = XMN
14267       RETURN
14268
14269  9999 CONTINUE
14270       IREJ = 1
14271       RETURN
14272       END
14273 *
14274 *===lmkine=============================================================*
14275 *
14276 CDECK  ID>, DT_LMKINE
14277       SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14278
14279 ************************************************************************
14280 * Kinematical treatment of low-mass excitations.                       *
14281 * This version dated 12.02.95 is written by S. Roesler                 *
14282 ************************************************************************
14283
14284       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14285       SAVE
14286
14287       PARAMETER ( LINP = 5 ,
14288      &            LOUT = 6 ,
14289      &            LDAT = 9 )
14290
14291       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14292
14293 * flags for input different options
14294       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14295       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14296      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14297 * kinematics of diffractive interactions (DTUNUC 1.x)
14298       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14299      &                PPF(4),PTF(4),
14300      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14301      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14302
14303       DIMENSION P1(4),P2(4)
14304
14305       IREJ = 0
14306
14307       IF (KP.EQ.1) THEN
14308          PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14309          POE  = PPF(4)/PABS
14310          FAC1 = OHALF*(POE+ONE)
14311          FAC2 = -OHALF*(POE-ONE)
14312          DO 1 K=1,3
14313             PPLM1(K) = FAC1*PPF(K)
14314             PPLM2(K) = FAC2*PPF(K)
14315     1    CONTINUE
14316          PPLM1(4) = FAC1*PABS
14317          PPLM2(4) = -FAC2*PABS
14318          IF (IMSHL.EQ.1) THEN
14319
14320             XM1 = PYMASS(IFP1)
14321             XM2 = PYMASS(IFP2)
14322
14323             CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14324             IF (IREJ1.NE.0) GOTO 9999
14325             DO 2 K=1,4
14326                PPLM1(K) = P1(K)
14327                PPLM2(K) = P2(K)
14328     2       CONTINUE
14329          ENDIF
14330       ENDIF
14331
14332       IF (KT.EQ.1) THEN
14333          PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14334          POE  = PTF(4)/PABS
14335          FAC1 = OHALF*(POE+ONE)
14336          FAC2 = -OHALF*(POE-ONE)
14337          DO 3 K=1,3
14338             PTLM2(K) = FAC1*PTF(K)
14339             PTLM1(K) = FAC2*PTF(K)
14340     3    CONTINUE
14341          PTLM2(4) = FAC1*PABS
14342          PTLM1(4) = -FAC2*PABS
14343          IF (IMSHL.EQ.1) THEN
14344
14345             XM1 = PYMASS(IFT1)
14346             XM2 = PYMASS(IFT2)
14347
14348             CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14349             IF (IREJ1.NE.0) GOTO 9999
14350             DO 4 K=1,4
14351                PTLM1(K) = P1(K)
14352                PTLM2(K) = P2(K)
14353     4       CONTINUE
14354          ENDIF
14355       ENDIF
14356
14357       RETURN
14358
14359  9999 CONTINUE
14360       WRITE(LOUT,'(A)') 'LMKINE:   kinematical treatment rejected'
14361       IREJ = 1
14362       RETURN
14363       END
14364 *
14365 *===difini=============================================================*
14366 *
14367 CDECK  ID>, DT_DIFINI
14368       SUBROUTINE DT_DIFINI
14369
14370 ************************************************************************
14371 * Initialization of common /DTDIKI/                                    *
14372 * This version dated 12.02.95 is written by S. Roesler                 *
14373 ************************************************************************
14374
14375       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14376       SAVE
14377
14378       PARAMETER ( LINP = 5 ,
14379      &            LOUT = 6 ,
14380      &            LDAT = 9 )
14381
14382       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14383
14384 * kinematics of diffractive interactions (DTUNUC 1.x)
14385       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14386      &                PPF(4),PTF(4),
14387      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14388      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14389
14390       DO 1 K=1,4
14391          PPOM(K)  = ZERO
14392          PSC(K)   = ZERO
14393          PPF(K)   = ZERO
14394          PTF(K)   = ZERO
14395          PPLM1(K) = ZERO
14396          PPLM2(K) = ZERO
14397          PTLM1(K) = ZERO
14398          PTLM2(K) = ZERO
14399     1 CONTINUE
14400       DO 2 K=1,2
14401          XPH(K)   = ZERO
14402          XPPO(K)  = ZERO
14403          XTH(K)   = ZERO
14404          XTPO(K)  = ZERO
14405          IFPPO(K) = 0
14406          IFTPO(K) = 0
14407     2 CONTINUE
14408       IDPR  = 0
14409       IDXPR = 0
14410       IDTR  = 0
14411       IDXTR = 0
14412
14413       RETURN
14414       END
14415 *
14416 *===difput=============================================================*
14417 *
14418 CDECK  ID>, DT_DIFPUT
14419       SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14420      &                                                          IREJ)
14421
14422 ************************************************************************
14423 * Dump diffractive chains into DTEVT1                                  *
14424 * This version dated 12.02.95 is written by S. Roesler                 *
14425 ************************************************************************
14426
14427       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14428       SAVE
14429
14430       PARAMETER ( LINP = 5 ,
14431      &            LOUT = 6 ,
14432      &            LDAT = 9 )
14433
14434       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14435
14436       LOGICAL LCHK
14437
14438 * kinematics of diffractive interactions (DTUNUC 1.x)
14439       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14440      &                PPF(4),PTF(4),
14441      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14442      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14443 * event history
14444
14445       PARAMETER (NMXHKK=200000)
14446
14447       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14448      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14449      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14450 * extended event history
14451       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14452      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14453      &                IHIST(2,NMXHKK)
14454 * rejection counter
14455       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14456      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14457      &                IREXCI(3),IRDIFF(2),IRINC
14458
14459       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
14460      &          P1(4),P2(4),P3(4),P4(4)
14461
14462       IREJ = 0
14463
14464       IF (KP.EQ.1) THEN
14465          DO 1 K=1,4
14466             PCH(K) = PPLM1(K)+PPLM2(K)
14467     1    CONTINUE
14468          ID1 = IFP1
14469          ID2 = IFP2
14470          IF (DT_RNDM(PT).GT.OHALF) THEN
14471             ID1 = IFP2
14472             ID2 = IFP1
14473          ENDIF
14474          CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
14475      &                                        PPLM1(4),0,0,0)
14476          CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
14477      &                                        PPLM2(4),0,0,0)
14478          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14479      &                                              IDPR,IDXPR,8)
14480       ELSEIF (KP.EQ.2) THEN
14481          DO 2 K=1,4
14482             PP1(K) = XPH(1)*PP(K)
14483             PP2(K) = XPH(2)*PP(K)
14484             PT1(K) = -XPPO(1)*PPOM(K)
14485             PT2(K) = -XPPO(2)*PPOM(K)
14486     2    CONTINUE
14487          CALL  DT_CHKCSY(IFP1,IFPPO(1),LCHK)
14488          XM1 = ZERO
14489          XM2 = ZERO
14490          IF (LCHK) THEN
14491             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14492             IF (IREJ1.NE.0) GOTO 9999
14493             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14494             IF (IREJ1.NE.0) GOTO 9999
14495             DO 3 K=1,4
14496                PP1(K) = P1(K)
14497                PT1(K) = P2(K)
14498                PP2(K) = P3(K)
14499                PT2(K) = P4(K)
14500     3       CONTINUE
14501             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14502      &                                                       0,0,8)
14503             CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14504      &                                             PT1(4),0,0,8)
14505             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14506      &                                                       0,0,8)
14507             CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14508      &                                             PT2(4),0,0,8)
14509          ELSE
14510             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14511             IF (IREJ1.NE.0) GOTO 9999
14512             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14513             IF (IREJ1.NE.0) GOTO 9999
14514             DO 4 K=1,4
14515                PP1(K) = P1(K)
14516                PT2(K) = P2(K)
14517                PP2(K) = P3(K)
14518                PT1(K) = P4(K)
14519     4       CONTINUE
14520             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14521      &                                                       0,0,8)
14522             CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14523      &                                                PT2(4),0,0,8)
14524             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14525      &                                                       0,0,8)
14526             CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14527      &                                                PT1(4),0,0,8)
14528          ENDIF
14529          NCSY = NCSY+1
14530       ELSE
14531          CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
14532      &                                                        0,0,0)
14533       ENDIF
14534
14535       IF (KT.EQ.1) THEN
14536          DO 5 K=1,4
14537             PCH(K) = PTLM1(K)+PTLM2(K)
14538     5    CONTINUE
14539          ID1 = IFT1
14540          ID2 = IFT2
14541          IF (DT_RNDM(PT).GT.OHALF) THEN
14542             ID1 = IFT2
14543             ID2 = IFT1
14544          ENDIF
14545          CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
14546      &                                              PTLM1(4),0,0,0)
14547          CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
14548      &                                              PTLM2(4),0,0,0)
14549          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14550      &                                              IDTR,IDXTR,8)
14551       ELSEIF (KT.EQ.2) THEN
14552          DO 6 K=1,4
14553             PP1(K) = XTPO(1)*PPOM(K)
14554             PP2(K) = XTPO(2)*PPOM(K)
14555             PT1(K) = XTH(2)*PT(K)
14556             PT2(K) = XTH(1)*PT(K)
14557     6    CONTINUE
14558          CALL  DT_CHKCSY(IFTPO(1),IFT1,LCHK)
14559          XM1 = ZERO
14560          XM2 = ZERO
14561          IF (LCHK) THEN
14562             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14563             IF (IREJ1.NE.0) GOTO 9999
14564             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14565             IF (IREJ1.NE.0) GOTO 9999
14566             DO 7 K=1,4
14567                PP1(K) = P1(K)
14568                PT1(K) = P2(K)
14569                PP2(K) = P3(K)
14570                PT2(K) = P4(K)
14571     7       CONTINUE
14572             CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14573      &                                                PP1(4),0,0,8)
14574             CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14575      &                                                       0,0,8)
14576             CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14577      &                                                PP2(4),0,0,8)
14578             CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14579      &                                                       0,0,8)
14580          ELSE
14581             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14582             IF (IREJ1.NE.0) GOTO 9999
14583             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14584             IF (IREJ1.NE.0) GOTO 9999
14585             DO 8 K=1,4
14586                PP1(K) = P1(K)
14587                PT2(K) = P2(K)
14588                PP2(K) = P3(K)
14589                PT1(K) = P4(K)
14590     8       CONTINUE
14591             CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14592      &                                                PP1(4),0,0,8)
14593             CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14594      &                                                       0,0,8)
14595             CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14596      &                                                PP2(4),0,0,8)
14597             CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14598      &                                                       0,0,8)
14599          ENDIF
14600          NCSY = NCSY+1
14601       ELSE
14602          CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
14603      &                                                        0,0,0)
14604       ENDIF
14605
14606       RETURN
14607
14608  9999 CONTINUE
14609       IRDIFF(2) = IRDIFF(2)+1
14610       IREJ      = 1
14611       RETURN
14612       END
14613 *
14614 *===evtfrg=============================================================*
14615 *
14616 CDECK  ID>, DT_EVTFRG
14617       SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
14618
14619 ************************************************************************
14620 * Hadronization of chains in DTEVT1.                                   *
14621 *                                                                      *
14622 * Input:                                                               *
14623 *   KMODE = 1   hadronization of PHOJET-chains (id=77xxx)              *
14624 *         = 2   hadronization of DTUNUC-chains (id=88xxx)              *
14625 *   NFRG  if KMODE = 1 : upper index of PHOJET-scatterings to be       *
14626 *                        hadronized with one PYEXEC call               *
14627 *         if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
14628 *                        with one PYEXEC call                          *
14629 * Output:                                                              *
14630 *   NPYMEM      number of entries in JETSET-common after hadronization *
14631 *   IREJ        rejection flag                                         *
14632 *                                                                      *
14633 * This version dated 17.09.00 is written by S. Roesler                 *
14634 ************************************************************************
14635
14636       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14637       SAVE
14638
14639       PARAMETER ( LINP = 5 ,
14640      &            LOUT = 6 ,
14641      &            LDAT = 9 )
14642
14643       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
14644       PARAMETER (ONE=1.0D0,ZERO=0.0D0)
14645
14646       LOGICAL LACCEP
14647
14648       PARAMETER (MXJOIN=200)
14649
14650 * event history
14651
14652       PARAMETER (NMXHKK=200000)
14653
14654       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14655      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14656      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14657 * extended event history
14658       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14659      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14660      &                IHIST(2,NMXHKK)
14661 * flags for input different options
14662       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14663       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14664      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14665 * statistics
14666       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
14667      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
14668      &                ICEVTG(8,0:30)
14669 * flags for diffractive interactions (DTUNUC 1.x)
14670       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14671 * nucleon-nucleon event-generator
14672       CHARACTER*8 CMODEL
14673       LOGICAL LPHOIN
14674       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
14675 * phojet
14676 C  model switches and parameters
14677       CHARACTER*8 MDLNA
14678       INTEGER ISWMDL,IPAMDL
14679       DOUBLE PRECISION PARMDL
14680       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14681 * jetset
14682
14683       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14684
14685       PARAMETER (MAXLND=4000)
14686       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
14687
14688       INTEGER PYK
14689
14690       DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
14691
14692       MODE = KMODE
14693       ISTSTG = 7
14694       IF (MODE.NE.1) ISTSTG = 8
14695       IREJ = 0
14696
14697       IP     = 0
14698       ISH    = 0
14699       INIEMC = 1
14700       NEND   = NHKK
14701       NACCEP = 0
14702       IFRG   = 0
14703       IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
14704       DO 10 I=NPOINT(3),NEND
14705 * sr 14.02.00: seems to be not necessary anymore, commented
14706 C        LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
14707 C    &            ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
14708          LACCEP = .TRUE.
14709 * pick up chains from dtevt1
14710          IDCHK = IDHKK(I)/10000
14711          IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
14712             IF (IDCHK.EQ.7) THEN
14713                IPJE = IDHKK(I)-IDCHK*10000
14714                IF (IPJE.NE.IFRG) THEN
14715                   IFRG = IPJE
14716                   IF (IFRG.GT.NFRG) GOTO 16
14717                ENDIF
14718             ELSE
14719                IPJE = 1
14720                IFRG = IFRG+1
14721                IF (IFRG.GT.NFRG) THEN
14722                   NFRG = -1
14723                   GOTO 16
14724                ENDIF
14725             ENDIF
14726 *   statistics counter
14727 c           IF (IDCH(I).LE.8)
14728 c    &         ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
14729 c           IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
14730 * special treatment for small chains already corrected to hadrons
14731             IF (IDRES(I).NE.0) THEN
14732                IF (IDRES(I).EQ.11) THEN
14733                   ID = IDXRES(I)
14734                ELSE
14735                   ID = IDT_IPDGHA(IDXRES(I))
14736                ENDIF
14737                IF (LEMCCK) THEN
14738                   CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
14739      &                              PHKK(4,I),INIEMC,IDUM,IDUM)
14740                   INIEMC = 2
14741                ENDIF
14742                IP = IP+1
14743                IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
14744                P(IP,1) = PHKK(1,I)
14745                P(IP,2) = PHKK(2,I)
14746                P(IP,3) = PHKK(3,I)
14747                P(IP,4) = PHKK(4,I)
14748                P(IP,5) = PHKK(5,I)
14749                K(IP,1) = 1
14750                K(IP,2) = ID
14751                K(IP,3) = 0
14752                K(IP,4) = 0
14753                K(IP,5) = 0
14754                IHIST(2,I) = 10000*IPJE+IP
14755                IF (IHIST(1,I).LE.-100) THEN
14756                   ISH = ISH+1
14757                   IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14758                   ISJOIN(ISH) = I
14759                ENDIF
14760                N = IP
14761                IHISMO(IP) = I
14762             ELSE
14763                IJ  = 0
14764                DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
14765                   IF (LEMCCK) THEN
14766                      CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
14767      &                                   PHKK(4,KK),INIEMC,IDUM,IDUM)
14768                      CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
14769                      INIEMC = 2
14770                   ENDIF
14771                   ID = IDHKK(KK)
14772                   IF (ID.EQ.0) ID = 21
14773 c                  PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
14774 c                  AM0  = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
14775
14776 c                  AMRQ   = PYMASS(ID)
14777
14778 c                  AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
14779 c                  IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
14780 c     &                (ABS(IDIFF).EQ.0)) THEN
14781 cC                    WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
14782 c                     DELTA      = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
14783 c                     PHKK(4,KK) = PHKK(4,KK)+DELTA
14784 c                     PTOT1      = PTOT-DELTA
14785 c                     PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
14786 c                     PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
14787 c                     PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
14788 c                     PHKK(5,KK) = AMRQ
14789 c                  ENDIF
14790                   IP = IP+1
14791                   IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
14792                   P(IP,1) = PHKK(1,KK)
14793                   P(IP,2) = PHKK(2,KK)
14794                   P(IP,3) = PHKK(3,KK)
14795                   P(IP,4) = PHKK(4,KK)
14796                   P(IP,5) = PHKK(5,KK)
14797                   K(IP,1) = 1
14798                   K(IP,2) = ID
14799                   K(IP,3) = 0
14800                   K(IP,4) = 0
14801                   K(IP,5) = 0
14802                   IHIST(2,KK) = 10000*IPJE+IP
14803                   IF (IHIST(1,KK).LE.-100) THEN
14804                      ISH = ISH+1
14805                      IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14806                      ISJOIN(ISH) = KK
14807                   ENDIF
14808                   IJ = IJ+1
14809                   IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
14810                   IJOIN(IJ)  = IP
14811                   IHISMO(IP) = I
14812    11          CONTINUE
14813                N = IP
14814 * join the two-parton system
14815
14816                CALL PYJOIN(IJ,IJOIN)
14817
14818             ENDIF
14819             IDHKK(I) = 99999
14820          ENDIF
14821    10 CONTINUE
14822    16 CONTINUE
14823       N = IP
14824
14825       IF (IP.GT.0) THEN
14826
14827 * final state parton shower
14828          DO 136 NPJE=1,IPJE
14829             IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
14830                IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
14831                   DO 130 K1=1,ISH
14832                      IF (ISJOIN(K1).EQ.0) GOTO 130
14833                      I = ISJOIN(K1)
14834                      IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
14835      &                                                       GOTO 130
14836                      IH1 = IHIST(2,I)/10000
14837                      IF (IH1.NE.NPJE) GOTO 130
14838                      IH1 = IHIST(2,I)-IH1*10000
14839                      DO 135 K2=K1+1,ISH
14840                         IF (ISJOIN(K2).EQ.0) GOTO 135
14841                         II = ISJOIN(K2)
14842                         IH2 = IHIST(2,II)/10000
14843                         IF (IH2.NE.NPJE) GOTO 135
14844                         IH2 = IHIST(2,II)-IH2*10000
14845                         IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
14846                            PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
14847                            PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
14848
14849                            RQLUN = MIN(PT1,PT2)
14850                            CALL PYSHOW(IH1,IH2,RQLUN)
14851
14852                            ISJOIN(K1) = 0
14853                            ISJOIN(K2) = 0
14854                            GOTO 130
14855                         ENDIF
14856  135                 CONTINUE
14857  130              CONTINUE
14858                ENDIF
14859             ENDIF
14860  136     CONTINUE
14861
14862          CALL DT_INITJS(MODE)
14863 * hadronization
14864
14865          CALL PYEXEC
14866
14867          IF (MSTU(24).NE.0) THEN
14868             WRITE(LOUT,*) ' JETSET-reject at event',
14869      &                    NEVHKK,MSTU(24),KMODE
14870 C           CALL DT_EVTOUT(4)
14871
14872 C           CALL PYLIST(2)
14873
14874             GOTO 9999
14875          ENDIF
14876
14877 *   number of entries in LUJETS
14878
14879          NLINES = PYK(0,1)
14880
14881          NPYMEM = NLINES
14882
14883          DO 12 I=1,NLINES
14884             IFLG(I) = 0
14885    12    CONTINUE
14886
14887          DO 13 II=1,NLINES
14888
14889             IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
14890
14891 *  pick up mother resonance if possible and put it together with
14892 *  their decay-products into the common
14893                IDXMOR = K(II,3)
14894                IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
14895                   KFMOR = K(IDXMOR,2)
14896                   ISMOR = K(IDXMOR,1)
14897                ELSE
14898                   KFMOR = 91
14899                   ISMOR = 1
14900                ENDIF
14901                IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
14902      &             (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
14903                   ID = K(IDXMOR,2)
14904
14905                   MO = IHISMO(PYK(IDXMOR,15))
14906                   PX = PYP(IDXMOR,1)
14907                   PY = PYP(IDXMOR,2)
14908                   PZ = PYP(IDXMOR,3)
14909                   PE = PYP(IDXMOR,4)
14910
14911                   CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14912                   IFLG(IDXMOR) = 1
14913                   MO = NHKK
14914                   DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
14915
14916                      IF (PYK(JDAUG,7).EQ.1) THEN
14917                         ID = PYK(JDAUG,8)
14918                         PX = PYP(JDAUG,1)
14919                         PY = PYP(JDAUG,2)
14920                         PZ = PYP(JDAUG,3)
14921                         PE = PYP(JDAUG,4)
14922
14923                         CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14924                         IF (LEMCCK) THEN
14925
14926                            PX = -PYP(JDAUG,1)
14927                            PY = -PYP(JDAUG,2)
14928                            PZ = -PYP(JDAUG,3)
14929                            PE = -PYP(JDAUG,4)
14930
14931                            CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14932                         ENDIF
14933                         IFLG(JDAUG) = 1
14934                      ENDIF
14935    15             CONTINUE
14936                ELSE
14937 *  there was no mother resonance
14938
14939                   MO = IHISMO(PYK(II,15))
14940                   ID = PYK(II,8)
14941                   PX = PYP(II,1)
14942                   PY = PYP(II,2)
14943                   PZ = PYP(II,3)
14944                   PE = PYP(II,4)
14945
14946                   CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14947                   IF (LEMCCK) THEN
14948
14949                      PX = -PYP(II,1)
14950                      PY = -PYP(II,2)
14951                      PZ = -PYP(II,3)
14952                      PE = -PYP(II,4)
14953
14954                      CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14955                   ENDIF
14956                ENDIF
14957             ENDIF
14958    13    CONTINUE
14959          IF (LEMCCK) THEN
14960             CHKLEV = TINY1
14961             CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
14962 C           IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
14963          ENDIF
14964
14965 * global energy-momentum & flavor conservation check
14966 **sr 16.5. this check is skipped in case of phojet-treatment
14967          IF (MCGENE.EQ.1)
14968      &      CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
14969
14970 * update statistics-counter for diffraction
14971 c        IF (IFLAGD.NE.0) THEN
14972 c           ICDIFF(1) = ICDIFF(1)+1
14973 c           IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
14974 c           IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
14975 c           IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
14976 c           IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
14977 c        ENDIF
14978
14979       ENDIF
14980
14981       RETURN
14982
14983  9999 CONTINUE
14984       IREJ = 1
14985       RETURN
14986       END
14987 *
14988 *===decay==============================================================*
14989 *
14990 CDECK  ID>, DT_DECAYS
14991       SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
14992
14993 ************************************************************************
14994 * Resonance-decay.                                                     *
14995 * This subroutine replaces DDECAY/DECHKK.                              *
14996 *             PIN(4)      4-momentum of resonance          (input)     *
14997 *             IDXIN       BAMJET-index of resonance        (input)     *
14998 *             POUT(20,4)  4-momenta of decay-products      (output)    *
14999 *             IDXOUT(20)  BAMJET-indices of decay-products (output)    *
15000 *             NSEC        number of secondaries            (output)    *
15001 * Adopted from the original version DECHKK.                            *
15002 * This version dated 09.01.95 is written by S. Roesler                 *
15003 ************************************************************************
15004
15005       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15006       SAVE
15007
15008       PARAMETER ( LINP = 5 ,
15009      &            LOUT = 6 ,
15010      &            LDAT = 9 )
15011
15012       PARAMETER (TINY17=1.0D-17)
15013
15014 * HADRIN: decay channel information
15015       PARAMETER (IDMAX9=602)
15016       CHARACTER*8 ZKNAME
15017       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15018 * particle properties (BAMJET index convention)
15019       CHARACTER*8  ANAME
15020       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15021      &                IICH(210),IIBAR(210),K1(210),K2(210)
15022 * flags for input different options
15023       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15024       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15025      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15026
15027       DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
15028      &          EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
15029      &          CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
15030
15031 * ISTAB = 1 strong and weak decays
15032 *       = 2 strong decays only
15033 *       = 3 strong decays, weak decays for charmed particles and tau
15034 *           leptons only
15035       DATA ISTAB /2/
15036
15037       IREJ = 0
15038       NSEC = 0
15039 * put initial resonance to stack
15040       NSTK = 1
15041       IDXSTK(NSTK) = IDXIN
15042       DO 5 I=1,4
15043          PI(NSTK,I) = PIN(I)
15044     5 CONTINUE
15045
15046 * store initial configuration for energy-momentum cons. check
15047       IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
15048      &                                   PI(NSTK,4),1,IDUM,IDUM)
15049
15050   100 CONTINUE
15051 * get particle from stack
15052       IDXI = IDXSTK(NSTK)
15053 * skip stable particles
15054       IF (ISTAB.EQ.1) THEN
15055          IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
15056          IF ((IDXI.GE.  1).AND.(IDXI.LE.  7)) GOTO 10
15057       ELSEIF (ISTAB.EQ.2) THEN
15058          IF ((IDXI.GE.  1).AND.(IDXI.LE. 30)) GOTO 10
15059          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15060          IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
15061          IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
15062          IF ( IDXI.EQ.109)                    GOTO 10
15063          IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
15064       ELSEIF (ISTAB.EQ.3) THEN
15065          IF ((IDXI.GE.  1).AND.(IDXI.LE. 23)) GOTO 10
15066          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15067          IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
15068          IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
15069       ENDIF
15070
15071 * calculate direction cosines and Lorentz-parameter of decaying part.
15072       PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
15073       PTOT = MAX(PTOT,TINY17)
15074       DO 1 I=1,3
15075          DCOS(I) = PI(NSTK,I)/PTOT
15076     1 CONTINUE
15077       GAM  = PI(NSTK,4)/AAM(IDXI)
15078       BGAM = PTOT/AAM(IDXI)
15079
15080 * get decay-channel
15081       KCHAN = K1(IDXI)-1
15082     2 CONTINUE
15083       KCHAN = KCHAN+1
15084       IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
15085
15086 * identities of secondaries
15087       IDX(1) = NZK(KCHAN,1)
15088       IDX(2) = NZK(KCHAN,2)
15089       IF (IDX(2).LT.1) GOTO 9999
15090       IDX(3) = NZK(KCHAN,3)
15091
15092 * handle decay in rest system of decaying particle
15093       IF (IDX(3).EQ.0) THEN
15094 *   two-particle decay
15095          NDEC = 2
15096          CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
15097      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15098      &               AAM(IDX(1)),AAM(IDX(2)))
15099       ELSE
15100 *   three-particle decay
15101          NDEC = 3
15102          CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
15103      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15104      &               CODF(3),COFF(3),SIFF(3),
15105      &               AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
15106       ENDIF
15107       NSTK = NSTK-1
15108
15109 * transform decay products back
15110       DO 3 I=1,NDEC
15111          NSTK = NSTK+1
15112          CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
15113      &               CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
15114      &               PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
15115 * add particle to stack
15116          IDXSTK(NSTK) = IDX(I)
15117          DO 4 J=1,3
15118             PI(NSTK,J) = DCOSF(J)*PFF(I)
15119     4    CONTINUE
15120     3 CONTINUE
15121       GOTO 100
15122
15123    10 CONTINUE
15124 * stable particle, put to output-arrays
15125       NSEC = NSEC+1
15126       DO 6 I=1,4
15127          POUT(NSEC,I) = PI(NSTK,I)
15128     6 CONTINUE
15129       IDXOUT(NSEC) = IDXSTK(NSTK)
15130 * store secondaries for energy-momentum conservation check
15131       IF (LEMCCK)
15132      &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15133      &            -POUT(NSEC,4),2,IDUM,IDUM)
15134       NSTK = NSTK-1
15135       IF (NSTK.GT.0) GOTO 100
15136
15137 * check energy-momentum conservation
15138       IF (LEMCCK) THEN
15139          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15140          IF (IREJ1.NE.0) GOTO 9999
15141       ENDIF
15142
15143       RETURN
15144
15145  9999 CONTINUE
15146       IREJ = 1
15147       RETURN
15148       END
15149 *
15150 *===decay1=============================================================*
15151 *
15152 CDECK  ID>, DT_DECAY1
15153       SUBROUTINE DT_DECAY1
15154
15155 ************************************************************************
15156 * Decay of resonances stored in DTEVT1.                                *
15157 * This version dated 20.01.95 is written by S. Roesler                 *
15158 ************************************************************************
15159
15160       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15161       SAVE
15162
15163       PARAMETER ( LINP = 5 ,
15164      &            LOUT = 6 ,
15165      &            LDAT = 9 )
15166
15167 * event history
15168
15169       PARAMETER (NMXHKK=200000)
15170
15171       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15172      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15173      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15174 * extended event history
15175       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15176      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15177      &                IHIST(2,NMXHKK)
15178
15179       DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15180
15181       NEND = NHKK
15182 C     DO 1 I=NPOINT(5),NEND
15183       DO 1 I=NPOINT(4),NEND
15184          IF (ABS(ISTHKK(I)).EQ.1) THEN
15185             DO 2 K=1,4
15186                PIN(K) = PHKK(K,I)
15187     2       CONTINUE
15188             IDXIN = IDBAM(I)
15189             CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15190             IF (NSEC.GT.1) THEN
15191                DO 3 N=1,NSEC
15192                   IDHAD = IDT_IPDGHA(IDXOUT(N))
15193                   CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15194      &                               POUT(N,3),POUT(N,4),0,0,0)
15195     3          CONTINUE
15196             ENDIF
15197          ENDIF
15198     1 CONTINUE
15199
15200       RETURN
15201       END
15202 *
15203 *===decpi0=============================================================*
15204 *
15205 CDECK  ID>, DT_DECPI0
15206       SUBROUTINE DT_DECPI0
15207
15208 ************************************************************************
15209 * Decay of pi0 handled with JETSET.                                    *
15210 * This version dated 18.02.96 is written by S. Roesler                 *
15211 ************************************************************************
15212
15213       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15214       SAVE
15215
15216       PARAMETER ( LINP = 5 ,
15217      &            LOUT = 6 ,
15218      &            LDAT = 9 )
15219
15220       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15221
15222 * event history
15223
15224       PARAMETER (NMXHKK=200000)
15225
15226       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15227      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15228      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15229 * extended event history
15230       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15231      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15232      &                IHIST(2,NMXHKK)
15233
15234       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15235
15236       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15237
15238       PARAMETER (MAXLND=4000)
15239       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15240
15241 * flags for input different options
15242       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15243       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15244      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15245
15246       INTEGER PYCOMP,PYK
15247
15248       DIMENSION IHISMO(NMXHKK),P1(4)
15249
15250       TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15251
15252       CALL DT_INITJS(2)
15253 * allow pi0 decay
15254
15255       KC = PYCOMP(111)
15256
15257       MDCY(KC,1) = 1
15258
15259       NN  = 0
15260       INI = 0
15261       DO 1 I=1,NHKK
15262          IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15263             IF (INI.EQ.0) THEN
15264                INI = 1
15265             ELSE
15266                INI = 2
15267             ENDIF
15268             IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15269      &                                    PHKK(4,I),INI,IDUM,IDUM)
15270             PT    = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15271             PTOT  = SQRT(PT**2+PHKK(3,I)**2)
15272             COSTH = PHKK(3,I)/(PTOT+TINY10)
15273             IF (COSTH.GT.ONE) THEN
15274                THETA = ZERO
15275             ELSEIF (COSTH.LT.-ONE) THEN
15276                THETA = TWOPI/2.0D0
15277             ELSE
15278                THETA = ACOS(COSTH)
15279             ENDIF
15280             PHI     = ASIN(PHKK(2,I)/(PT  +TINY10))
15281             IF (PHKK(1,I).LT.0.0D0)
15282
15283      &         PHI  = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15284
15285             ENER    = PHKK(4,I)
15286             NN      = NN+1
15287             KTEMP   = MSTU(10)
15288             MSTU(10)= 1
15289             P(NN,5) = PHKK(5,I)
15290
15291             CALL PY1ENT(NN,111,ENER,THETA,PHI)
15292
15293             MSTU(10)  = KTEMP
15294             IHISMO(NN)= I
15295          ENDIF
15296     1 CONTINUE
15297       IF (NN.GT.0) THEN
15298
15299          CALL PYEXEC
15300
15301          NLINES = PYK(0,1)
15302
15303          DO 2 II=1,NLINES
15304
15305             IF (PYK(II,7).EQ.1) THEN
15306
15307                DO 3 KK=1,4
15308
15309                   P1(KK) = PYP(II,KK)
15310
15311     3          CONTINUE
15312
15313                ID = PYK(II,8)
15314                MO = IHISMO(PYK(II,15))
15315
15316                CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15317                IF (LEMCCK)
15318      &            CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15319      &                                            IDUM,IDUM)
15320 *sr: flag with neg. sign (for HELIOS p/A-W jobs)
15321                ISTHKK(MO) = -2
15322             ENDIF
15323     2    CONTINUE
15324          IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15325       ENDIF
15326       MDCY(KC,1) = 0
15327
15328       RETURN
15329       END
15330 *
15331 *===dtwopd=============================================================*
15332 *
15333 CDECK  ID>, DT_DTWOPD
15334       SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15335      &                                            COF2,SIF2,AM1,AM2)
15336
15337 ************************************************************************
15338 * Two-particle decay.                                                  *
15339 *  UMO                 cm-energy of the decaying system       (input)  *
15340 *  AM1/AM2             masses of the decay products           (input)  *
15341 *  ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15342 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15343 * Revised by S. Roesler, 20.11.95                                      *
15344 ************************************************************************
15345
15346       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15347       SAVE
15348
15349       PARAMETER ( LINP = 5 ,
15350      &            LOUT = 6 ,
15351      &            LDAT = 9 )
15352
15353       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15354
15355       IF (UMO.LT.(AM1+AM2)) THEN
15356          WRITE(LOUT,1000) UMO,AM1,AM2
15357  1000    FORMAT(1X,'DTWOPD:    inconsistent kinematics - UMO,AM1,AM2 ',
15358      &          3E12.3)
15359          STOP
15360       ENDIF
15361
15362       ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15363       ECM2 = UMO-ECM1
15364       PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15365       PCM2 = PCM1
15366       CALL DT_DSFECF(SIF1,COF1)
15367       COD1 = TWO*DT_RNDM(PCM2)-ONE
15368       COD2 = -COD1
15369       COF2 = -COF1
15370       SIF2 = -SIF1
15371
15372       RETURN
15373       END
15374 *
15375 *===dthrep=============================================================*
15376 *
15377 CDECK  ID>, DT_DTHREP
15378       SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15379      &                  SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15380
15381 ************************************************************************
15382 * Three-particle decay.                                                *
15383 *  UMO                 cm-energy of the decaying system       (input)  *
15384 *  AM1/2/3             masses of the decay products           (input)  *
15385 *  ECM1/2/2,PCM1/2/3   cm-energies/momenta of the decay prod. (output) *
15386 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15387 *                                                                      *
15388 * Threpd89: slight revision by A. Ferrari                              *
15389 * Last change on   11-oct-93   by    Alfredo Ferrari, INFN - Milan     *
15390 * Revised by S. Roesler, 20.11.95                                      *
15391 ************************************************************************
15392
15393       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15394       SAVE
15395
15396       PARAMETER ( LINP = 5 ,
15397      &            LOUT = 6 ,
15398      &            LDAT = 9 )
15399
15400       PARAMETER ( ANGLSQ = 2.5D-31 )
15401       PARAMETER ( AZRZRZ = 1.0D-30 )
15402       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
15403       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
15404       PARAMETER ( ONEONE = 1.D+00 )
15405       PARAMETER ( TWOTWO = 2.D+00 )
15406       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15407
15408       COMMON /HNGAMR/ REDU,AMO,AMM(15)
15409 * flags for input different options
15410       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15411       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15412      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15413
15414       DIMENSION F(5),XX(5)
15415       DATA EPS /AZRZRZ/
15416
15417       UMOO=UMO+UMO
15418 C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
15419 C***J. VON NEUMANN - RANDOM - SELECTION OF S2
15420 C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
15421       UUMO=UMO
15422       AAM1=AM1
15423       AAM2=AM2
15424       AAM3=AM3
15425       GU=(AM2+AM3)**2
15426       GO=(UMO-AM1)**2
15427 *     UFAK=1.0000000000001D0
15428 *     IF (GU.GT.GO) UFAK=0.9999999999999D0
15429       IF (GU.GT.GO) THEN
15430          UFAK=ONEMNS
15431       ELSE
15432          UFAK=ONEPLS
15433       END IF
15434       OFAK=2.D0-UFAK
15435       GU=GU*UFAK
15436       GO=GO*OFAK
15437       DS2=(GO-GU)/99.D0
15438       AM11=AM1*AM1
15439       AM22=AM2*AM2
15440       AM33=AM3*AM3
15441       UMO2=UMO*UMO
15442       RHO2=0.D0
15443       S22=GU
15444       DO 124 I=1,100
15445          S21=S22
15446          S22=GU+(I-1.D0)*DS2
15447          RHO1=RHO2
15448          RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
15449      *                                             (S22+EPS)
15450          IF(RHO2.LT.RHO1) GO TO 125
15451   124 CONTINUE
15452   125 S2SUP=(S22-S21)*.5D0+S21
15453       SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
15454      *                                           (S2SUP+EPS)
15455       SUPRHO=SUPRHO*1.05D0
15456       XO=S21-DS2
15457       IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
15458       IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
15459       XX(1)=XO
15460       XX(3)=S22
15461       X1=(XO+S22)*0.5D0
15462       XX(2)=X1
15463       F(3)=RHO2
15464       F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
15465       F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
15466       DO 126 I=1,16
15467          X4=(XX(1)+XX(2))*0.5D0
15468          X5=(XX(2)+XX(3))*0.5D0
15469          F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
15470      *                                               (X4+EPS)
15471          F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
15472      *                                               (X5+EPS)
15473          XX(4)=X4
15474          XX(5)=X5
15475          DO 128 II=1,5
15476             IA=II
15477             DO 128 III=IA,5
15478                IF (F (II).GE.F (III)) GO TO 128
15479                FH=F(II)
15480                F(II)=F(III)
15481                F(III)=FH
15482                FH=XX(II)
15483                XX(II)=XX(III)
15484                XX(III)=FH
15485 128      CONTINUE
15486          SUPRHO=F(1)
15487          S2SUP=XX(1)
15488          DO 129 II=1,3
15489             IA=II
15490             DO 129 III=IA,3
15491                IF (XX(II).GE.XX(III)) GO TO 129
15492                FH=F(II)
15493                F(II)=F(III)
15494                F(III)=FH
15495                FH=XX(II)
15496                XX(II)=XX(III)
15497                XX(III)=FH
15498 129      CONTINUE
15499 126   CONTINUE
15500       AM23=(AM2+AM3)**2
15501       ITH=0
15502       REDU=2.D0
15503     1 CONTINUE
15504       ITH=ITH+1
15505       IF (ITH.GT.200) REDU=-9.D0
15506       IF (ITH.GT.200) GO TO 400
15507       C=DT_RNDM(REDU)
15508 *     S2=AM23+C*((UMO-AM1)**2-AM23)
15509       S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
15510       Y=DT_RNDM(S2)
15511       Y=Y*SUPRHO
15512       RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
15513       IF(Y.GT.RHO) GO TO 1
15514 C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
15515       S1=DT_RNDM(S2)
15516       S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
15517      &RHO*.5D0
15518       S3=UMO2+AM11+AM22+AM33-S1-S2
15519       ECM1=(UMO2+AM11-S2)/UMOO
15520       ECM2=(UMO2+AM22-S3)/UMOO
15521       ECM3=(UMO2+AM33-S1)/UMOO
15522       PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
15523       PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
15524       PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
15525       CALL DT_DSFECF(SFE,CFE)
15526 C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
15527 C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
15528       PCM12 = PCM1 * PCM2
15529       IF ( PCM12 .LT. ANGLSQ ) GO TO 200
15530       COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
15531       GO TO 300
15532  200  CONTINUE
15533          UW=DT_RNDM(S1)
15534          COSTH=(UW-0.5D+00)*2.D+00
15535  300  CONTINUE
15536 *     IF(ABS(COSTH).GT.0.9999999999999999D0)
15537 *    &COSTH=SIGN(0.9999999999999999D0,COSTH)
15538       IF(ABS(COSTH).GT.ONEONE)
15539      &COSTH=SIGN(ONEONE,COSTH)
15540       IF (REDU.LT.1.D+00) RETURN
15541       COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
15542 *     IF(ABS(COSTH2).GT.0.9999999999999999D0)
15543 *    &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
15544       IF(ABS(COSTH2).GT.ONEONE)
15545      &COSTH2=SIGN(ONEONE,COSTH2)
15546       SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
15547       SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
15548       SINTH1=COSTH2*SINTH-COSTH*SINTH2
15549       COSTH1=COSTH*COSTH2+SINTH2*SINTH
15550 C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
15551 C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
15552 C***THE DIRECTION OF PARTICLE 3
15553 C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
15554       CX11=-COSTH1
15555       CY11=SINTH1*CFE
15556       CZ11=SINTH1*SFE
15557       CX22=-COSTH2
15558       CY22=-SINTH2*CFE
15559       CZ22=-SINTH2*SFE
15560       CALL DT_DSFECF(SIF3,COF3)
15561       COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
15562       SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
15563     2 FORMAT(5F20.15)
15564       COD1=CX11*COD3+CZ11*SID3
15565       CHLP=(ONEONE-COD1)*(ONEONE+COD1)
15566       IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
15567      &CX11,CZ11
15568       SID1=SQRT(CHLP)
15569       COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
15570       SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
15571       COD2=CX22*COD3+CZ22*SID3
15572       SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
15573       COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
15574       SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
15575  400  CONTINUE
15576 * === Energy conservation check: === *
15577       EOCHCK = UMO - ECM1 - ECM2 - ECM3
15578 *     SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
15579 *     SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
15580 *     SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
15581       PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
15582       PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
15583      &       + PCM3 * COF3 * SID3
15584       PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
15585      &       + PCM3 * SIF3 * SID3
15586       EOCMPR = 1.D-12 * UMO
15587       IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
15588      &     .GT. EOCMPR ) THEN
15589 **sr 5.5.95 output-unit changed
15590          IF (IOULEV(1).GT.0) THEN
15591             WRITE(LOUT,*)
15592      &      ' *** Threpd: energy/momentum conservation failure! ***',
15593      &      EOCHCK,PXCHCK,PYCHCK,PZCHCK
15594             WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
15595          ENDIF
15596 **
15597       END IF
15598       RETURN
15599       END
15600 *
15601 *===dbklas=============================================================*
15602 *
15603 CDECK  ID>, DT_DBKLAS
15604       SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
15605
15606       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15607       SAVE
15608
15609       PARAMETER ( LINP = 5 ,
15610      &            LOUT = 6 ,
15611      &            LDAT = 9 )
15612
15613 * quark-content to particle index conversion (DTUNUC 1.x)
15614       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15615      &                IA08(6,21),IA10(6,21)
15616
15617       IF (I) 20,20,10
15618 * baryons
15619    10 CONTINUE
15620       CALL DT_INDEXD(J,K,IND)
15621       I8  = IB08(I,IND)
15622       I10 = IB10(I,IND)
15623       IF (I8.LE.0) I8 = I10
15624       RETURN
15625 * antibaryons
15626    20 CONTINUE
15627       II = IABS(I)
15628       JJ = IABS(J)
15629       KK = IABS(K)
15630       CALL DT_INDEXD(JJ,KK,IND)
15631       I8  = IA08(II,IND)
15632       I10 = IA10(II,IND)
15633       IF (I8.LE.0) I8 = I10
15634
15635       RETURN
15636       END
15637 *
15638 *===indexd=============================================================*
15639 *
15640 CDECK  ID>, DT_INDEXD
15641       SUBROUTINE DT_INDEXD(KA,KB,IND)
15642
15643       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15644       SAVE
15645
15646       PARAMETER ( LINP = 5 ,
15647      &            LOUT = 6 ,
15648      &            LDAT = 9 )
15649
15650       KP = KA*KB
15651       KS = KA+KB
15652       IF (KP.EQ.1) IND=1
15653       IF (KP.EQ.2) IND=2
15654       IF (KP.EQ.3) IND=3
15655       IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
15656       IF (KP.EQ.5) IND=5
15657       IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
15658       IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
15659       IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
15660       IF (KP.EQ.8)  IND=9
15661       IF (KP.EQ.10) IND=10
15662       IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
15663       IF (KP.EQ.9)  IND=12
15664       IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
15665       IF (KP.EQ.15) IND=14
15666       IF (KP.EQ.18) IND=15
15667       IF (KP.EQ.16) IND=16
15668       IF (KP.EQ.20) IND=17
15669       IF (KP.EQ.24) IND=18
15670       IF (KP.EQ.25) IND=19
15671       IF (KP.EQ.30) IND=20
15672       IF (KP.EQ.36) IND=21
15673
15674       RETURN
15675       END
15676 *
15677 *===dchant=============================================================*
15678 *
15679 CDECK  ID>, DT_DCHANT
15680       SUBROUTINE DT_DCHANT
15681
15682       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15683       SAVE
15684
15685       PARAMETER ( LINP = 5 ,
15686      &            LOUT = 6 ,
15687      &            LDAT = 9 )
15688
15689       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15690
15691 * HADRIN: decay channel information
15692       PARAMETER (IDMAX9=602)
15693       CHARACTER*8 ZKNAME
15694       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15695 * particle properties (BAMJET index convention)
15696       CHARACTER*8  ANAME
15697       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15698      &                IICH(210),IIBAR(210),K1(210),K2(210)
15699
15700       DIMENSION HWT(IDMAX9)
15701
15702 * change of weights wt from absolut values into the sum of wt of a dec.
15703       DO 10 J=1,IDMAX9
15704          HWT(J) = ZERO
15705    10 CONTINUE
15706 C     DO 999 KKK=1,210
15707 C        WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
15708 C    &      ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
15709 C    &      K1(KKK),K2(KKK)
15710 C 999 CONTINUE
15711 C     STOP
15712       DO 30 I=1,210
15713          IK1 = K1(I)
15714          IK2 = K2(I)
15715          HV  = ZERO
15716          DO 20 J=IK1,IK2
15717             HV     = HV+WT(J)
15718             HWT(J) = HV
15719 **sr 13.1.95
15720             IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
15721  1000       FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
15722    20    CONTINUE
15723    30 CONTINUE
15724       DO 40 J=1,IDMAX9
15725          WT(J) = HWT(J)
15726    40 CONTINUE
15727
15728       RETURN
15729       END
15730 *
15731 *===ddatar=============================================================*
15732 *
15733 CDECK  ID>, DT_DDATAR
15734       SUBROUTINE DT_DDATAR
15735
15736       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15737       SAVE
15738
15739       PARAMETER ( LINP = 5 ,
15740      &            LOUT = 6 ,
15741      &            LDAT = 9 )
15742
15743       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15744
15745 * quark-content to particle index conversion (DTUNUC 1.x)
15746       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15747      &                IA08(6,21),IA10(6,21)
15748
15749       DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
15750
15751       DATA IV/ 33, 34, 38,123,  0,  0, 32, 33, 39,124,
15752      &          0,  0, 36, 37, 96,127,  0,  0,126,125,
15753      &        128,129,14*0/
15754       DATA IP/ 23, 14, 16,116,  0,  0, 13, 23, 25,117,
15755      &          0,  0, 15, 24, 31,120,  0,  0,119,118,
15756      &        121,122,14*0/
15757       DATA IB/  0,  1, 21,140,  0,  0,  8, 22,137,  0,
15758      &          0, 97,138,  0,  0,146,  0,  0,  0,  0,
15759      &          0,  1,  8, 22,137,  0,  0,  0, 20,142,
15760      &          0,  0, 98,139,  0,  0,147,  0,  0,  0,
15761      &          0,  0, 21, 22, 97,138,  0,  0, 20, 98,
15762      &        139,  0,  0,  0,145,  0,  0,148,  0,  0,
15763      &          0,  0,  0,140,137,138,146,  0,  0,142,
15764      &        139,147,  0,  0,145,148,           50*0/
15765       DATA IBB/53, 54,104,161,  0,  0, 55,105,162,  0,
15766      &          0,107,164,  0,  0,167,  0,  0,  0,  0,
15767      &          0, 54, 55,105,162,  0,  0, 56,106,163,
15768      &          0,  0,108,165,  0,  0,168,  0,  0,  0,
15769      &          0,  0,104,105,107,164,  0,  0,106,108,
15770      &        165,  0,  0,109,166,  0,  0,169,  0,  0,
15771      &          0,  0,  0,161,162,164,167,  0,  0,163,
15772      &        165,168,  0,  0,166,169,  0,  0,170,47*0/
15773       DATA IA/  0,  2, 99,152,  0,  0,  9,100,149,  0,
15774      &          0,102,150,  0,  0,158,  0,  0,  0,  0,
15775      &          0,  2,  9,100,149,  0,  0,  0,101,154,
15776      &          0,  0,103,151,  0,  0,159,  0,  0,  0,
15777      &          0,  0, 99,100,102,150,  0,  0,101,103,
15778      &        151,  0,  0,  0,157,  0,  0,160,  0,  0,
15779      &          0,  0,  0,152,149,150,158,  0,  0,154,
15780      &        151,159,  0,  0,157,160,           50*0/
15781       DATA IAA/67, 68,110,171,  0,  0, 69,111,172,  0,
15782      &          0,113,174,  0,  0,177,  0,  0,  0,  0,
15783      &          0, 68, 69,111,172,  0,  0, 70,112,173,
15784      &          0,  0,114,175,  0,  0,178,  0,  0,  0,
15785      &          0,  0,110,111,113,174,  0,  0,112,114,
15786      &        175,  0,  0,115,176,  0,  0,179,  0,  0,
15787      &          0,  0,  0,171,172,174,177,  0,  0,173,
15788      &        175,178,  0,  0,176,179,  0,  0,180,47*0/
15789
15790       L=0
15791       DO 2 I=1,6
15792          DO 1 J=1,6
15793             L = L+1
15794             IMPS(I,J) = IP(L)
15795             IMVE(I,J) = IV(L)
15796     1    CONTINUE
15797     2 CONTINUE
15798       L=0
15799       DO 4 I=1,6
15800          DO 3 J=1,21
15801             L = L+1
15802             IB08(I,J) = IB(L)
15803             IB10(I,J) = IBB(L)
15804             IA08(I,J) = IA(L)
15805             IA10(I,J) = IAA(L)
15806     3    CONTINUE
15807     4 CONTINUE
15808 C     A1  = 0.88D0
15809 C     B1  = 3.0D0
15810 C     B2  = 3.0D0
15811 C     B3  = 8.0D0
15812 C     LT  = 0
15813 C     LB  = 0
15814 C     BET = 12.0D0
15815 C     AS  = 0.25D0
15816 C     B8  = 0.33D0
15817 C     AME = 0.95D0
15818 C     DIQ = 0.375D0
15819 C     ISU = 4
15820
15821       RETURN
15822       END
15823 *
15824 *===initjs=============================================================*
15825 *
15826 CDECK  ID>, DT_INITJS
15827       SUBROUTINE DT_INITJS(MODE)
15828
15829 ************************************************************************
15830 * Initialize JETSET paramters.                                         *
15831 *           MODE = 0 default settings                                  *
15832 *                = 1 PHOJET settings                                   *
15833 *                = 2 DTUNUC settings                                   *
15834 * This version dated 16.02.96 is written by S. Roesler                 *
15835 ************************************************************************
15836
15837       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15838       SAVE
15839
15840       PARAMETER ( LINP = 5 ,
15841      &            LOUT = 6 ,
15842      &            LDAT = 9 )
15843
15844       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15845
15846       LOGICAL LFIRST,LFIRDT,LFIRPH
15847
15848       INCLUDE '(DIMPAR)'
15849       INCLUDE '(PART)'
15850
15851       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15852
15853       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15854
15855       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15856
15857 * flags for particle decays
15858       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
15859      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
15860      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
15861 * flags for input different options
15862       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15863       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15864      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15865
15866       INTEGER PYCOMP
15867
15868       DIMENSION IDXSTA(40)
15869       DATA IDXSTA
15870 *          K0s   pi0  lam   alam  sig+  asig+ sig-  asig- tet0  atet0
15871      &  /  310,  111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
15872 *          tet- atet-  om-  aom-   D+    D-    D0    aD0   Ds+   aDs+
15873      &    3312,-3312, 3334,-3334,  411, -411,  421, -421,  431, -431,
15874 *          etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
15875      &     441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
15876 *         Ksic0 aKsic+aKsic0 sig0 asig0
15877      &    4132,-4232,-4132, 3212,-3212, 5*0/
15878
15879       DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
15880
15881       IF (LFIRST) THEN
15882 * save default settings
15883          PDEF1  = PARJ(1)
15884          PDEF2  = PARJ(2)
15885          PDEF3  = PARJ(3)
15886          PDEF5  = PARJ(5)
15887          PDEF6  = PARJ(6)
15888          PDEF7  = PARJ(7)
15889          PDEF18 = PARJ(18)
15890          PDEF19 = PARJ(19)
15891          PDEF21 = PARJ(21)
15892          PDEF42 = PARJ(42)
15893          MDEF12 = MSTJ(12)
15894 * LUJETS / PYJETS array-dimensions
15895
15896          MSTU(4) = 4000
15897
15898 * increase maximum number of JETSET-error prints
15899          MSTU(22) = 50000
15900 * prevent particles decaying
15901          DO 1 I=1,35
15902             IF (I.LT.34) THEN
15903
15904                KC = PYCOMP(IDXSTA(I))
15905
15906                IF (I.EQ.2) THEN
15907 *  pi0 decay
15908 C                 MDCY(KC,1) = 1
15909                   MDCY(KC,1) = 0
15910 **cr mode
15911 C              ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
15912 C   &                 (I.EQ.8).OR.(I.EQ.10)) THEN
15913 C              ELSEIF (I.EQ.4) THEN
15914 C                 MDCY(KC,1) = 1
15915 **
15916                ELSE
15917                   MDCY(KC,1) = 0
15918                ENDIF
15919             ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
15920
15921                KC = PYCOMP(IDXSTA(I))
15922
15923                MDCY(KC,1) = 0
15924             ENDIF
15925     1    CONTINUE
15926 *
15927
15928 * as Fluka event-generator: allow only paprop particles to be stable
15929 * and let all other particles decay (i.e. those with strong decays)
15930          IF (ITRSPT.EQ.1) THEN
15931             DO 5 I=1,IDMAXP
15932                IF (KPTOIP(I).NE.0) THEN
15933                   IDPDG = MPDGHA(I)
15934
15935                   KC    = PYCOMP(IDPDG)
15936
15937                   IF (MDCY(KC,1).EQ.1) THEN
15938                      WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-',
15939      &                             'transport : particle should not ',
15940      &                             'decay : ',IDPDG,'  ',ANAME(I)
15941                      MDCY(KC,1) = 0
15942                   ENDIF
15943                ENDIF
15944     5       CONTINUE
15945             DO 6 KC=1,500
15946                IDPDG = KCHG(KC,4)
15947                KP    = MCIHAD(IDPDG)
15948                IF (KP.GT.0) THEN
15949                   IF ((MDCY(KC,1).EQ.0).AND.(KPTOIP(KP).EQ.0).AND.
15950      &                (ANAME(KP).NE.'BLANK   ').AND.
15951      &                (ANAME(KP).NE.'RNDFLV  ')) THEN
15952                      WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-',
15953      &                             'transport: particle should decay ',
15954      &                             ': ',IDPDG,' ',ANAME(KP)
15955                      MDCY(KC,1) = 1
15956                   ENDIF
15957                ENDIF
15958     6       CONTINUE
15959          ENDIF
15960
15961 *
15962 * popcorn:
15963          IF (PDB.LE.ZERO) THEN
15964 *   no popcorn-mechanism
15965             MSTJ(12) = 1
15966          ELSE
15967             MSTJ(12) = 3
15968             PARJ(5)  = PDB
15969          ENDIF
15970 * set JETSET-parameter requested by input cards
15971          IF (NMSTU.GT.0) THEN
15972             DO 2 I=1,NMSTU
15973                MSTU(IMSTU(I)) = MSTUX(I)
15974     2       CONTINUE
15975          ENDIF
15976          IF (NMSTJ.GT.0) THEN
15977             DO 3 I=1,NMSTJ
15978                MSTJ(IMSTJ(I)) = MSTJX(I)
15979     3       CONTINUE
15980          ENDIF
15981          IF (NPARU.GT.0) THEN
15982             DO 4 I=1,NPARU
15983                PARU(IPARU(I)) = PARUX(I)
15984     4       CONTINUE
15985          ENDIF
15986          LFIRST = .FALSE.
15987       ENDIF
15988 *
15989 * PARJ(1)  suppression of qq-aqaq pair prod. compared to
15990 *          q-aq pair prod.                      (default: 0.1)
15991 * PARJ(2)  strangeness suppression               (default: 0.3)
15992 * PARJ(3)  extra suppression of strange diquarks (default: 0.4)
15993 * PARJ(6)  extra suppression of sas-pair shared by B and
15994 *          aB in BMaB                           (default: 0.5)
15995 * PARJ(7)  extra suppression of strange meson M in BMaB
15996 *          configuration                        (default: 0.5)
15997 * PARJ(18) spin 3/2 baryon suppression           (default: 1.0)
15998 * PARJ(21) width sigma in Gaussian p_x, p_y transverse
15999 *          momentum distrib. for prim. hadrons  (default: 0.35)
16000 * PARJ(42) b-parameter for symmetric Lund-fragmentation
16001 *          function                             (default: 0.9 GeV^-2)
16002 *
16003 * PHOJET settings
16004       IF (MODE.EQ.1) THEN
16005 *   JETSET default
16006 C        PARJ(1)  = PDEF1
16007 C        PARJ(2)  = PDEF2
16008 C        PARJ(3)  = PDEF3
16009 C        PARJ(6)  = PDEF6
16010 C        PARJ(7)  = PDEF7
16011 C        PARJ(18) = PDEF18
16012 C        PARJ(21) = PDEF21
16013 C        PARJ(42) = PDEF42
16014 **sr 18.11.98 parameter tuning
16015 C        PARJ(1)  = 0.092D0
16016 C        PARJ(2)  = 0.25D0
16017 C        PARJ(3)  = 0.45D0
16018 C        PARJ(19) = 0.3D0
16019 C        PARJ(21) = 0.45D0
16020 C        PARJ(42) = 1.0D0
16021 **sr 28.04.99 parameter tuning (May 99 minor modifications)
16022          PARJ(1)  = 0.085D0
16023          PARJ(2)  = 0.26D0
16024          PARJ(3)  = 0.8D0
16025          PARJ(11) = 0.38D0
16026          PARJ(18) = 0.3D0
16027          PARJ(19) = 0.4D0
16028          PARJ(21) = 0.36D0
16029          PARJ(41) = 0.3D0
16030          PARJ(42) = 0.86D0
16031          IF (NPARJ.GT.0) THEN
16032             DO 10 I=1,NPARJ
16033                IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
16034    10       CONTINUE
16035          ENDIF
16036          IF (LFIRPH) THEN
16037 C *** Commented by Chiara
16038 C            WRITE(LOUT,'(1X,A)')
16039 C     &         'DT_INITJS: JETSET-parameter for PHOJET'
16040             CALL DT_JSPARA(0)
16041             LFIRPH = .FALSE.
16042          ENDIF
16043 * DTUNUC settings
16044       ELSEIF (MODE.EQ.2) THEN
16045          IF (IFRAG(2).EQ.1) THEN
16046 **sr parameters before 9.3.96
16047 C           PARJ(2)  = 0.27D0
16048 C           PARJ(3)  = 0.6D0
16049 C           PARJ(6)  = 0.75D0
16050 C           PARJ(7)  = 0.75D0
16051 C           PARJ(21) = 0.55D0
16052 C           PARJ(42) = 1.3D0
16053 **sr 18.11.98 parameter tuning
16054 C           PARJ(1)  = 0.05D0
16055 C           PARJ(2)  = 0.27D0
16056 C           PARJ(3)  = 0.4D0
16057 C           PARJ(19) = 0.2D0
16058 C           PARJ(21) = 0.45D0
16059 C           PARJ(42) = 1.0D0
16060 **sr 28.04.99 parameter tuning
16061             PARJ(1)  = 0.11D0
16062             PARJ(2)  = 0.36D0
16063             PARJ(3)  = 0.8D0
16064             PARJ(19) = 0.2D0
16065             PARJ(21) = 0.3D0
16066             PARJ(41) = 0.3D0
16067             PARJ(42) = 0.58D0
16068             IF (NPARJ.GT.0) THEN
16069                DO 20 I=1,NPARJ
16070                   IF (IPARJ(I).LT.0) THEN
16071                      IDX = ABS(IPARJ(I))
16072                      PARJ(IDX) = PARJX(I)
16073                   ENDIF
16074    20          CONTINUE
16075             ENDIF
16076             IF (LFIRDT) THEN
16077                WRITE(LOUT,'(1X,A)')
16078      &           'DT_INITJS: JETSET-parameter for DTUNUC'
16079                CALL DT_JSPARA(0)
16080                LFIRDT = .FALSE.
16081             ENDIF
16082          ELSEIF (IFRAG(2).EQ.2) THEN
16083             PARJ(1)  = 0.11D0
16084             PARJ(2)  = 0.27D0
16085             PARJ(3)  = 0.3D0
16086             PARJ(6)  = 0.35D0
16087             PARJ(7)  = 0.45D0
16088             PARJ(18) = 0.66D0
16089 C           PARJ(21) = 0.55D0
16090 C           PARJ(42) = 1.0D0
16091             PARJ(21) = 0.60D0
16092             PARJ(42) = 1.3D0
16093          ELSE
16094             PARJ(1)  = PDEF1
16095             PARJ(2)  = PDEF2
16096             PARJ(3)  = PDEF3
16097             PARJ(6)  = PDEF6
16098             PARJ(7)  = PDEF7
16099             PARJ(18) = PDEF18
16100             PARJ(21) = PDEF21
16101             PARJ(42) = PDEF42
16102          ENDIF
16103       ELSE
16104          PARJ(1)  = PDEF1
16105          PARJ(2)  = PDEF2
16106          PARJ(3)  = PDEF3
16107          PARJ(5)  = PDEF5
16108          PARJ(6)  = PDEF6
16109          PARJ(7)  = PDEF7
16110          PARJ(18) = PDEF18
16111          PARJ(19) = PDEF19
16112          PARJ(21) = PDEF21
16113          PARJ(42) = PDEF42
16114          MSTJ(12) = MDEF12
16115       ENDIF
16116
16117       RETURN
16118       END
16119 *
16120 *===jspara=============================================================*
16121 *
16122 CDECK  ID>, DT_JSPARA
16123       SUBROUTINE DT_JSPARA(MODE)
16124
16125       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16126       SAVE
16127
16128       PARAMETER ( LINP = 5 ,
16129      &            LOUT = 6 ,
16130      &            LDAT = 9 )
16131
16132       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
16133      &           ONE=1.0D0,ZERO=0.0D0)
16134
16135       LOGICAL LFIRST
16136
16137       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16138
16139       DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
16140
16141       DATA LFIRST /.TRUE./
16142
16143 * save the default JETSET-parameter on the first call
16144       IF (LFIRST) THEN
16145          DO 1 I=1,200
16146             ISTU(I) = MSTU(I)
16147             QARU(I) = PARU(I)
16148             ISTJ(I) = MSTJ(I)
16149             QARJ(I) = PARJ(I)
16150     1    CONTINUE
16151          LFIRST = .FALSE.
16152       ENDIF
16153
16154 C *** Commented by Chiara
16155 C      WRITE(LOUT,1000)
16156 C 1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
16157
16158 * compare the default JETSET-parameter with the present values
16159       DO 2 I=1,200
16160 C *** Commented by Chiara
16161 C         IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
16162 C            WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
16163 CC           ISTU(I) = MSTU(I)
16164 C         ENDIF
16165          DIFF = ABS(PARU(I)-QARU(I))
16166 C *** Commented by Chiara
16167 C         IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
16168 C            WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
16169 CC           QARU(I) = PARU(I)
16170 C         ENDIF
16171 C *** Commented by Chiara
16172 C         IF (MSTJ(I).NE.ISTJ(I)) THEN
16173 C            WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16174 CC           ISTJ(I) = MSTJ(I)
16175 C         ENDIF
16176          DIFF = ABS(PARJ(I)-QARJ(I))
16177 C *** Commented by Chiara
16178 C         IF (DIFF.GE.1.0D-5) THEN
16179 C            WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16180 CC           QARJ(I) = PARJ(I)
16181 C         ENDIF
16182     2 CONTINUE
16183  1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16184  1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16185
16186       RETURN
16187       END
16188 *
16189 *===fozoca=============================================================*
16190 *
16191 CDECK  ID>, DT_FOZOCA
16192       SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16193
16194 ************************************************************************
16195 * This subroutine treats the complete FOrmation ZOne supressed intra-  *
16196 * nuclear CAscade.                                                     *
16197 *               LFZC = .true.  cascade has been treated                *
16198 *                    = .false. cascade skipped                         *
16199 * This is a completely revised version of the original FOZOKL.         *
16200 * This version dated 18.11.95 is written by S. Roesler                 *
16201 ************************************************************************
16202
16203       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16204       SAVE
16205
16206       PARAMETER ( LINP = 5 ,
16207      &            LOUT = 6 ,
16208      &            LDAT = 9 )
16209
16210       PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16211       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16212
16213       LOGICAL LSTART,LCAS,LFZC
16214
16215 * event history
16216
16217       PARAMETER (NMXHKK=200000)
16218
16219       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16220      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16221      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16222 * extended event history
16223       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16224      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16225      &                IHIST(2,NMXHKK)
16226 * rejection counter
16227       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16228      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16229      &                IREXCI(3),IRDIFF(2),IRINC
16230 * properties of interacting particles
16231       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16232 * Glauber formalism: collision properties
16233       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16234      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16235 * flags for input different options
16236       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16237       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16238      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16239 * final state after intranuclear cascade step
16240       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16241 * parameter for intranuclear cascade
16242       LOGICAL LPAULI
16243       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16244
16245       DIMENSION NCWOUN(2)
16246
16247       DATA LSTART /.TRUE./
16248
16249       LFZC = .TRUE.
16250       IREJ = 0
16251
16252 * skip cascade if hadron-hadron interaction or if supressed by user
16253       IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16254 * skip cascade if not all possible chains systems are hadronized
16255       DO 1 I=1,8
16256          IF (.NOT.LHADRO(I)) GOTO 9999
16257     1 CONTINUE
16258
16259       IF (LSTART) THEN
16260          WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16261  1000    FORMAT(/,1X,'FOZOCA:  intranuclear cascade treated for a ',
16262      &          'maximum of',I4,' generations',/,10X,'formation time ',
16263      &          'parameter:',F5.1,'  fm/c',9X,'modus:',I2)
16264          IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16265          IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16266  1001    FORMAT(10X,'p_t dependent formation zone',/)
16267  1002    FORMAT(10X,'constant formation zone',/)
16268          LSTART = .FALSE.
16269       ENDIF
16270
16271 * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16272 * which may interact with final state particles are stored in a seperate
16273 * array - here all proj./target nucleon-indices (just for simplicity)
16274       NOINC = 0
16275       DO 9 I=1,NPOINT(1)-1
16276          NOINC = NOINC+1
16277          IDXINC(NOINC) = I
16278     9 CONTINUE
16279
16280 * initialize Pauli-principle treatment (find wounded nucleons)
16281       NWOUND(1) = 0
16282       NWOUND(2) = 0
16283       NCWOUN(1) = 0
16284       NCWOUN(2) = 0
16285       DO 2 J=1,NPOINT(1)
16286          DO 3 I=1,2
16287             IF (ISTHKK(J).EQ.10+I) THEN
16288                NWOUND(I) = NWOUND(I)+1
16289                EWOUND(I,NWOUND(I)) = PHKK(4,J)
16290                IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16291             ENDIF
16292     3    CONTINUE
16293     2 CONTINUE
16294
16295 * modify nuclear potential for wounded nucleons
16296       IPRCL  = IP -NWOUND(1)
16297       IPZRCL = IPZ-NCWOUN(1)
16298       ITRCL  = IT -NWOUND(2)
16299       ITZRCL = ITZ-NCWOUN(2)
16300       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16301
16302       NSTART = NPOINT(4)
16303       NEND   = NHKK
16304
16305     7 CONTINUE
16306       DO 8 I=NSTART,NEND
16307
16308          IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16309 * select nucleus the cascade starts first (proj. - 1, target - -1)
16310             NCAS   = 1
16311 *   projectile/target with probab. 1/2
16312             IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16313                IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16314 *   in the nucleus with highest mass
16315             ELSEIF (INCMOD.EQ.2) THEN
16316                IF (IP.GT.IT) THEN
16317                   NCAS = -NCAS
16318                ELSEIF (IP.EQ.IT) THEN
16319                   IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16320                ENDIF
16321 * the nucleus the cascade starts first is requested to be the one
16322 * moving in the direction of the secondary
16323             ELSEIF (INCMOD.EQ.3) THEN
16324                NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
16325             ENDIF
16326 * check that the selected "nucleus" is not a hadron
16327             IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
16328      &          ((NCAS.EQ.-1).AND.(IT.LE.1)))    NCAS = -NCAS
16329
16330 * treat intranuclear cascade in the nucleus selected first
16331             LCAS = .FALSE.
16332             CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16333             IF (IREJ1.NE.0) GOTO 9998
16334 * treat intranuclear cascade in the other nucleus if this isn't a had.
16335             NCAS = -NCAS
16336             IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
16337      &          ((NCAS.EQ.-1).AND.(IT.GT.1)))    THEN
16338                IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16339                IF (IREJ1.NE.0) GOTO 9998
16340             ENDIF
16341
16342          ENDIF
16343
16344     8 CONTINUE
16345       NSTART = NEND+1
16346       NEND   = NHKK
16347       IF (NSTART.LE.NEND) GOTO 7
16348
16349       RETURN
16350
16351  9998 CONTINUE
16352 * reject this event
16353       IRINC = IRINC+1
16354       IREJ = 1
16355
16356  9999 CONTINUE
16357 * intranucl. cascade not treated because of interaction properties or
16358 * it is supressed by user or it was rejected or...
16359       LFZC = .FALSE.
16360 * reset flag characterizing direction of motion in n-n-cms
16361 **sr14-11-95
16362 C     DO 9990 I=NPOINT(5),NHKK
16363 C        IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
16364 C9990 CONTINUE
16365
16366       RETURN
16367       END
16368 *
16369 *===inucas=============================================================*
16370 *
16371 CDECK  ID>, DT_INUCAS
16372       SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
16373
16374 ************************************************************************
16375 * Formation zone supressed IntraNUclear CAScade for one final state    *
16376 * particle.                                                            *
16377 *           IT, IP    mass numbers of target, projectile nuclei        *
16378 *           IDXCAS    index of final state particle in DTEVT1          *
16379 *           NCAS =  1 intranuclear cascade in projectile               *
16380 *                = -1 intranuclear cascade in target                   *
16381 * This version dated 18.11.95 is written by S. Roesler                 *
16382 ************************************************************************
16383
16384       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16385       SAVE
16386
16387       PARAMETER ( LINP = 5 ,
16388      &            LOUT = 6 ,
16389      &            LDAT = 9 )
16390
16391       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
16392      &           OHALF=0.5D0,ONE=1.0D0)
16393       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16394       PARAMETER (TWOPI=6.283185307179586454D+00)
16395       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
16396
16397       LOGICAL LABSOR,LCAS
16398
16399 * event history
16400
16401       PARAMETER (NMXHKK=200000)
16402
16403       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16404      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16405      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16406 * extended event history
16407       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16408      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16409      &                IHIST(2,NMXHKK)
16410 * final state after inc step
16411       PARAMETER (MAXFSP=10)
16412       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
16413 * flags for input different options
16414       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16415       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16416      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16417 * particle properties (BAMJET index convention)
16418       CHARACTER*8  ANAME
16419       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16420      &                IICH(210),IIBAR(210),K1(210),K2(210)
16421 * Glauber formalism: collision properties
16422       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16423      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16424 * nuclear potential
16425       LOGICAL LFERMI
16426       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
16427      &                EBINDP(2),EBINDN(2),EPOT(2,210),
16428      &                ETACOU(2),ICOUL,LFERMI
16429 * parameter for intranuclear cascade
16430       LOGICAL LPAULI
16431       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16432 * final state after intranuclear cascade step
16433       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16434 * nucleon-nucleon event-generator
16435       CHARACTER*8 CMODEL
16436       LOGICAL LPHOIN
16437       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
16438 * statistics: residual nuclei
16439       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
16440      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
16441      &                NINCST(2,4),NINCEV(2),
16442      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
16443      &                NRESPB(2),NRESCH(2),NRESEV(4),
16444      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
16445      &                NEVAFI(2,2)
16446
16447       DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
16448      &          PCAS1(5),PNUC(5),BGTA(4),
16449      &          BGCAS(2),GACAS(2),BECAS(2),
16450      &          RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
16451
16452       DATA PDIF /0.545D0/
16453
16454       IREJ = 0
16455
16456 * update counter
16457       IF (NINCEV(1).NE.NEVHKK) THEN
16458          NINCEV(1) = NEVHKK
16459          NINCEV(2) = NINCEV(2)+1
16460       ENDIF
16461
16462 * "BAMJET-index" of this hadron
16463       IDCAS = IDBAM(IDXCAS)
16464       IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
16465
16466 * skip gammas, electrons, etc..
16467       IF (AAM(IDCAS).LT.TINY2) RETURN
16468
16469 * Lorentz-trsf. into projectile rest system
16470       IF (IP.GT.1) THEN
16471          CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16472      &               PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
16473      &               PCAS(1,4),IDCAS,-2)
16474          PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
16475          PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
16476          IF (PCAS(1,5).GT.ZERO) THEN
16477             PCAS(1,5) = SQRT(PCAS(1,5))
16478          ELSE
16479             PCAS(1,5) = AAM(IDCAS)
16480          ENDIF
16481          DO 20 K=1,3
16482             COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
16483    20    CONTINUE
16484 * Lorentz-parameters
16485 *   particle rest system --> projectile rest system
16486          BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
16487          GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
16488          BECAS(1) = BGCAS(1)/GACAS(1)
16489       ELSE
16490          DO 21 K=1,5
16491             PCAS(1,K) = ZERO
16492             IF (K.LE.3) COSCAS(1,K) = ZERO
16493    21    CONTINUE
16494          PTOCAS(1) = ZERO
16495          BGCAS(1)  = ZERO
16496          GACAS(1)  = ZERO
16497          BECAS(1)  = ZERO
16498       ENDIF
16499 * Lorentz-trsf. into target rest system
16500       IF (IT.GT.1) THEN
16501 * LEPTO: final state particles are already in target rest frame
16502 C        IF (MCGENE.EQ.3) THEN
16503 C           PCAS(2,1) = PHKK(1,IDXCAS)
16504 C           PCAS(2,2) = PHKK(2,IDXCAS)
16505 C           PCAS(2,3) = PHKK(3,IDXCAS)
16506 C           PCAS(2,4) = PHKK(4,IDXCAS)
16507 C        ELSE
16508             CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16509      &                  PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
16510      &                  PCAS(2,4),IDCAS,-3)
16511 C        ENDIF
16512          PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
16513          PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
16514          IF (PCAS(2,5).GT.ZERO) THEN
16515             PCAS(2,5) = SQRT(PCAS(2,5))
16516          ELSE
16517             PCAS(2,5) = AAM(IDCAS)
16518          ENDIF
16519          DO 22 K=1,3
16520             COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
16521    22    CONTINUE
16522 * Lorentz-parameters
16523 *   particle rest system --> target rest system
16524          BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
16525          GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
16526          BECAS(2) = BGCAS(2)/GACAS(2)
16527       ELSE
16528          DO 23 K=1,5
16529             PCAS(2,K) = ZERO
16530             IF (K.LE.3) COSCAS(2,K) = ZERO
16531    23    CONTINUE
16532          PTOCAS(2) = ZERO
16533          BGCAS(2)  = ZERO
16534          GACAS(2)  = ZERO
16535          BECAS(2)  = ZERO
16536       ENDIF
16537
16538 * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
16539 * potential (see CONUCL)
16540       RNUC(1)  = (RPROJ+4.605D0*PDIF)*FM2MM
16541       RNUC(2)  = (RTARG+4.605D0*PDIF)*FM2MM
16542 * impact parameter (the projectile moving along z)
16543       BIMPC(1) = ZERO
16544       BIMPC(2) = BIMPAC*FM2MM
16545
16546 * get position of initial hadron in projectile/target rest-syst.
16547       DO 3 K=1,4
16548          VTXCAS(1,K) = WHKK(K,IDXCAS)
16549          VTXCAS(2,K) = VHKK(K,IDXCAS)
16550     3 CONTINUE
16551
16552       ICAS = 1
16553       I2   = 2
16554       IF (NCAS.EQ.-1) THEN
16555          ICAS = 2
16556          I2   = 1
16557       ENDIF
16558
16559       IF (PTOCAS(ICAS).LT.TINY10) THEN
16560          WRITE(LOUT,1000) PTOCAS
16561  1000    FORMAT(1X,'INUCAS:   warning! zero momentum of initial',
16562      &          '  hadron ',/,20X,2E12.4)
16563          GOTO 9999
16564       ENDIF
16565
16566 * reset spectator flags
16567       NSPE = 0
16568       IDXSPE(1) = 0
16569       IDXSPE(2) = 0
16570       IDSPE(1)  = 0
16571       IDSPE(2)  = 0
16572
16573 * formation length (in fm)
16574 C     IF (LCAS) THEN
16575 C        DEL0 = ZERO
16576 C     ELSE
16577          DEL0 = TAUFOR*BGCAS(ICAS)
16578          IF (ITAUVE.EQ.1) THEN
16579             AMT  = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
16580             DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
16581          ENDIF
16582 C     ENDIF
16583 *   sample from exp(-del/del0)
16584       DEL1   = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
16585 * save formation time
16586       TAUSA1 = DEL1/BGCAS(ICAS)
16587       REL1   = TAUSA1*BGCAS(I2)
16588
16589       DEL    = DEL1
16590       TAUSAM = DEL/BGCAS(ICAS)
16591       REL    = TAUSAM*BGCAS(I2)
16592
16593 * special treatment for negative particles unable to escape
16594 * nuclear potential (implemented for ap, pi-, K- only)
16595       LABSOR = .FALSE.
16596       IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
16597 *   threshold energy = nuclear potential + Coulomb potential
16598 *   (nuclear potential for hadron-nucleus interactions only)
16599          ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
16600          IF (PCAS(ICAS,4).LT.ETHR) THEN
16601             DO 4 K=1,5
16602                PCAS1(K) = PCAS(ICAS,K)
16603     4       CONTINUE
16604 *   "absorb" negative particle in nucleus
16605             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
16606             IF (IREJ1.NE.0) GOTO 9999
16607             IF (NSPE.GE.1) LABSOR = .TRUE.
16608          ENDIF
16609       ENDIF
16610
16611 * if the initial particle has not been absorbed proceed with
16612 * "normal" cascade
16613       IF (.NOT.LABSOR) THEN
16614
16615 *   calculate coordinates of hadron at the end of the formation zone
16616 *   transport-time and -step in the rest system where this step is
16617 *   treated
16618          DSTEP  = DEL*FM2MM
16619          DTIME  = DSTEP/BECAS(ICAS)
16620          RSTEP  = REL*FM2MM
16621          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16622             RTIME = RSTEP/BECAS(I2)
16623          ELSE
16624             RTIME = ZERO
16625          ENDIF
16626 *   save step whithout considering the overlapping region
16627          DSTEP1 = DEL1*FM2MM
16628          DTIME1 = DSTEP1/BECAS(ICAS)
16629          RSTEP1 = REL1*FM2MM
16630          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16631             RTIME1 = RSTEP1/BECAS(I2)
16632          ELSE
16633             RTIME1 = ZERO
16634          ENDIF
16635 *   transport to the end of the formation zone in this system
16636          DO 5 K=1,3
16637             VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
16638             VTXCA1(I2,K)   = VTXCAS(I2,K)  +RSTEP1*COSCAS(I2,K)
16639             VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
16640             VTXCAS(I2,K)   = VTXCAS(I2,K)  +RSTEP*COSCAS(I2,K)
16641     5    CONTINUE
16642          VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
16643          VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME1
16644          VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16645          VTXCAS(I2,4)   = VTXCAS(I2,4)  +RTIME
16646
16647          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16648             XCAS   = VTXCAS(ICAS,1)
16649             YCAS   = VTXCAS(ICAS,2)
16650             XNCLTA = BIMPAC*FM2MM
16651             RNCLPR = (RPROJ+RNUCLE)*FM2MM
16652             RNCLTA = (RTARG+RNUCLE)*FM2MM
16653 C           RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
16654 C           RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
16655 C           RNCLPR = (RPROJ)*FM2MM
16656 C           RNCLTA = (RTARG)*FM2MM
16657             RCASPR = SQRT( XCAS**2        +YCAS**2)
16658             RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
16659             IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
16660                IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
16661             ENDIF
16662          ENDIF
16663
16664 *   check if particle is already outside of the corresp. nucleus
16665          RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
16666      &                VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
16667          IF (RDIST.GE.RNUC(ICAS)) THEN
16668 *   here: IDCH is the generation of the final state part. starting
16669 *   with zero for hadronization products
16670 *   flag particles of generation 0 being outside the nuclei after
16671 *   formation time (to be used for excitation energy calculation)
16672             IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
16673      &         NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
16674             GOTO 9997
16675          ENDIF
16676          DIST   = DLARGE
16677          DISTP  = DLARGE
16678          DISTN  = DLARGE
16679          IDXP   = 0
16680          IDXN   = 0
16681
16682 *   already here: skip particles being outside HADRIN "energy-window"
16683 *   to avoid wasting of time
16684          NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
16685          IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
16686             NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
16687 C           WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
16688 C1002       FORMAT(1X,'INUCAS:   warning! momentum of particle with ',
16689 C    &             'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
16690 C    &             E12.4,', above or below HADRIN-thresholds',I6)
16691             NSPE = 0
16692             GOTO 9997
16693          ENDIF
16694
16695          DO 7 IDXHKK=1,NOINC
16696             I = IDXINC(IDXHKK)
16697 *   scan DTEVT1 for unwounded or excited nucleons
16698             IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
16699                DO 8 K=1,3
16700                   IF (ICAS.EQ.1) THEN
16701                      VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
16702                   ELSEIF (ICAS.EQ.2) THEN
16703                      VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
16704                   ENDIF
16705     8          CONTINUE
16706                POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
16707      &                  VTXDST(2)*COSCAS(ICAS,2)+
16708      &                  VTXDST(3)*COSCAS(ICAS,3)
16709 *   check if nucleon is situated in forward direction
16710                IF (POSNUC.GT.ZERO) THEN
16711 *   distance between hadron and this nucleon
16712                   DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16713      &                          VTXDST(3)**2)
16714 *   impact parameter
16715                   BIMNU2 = DISTNU**2-POSNUC**2
16716                   IF (BIMNU2.LT.ZERO) THEN
16717                      WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
16718  1001                FORMAT(1X,'INUCAS:   warning! inconsistent impact',
16719      &                      '  parameter ',/,20X,3E12.4)
16720                      GOTO 7
16721                   ENDIF
16722                   BIMNU  = SQRT(BIMNU2)
16723 *   maximum impact parameter to have interaction
16724                   IDNUC  = IDT_ICIHAD(IDHKK(I))
16725                   IDNUC1 = IDT_MCHAD(IDNUC)
16726                   IDCAS1 = IDT_MCHAD(IDCAS)
16727                   DO 19 K=1,5
16728                      PCAS1(K) = PCAS(ICAS,K)
16729                      PNUC(K)  = PHKK(K,I)
16730    19             CONTINUE
16731 * Lorentz-parameter for trafo into rest-system of target
16732                   DO 18 K=1,4
16733                      BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
16734    18             CONTINUE
16735 * transformation of projectile into rest-system of target
16736                   CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
16737      &                        PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
16738      &                        PPTOT,PX,PY,PZ,PE)
16739 **
16740 C                 CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
16741 C                 CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
16742                   DUMZER = ZERO
16743                   CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
16744                   CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
16745                   IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
16746      &                (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
16747                   SIGIN = SIGTOT-SIGEL-SIGAB
16748 C                 SIGTOT = SIGIN+SIGEL+SIGAB
16749 **
16750                   BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
16751 *   check if interaction is possible
16752                   IF (BIMNU.LE.BIMMAX) THEN
16753 *   get nucleon with smallest distance and kind of interaction
16754 *   (elastic/inelastic)
16755                      IF (DISTNU.LT.DIST) THEN
16756                         DIST      = DISTNU
16757                         BINT      = BIMNU
16758                         IF (IDNUC.NE.IDSPE(1)) THEN
16759                            IDSPE(2)  = IDSPE(1)
16760                            IDXSPE(2) = IDXSPE(1)
16761                            IDSPE(1)  = IDNUC
16762                         ENDIF
16763                         IDXSPE(1) = I
16764                         NSPE      = 1
16765 **sr
16766                         SELA = SIGEL
16767                         SABS = SIGAB
16768                         STOT = SIGTOT
16769 C                       IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
16770 C                          SELA = SIGEL
16771 C                          STOT = SIGIN+SIGEL
16772 C                       ELSE
16773 C                          SELA = SIGEL+0.75D0*SIGIN
16774 C                          STOT = 0.25D0*SIGIN+SELA
16775 C                       ENDIF
16776 **
16777                      ENDIF
16778                   ENDIf
16779                ENDIF
16780                DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16781      &                       VTXDST(3)**2)
16782                IDNUC  = IDT_ICIHAD(IDHKK(I))
16783                IF (IDNUC.EQ.1) THEN
16784                   IF (DISTNU.LT.DISTP) THEN
16785                      DISTP = DISTNU
16786                      IDXP  = I
16787                      POSP  = POSNUC
16788                   ENDIF
16789                ELSEIF (IDNUC.EQ.8) THEN
16790                   IF (DISTNU.LT.DISTN) THEN
16791                      DISTN = DISTNU
16792                      IDXN  = I
16793                      POSN  = POSNUC
16794                   ENDIF
16795                ENDIF
16796             ENDIF
16797     7    CONTINUE
16798
16799 * there is no nucleon for a secondary interaction
16800          IF (NSPE.EQ.0) GOTO 9997
16801
16802 C        IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
16803 C    &      WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
16804          IF (IDXSPE(2).EQ.0) THEN
16805             IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
16806 C              DO 80 K=1,3
16807 C                 IF (ICAS.EQ.1) THEN
16808 C                    VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
16809 C                 ELSEIF (ICAS.EQ.2) THEN
16810 C                    VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
16811 C                 ENDIF
16812 C  80          CONTINUE
16813 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16814 C    &                       VTXDST(3)**2)
16815 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
16816                   IDXSPE(2) = IDXN
16817                   IDSPE(2)  = 8
16818 C              ELSE
16819 C                 STOT = STOT-SABS
16820 C                 SABS = ZERO
16821 C              ENDIF
16822             ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
16823 C              DO 81 K=1,3
16824 C                 IF (ICAS.EQ.1) THEN
16825 C                    VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
16826 C                 ELSEIF (ICAS.EQ.2) THEN
16827 C                    VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
16828 C                 ENDIF
16829 C  81          CONTINUE
16830 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16831 C    &                       VTXDST(3)**2)
16832 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
16833                   IDXSPE(2) = IDXP
16834                   IDSPE(2)  = 1
16835 C              ELSE
16836 C                 STOT = STOT-SABS
16837 C                 SABS = ZERO
16838 C              ENDIF
16839             ELSE
16840                STOT = STOT-SABS
16841                SABS = ZERO
16842             ENDIF
16843          ENDIF
16844          RR = DT_RNDM(DIST)
16845          IF (RR.LT.SELA/STOT) THEN
16846             IPROC = 2
16847          ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
16848             IPROC = 3
16849          ELSE
16850             IPROC = 1
16851          ENDIF
16852
16853          DO 9 K=1,5
16854             PCAS1(K) = PCAS(ICAS,K)
16855             PNUC(K)  = PHKK(K,IDXSPE(1))
16856     9    CONTINUE
16857          IF (IPROC.EQ.3) THEN
16858 * 2-nucleon absorption of pion
16859             NSPE = 2
16860             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
16861             IF (IREJ1.NE.0) GOTO 9999
16862             IF (NSPE.GE.1) LABSOR = .TRUE.
16863          ELSE
16864 * sample secondary interaction
16865             IDNUC = IDBAM(IDXSPE(1))
16866             CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
16867             IF (IREJ1.EQ.1) GOTO 9999
16868             IF (IREJ1.GT.1) GOTO 9998
16869          ENDIF
16870       ENDIF
16871
16872 * update arrays to include Pauli-principle
16873       DO 10 I=1,NSPE
16874          IF (NWOUND(ICAS).LE.299) THEN
16875             NWOUND(ICAS) = NWOUND(ICAS)+1
16876             EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
16877          ENDIF
16878    10 CONTINUE
16879
16880 * dump initial hadron for energy-momentum conservation check
16881       IF (LEMCCK)
16882      &   CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
16883      &               PCAS(ICAS,4),1,IDUM,IDUM)
16884
16885 * dump final state particles into DTEVT1
16886
16887 *   check if Pauli-principle is fulfilled
16888       NPAULI = 0
16889       NWTMP(1) = NWOUND(1)
16890       NWTMP(2) = NWOUND(2)
16891       DO 111 I=1,NFSP
16892          NPAULI = 0
16893          J1 = 2
16894          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16895      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
16896          DO 117 J=1,J1
16897             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
16898             IF (J.EQ.1) THEN
16899                IDX = ICAS
16900                PE  = PFSP(4,I)
16901             ELSE
16902                IDX  = I2
16903                MODE = 1
16904                IF (IDX.EQ.1) MODE = -1
16905                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
16906             ENDIF
16907 * first check if cascade step is forbidden due to Pauli-principle
16908 * (in case of absorpion this step is forced)
16909             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16910      &          (IDFSP(I).EQ.8))) THEN
16911 *   get nuclear potential barrier
16912                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16913                IF (IDFSP(I).EQ.1) THEN
16914                   POTLOW = POT-EBINDP(IDX)
16915                ELSE
16916                   POTLOW = POT-EBINDN(IDX)
16917                ENDIF
16918 *   final state particle not able to escape nucleus
16919                IF (PE.LE.POTLOW) THEN
16920 *     check if there are wounded nucleons
16921                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16922      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
16923                      NPAULI      = NPAULI+1
16924                      NWOUND(IDX) = NWOUND(IDX)-1
16925                   ELSE
16926 *     interaction prohibited by Pauli-principle
16927                      NWOUND(1) = NWTMP(1)
16928                      NWOUND(2) = NWTMP(2)
16929                      GOTO 9997
16930                   ENDIF
16931                ENDIF
16932             ENDIF
16933   117    CONTINUE
16934   111 CONTINUE
16935
16936       NPAULI = 0
16937       NWOUND(1) = NWTMP(1)
16938       NWOUND(2) = NWTMP(2)
16939
16940       DO 11 I=1,NFSP
16941
16942          IST = ISTHKK(IDXCAS)
16943
16944          NPAULI = 0
16945          J1 = 2
16946          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16947      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
16948          DO 17 J=1,J1
16949             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
16950             IDX = ICAS
16951             PE  = PFSP(4,I)
16952             IF (J.EQ.2) THEN
16953                IDX = I2
16954                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
16955             ENDIF
16956 * first check if cascade step is forbidden due to Pauli-principle
16957 * (in case of absorpion this step is forced)
16958             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16959      &          (IDFSP(I).EQ.8))) THEN
16960 *   get nuclear potential barrier
16961                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16962                IF (IDFSP(I).EQ.1) THEN
16963                   POTLOW = POT-EBINDP(IDX)
16964                ELSE
16965                   POTLOW = POT-EBINDN(IDX)
16966                ENDIF
16967 *   final state particle not able to escape nucleus
16968                IF (PE.LE.POTLOW) THEN
16969 *     check if there are wounded nucleons
16970                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16971      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
16972                      NWOUND(IDX) = NWOUND(IDX)-1
16973                      NPAULI = NPAULI+1
16974                      IST    = 14+IDX
16975                   ELSE
16976 *     interaction prohibited by Pauli-principle
16977                      NWOUND(1) = NWTMP(1)
16978                      NWOUND(2) = NWTMP(2)
16979                      GOTO 9997
16980                   ENDIF
16981 **sr
16982 c               ELSEIF (PE.LE.POT) THEN
16983 cC              ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
16984 cC                 NWOUND(IDX) = NWOUND(IDX)-1
16985 c**
16986 c                  NPAULI = NPAULI+1
16987 c                  IST    = 14+IDX
16988                ENDIF
16989             ENDIF
16990    17    CONTINUE
16991
16992 * dump final state particles for energy-momentum conservation check
16993          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
16994      &                           -PFSP(4,I),2,IDUM,IDUM)
16995
16996          PX = PFSP(1,I)
16997          PY = PFSP(2,I)
16998          PZ = PFSP(3,I)
16999          PE = PFSP(4,I)
17000          IF (ABS(IST).EQ.1) THEN
17001 * transform particles back into n-n cms
17002 * LEPTO: leave final state particles in target rest frame
17003 C           IF (MCGENE.EQ.3) THEN
17004 C              PFSP(1,I) = PX
17005 C              PFSP(2,I) = PY
17006 C              PFSP(3,I) = PZ
17007 C              PFSP(4,I) = PE
17008 C           ELSE
17009                IMODE = ICAS+1
17010                CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17011      &                     PFSP(4,I),IDFSP(I),IMODE)
17012 C           ENDIF
17013          ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
17014 * target cascade but fsp got stuck in proj. --> transform it into
17015 * proj. rest system
17016             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17017      &                  PFSP(4,I),IDFSP(I),-1)
17018          ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
17019 * proj. cascade but fsp got stuck in target --> transform it into
17020 * target rest system
17021             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17022      &                  PFSP(4,I),IDFSP(I),1)
17023          ENDIF
17024
17025 * dump final state particles into DTEVT1
17026          IGEN = IDCH(IDXCAS)+1
17027          ID   = IDT_IPDGHA(IDFSP(I))
17028          IXR  = 0
17029          IF (LABSOR) IXR = 99
17030          CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
17031      &               PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
17032
17033 * update the counter for particles which got stuck inside the nucleus
17034          IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
17035             NOINC = NOINC+1
17036             IDXINC(NOINC) = NHKK
17037          ENDIF
17038          IF (LABSOR) THEN
17039 *   in case of absorption the spatial treatment is an approximate
17040 *   solution anyway (the positions of the nucleons which "absorb" the
17041 *   cascade particle are not taken into consideration) therefore the
17042 *   particles are produced at the position of the cascade particle
17043             DO 12 K=1,4
17044                WHKK(K,NHKK) = WHKK(K,IDXCAS)
17045                VHKK(K,NHKK) = VHKK(K,IDXCAS)
17046    12       CONTINUE
17047          ELSE
17048 *   DDISTL - distance the cascade particle moves to the intera. point
17049 *   (the position where impact-parameter = distance to the interacting
17050 *   nucleon), DIST - distance to the interacting nucleon at the time of
17051 *   formation of the cascade particle, BINT - impact-parameter of this
17052 *   cascade-interaction
17053             DDISTL = SQRT(DIST**2-BINT**2)
17054             DTIME  = DDISTL/BECAS(ICAS)
17055             DTIMEL = DDISTL/BGCAS(ICAS)
17056             RDISTL = DTIMEL*BGCAS(I2)
17057             IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17058                RTIME = RDISTL/BECAS(I2)
17059             ELSE
17060                RTIME = ZERO
17061             ENDIF
17062 *   RDISTL, RTIME are this step and time in the rest system of the other
17063 *   nucleus
17064             DO 13 K=1,3
17065                VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
17066                VTXCA1(I2,K)   = VTXCAS(I2,K)  +COSCAS(I2,K)  *RDISTL
17067    13       CONTINUE
17068             VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17069             VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME
17070 *   position of particle production is half the impact-parameter to
17071 *   the interacting nucleon
17072             DO 14 K=1,3
17073                WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
17074                VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
17075    14       CONTINUE
17076 *   time of production of secondary = time of interaction
17077             WHKK(4,NHKK) = VTXCA1(1,4)
17078             VHKK(4,NHKK) = VTXCA1(2,4)
17079          ENDIF
17080
17081    11 CONTINUE
17082
17083 * modify status and position of cascade particle (the latter for
17084 * statistics reasons only)
17085       ISTHKK(IDXCAS) = 2
17086       IF (LABSOR) ISTHKK(IDXCAS) = 19
17087       IF (.NOT.LABSOR) THEN
17088          DO 15 K=1,4
17089             WHKK(K,IDXCAS) = VTXCA1(1,K)
17090             VHKK(K,IDXCAS) = VTXCA1(2,K)
17091    15    CONTINUE
17092       ENDIF
17093
17094       DO 16 I=1,NSPE
17095          IS = IDXSPE(I)
17096 * dump interacting nucleons for energy-momentum conservation check
17097          IF (LEMCCK)
17098      &      CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
17099      &                                                  2,IDUM,IDUM)
17100 * modify entry for interacting nucleons
17101          IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
17102          IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
17103          IF (I.GE.2) THEN
17104             JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
17105             JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
17106          ENDIF
17107    16 CONTINUE
17108
17109 * check energy-momentum conservation
17110       IF (LEMCCK) THEN
17111          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
17112          IF (IREJ1.NE.0) GOTO 9999
17113       ENDIF
17114
17115 * update counter
17116       IF (LABSOR) THEN
17117          NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
17118       ELSE
17119          IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
17120          IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
17121       ENDIF
17122
17123       RETURN
17124
17125  9997 CONTINUE
17126  9998 CONTINUE
17127 * transport-step but no cascade step due to configuration (i.e. there
17128 * is no nucleon for interaction etc.)
17129       IF (LCAS) THEN
17130          DO 100 K=1,4
17131 C           WHKK(K,IDXCAS) = VTXCAS(1,K)
17132 C           VHKK(K,IDXCAS) = VTXCAS(2,K)
17133             WHKK(K,IDXCAS) = VTXCA1(1,K)
17134             VHKK(K,IDXCAS) = VTXCA1(2,K)
17135   100    CONTINUE
17136       ENDIF
17137
17138 C9998 CONTINUE
17139 * no cascade-step because of configuration
17140 * (i.e. hadron outside nucleus etc.)
17141       LCAS = .TRUE.
17142       RETURN
17143
17144  9999 CONTINUE
17145 * rejection
17146       IREJ = 1
17147       RETURN
17148       END
17149 *
17150 *===absorp=============================================================*
17151 *
17152 CDECK  ID>, DT_ABSORP
17153       SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
17154
17155 ************************************************************************
17156 * Two-nucleon absorption of antiprotons, pi-, and K-.                  *
17157 * Antiproton absorption is handled by HADRIN.                          *
17158 * The following channels for meson-absorption are considered:          *
17159 *          pi- + p + p ---> n + p                                      *
17160 *          pi- + p + n ---> n + n                                      *
17161 *          K-  + p + p ---> sigma+ + n / Lam + p / sigma0 + p          *
17162 *          K-  + p + n ---> sigma- + n / Lam + n / sigma0 + n          *
17163 *          K-  + p + p ---> sigma- + n                                 *
17164 *      IDCAS, PCAS   identity, momentum of particle to be absorbed     *
17165 *      NCAS =  1     intranuclear cascade in projectile                *
17166 *           = -1     intranuclear cascade in target                    *
17167 *      NSPE          number of spectator nucleons involved             *
17168 *      IDXSPE(2)     DTEVT1-indices of spectator nucleons involved     *
17169 * Revised version of the original STOPIK written by HJM and J. Ranft.  *
17170 * This version dated 24.02.95 is written by S. Roesler                 *
17171 ************************************************************************
17172
17173       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17174       SAVE
17175
17176       PARAMETER ( LINP = 5 ,
17177      &            LOUT = 6 ,
17178      &            LDAT = 9 )
17179
17180       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17181      &           ONETHI=0.3333D0,TWOTHI=0.6666D0)
17182
17183 * event history
17184
17185       PARAMETER (NMXHKK=200000)
17186
17187       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17188      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17189      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17190 * extended event history
17191       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17192      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17193      &                IHIST(2,NMXHKK)
17194 * flags for input different options
17195       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17196       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17197      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17198 * final state after inc step
17199       PARAMETER (MAXFSP=10)
17200       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17201 * particle properties (BAMJET index convention)
17202       CHARACTER*8  ANAME
17203       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17204      &                IICH(210),IIBAR(210),K1(210),K2(210)
17205
17206       DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17207      &          PTOT3P(4),BG3P(4),
17208      &          ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17209
17210       IREJ = 0
17211       NFSP = 0
17212
17213 * skip particles others than ap, pi-, K- for mode=0
17214       IF ((MODE.EQ.0).AND.
17215      &    (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17216 * skip particles others than pions for mode=1
17217 * (2-nucleon absorption in intranuclear cascade)
17218       IF ((MODE.EQ.1).AND.
17219      &    (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17220
17221       NUCAS = NCAS
17222       IF (NUCAS.EQ.-1) NUCAS = 2
17223
17224       IF (MODE.EQ.0) THEN
17225 * scan spectator nucleons for nucleons being able to "absorb"
17226          NSPE      = 0
17227          IDXSPE(1) = 0
17228          IDXSPE(2) = 0
17229          DO 1 I=1,NHKK
17230             IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17231                NSPE         = NSPE+1
17232                IDXSPE(NSPE) = I
17233                IDSPE(NSPE)  = IDBAM(I)
17234                IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17235                IF (NSPE.EQ.2) THEN
17236                   IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17237      &                                  (IDSPE(2).EQ.8)) THEN
17238 *    there is no pi-+n+n channel
17239                      NSPE = 1
17240                      GOTO 1
17241                   ELSE
17242                      GOTO 2
17243                   ENDIF
17244                ENDIF
17245             ENDIF
17246     1    CONTINUE
17247
17248     2    CONTINUE
17249       ENDIF
17250 * transform excited projectile nucleons (status=15) into proj. rest s.
17251       DO 3 I=1,NSPE
17252          DO 4 K=1,5
17253             PSPE(I,K) = PHKK(K,IDXSPE(I))
17254     4    CONTINUE
17255     3 CONTINUE
17256
17257 * antiproton absorption
17258       IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17259          DO 5 K=1,5
17260             PSPE1(K) = PSPE(1,K)
17261     5    CONTINUE
17262          CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17263          IF (IREJ1.NE.0) GOTO 9999
17264
17265 * meson absorption
17266       ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17267      &                      .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17268          IF (IDCAS.EQ.14) THEN
17269 *   pi- absorption
17270             IDFSP(1) = 8
17271             IDFSP(2) = 8
17272             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17273          ELSEIF (IDCAS.EQ.13) THEN
17274 *   pi+ absorption
17275             IDFSP(1) = 1
17276             IDFSP(2) = 1
17277             IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17278          ELSEIF (IDCAS.EQ.23) THEN
17279 *   pi0 absorption
17280             IDFSP(1) = IDSPE(1)
17281             IDFSP(2) = IDSPE(2)
17282          ELSEIF (IDCAS.EQ.16) THEN
17283 *   K- absorption
17284             R = DT_RNDM(PCAS)
17285             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17286                IF (R.LT.ONETHI) THEN
17287                   IDFSP(1) = 21
17288                   IDFSP(2) = 8
17289                ELSEIF (R.LT.TWOTHI) THEN
17290                   IDFSP(1) = 17
17291                   IDFSP(2) = 1
17292                ELSE
17293                   IDFSP(1) = 22
17294                   IDFSP(2) = 1
17295                ENDIF
17296             ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17297                IDFSP(1) = 20
17298                IDFSP(2) = 8
17299             ELSE
17300                IF (R.LT.ONETHI) THEN
17301                   IDFSP(1) = 20
17302                   IDFSP(2) = 1
17303                ELSEIF (R.LT.TWOTHI) THEN
17304                   IDFSP(1) = 17
17305                   IDFSP(2) = 8
17306                ELSE
17307                   IDFSP(1) = 22
17308                   IDFSP(2) = 8
17309                ENDIF
17310             ENDIF
17311          ENDIF
17312 *   dump initial particles for energy-momentum cons. check
17313          IF (LEMCCK) THEN
17314             CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
17315             CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
17316      &                                                    IDUM,IDUM)
17317             CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
17318      &                                                    IDUM,IDUM)
17319          ENDIF
17320 *   get Lorentz-parameter of 3 particle initial state
17321          DO 6 K=1,4
17322             PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
17323     6    CONTINUE
17324          P3P  = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
17325          AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
17326          DO 7 K=1,4
17327             BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
17328     7    CONTINUE
17329 *   2-particle decay of the 3-particle compound system
17330          CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
17331      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
17332      &               AAM(IDFSP(1)),AAM(IDFSP(2)))
17333          DO 8 I=1,2
17334             SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
17335             PX  = PCMF(I)*COFF(I)*SDF
17336             PY  = PCMF(I)*SIFF(I)*SDF
17337             PZ  = PCMF(I)*CODF(I)
17338             CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
17339      &                  ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17340      &                  PFSP(4,I))
17341             PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
17342 *   check consistency of kinematics
17343             IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
17344                WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
17345  1001          FORMAT(1X,'ABSORP:   warning! inconsistent',
17346      &                ' tree-particle kinematics',/,20X,'id: ',I3,
17347      &                ' AAM = ',E10.4,' MFSP = ',E10.4)
17348             ENDIF
17349 *   dump final state particles for energy-momentum cons. check
17350             IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17351      &                              -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17352     8    CONTINUE
17353          NFSP = 2
17354          IF (LEMCCK) THEN
17355             CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
17356             IF (IREJ1.NE.0) THEN
17357                WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
17358      &                      AM3P
17359                GOTO 9999
17360             ENDIF
17361          ENDIF
17362       ELSE
17363          IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
17364  1000    FORMAT(1X,'ABSORP:   warning! absorption for particle ',I3,
17365      &          ' impossible',/,20X,'too few spectators (',I2,')')
17366          NSPE = 0
17367       ENDIF
17368
17369       RETURN
17370
17371  9999 CONTINUE
17372       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
17373       IREJ = 1
17374       RETURN
17375       END
17376 *
17377 *===hadrin=============================================================*
17378 *
17379 CDECK  ID>, DT_HADRIN
17380       SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
17381
17382 ************************************************************************
17383 * Interface to the HADRIN-routines for inelastic and elastic           *
17384 * scattering.                                                          *
17385 *      IDPR,PPR(5)   identity, momentum of projectile                  *
17386 *      IDTA,PTA(5)   identity, momentum of target                      *
17387 *      MODE  = 1     inelastic interaction                             *
17388 *            = 2     elastic   interaction                             *
17389 * Revised version of the original FHAD.                                *
17390 * This version dated 27.10.95 is written by S. Roesler                 *
17391 ************************************************************************
17392
17393       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17394       SAVE
17395
17396       PARAMETER ( LINP = 5 ,
17397      &            LOUT = 6 ,
17398      &            LDAT = 9 )
17399
17400       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
17401      &           TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
17402
17403       LOGICAL LCORR,LMSSG
17404
17405 * flags for input different options
17406       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17407       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17408      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17409 * final state after inc step
17410       PARAMETER (MAXFSP=10)
17411       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17412 * particle properties (BAMJET index convention)
17413       CHARACTER*8  ANAME
17414       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17415      &                IICH(210),IIBAR(210),K1(210),K2(210)
17416 * output-common for DHADRI/ELHAIN
17417 * final state from HADRIN interaction
17418       PARAMETER (MAXFIN=10)
17419       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
17420      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
17421
17422       DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
17423      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
17424
17425       DATA LMSSG /.TRUE./
17426
17427       IREJ  = 0
17428       NFSP  = 0
17429       KCORR = 0
17430       IMCORR(1) = 0
17431       IMCORR(2) = 0
17432       LCORR = .FALSE.
17433
17434 *   dump initial particles for energy-momentum cons. check
17435       IF (LEMCCK) THEN
17436          CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
17437          CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
17438       ENDIF
17439
17440       AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
17441       AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
17442       IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
17443      &    (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
17444      &    (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
17445          IF (LMSSG.AND.(IOULEV(3).GT.0))
17446      &   WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
17447  1000    FORMAT(1X,'HADRIN:   warning! inconsistent projectile/target',
17448      &          ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
17449      &          E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
17450          LMSSG = .FALSE.
17451          LCORR = .TRUE.
17452       ENDIF
17453
17454 * convert initial state particles into particles which can be
17455 * handled by HADRIN
17456       IDHPR = IDPR
17457       IDHTA = IDTA
17458       IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
17459          IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
17460          DO 1 K=1,4
17461             P1IN(K) = PPR(K)
17462             P2IN(K) = PTA(K)
17463     1    CONTINUE
17464          XM1 = AAM(IDHPR)
17465          XM2 = AAM(IDHTA)
17466          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17467          IF (IREJ1.GT.0) THEN
17468             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
17469             GOTO 9999
17470          ENDIF
17471          DO 2 K=1,4
17472             PPR(K) = P1OUT(K)
17473             PTA(K) = P2OUT(K)
17474     2    CONTINUE
17475          PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
17476          PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
17477       ENDIF
17478
17479 * Lorentz-parameter for trafo into rest-system of target
17480       DO 3 K=1,4
17481          BGTA(K) = PTA(K)/PTA(5)
17482     3 CONTINUE
17483 * transformation of projectile into rest-system of target
17484       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
17485      &            PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
17486      &            PPR1(4))
17487
17488 * direction cosines of projectile in target rest system
17489       CX = PPR1(1)/PPRTO1
17490       CY = PPR1(2)/PPRTO1
17491       CZ = PPR1(3)/PPRTO1
17492
17493 * sample inelastic interaction
17494       IF (MODE.EQ.1) THEN
17495          CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
17496          IF (IRH.EQ.1) GOTO 9998
17497 * sample elastic interaction
17498       ELSEIF (MODE.EQ.2) THEN
17499          CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
17500          IF (IREJ1.NE.0) THEN
17501             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
17502             GOTO 9999
17503          ENDIF
17504          IF (IRH.EQ.1) GOTO 9998
17505       ELSE
17506          WRITE(LOUT,1001) MODE,INTHAD
17507  1001    FORMAT(1X,'HADRIN:   warning! inconsistent interaction mode',
17508      &          I4,' (INTHAD =',I4,')')
17509          GOTO 9999
17510       ENDIF
17511
17512 * transform final state particles back into Lab.
17513       DO 4 I=1,IRH
17514          NFSP = NFSP+1
17515          PX   = CXRH(I)*PLRH(I)
17516          PY   = CYRH(I)*PLRH(I)
17517          PZ   = CZRH(I)*PLRH(I)
17518          CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
17519      &               PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
17520      &               PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
17521          IDFSP(NFSP) = ITRH(I)
17522          AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
17523      &                                            PFSP(3,NFSP)**2
17524          IF (AMFSP2.LT.-TINY3) THEN
17525             WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
17526      &                       PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
17527  1002       FORMAT(1X,'HADRIN:   warning! final state particle (id = ',
17528      &             I2,') with negative mass^2',/,1X,5E12.4)
17529             GOTO 9999
17530          ELSE
17531             PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
17532             IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
17533                WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
17534      &                          PFSP(5,NFSP)
17535  1003          FORMAT(1X,'HADRIN:   warning! final state particle',
17536      &                ' (id = ',I2,') with inconsistent mass',/,1X,
17537      &                2E12.4)
17538                KCORR         = KCORR+1
17539                IF (KCORR.GT.2) GOTO 9999
17540                IMCORR(KCORR) = NFSP
17541             ENDIF
17542          ENDIF
17543 *   dump final state particles for energy-momentum cons. check
17544          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17545      &                           -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17546     4 CONTINUE
17547
17548 * transform momenta on mass shell in case of inconsistencies in
17549 * HADRIN
17550       IF (KCORR.GT.0) THEN
17551          IF (KCORR.EQ.2) THEN
17552             I1 = IMCORR(1)
17553             I2 = IMCORR(2)
17554          ELSE
17555             IF (IMCORR(1).EQ.1) THEN
17556                I1 = 1
17557                I2 = 2
17558             ELSE
17559                I1 = 1
17560                I2 = IMCORR(1)
17561             ENDIF
17562          ENDIF
17563          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
17564      &                           PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
17565          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
17566      &                           PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
17567          DO 5 K=1,4
17568             P1IN(K) = PFSP(K,I1)
17569             P2IN(K) = PFSP(K,I2)
17570     5    CONTINUE
17571          XM1 = AAM(IDFSP(I1))
17572          XM2 = AAM(IDFSP(I2))
17573          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17574          IF (IREJ1.GT.0) THEN
17575             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
17576 C           GOTO 9999
17577          ENDIF
17578          DO 6 K=1,4
17579             PFSP(K,I1) = P1OUT(K)
17580             PFSP(K,I2) = P2OUT(K)
17581     6    CONTINUE
17582          PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
17583      &                    -PFSP(2,I1)**2-PFSP(3,I1)**2)
17584          PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
17585      &                    -PFSP(2,I2)**2-PFSP(3,I2)**2)
17586 *   dump final state particles for energy-momentum cons. check
17587          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
17588      &                           -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
17589          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
17590      &                           -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
17591       ENDIF
17592
17593 * check energy-momentum conservation
17594       IF (LEMCCK) THEN
17595          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
17596          IF (IREJ1.NE.0) GOTO 9999
17597       ENDIF
17598
17599       RETURN
17600
17601  9998 CONTINUE
17602       IREJ = 2
17603       RETURN
17604
17605  9999 CONTINUE
17606       IREJ = 1
17607       RETURN
17608       END
17609 *
17610 *===hadcol=============================================================*
17611 *
17612 CDECK  ID>, DT_HADCOL
17613       SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
17614
17615 ************************************************************************
17616 * Interface to the HADRIN-routines for inelastic and elastic           *
17617 * scattering. This subroutine samples hadron-nucleus interactions      *
17618 * below DPM-threshold.                                                 *
17619 *      IDPROJ        BAMJET-index of projectile hadron                 *
17620 *      PPN           projectile momentum in target rest frame          *
17621 *      IDXTAR        DTEVT1-index of target nucleon undergoing         *
17622 *                    interaction with projectile hadron                *
17623 * This subroutine replaces HADHAD.                                     *
17624 * This version dated 5.5.95 is written by S. Roesler                   *
17625 ************************************************************************
17626
17627       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17628       SAVE
17629
17630       PARAMETER ( LINP = 5 ,
17631      &            LOUT = 6 ,
17632      &            LDAT = 9 )
17633
17634       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
17635
17636       LOGICAL LSTART
17637
17638 * event history
17639
17640       PARAMETER (NMXHKK=200000)
17641
17642       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17643      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17644      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17645 * extended event history
17646       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17647      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17648      &                IHIST(2,NMXHKK)
17649 * nuclear potential
17650       LOGICAL LFERMI
17651       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17652      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17653      &                ETACOU(2),ICOUL,LFERMI
17654 * interface HADRIN-DPM
17655       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
17656 * parameter for intranuclear cascade
17657       LOGICAL LPAULI
17658       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17659 * final state after inc step
17660       PARAMETER (MAXFSP=10)
17661       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17662 * particle properties (BAMJET index convention)
17663       CHARACTER*8  ANAME
17664       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17665      &                IICH(210),IIBAR(210),K1(210),K2(210)
17666
17667       DIMENSION PPROJ(5),PNUC(5)
17668
17669       DATA LSTART /.TRUE./
17670
17671       IREJ   = 0
17672
17673       NPOINT(1) = NHKK+1
17674
17675       TAUSAV = TAUFOR
17676 **sr 6/9/01 commented
17677 C     TAUFOR = TAUFOR/2.0D0
17678 **
17679       IF (LSTART) THEN
17680          WRITE(LOUT,1000)
17681  1000    FORMAT(/,1X,'HADCOL:  Scattering handled by HADRIN')
17682          WRITE(LOUT,1001) TAUFOR
17683  1001    FORMAT(/,1X,'HADCOL:  Formation zone parameter set to ',
17684      &          F5.1,' fm/c')
17685          LSTART = .FALSE.
17686       ENDIF
17687
17688       IDNUC  = IDBAM(IDXTAR)
17689       IDNUC1 = IDT_MCHAD(IDNUC)
17690       IDPRO1 = IDT_MCHAD(IDPROJ)
17691
17692       IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
17693          IPROC = INTHAD
17694       ELSE
17695 **
17696 C        CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
17697 C        CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
17698          DUMZER = ZERO
17699          CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
17700          SIGIN = SIGTOT-SIGEL
17701 C        SIGTOT = SIGIN+SIGEL
17702 **
17703          IPROC  = 1
17704          IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
17705       ENDIF
17706
17707       PPROJ(1) = ZERO
17708       PPROJ(2) = ZERO
17709       PPROJ(3) = PPN
17710       PPROJ(5) = AAM(IDPROJ)
17711       PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
17712       DO 1 K=1,5
17713          PNUC(K)  = PHKK(K,IDXTAR)
17714     1 CONTINUE
17715
17716       ILOOP = 0
17717     2 CONTINUE
17718       ILOOP = ILOOP+1
17719       IF (ILOOP.GT.100) GOTO 9999
17720
17721       CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
17722       IF (IREJ1.EQ.1) GOTO 9999
17723
17724       IF (IREJ1.GT.1) THEN
17725 * no interaction possible
17726 *   require Pauli blocking
17727          IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
17728          IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
17729          IF ((IIBAR(IDPROJ).NE.1).AND.
17730      &       (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5)))              GOTO 2
17731 *   store incoming particle as final state particle
17732          CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
17733          CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
17734          NPOINT(4) = NHKK
17735       ELSE
17736 * require Pauli blocking for final state nucleons
17737          DO 4 I=1,NFSP
17738             IF ((IDFSP(I).EQ.1).AND.
17739      &          (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I))))       GOTO 2
17740             IF ((IDFSP(I).EQ.8).AND.
17741      &          (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I))))       GOTO 2
17742             IF ((IIBAR(IDFSP(I)).NE.1).AND.
17743      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
17744     4    CONTINUE
17745 * store final state particles
17746          DO 5 I=1,NFSP
17747             IST = 1
17748             IF ((IIBAR(IDFSP(I)).EQ.1).AND.
17749      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
17750             IDHAD = IDT_IPDGHA(IDFSP(I))
17751             CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
17752             CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
17753      &                                        PCMS,ECMS,0,0,0)
17754             IF (I.EQ.1) NPOINT(4) = NHKK
17755             VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
17756             VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
17757             VHKK(3,NHKK) = VHKK(3,IDXTAR)
17758             VHKK(4,NHKK) = VHKK(4,IDXTAR)
17759             WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
17760             WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
17761             WHKK(3,NHKK) = WHKK(3,1)
17762             WHKK(4,NHKK) = WHKK(4,1)
17763     5    CONTINUE
17764       ENDIF
17765       TAUFOR = TAUSAV
17766       RETURN
17767
17768  9999 CONTINUE
17769       IREJ = 1
17770       TAUFOR = TAUSAV
17771       RETURN
17772       END
17773 *
17774 *===getemu=============================================================*
17775 *
17776 CDECK  ID>, DT_GETEMU
17777       SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
17778
17779 ************************************************************************
17780 * Sampling of emulsion component to be considered as target-nucleus.   *
17781 * This version dated 6.5.95   is written by S. Roesler.                *
17782 ************************************************************************
17783
17784       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17785       SAVE
17786
17787       PARAMETER ( LINP = 5 ,
17788      &            LOUT = 6 ,
17789      &            LDAT = 9 )
17790
17791       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
17792
17793       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
17794
17795 * emulsion treatment
17796       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
17797      &                NCOMPO,IEMUL
17798 * Glauber formalism: flags and parameters for statistics
17799       LOGICAL LPROD
17800       CHARACTER*8 CGLB
17801       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
17802
17803       IF (MODE.EQ.0) THEN
17804          SUMFRA = ZERO
17805          RR = DT_RNDM(SUMFRA)
17806          IT  = 0
17807          ITZ = 0
17808          DO 1 ICOMP=1,NCOMPO
17809             SUMFRA = SUMFRA+EMUFRA(ICOMP)
17810             IF (SUMFRA.GT.RR) THEN
17811                IT    = IEMUMA(ICOMP)
17812                ITZ   = IEMUCH(ICOMP)
17813                KKMAT = ICOMP
17814                GOTO 2
17815             ENDIF
17816     1    CONTINUE
17817     2    CONTINUE
17818          IF (IT.LE.0) THEN
17819             WRITE(LOUT,'(1X,A,E12.3)')
17820      &       'Warning!  norm. failure within emulsion fractions',
17821      &       SUMFRA
17822             STOP
17823          ENDIF
17824       ELSEIF (MODE.EQ.1) THEN
17825          NDIFF = 10000
17826          DO 3 I=1,NCOMPO
17827             IDIFF = ABS(IT-IEMUMA(I))
17828             IF (IDIFF.LT.NDIFF) THEN
17829                KKMAT = I
17830                NDIFF = IDIFF
17831             ENDIF
17832     3    CONTINUE
17833       ELSE
17834          STOP 'DT_GETEMU'
17835       ENDIF
17836
17837 * bypass for variable projectile/target/energy runs: the correct
17838 * Glauber data will be always loaded on kkmat=1
17839       IF (IOGLB.EQ.100) THEN
17840          KKMAT = 1
17841       ENDIF
17842
17843       RETURN
17844       END
17845 *
17846 *===nclpot=============================================================*
17847 *
17848 CDECK  ID>, DT_NCLPOT
17849       SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
17850
17851 ************************************************************************
17852 * Calculation of Coulomb and nuclear potential for a given configurat. *
17853 *               IPZ, IP       charge/mass number of proj.              *
17854 *               ITZ, IT       charge/mass number of targ.              *
17855 *               AFERP,AFERT   factors modifying proj./target pot.      *
17856 *                             if =0, FERMOD is used                    *
17857 *               MODE = 0      calculation of binding energy            *
17858 *                    = 1      pre-calculated binding energy is used    *
17859 * This version dated 16.11.95  is written by S. Roesler.               *
17860 ************************************************************************
17861
17862       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17863       SAVE
17864
17865       PARAMETER ( LINP = 5 ,
17866      &            LOUT = 6 ,
17867      &            LDAT = 9 )
17868
17869       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
17870      &           TINY10=1.0D-10)
17871
17872       LOGICAL LSTART
17873
17874 * particle properties (BAMJET index convention)
17875       CHARACTER*8  ANAME
17876       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17877      &                IICH(210),IIBAR(210),K1(210),K2(210)
17878 * nuclear potential
17879       LOGICAL LFERMI
17880       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17881      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17882      &                ETACOU(2),ICOUL,LFERMI
17883
17884       DIMENSION IDXPOT(14)
17885 *                   ap   an  lam  alam sig- sig+ sig0 tet0 tet- asig-
17886       DATA IDXPOT /   2,   9,  17,  18,  20,  21,  22,  97,  98,  99,
17887 *                 asig0 asig+ atet0 atet+
17888      &              100, 101, 102, 103/
17889
17890       DATA AN     /0.4D0/
17891       DATA LSTART /.TRUE./
17892
17893       IF (MODE.EQ.0) THEN
17894          EBINDP(1) = ZERO
17895          EBINDN(1) = ZERO
17896          EBINDP(2) = ZERO
17897          EBINDN(2) = ZERO
17898       ENDIF
17899       AIP  = DBLE(IP)
17900       AIPZ = DBLE(IPZ)
17901       AIT  = DBLE(IT)
17902       AITZ = DBLE(ITZ)
17903
17904       FERMIP = AFERP
17905       IF (AFERP.LE.ZERO) FERMIP = FERMOD
17906       FERMIT = AFERT
17907       IF (AFERT.LE.ZERO) FERMIT = FERMOD
17908
17909 * Fermi momenta and binding energy for projectile
17910       IF ((IP.GT.1).AND.LFERMI) THEN
17911          IF (MODE.EQ.0) THEN
17912 C           EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
17913 C           EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
17914             BIP  = AIP -ONE
17915             BIPZ = AIPZ-ONE
17916
17917             EBINDP(1) = 1.0D-3*ABS(ENERGY(AIP,AIPZ)
17918      &                            -ENERGY(BIP,BIPZ))
17919
17920             IF (AIP.LE.AIPZ) THEN
17921                EBINDN(1) = EBINDP(1)
17922                WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
17923             ELSE
17924
17925                EBINDN(1) = 1.0D-3*ABS(ENERGY(AIP,AIPZ)
17926      &                               -ENERGY(BIP,AIPZ))
17927
17928             ENDIF
17929          ENDIF
17930          PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
17931          PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
17932       ELSE
17933          PFERMP(1) = ZERO
17934          PFERMN(1) = ZERO
17935       ENDIF
17936 * effective nuclear potential for projectile
17937 C     EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
17938 C     EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
17939       EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
17940       EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
17941
17942 * Fermi momenta and binding energy for target
17943       IF ((IT.GT.1).AND.LFERMI) THEN
17944          IF (MODE.EQ.0) THEN
17945 C           EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
17946 C           EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
17947             BIT  = AIT -ONE
17948             BITZ = AITZ-ONE
17949
17950             EBINDP(2) = 1.0D-3*ABS(ENERGY(AIT,AITZ)
17951      &                            -ENERGY(BIT,BITZ))
17952
17953             IF (AIT.LE.AITZ) THEN
17954                EBINDN(2) = EBINDP(2)
17955                WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
17956             ELSE
17957
17958                EBINDN(2) = 1.0D-3*ABS(ENERGY(AIT,AITZ)
17959      &                               -ENERGY(BIT,AITZ))
17960
17961             ENDIF
17962          ENDIF
17963          PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
17964          PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
17965       ELSE
17966          PFERMP(2) = ZERO
17967          PFERMN(2) = ZERO
17968       ENDIF
17969 * effective nuclear potential for target
17970 C     EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
17971 C     EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
17972       EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
17973       EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
17974
17975       DO 2 I=1,14
17976          EPOT(1,IDXPOT(I)) = EPOT(1,8)
17977          EPOT(2,IDXPOT(I)) = EPOT(2,8)
17978     2 CONTINUE
17979
17980 * Coulomb energy
17981       ETACOU(1) = ZERO
17982       ETACOU(2) = ZERO
17983       IF (ICOUL.EQ.1) THEN
17984          IF (IP.GT.1)
17985      &   ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
17986          IF (IT.GT.1)
17987      &   ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
17988       ENDIF
17989
17990       IF (LSTART) THEN
17991          WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
17992      &                    EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
17993      &                    EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
17994      &                    FERMOD,ETACOU
17995  1000    FORMAT(/,/,1X,'NCLPOT:    quantities for inclusion of nuclear'
17996      &           ,' effects',/,12X,'---------------------------',
17997      &           '----------------',/,/,38X,'projectile',
17998      &           '      target',/,/,1X,'Mass number / charge',
17999      &           17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy  -',
18000      &           ' proton   (GeV) ',2E14.4,/,17X,'- neutron  (GeV)'
18001      &          ,1X,2E14.4,/,1X,'Fermi-potential - proton   (GeV)',
18002      &           1X,2E14.4,/,17X,'- neutron  (GeV) ',2E14.4,/,/,
18003      &           1X,'Scale factor for Fermi-momentum    ',F4.2,/,
18004      &           /,1X,'Coulomb-energy ',2(E14.4,' GeV  '),/,/)
18005          LSTART = .FALSE.
18006       ENDIF
18007
18008       RETURN
18009       END
18010 *
18011 *===resncl=============================================================*
18012 *
18013 CDECK  ID>, DT_RESNCL
18014       SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
18015
18016 ************************************************************************
18017 * Treatment of residual nuclei and nuclear effects.                    *
18018 *         MODE = 1     initializations                                 *
18019 *              = 2     treatment of final state                        *
18020 * This version dated 16.11.95 is written by S. Roesler.                *
18021 ************************************************************************
18022
18023       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18024       SAVE
18025
18026       PARAMETER ( LINP = 5 ,
18027      &            LOUT = 6 ,
18028      &            LDAT = 9 )
18029
18030       PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
18031      &           TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
18032      &           ONETHI=ONE/THREE)
18033       PARAMETER (AMUAMU = 0.93149432D0,
18034      &           FM2MM  = 1.0D-12,
18035      &           RNUCLE = 1.12D0)
18036
18037 * event history
18038
18039       PARAMETER (NMXHKK=200000)
18040
18041       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18042      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18043      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18044 * extended event history
18045       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18046      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18047      &                IHIST(2,NMXHKK)
18048 * particle properties (BAMJET index convention)
18049       CHARACTER*8  ANAME
18050       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18051      &                IICH(210),IIBAR(210),K1(210),K2(210)
18052 * flags for input different options
18053       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18054       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18055      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18056 * nuclear potential
18057       LOGICAL LFERMI
18058       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18059      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18060      &                ETACOU(2),ICOUL,LFERMI
18061 * properties of interacting particles
18062       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18063 * properties of photon/lepton projectiles
18064       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
18065 * Lorentz-parameters of the current interaction
18066       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
18067      &                UMO,PPCM,EPROJ,PPROJ
18068 * treatment of residual nuclei: wounded nucleons
18069       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18070 * treatment of residual nuclei: 4-momenta
18071       LOGICAL LRCLPR,LRCLTA
18072       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18073      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18074
18075       DIMENSION PFSP(4),PSEC(4),PSEC0(4)
18076       DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
18077      &          IDXCOR(15000),IDXOTH(NMXHKK)
18078
18079       GOTO (1,2) MODE
18080
18081 *------- initializations
18082     1 CONTINUE
18083
18084 * initialize arrays for residual nuclei
18085       DO 10 K=1,5
18086          IF (K.LE.4) THEN
18087             PFSP(K)     = ZERO
18088          ENDIF
18089          PINIPR(K) = ZERO
18090          PINITA(K) = ZERO
18091          PRCLPR(K) = ZERO
18092          PRCLTA(K) = ZERO
18093          TRCLPR(K) = ZERO
18094          TRCLTA(K) = ZERO
18095    10 CONTINUE
18096       SCPOT = ONE
18097       NLOOP = 0
18098
18099 * correction of projectile 4-momentum for effective target pot.
18100 * and Coulomb-energy (in case of hadron-nucleus interaction only)
18101       IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18102          EPNI = EPN
18103 *   Coulomb-energy:
18104 *     positively charged hadron - check energy for Coloumb pot.
18105          IF (IICH(IJPROJ).EQ.1) THEN
18106             THRESH = ETACOU(2)+AAM(IJPROJ)
18107             IF (EPNI.LE.THRESH) THEN
18108                WRITE(LOUT,1000)
18109  1000          FORMAT(/,1X,'KKINC:  WARNING!  projectile energy',
18110      &                ' below Coulomb threshold - event rejected',/)
18111                ISTHKK(1) = 1
18112                RETURN
18113             ENDIF
18114 *     negatively charged hadron - increase energy by Coulomb energy
18115          ELSEIF (IICH(IJPROJ).EQ.-1) THEN
18116             EPNI = EPNI+ETACOU(2)
18117          ENDIF
18118          IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
18119 *   Effective target potential
18120 *sr 6.6. binding energy only (to avoid negative exc. energies)
18121 C           EPNI = EPNI+EPOT(2,IJPROJ)
18122             EBIPOT = EBINDP(2)
18123             IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
18124      &         EBIPOT = EBINDN(2)
18125             EPNI = EPNI+ABS(EBIPOT)
18126 * re-initialization of DTLTRA
18127             DUM1 = ZERO
18128             DUM2 = ZERO
18129             CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
18130          ENDIF
18131       ENDIF
18132
18133 * projectile in n-n cms
18134       IF ((IP.LE.1).AND.(IT.GT.1)) THEN
18135          PMASS1 = AAM(IJPROJ)
18136 C* VDM assumption
18137 C         IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
18138          IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
18139          PMASS2 = AAM(1)
18140          PM1 = SIGN(PMASS1**2,PMASS1)
18141          PM2 = SIGN(PMASS2**2,PMASS2)
18142          PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
18143          PINIPR(5) = PMASS1
18144          IF (PMASS1.GT.ZERO) THEN
18145             PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
18146      &                      *(PINIPR(4)+PINIPR(5)))
18147          ELSE
18148             PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
18149          ENDIF
18150          AIT  = DBLE(IT)
18151          AITZ = DBLE(ITZ)
18152
18153          PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18154
18155          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18156       ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
18157          PMASS1 = AAM(1)
18158          PMASS2 = AAM(IJTARG)
18159          PM1 = SIGN(PMASS1**2,PMASS1)
18160          PM2 = SIGN(PMASS2**2,PMASS2)
18161          PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
18162          PINITA(5) = PMASS2
18163          PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
18164      &                    *(PINITA(4)+PINITA(5)))
18165          AIP  = DBLE(IP)
18166          AIPZ = DBLE(IPZ)
18167
18168          PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18169
18170          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18171       ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
18172          AIP  = DBLE(IP)
18173          AIPZ = DBLE(IPZ)
18174
18175          PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18176
18177          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18178          AIT  = DBLE(IT)
18179          AITZ = DBLE(ITZ)
18180
18181          PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18182
18183          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18184       ENDIF
18185
18186       RETURN
18187
18188 *------- treatment of final state
18189     2 CONTINUE
18190
18191       NLOOP = NLOOP+1
18192       IF (NLOOP.GT.1) SCPOT = 0.10D0
18193 C     WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18194
18195       JPW  = NPW
18196       JPCW = NPCW
18197       JTW  = NTW
18198       JTCW = NTCW
18199       DO 40 K=1,4
18200          PFSP(K)   = ZERO
18201    40 CONTINUE
18202
18203       NOB = 0
18204       NOM = 0
18205       DO 900 I=NPOINT(4),NHKK
18206          IDXOTH(I) = -1
18207          IF (ISTHKK(I).EQ.1) THEN
18208             IF (IDBAM(I).EQ.7) GOTO 900
18209             IPOT = 0
18210             IOTHER = 0
18211 * particle moving into forward direction
18212             IF (PHKK(3,I).GE.ZERO) THEN
18213 *   most likely to be effected by projectile potential
18214                IPOT = 1
18215 *     there is no projectile nucleus, try target
18216                IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18217                   IPOT   = 2
18218                   IF (IP.GT.1) IOTHER = 1
18219 *       there is no target nucleus --> skip
18220                   IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18221                ENDIF
18222 * particle moving into backward direction
18223             ELSE
18224 *   most likely to be effected by target potential
18225                IPOT = 2
18226 *     there is no target nucleus, try projectile
18227                IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18228                   IPOT   = 1
18229                   IF (IT.GT.1) IOTHER = 1
18230 *       there is no projectile nucleus --> skip
18231                   IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18232                ENDIF
18233             ENDIF
18234             IFLG = -IPOT
18235 * nobam=3: particle is in overlap-region or neither inside proj. nor target
18236 *      =1: particle is not in overlap-region AND is inside target (2)
18237 *      =2: particle is not in overlap-region AND is inside projectile (1)
18238 * flag particles which are inside the nucleus ipot but not in its
18239 * overlap region
18240             IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
18241 * baryons: keep all nucleons and all others where flag is set
18242             IF (IIBAR(IDBAM(I)).NE.0) THEN
18243                IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
18244      &                                                           THEN
18245                   NOB = NOB+1
18246                   PMOMB(NOB) = PHKK(3,I)
18247                   IDXB(NOB)  = SIGN(1000000*IABS(IFLG)
18248      &                        +100000*IOTHER+I,IFLG)
18249                ENDIF
18250 * mesons: keep only those mesons where flag is set
18251             ELSE
18252                IF (IFLG.GT.0) THEN
18253                   NOM = NOM+1
18254                   PMOMM(NOM) = PHKK(3,I)
18255                   IDXM(NOM)  = 1000000*IFLG+100000*IOTHER+I
18256                ENDIF
18257             ENDIF
18258          ENDIF
18259   900 CONTINUE
18260 *
18261 * sort particles in the arrays according to increasing long. momentum
18262       CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
18263       CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
18264 *
18265 * shuffle indices into one and the same array according to the later
18266 * sequence of correction
18267       NCOR = 0
18268       IF (IT.GT.1) THEN
18269          DO 910 I=1,NOB
18270             IF (PMOMB(I).GT.ZERO) GOTO 911
18271             NCOR = NCOR+1
18272             IDXCOR(NCOR) = IDXB(I)
18273   910    CONTINUE
18274   911    CONTINUE
18275          IF (IP.GT.1) THEN
18276             DO 912 J=1,NOB
18277                I = NOB+1-J
18278                IF (PMOMB(I).LT.ZERO) GOTO 913
18279                NCOR = NCOR+1
18280                IDXCOR(NCOR) = IDXB(I)
18281   912       CONTINUE
18282   913       CONTINUE
18283          ELSE
18284             DO 914 I=1,NOB
18285                IF (PMOMB(I).GT.ZERO) THEN
18286                   NCOR = NCOR+1
18287                   IDXCOR(NCOR) = IDXB(I)
18288                ENDIF
18289   914       CONTINUE
18290          ENDIF
18291       ELSE
18292          DO 915 J=1,NOB
18293             I = NOB+1-J
18294             NCOR = NCOR+1
18295             IDXCOR(NCOR) = IDXB(I)
18296   915    CONTINUE
18297       ENDIF
18298       DO 925 I=1,NOM
18299          IF (PMOMM(I).GT.ZERO) GOTO 926
18300          NCOR = NCOR+1
18301          IDXCOR(NCOR) = IDXM(I)
18302   925 CONTINUE
18303   926 CONTINUE
18304       DO 927 J=1,NOM
18305          I = NOM+1-J
18306          IF (PMOMM(I).LT.ZERO) GOTO 928
18307          NCOR = NCOR+1
18308          IDXCOR(NCOR) = IDXM(I)
18309   927 CONTINUE
18310   928 CONTINUE
18311 *
18312 C      IF (NEVHKK.EQ.484) THEN
18313 C         WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
18314 C 9000    FORMAT(1X,'wounded nucleons (proj.-p,n  targ.-p,n)',/,4I10)
18315 C         WRITE(LOUT,9001) NOB,NOM,NCOR
18316 C 9001    FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
18317 C         WRITE(LOUT,'(/,A)') ' baryons '
18318 C         DO 950 I=1,NOB
18319 CC           J     = IABS(IDXB(I))
18320 CC           INDEX = J-IABS(J/1000000)*1000000
18321 C            IPOT   = IABS(IDXB(I))/1000000
18322 C            IOTHER = IABS(IDXB(I))/100000-IPOT*10
18323 C            INDEX = IABS(IDXB(I))-IPOT*1000000-IOTHER*100000
18324 C            WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
18325 C  950    CONTINUE
18326 C         WRITE(LOUT,'(/,A)') ' mesons '
18327 C         DO 951 I=1,NOM
18328 CC           INDEX = IDXM(I)-IABS(IDXM(I)/1000000)*1000000
18329 C            IPOT   = IABS(IDXM(I))/1000000
18330 C            IOTHER = IABS(IDXM(I))/100000-IPOT*10
18331 C            INDEX = IABS(IDXM(I))-IPOT*1000000-IOTHER*100000
18332 C            WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
18333 C  951    CONTINUE
18334 C 9002    FORMAT(1X,4I14,E14.5)
18335 C         WRITE(LOUT,'(/,A)') ' all '
18336 C         DO 952 I=1,NCOR
18337 CC           J     = IABS(IDXCOR(I))
18338 CC           INDEX = J-IABS(J/1000000)*1000000
18339 CC            IPOT   = IABS(IDXCOR(I))/1000000
18340 C            IOTHER = IABS(IDXCOR(I))/100000-IPOT*10
18341 C            INDEX = IABS(IDXCOR(I))-IPOT*1000000-IOTHER*100000
18342 C            WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
18343 C  952    CONTINUE
18344 C 9003    FORMAT(1X,4I14)
18345 C      ENDIF
18346 *
18347       DO 20 ICOR=1,NCOR
18348          IPOT   = IABS(IDXCOR(ICOR))/1000000
18349          IOTHER = IABS(IDXCOR(ICOR))/100000-IPOT*10
18350          I = IABS(IDXCOR(ICOR))-IPOT*1000000-IOTHER*100000
18351          IDXOTH(I) = 1
18352
18353          IDSEC  = IDBAM(I)
18354
18355 * reduction of particle momentum by corresponding nuclear potential
18356 * (this applies only if Fermi-momenta are requested)
18357
18358          IF (LFERMI) THEN
18359
18360 *   Lorentz-transformation into the rest system of the selected nucleus
18361             IMODE = -IPOT-1
18362             CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18363      &                  PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
18364             PSECO  = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
18365             AMSEC  = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
18366             JPMOD  = 0
18367
18368             CHKLEV = TINY3
18369             IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
18370             IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
18371             IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
18372                IF (IOULEV(3).GT.0)
18373      &            WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
18374  2000          FORMAT(1X,'RESNCL: inconsistent mass of particle',
18375      &                ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
18376      &                I4,'   AMSEC: ',E12.3,'  AAM(IDSEC): ',E12.3,/)
18377                GOTO 23
18378             ENDIF
18379
18380             DO 21 K=1,4
18381                PSEC0(K) = PSEC(K)
18382    21       CONTINUE
18383
18384 *   the correction for nuclear potential effects is applied to as many
18385 *   p/n as many nucleons were wounded; the momenta of other final state
18386 *   particles are corrected only if they materialize inside the corresp.
18387 *   nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
18388 *   = 3 part. outside proj. and targ., >=10 in overlapping region)
18389             IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
18390                IF (IPOT.EQ.1) THEN
18391                   IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
18392 *      this is most likely a wounded nucleon
18393 **test
18394 C                    RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
18395 C    &                           +(VHKK(2,IPW(JPW))/FM2MM)**2
18396 C    &                           +(VHKK(3,IPW(JPW))/FM2MM)**2)
18397 C                    RAD   = RNUCLE*DBLE(IP)**ONETHI
18398 C                    FDEN  = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
18399 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18400 **
18401                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18402                      JPW = JPW-1
18403                      JPMOD = 1
18404                   ELSE
18405 *      correct only if part. was materialized inside nucleus
18406 *      and if it is ouside the overlapping region
18407                      IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
18408                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18409                         JPMOD = 1
18410                      ENDIF
18411                   ENDIF
18412                ELSEIF (IPOT.EQ.2) THEN
18413                   IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
18414 *      this is most likely a wounded nucleon
18415 **test
18416 C                    RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
18417 C    &                           +(VHKK(2,ITW(JTW))/FM2MM)**2
18418 C    &                           +(VHKK(3,ITW(JTW))/FM2MM)**2)
18419 C                    RAD   = RNUCLE*DBLE(IT)**ONETHI
18420 C                    FDEN  = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
18421 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18422 **
18423                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18424                      JTW = JTW-1
18425                      JPMOD = 1
18426                   ELSE
18427 *      correct only if part. was materialized inside nucleus
18428                      IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
18429                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18430                         JPMOD = 1
18431                      ENDIF
18432                   ENDIF
18433                ENDIF
18434             ELSE
18435                IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
18436                   PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18437                   JPMOD = 1
18438                ENDIF
18439             ENDIF
18440
18441             IF (NLOOP.EQ.1) THEN
18442 * Coulomb energy correction:
18443 * the treatment of Coulomb potential correction is similar to the
18444 * one for nuclear potential
18445                IF (IDSEC.EQ.1) THEN
18446                   IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
18447                      JPCW = JPCW-1
18448                   ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
18449                      JTCW = JTCW-1
18450                   ELSE
18451                      IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18452                   ENDIF
18453                ELSE
18454                   IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18455                ENDIF
18456                IF (IICH(IDSEC).EQ.1) THEN
18457 *    pos. particles: check if they are able to escape Coulomb potential
18458                   IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
18459                      ISTHKK(I) = 14+IPOT
18460                      IF (ISTHKK(I).EQ.15) THEN
18461                         DO 26 K=1,4
18462                            PHKK(K,I) = PSEC0(K)
18463                            TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18464    26                CONTINUE
18465                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18466                         IF (IDSEC.EQ.1) NPCW = NPCW-1
18467                      ELSEIF (ISTHKK(I).EQ.16) THEN
18468                         DO 27 K=1,4
18469                            PHKK(K,I) = PSEC0(K)
18470                            TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18471    27                   CONTINUE
18472                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18473                         IF (IDSEC.EQ.1) NTCW = NTCW-1
18474                      ENDIF
18475                      GOTO 20
18476                   ENDIF
18477                ELSEIF (IICH(IDSEC).EQ.-1) THEN
18478 *    neg. particles: decrease energy by Coulomb-potential
18479                   PSEC(4) = PSEC(4)-ETACOU(IPOT)
18480                   JPMOD = 1
18481                ENDIF
18482             ENDIF
18483
18484    25       CONTINUE
18485
18486             IF (PSEC(4).LT.AMSEC) THEN
18487                IF (IOULEV(6).GT.0)
18488      &            WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
18489  2001          FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
18490      &                ' is not allowed to escape nucleus',/,
18491      &                8X,'id : ',I3,'   reduced energy: ',E15.4,
18492      &                '   mass: ',E12.3)
18493                ISTHKK(I) = 14+IPOT
18494                IF (ISTHKK(I).EQ.15) THEN
18495                   DO 28 K=1,4
18496                      PHKK(K,I) = PSEC0(K)
18497                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18498    28             CONTINUE
18499                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18500                   IF (IDSEC.EQ.1) NPCW = NPCW-1
18501                ELSEIF (ISTHKK(I).EQ.16) THEN
18502                   DO 29 K=1,4
18503                      PHKK(K,I) = PSEC0(K)
18504                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18505    29             CONTINUE
18506                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18507                   IF (IDSEC.EQ.1) NTCW = NTCW-1
18508                ENDIF
18509                GOTO 20
18510             ENDIF
18511
18512             IF (JPMOD.EQ.1) THEN
18513                PSECN  = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
18514 * 4-momentum after correction for nuclear potential
18515                DO 22 K=1,3
18516                   PSEC(K) = PSEC(K)*PSECN/PSECO
18517    22          CONTINUE
18518
18519 * store recoil momentum from particles escaping the nuclear potentials
18520                DO 30 K=1,4
18521                   IF (IPOT.EQ.1) THEN
18522                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
18523                   ELSEIF (IPOT.EQ.2) THEN
18524                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
18525                   ENDIF
18526    30          CONTINUE
18527
18528 * transform momentum back into n-n cms
18529                IMODE = IPOT+1
18530                CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
18531      &                     PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18532      &                     IDSEC,IMODE)
18533             ENDIF
18534
18535          ENDIF
18536
18537    23    CONTINUE
18538          DO 31 K=1,4
18539             PFSP(K) = PFSP(K)+PHKK(K,I)
18540    31    CONTINUE
18541
18542    20 CONTINUE
18543
18544       DO 33 I=NPOINT(4),NHKK
18545          IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
18546             PFSP(1) = PFSP(1)+PHKK(1,I)
18547             PFSP(2) = PFSP(2)+PHKK(2,I)
18548             PFSP(3) = PFSP(3)+PHKK(3,I)
18549             PFSP(4) = PFSP(4)+PHKK(4,I)
18550          ENDIF
18551    33 CONTINUE
18552
18553       DO 34 K=1,5
18554          PRCLPR(K) = TRCLPR(K)
18555          PRCLTA(K) = TRCLTA(K)
18556    34 CONTINUE
18557
18558       IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18559 * hadron-nucleus interactions: get residual momentum from energy-
18560 * momentum conservation
18561          DO 32 K=1,4
18562             PRCLPR(K) = ZERO
18563             PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
18564    32    CONTINUE
18565       ELSE
18566 * nucleus-hadron, nucleus-nucleus: get residual momentum from
18567 * accumulated recoil momenta of particles leaving the spectators
18568 *   transform accumulated recoil momenta of residual nuclei into
18569 *   n-n cms
18570          PZI = PRCLPR(3)
18571          PEI = PRCLPR(4)
18572          CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
18573          PZI = PRCLTA(3)
18574          PEI = PRCLTA(4)
18575          CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
18576 C        IF (IP.GT.1) THEN
18577             PRCLPR(3) = PRCLPR(3)+PINIPR(3)
18578             PRCLPR(4) = PRCLPR(4)+PINIPR(4)
18579 C        ENDIF
18580          IF (IT.GT.1) THEN
18581             PRCLTA(3) = PRCLTA(3)+PINITA(3)
18582             PRCLTA(4) = PRCLTA(4)+PINITA(4)
18583          ENDIF
18584       ENDIF
18585
18586 * check momenta of residual nuclei
18587       IF (LEMCCK) THEN
18588          CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
18589      &               1,IDUM,IDUM)
18590          CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
18591      &               2,IDUM,IDUM)
18592          CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
18593      &               2,IDUM,IDUM)
18594          CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
18595      &               2,IDUM,IDUM)
18596          CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
18597 **sr 19.12. changed to avoid output when used with phojet
18598 C        CHKLEV = TINY3
18599          CHKLEV = TINY1
18600          CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
18601 C        IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
18602 C    &      CALL DT_EVTOUT(4)
18603          IF (IREJ1.GT.0) RETURN
18604       ENDIF
18605
18606       RETURN
18607       END
18608 *
18609 *===scn4ba=============================================================*
18610 *
18611 CDECK  ID>, DT_SCN4BA
18612       SUBROUTINE DT_SCN4BA
18613
18614 ************************************************************************
18615 * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot.    *
18616 * This version dated 12.12.95 is written by S. Roesler.                *
18617 ************************************************************************
18618
18619       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18620       SAVE
18621
18622       PARAMETER ( LINP = 5 ,
18623      &            LOUT = 6 ,
18624      &            LDAT = 9 )
18625
18626       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18627      &           TINY10=1.0D-10)
18628
18629 * event history
18630
18631       PARAMETER (NMXHKK=200000)
18632
18633       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18634      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18635      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18636 * extended event history
18637       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18638      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18639      &                IHIST(2,NMXHKK)
18640 * particle properties (BAMJET index convention)
18641       CHARACTER*8  ANAME
18642       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18643      &                IICH(210),IIBAR(210),K1(210),K2(210)
18644 * properties of interacting particles
18645       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18646 * nuclear potential
18647       LOGICAL LFERMI
18648       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18649      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18650      &                ETACOU(2),ICOUL,LFERMI
18651 * treatment of residual nuclei: wounded nucleons
18652       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18653 * treatment of residual nuclei: 4-momenta
18654       LOGICAL LRCLPR,LRCLTA
18655       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18656      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18657
18658       DIMENSION PLAB(2,5),PCMS(4)
18659
18660       IREJ = 0
18661
18662 * get number of wounded nucleons
18663       NPW    = 0
18664       NPW0   = 0
18665       NPCW   = 0
18666       NPSTCK = 0
18667       NTW    = 0
18668       NTW0   = 0
18669       NTCW   = 0
18670       NTSTCK = 0
18671
18672       ISGLPR = 0
18673       ISGLTA = 0
18674       LRCLPR = .FALSE.
18675       LRCLTA = .FALSE.
18676
18677 C     DO 2 I=1,NHKK
18678       DO 2 I=1,NPOINT(1)
18679 * projectile nucleons wounded in primary interaction and in fzc
18680          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
18681             NPW      = NPW+1
18682             IPW(NPW) = I
18683             NPSTCK   = NPSTCK+1
18684             IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
18685             IF (ISTHKK(I).EQ.11)  NPW0 = NPW0+1
18686 C           IF (IP.GT.1) THEN
18687                DO 5 K=1,4
18688                   TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
18689     5          CONTINUE
18690 C           ENDIF
18691 * target nucleons wounded in primary interaction and in fzc
18692          ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
18693             NTW      = NTW+1
18694             ITW(NTW) = I
18695             NTSTCK   = NTSTCK+1
18696             IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
18697             IF (ISTHKK(I).EQ.12)  NTW0 = NTW0+1
18698             IF (IT.GT.1) THEN
18699                DO 6 K=1,4
18700                   TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
18701     6          CONTINUE
18702             ENDIF
18703          ELSEIF (ISTHKK(I).EQ.13) THEN
18704             ISGLPR = I
18705          ELSEIF (ISTHKK(I).EQ.14) THEN
18706             ISGLTA = I
18707          ENDIF
18708     2 CONTINUE
18709
18710       DO 11 I=NPOINT(4),NHKK
18711 * baryons which are unable to escape the nuclear potential of proj.
18712          IF (ISTHKK(I).EQ.15) THEN
18713             ISGLPR = I
18714             NPSTCK = NPSTCK-1
18715             IF (IIBAR(IDBAM(I)).NE.0) THEN
18716                NPW    = NPW-1
18717                IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
18718             ENDIF
18719             DO 7 K=1,4
18720                TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18721     7       CONTINUE
18722 * baryons which are unable to escape the nuclear potential of targ.
18723          ELSEIF (ISTHKK(I).EQ.16) THEN
18724             ISGLTA = I
18725             NTSTCK = NTSTCK-1
18726             IF (IIBAR(IDBAM(I)).NE.0) THEN
18727                NTW    = NTW-1
18728                IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
18729             ENDIF
18730             DO 8 K=1,4
18731                TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18732     8       CONTINUE
18733          ENDIF
18734    11 CONTINUE
18735
18736 * residual nuclei so far
18737       IRESP = IP-NPSTCK
18738       IREST = IT-NTSTCK
18739
18740 * ckeck for "residual nuclei" consisting of one nucleon only
18741 * treat it as final state particle
18742       IF (IRESP.EQ.1) THEN
18743          ID  = IDBAM(ISGLPR)
18744          IST = ISTHKK(ISGLPR)
18745          CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
18746      &               PHKK(3,ISGLPR),PHKK(4,ISGLPR),
18747      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
18748          IF (IST.EQ.13) THEN
18749             ISTHKK(ISGLPR) = 11
18750          ELSE
18751             ISTHKK(ISGLPR) = 2
18752          ENDIF
18753          CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
18754      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18755      &               IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
18756          NOBAM(NHKK)      = NOBAM(ISGLPR)
18757          JDAHKK(1,ISGLPR) = NHKK
18758          DO 21 K=1,4
18759             TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
18760    21    CONTINUE
18761       ENDIF
18762       IF (IREST.EQ.1) THEN
18763          ID  = IDBAM(ISGLTA)
18764          IST = ISTHKK(ISGLTA)
18765          CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
18766      &               PHKK(3,ISGLTA),PHKK(4,ISGLTA),
18767      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
18768          IF (IST.EQ.14) THEN
18769             ISTHKK(ISGLTA) = 12
18770          ELSE
18771             ISTHKK(ISGLTA) = 2
18772          ENDIF
18773          CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
18774      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18775      &               IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
18776          NOBAM(NHKK)      = NOBAM(ISGLTA)
18777          JDAHKK(1,ISGLTA) = NHKK
18778          DO 22 K=1,4
18779             TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
18780    22    CONTINUE
18781       ENDIF
18782
18783 * get nuclear potential corresp. to the residual nucleus
18784       IPRCL  = IP -NPW
18785       IPZRCL = IPZ-NPCW
18786       ITRCL  = IT -NTW
18787       ITZRCL = ITZ-NTCW
18788       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
18789
18790 * baryons unable to escape the nuclear potential are treated as
18791 * excited nucleons (ISTHKK=15,16)
18792       DO 3 I=NPOINT(4),NHKK
18793          IF (ISTHKK(I).EQ.1) THEN
18794             ID  = IDBAM(I)
18795             IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
18796 *   final state n and p not being outside of both nuclei are considered
18797                NPOTP = 1
18798                NPOTT = 1
18799                IF ( (IP.GT.1)      .AND.(IRESP.GT.1).AND.
18800      &              (NOBAM(I).NE.1).AND.(NPW.GT.0)        ) THEN
18801 *     Lorentz-trsf. into proj. rest sys. for those being inside proj.
18802                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18803      &                        PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
18804      &                        PLAB(1,4),ID,-2)
18805                   PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
18806                   PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
18807      &                                  (PLAB(1,4)+PLABT) ))
18808                   EKIN = PLAB(1,4)-PLAB(1,5)
18809                   IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
18810                   IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
18811                ENDIF
18812                IF ( (IT.GT.1)      .AND.(IREST.GT.1).AND.
18813      &              (NOBAM(I).NE.2).AND.(NTW.GT.0)        ) THEN
18814 *     Lorentz-trsf. into targ. rest sys. for those being inside targ.
18815                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18816      &                        PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
18817      &                        PLAB(2,4),ID,-3)
18818                   PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
18819                   PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
18820      &                                  (PLAB(2,4)+PLABT) ))
18821                   EKIN = PLAB(2,4)-PLAB(2,5)
18822                   IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
18823                   IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
18824                ENDIF
18825                IF (PHKK(3,I).GE.ZERO) THEN
18826                   ISTHKK(I) = NPOTT
18827                   IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
18828                ELSE
18829                   ISTHKK(I) = NPOTP
18830                   IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
18831                ENDIF
18832                IF (ISTHKK(I).NE.1) THEN
18833                   J = ISTHKK(I)-14
18834                   DO 4 K=1,5
18835                      PHKK(K,I) = PLAB(J,K)
18836     4             CONTINUE
18837                   IF (ISTHKK(I).EQ.15) THEN
18838                      NPW = NPW-1
18839                      IF (ID.EQ.1) NPCW = NPCW-1
18840                      DO 9 K=1,4
18841                         TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18842     9                CONTINUE
18843                   ELSEIF (ISTHKK(I).EQ.16) THEN
18844                      NTW = NTW-1
18845                      IF (ID.EQ.1) NTCW = NTCW-1
18846                      DO 10 K=1,4
18847                         TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18848    10                CONTINUE
18849                   ENDIF
18850                ENDIF
18851             ENDIF
18852          ENDIF
18853     3 CONTINUE
18854
18855 * again: get nuclear potential corresp. to the residual nucleus
18856       IPRCL  = IP -NPW
18857       IPZRCL = IPZ-NPCW
18858       ITRCL  = IT -NTW
18859       ITZRCL = ITZ-NTCW
18860 c      AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
18861 cC     AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
18862 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
18863 C     AFERP = 0.0D0
18864 c      AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
18865 cC     AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
18866 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
18867 C     AFERT = 0.0D0
18868 C     IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
18869 C     IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
18870 C     IF (AFERP.GT.0.85D0) AFERP = 0.85D0
18871 C     IF (AFERT.GT.0.85D0) AFERT = 0.85D0
18872       AFERP = FERMOD+0.1D0
18873       AFERT = FERMOD+0.1D0
18874
18875       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
18876
18877       RETURN
18878       END
18879 *
18880 *===ficonf=============================================================*
18881 *
18882 CDECK  ID>, DT_FICONF
18883       SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
18884
18885 ************************************************************************
18886 * Treatment of FInal CONFiguration including evaporation, fission and  *
18887 * Fermi-break-up (for light nuclei only).                              *
18888 * Adopted from the original routine FINALE and extended to residual    *
18889 * projectile nuclei.                                                   *
18890 * This version dated 12.12.95 is written by S. Roesler.                *
18891 ************************************************************************
18892
18893       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18894       SAVE
18895
18896       PARAMETER ( LINP = 5 ,
18897      &            LOUT = 6 ,
18898      &            LDAT = 9 )
18899
18900       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18901       PARAMETER (ANGLGB=5.0D-16)
18902
18903 * event history
18904
18905       PARAMETER (NMXHKK=200000)
18906
18907       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18908      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18909      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18910 * extended event history
18911       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18912      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18913      &                IHIST(2,NMXHKK)
18914 * rejection counter
18915       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
18916      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
18917      &                IREXCI(3),IRDIFF(2),IRINC
18918 * central particle production, impact parameter biasing
18919       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
18920 * particle properties (BAMJET index convention)
18921       CHARACTER*8  ANAME
18922       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18923      &                IICH(210),IIBAR(210),K1(210),K2(210)
18924 * treatment of residual nuclei: 4-momenta
18925       LOGICAL LRCLPR,LRCLTA
18926       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18927      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18928 * treatment of residual nuclei: properties of residual nuclei
18929       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
18930      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
18931      &                NTOTFI(2),NPROFI(2)
18932 * statistics: residual nuclei
18933       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
18934      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
18935      &                NINCST(2,4),NINCEV(2),
18936      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
18937      &                NRESPB(2),NRESCH(2),NRESEV(4),
18938      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
18939      &                NEVAFI(2,2)
18940 * flags for input different options
18941       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18942       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18943      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18944
18945       INCLUDE '(DIMPAR)'
18946       INCLUDE '(FINUC)'
18947       INCLUDE '(RESNUC)'
18948       PARAMETER ( EMVGEV = 1.0                D-03 )
18949       PARAMETER ( AMUGEV = 0.93149432         D+00 )
18950       PARAMETER ( AMPRTN = 0.93827231         D+00 )
18951       PARAMETER ( AMNTRN = 0.93956563         D+00 )
18952       PARAMETER ( AMELCT = 0.51099906         D-03 )
18953       PARAMETER ( ELCCGS = 4.8032068          D-10 )
18954       PARAMETER ( ELCMKS = 1.60217733         D-19 )
18955       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
18956      &                   * 1.D-09 )
18957       PARAMETER ( HLFHLF = 0.5D+00 )
18958       PARAMETER ( FERTHO = 14.33       D-09 )
18959       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
18960       PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
18961       PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
18962       INCLUDE '(NUCDAT)'
18963       INCLUDE '(PAREVT)'
18964       INCLUDE '(FHEAVY)'
18965
18966 * event flag
18967       COMMON /DTEVNO/ NEVENT,ICASCA
18968
18969       DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
18970      &          PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
18971      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
18972
18973       DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
18974       DATA EXC,NEXC /520*ZERO,520*0/
18975       DATA EXPNUC /4.0D-3,4.0D-3/
18976
18977       IREJ   = 0
18978       LRCLPR = .FALSE.
18979       LRCLTA = .FALSE.
18980
18981 * skip residual nucleus treatment if not requested or in case
18982 * of central collisions
18983       IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
18984
18985       DO 1 K=1,2
18986          IDPAR(K) = 0
18987          IDXPAR(K)= 0
18988          NTOT(K)  = 0
18989          NTOTFI(K)= 0
18990          NPRO(K)  = 0
18991          NPROFI(K)= 0
18992          NN(K)    = 0
18993          NH(K)    = 0
18994          NHPOS(K) = 0
18995          NQ(K)    = 0
18996          EEXC(K)  = ZERO
18997          MO1(K)   = 0
18998          MO2(K)   = 0
18999          DO 2 I=1,4
19000             VRCL(K,I) = ZERO
19001             WRCL(K,I) = ZERO
19002     2    CONTINUE
19003     1 CONTINUE
19004       NFSP = 0
19005       INUC(1) = IP
19006       INUC(2) = IT
19007
19008       DO 3 I=1,NHKK
19009
19010 * number of final state particles
19011          IF (ABS(ISTHKK(I)).EQ.1) THEN
19012             NFSP  = NFSP+1
19013             IDFSP = IDBAM(I)
19014          ENDIF
19015
19016 * properties of remaining nucleon configurations
19017          KF = 0
19018          IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
19019          IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
19020          IF (KF.GT.0) THEN
19021             IF (MO1(KF).EQ.0) MO1(KF) = I
19022             MO2(KF)  = I
19023 *   position of residual nucleus = average position of nucleons
19024             DO 4 K=1,4
19025                VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
19026                WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
19027     4       CONTINUE
19028 *   total number of particles contributing to each residual nucleus
19029             NTOT(KF)  = NTOT(KF)+1
19030             IDTMP     = IDBAM(I)
19031             IDXTMP    = I
19032 *   total charge of residual nuclei
19033             NQ(KF) = NQ(KF)+IICH(IDTMP)
19034 *   number of protons
19035             IF (IDHKK(I).EQ.2212) THEN
19036                NPRO(KF) = NPRO(KF)+1
19037 *   number of neutrons
19038             ELSEIF (IDHKK(I).EQ.2112) THEN
19039                NN(KF) = NN(KF)+1
19040             ELSE
19041 *   number of baryons other than n, p
19042                IF (IIBAR(IDTMP).EQ.1) THEN
19043                   NH(KF) = NH(KF)+1
19044                   IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
19045                ELSE
19046 *   any other mesons (status set to 1)
19047 C                 WRITE(LOUT,1002) KF,IDTMP
19048 C1002             FORMAT(1X,'FICONF:   residual nucleus ',I2,
19049 C    &                   ' containing meson ',I4,', status set to 1')
19050                   ISTHKK(I) = 1
19051                   IDTMP     = IDPAR(KF)
19052                   IDXTMP    = IDXPAR(KF)
19053                   NTOT(KF)  = NTOT(KF)-1
19054                ENDIF
19055             ENDIF
19056             IDPAR(KF)  = IDTMP
19057             IDXPAR(KF) = IDXTMP
19058          ENDIF
19059     3 CONTINUE
19060
19061 * reject elastic events (def: one final state particle = projectile)
19062       IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
19063          IREXCI(3) = IREXCI(3)+1
19064          GOTO 9999
19065 C        RETURN
19066       ENDIF
19067
19068 * check if one nucleus disappeared..
19069 C     IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
19070 C        DO 5 K=1,4
19071 C           PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
19072 C           PRCLPR(K) = ZERO
19073 C   5    CONTINUE
19074 C     ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
19075 C        DO 6 K=1,4
19076 C           PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
19077 C           PRCLTA(K) = ZERO
19078 C   6    CONTINUE
19079 C     ENDIF
19080
19081       ICOR   = 0
19082       INORCL = 0
19083       DO 7 I=1,2
19084          DO 8 K=1,4
19085 * get the average of the nucleon positions
19086             VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
19087             WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
19088             IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
19089             IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
19090     8    CONTINUE
19091 * mass number and charge of residual nuclei
19092          AIF(I)  = DBLE(NTOT(I))
19093          AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
19094          IF (NTOT(I).GT.1) THEN
19095 * masses of residual nuclei in ground state
19096
19097 C           AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*ENERGY(AIF(I),AIZF(I))
19098             AMRCL0(I) = AIF(I)*AMUC12
19099      &                  +EMVGEV*EXMSAZ(AIF(I),AIZF(I),.TRUE.,IZDUM)
19100
19101 * masses of residual nuclei
19102             PTORCL   = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
19103             AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
19104             IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
19105             IF (AMRCL(I).LE.ZERO) THEN
19106                IF (IOULEV(3).GT.0)
19107      &            WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
19108      &                             PRCL(I,4),NTOT
19109  1000          FORMAT(1X,'warning! negative excitation energy',/,
19110      &                I4,4E15.4,2I4)
19111                AMRCL(I) = ZERO
19112                EEXC(I)  = ZERO
19113                IF (NLOOP.LE.500) THEN
19114                   GOTO 9998
19115                ELSE
19116                   IREXCI(2) = IREXCI(2)+1
19117                   GOTO 9999
19118                ENDIF
19119             ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
19120      &                                                         THEN
19121 **sr
19122 C              WRITE(6,*) NEVHKK,I,NTOT(1),NTOT(2),AMRCL(I),AMRCL0(I)
19123 **
19124 **sr 3.3
19125 C              AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
19126                M = MIN(NTOT(I),260)
19127                IF (NEXC(I,M).GT.0) THEN
19128                   AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
19129                ELSE
19130    70             CONTINUE
19131                   M = M+1
19132                   IF (M.GE.INUC(I)) THEN
19133                      AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
19134                   ELSE
19135                      IF (NEXC(I,M).GT.0) THEN
19136                         AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
19137                      ELSE
19138                         GOTO 70
19139                      ENDIF
19140                   ENDIF
19141                ENDIF
19142 **
19143                EEXC(I)  = AMRCL(I)-AMRCL0(I)
19144                ICOR     = ICOR+I
19145             ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
19146                IF (IOULEV(3).GT.0)
19147 &                 WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
19148  1004          FORMAT(1X,'warning! too high excitation energy',/,
19149      &                I4,1P,2E15.4,3I5)
19150                AMRCL(I) = ZERO
19151                EEXC(I)  = ZERO
19152                IF (NLOOP.LE.500) THEN
19153                   GOTO 9998
19154                ELSE
19155                   IREXCI(2) = IREXCI(2)+1
19156                   GOTO 9999
19157                ENDIF
19158             ELSE
19159 * excitation energies of residual nuclei
19160                EEXC(I)   = AMRCL(I)-AMRCL0(I)
19161                IF (ICASCA.EQ.0) THEN
19162 **sr 15.1.
19163 C                 EXPNUC(I) = EEXC(I)/DBLE(NTOT(I))
19164                   EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
19165                   M = MIN(NTOT(I),260)
19166                   EXC(I,M)  = EXC(I,M)+EEXC(I)
19167                   NEXC(I,M) = NEXC(I,M)+1
19168                ENDIF
19169             ENDIF
19170          ELSEIF (NTOT(I).EQ.1) THEN
19171             WRITE(LOUT,1003) I
19172  1003       FORMAT(1X,'FICONF:   warning! NTOT(I)=1? (I=',I3,')')
19173             GOTO 9999
19174          ELSE
19175             AMRCL0(I) = ZERO
19176             AMRCL(I)  = ZERO
19177             EEXC(I)   = ZERO
19178             INORCL    = INORCL+I
19179          ENDIF
19180     7 CONTINUE
19181
19182       PRCLPR(5) = AMRCL(1)
19183       PRCLTA(5) = AMRCL(2)
19184
19185       IF (ICOR.GT.0) THEN
19186          IF (INORCL.EQ.0) THEN
19187 * one or both residual nuclei consist of one nucleon only, transform
19188 * this nucleon on mass shell
19189             DO 9 K=1,4
19190                P1IN(K) = PRCL(1,K)
19191                P2IN(K) = PRCL(2,K)
19192     9       CONTINUE
19193             XM1 = AMRCL(1)
19194             XM2 = AMRCL(2)
19195             CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
19196             IF (IREJ1.GT.0) THEN
19197                WRITE(LOUT,*) 'ficonf-mashel rejection'
19198                GOTO 9999
19199             ENDIF
19200             DO 10 K=1,4
19201                PRCL(1,K) = P1OUT(K)
19202                PRCL(2,K) = P2OUT(K)
19203                PRCLPR(K) = P1OUT(K)
19204                PRCLTA(K) = P2OUT(K)
19205    10       CONTINUE
19206             PRCLPR(5) = AMRCL(1)
19207             PRCLTA(5) = AMRCL(2)
19208          ELSE
19209             IF (IOULEV(3).GT.0)
19210      &      WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
19211      &                       INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
19212      &                       AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
19213      &                       AMRCL(2),AMRCL(2)-AMRCL0(2)
19214  1001       FORMAT(1X,'FICONF:   warning! no residual nucleus for',
19215      &             ' correction',/,11X,'at event',I8,
19216      &             ',  nucleon config. 1:',2I4,' 2:',2I4,
19217      &             2(/,11X,3E12.3))
19218             IF (NLOOP.LE.500) THEN
19219                GOTO 9998
19220             ELSE
19221                IREXCI(1) = IREXCI(1)+1
19222             ENDIF
19223          ENDIF
19224       ENDIF
19225
19226 * update counter
19227 C     IF (NRESEV(1).NE.NEVHKK) THEN
19228 C        NRESEV(1) = NEVHKK
19229 C        NRESEV(2) = NRESEV(2)+1
19230 C     ENDIF
19231       NRESEV(2) = NRESEV(2)+1
19232       DO 15 I=1,2
19233          EXCDPM(I)   = EXCDPM(I)+EEXC(I)
19234          EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
19235          NRESTO(I) = NRESTO(I)+NTOT(I)
19236          NRESPR(I) = NRESPR(I)+NPRO(I)
19237          NRESNU(I) = NRESNU(I)+NN(I)
19238          NRESBA(I) = NRESBA(I)+NH(I)
19239          NRESPB(I) = NRESPB(I)+NHPOS(I)
19240          NRESCH(I) = NRESCH(I)+NQ(I)
19241    15 CONTINUE
19242
19243 * evaporation
19244       IF (LEVPRT) THEN
19245          DO 13 I=1,2
19246 * initialize evaporation counter
19247             NP = 0
19248             EEXCFI(I) = ZERO
19249             IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
19250      &          (EEXC(I).GT.ZERO)) THEN
19251 * put residual nuclei into DTEVT1
19252                IDRCL = 80000
19253                JMASS = INT( AIF(I))
19254                JCHAR = INT(AIZF(I))
19255 *  the following patch is required to transmit the correct excitation
19256 *   energy to Eventd
19257                IF (ITRSPT.EQ.1) THEN
19258                   PRCL0 = PRCL(I,4)
19259                   PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
19260      &                                                    +PRCL(I,3)**2)
19261                   IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
19262                      WRITE(LOUT,*)
19263      &                  ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
19264                   ENDIF
19265                ENDIF
19266                CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
19267      &              PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
19268 **sr 22.6.97
19269                NOBAM(NHKK) = I
19270 **
19271                DO 14 J=1,4
19272                   VHKK(J,NHKK) = VRCL(I,J)
19273                   WHKK(J,NHKK) = WRCL(I,J)
19274    14          CONTINUE
19275 *  interface to evaporation module - fill final residual nucleus into
19276 *  common FKRESN
19277 *   fill resnuc only if code is not used as event generator in Fluka
19278                IF (ITRSPT.NE.1) THEN
19279                   PXRES  = PRCL(I,1)
19280                   PYRES  = PRCL(I,2)
19281                   PZRES  = PRCL(I,3)
19282                   IBRES  = NPRO(I)+NN(I)+NH(I)
19283                   ICRES  = NPRO(I)+NHPOS(I)
19284                   ANOW   = DBLE(IBRES)
19285                   ZNOW   = DBLE(ICRES)
19286                   PTRES  = SQRT(PXRES**2+PYRES**2+PZRES**2)
19287 *   ground state mass of the residual nucleus (should be equal to AM0T)
19288
19289                   AMNRES = AMRCL0(I)
19290                   AMMRES = AMNAMA ( AMNRES, IBRES, ICRES )
19291
19292 *  common FKFINU
19293                   TV = ZERO
19294 *   kinetic energy of residual nucleus
19295                   TVRECL = PRCL(I,4)-AMRCL(I)
19296 *   excitation energy of residual nucleus
19297                   TVCMS  = EEXC(I)
19298                   PTOLD  = PTRES
19299                   PTRES  = SQRT(ABS(TVRECL*(TVRECL+
19300      &                          2.0D0*(AMMRES+TVCMS))))
19301                   IF (PTOLD.LT.ANGLGB) THEN
19302                      CALL DT_RACO(PXRES,PYRES,PZRES)
19303                      PTOLD = ONE
19304                   ENDIF
19305                   PXRES = PXRES*PTRES/PTOLD
19306                   PYRES = PYRES*PTRES/PTOLD
19307                   PZRES = PZRES*PTRES/PTOLD
19308 * evaporation
19309                   WE = ONE
19310
19311                   NPHEAV = 0
19312                   LRNFSS = .FALSE.
19313                   LFRAGM = .FALSE.
19314                   CALL EVEVAP(WE)
19315
19316 * put evaporated particles and residual nuclei to DTEVT1
19317                   MO = NHKK
19318                   CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
19319                ENDIF
19320                EEXCFI(I) = EXCITF
19321                EXCEVA(I) = EXCEVA(I)+EXCITF
19322             ENDIF
19323    13    CONTINUE
19324       ENDIF
19325
19326       RETURN
19327
19328 C9998 IREXCI(1) = IREXCI(1)+1
19329  9998 IREJ   = IREJ+1
19330  9999 CONTINUE
19331       LRCLPR = .TRUE.
19332       LRCLTA = .TRUE.
19333       IREJ   = IREJ+1
19334       RETURN
19335       END
19336 *                                                                      *
19337 *====eva2he============================================================*
19338 *                                                                      *
19339 CDECK  ID>, DT_EVA2HE
19340       SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
19341
19342 ************************************************************************
19343 * Interface between common's of evaporation module (FKFINU,FKFHVY)     *
19344 * and DTEVT1.                                                          *
19345 *    MO    DTEVT1-index of "mother" (residual) nucleus before evap.    *
19346 *    EEXCF exitation energy of residual nucleus after evaporation      *
19347 *    IRCL  = 1 projectile residual nucleus                             *
19348 *          = 2 target     residual nucleus                             *
19349 * This version dated 19.04.95 is written by S. Roesler.                *
19350 ************************************************************************
19351
19352       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19353       SAVE
19354
19355       PARAMETER ( LINP = 5 ,
19356      &            LOUT = 6 ,
19357      &            LDAT = 9 )
19358
19359       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
19360
19361 * event history
19362
19363       PARAMETER (NMXHKK=200000)
19364
19365       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19366      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19367      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19368 * Note: DTEVT2 - special use for heavy fragments !
19369 *       (IDRES(I) = mass number, IDXRES(I) = charge)
19370 * extended event history
19371       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19372      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19373      &                IHIST(2,NMXHKK)
19374 * particle properties (BAMJET index convention)
19375       CHARACTER*8  ANAME
19376       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19377      &                IICH(210),IIBAR(210),K1(210),K2(210)
19378 * flags for input different options
19379       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19380       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19381      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19382 * statistics: residual nuclei
19383       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19384      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19385      &                NINCST(2,4),NINCEV(2),
19386      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19387      &                NRESPB(2),NRESCH(2),NRESEV(4),
19388      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19389      &                NEVAFI(2,2)
19390 * treatment of residual nuclei: properties of residual nuclei
19391       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19392      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19393      &                NTOTFI(2),NPROFI(2)
19394
19395       INCLUDE '(DIMPAR)'
19396       INCLUDE '(FINUC)'
19397       INCLUDE '(RESNUC)'
19398       INCLUDE '(FHEAVY)'
19399
19400       DIMENSION IPTOKP(39)
19401       DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
19402      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
19403      & 100, 101, 97, 102, 98, 103, 109, 115 /
19404
19405       IREJ = 0
19406
19407 * skip if evaporation package is not included
19408       IF (.NOT.LEVAPO) RETURN
19409
19410 * update counter
19411       IF (NRESEV(3).NE.NEVHKK) THEN
19412          NRESEV(3) = NEVHKK
19413          NRESEV(4) = NRESEV(4)+1
19414       ENDIF
19415
19416       IF (LEMCCK)
19417      &   CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
19418      &                                                   IDUM,IDUM)
19419 * mass number/charge of residual nucleus before evaporation
19420       IBTOT = IDRES(MO)
19421       IZTOT = IDXRES(MO)
19422
19423 * protons/neutrons/gammas
19424       DO 1 I=1,NP
19425          PX    = CXR(I)*PLR(I)
19426          PY    = CYR(I)*PLR(I)
19427          PZ    = CZR(I)*PLR(I)
19428          ID    = IPTOKP(KPART(I))
19429          IDPDG = IDT_IPDGHA(ID)
19430          AM    = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
19431      &           (2.0D0*MAX(TKI(I),TINY10))
19432          IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
19433             WRITE(LOUT,1000) ID,AM,AAM(ID)
19434  1000       FORMAT(1X,'EVA2HE:  inconsistent mass of evap. ',
19435      &             'particle',I3,2E10.3)
19436          ENDIF
19437          PE = TKI(I)+AM
19438          CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
19439          NOBAM(NHKK) = IRCL
19440          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19441          IBTOT = IBTOT-IIBAR(ID)
19442          IZTOT = IZTOT-IICH(ID)
19443     1 CONTINUE
19444
19445 * heavy fragments
19446       DO 2 I=1,NPHEAV
19447          PX     = CXHEAV(I)*PHEAVY(I)
19448          PY     = CYHEAV(I)*PHEAVY(I)
19449          PZ     = CZHEAV(I)*PHEAVY(I)
19450          IDHEAV = 80000
19451          AM     = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
19452      &            (2.0D0*MAX(TKHEAV(I),TINY10))
19453          PE     = TKHEAV(I)+AM
19454          CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
19455      &                  IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
19456          NOBAM(NHKK) = IRCL
19457          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19458          IBTOT = IBTOT-IBHEAV(KHEAVY(I))
19459          IZTOT = IZTOT-ICHEAV(KHEAVY(I))
19460     2 CONTINUE
19461
19462       IF (IBRES.GT.0) THEN
19463 * residual nucleus after evaporation
19464          IDNUC = 80000
19465          CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
19466      &                                        IBRES,ICRES,0)
19467          NOBAM(NHKK) = IRCL
19468       ENDIF
19469       EEXCF = TVCMS
19470       NTOTFI(IRCL) = IBRES
19471       NPROFI(IRCL) = ICRES
19472       IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
19473       IBTOT = IBTOT-IBRES
19474       IZTOT = IZTOT-ICRES
19475
19476 * count events with fission
19477       NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
19478       IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
19479
19480 * energy-momentum conservation check
19481       IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
19482 C     IF (IREJ.GT.0) THEN
19483 C        CALL DT_EVTOUT(4)
19484 C        WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
19485 C     ENDIF
19486 * baryon-number/charge conservation check
19487       IF (IBTOT+IZTOT.NE.0) THEN
19488          WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
19489  1001    FORMAT(1X,'EVA2HE:   baryon-number/charge conservation ',
19490      &          'failure at event ',I8,' :  IBTOT,IZTOT = ',2I3)
19491       ENDIF
19492
19493       RETURN
19494       END
19495 *
19496 *===ebind==============================================================*
19497 *
19498 CDECK  ID>, DT_EBIND
19499       DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
19500
19501 ************************************************************************
19502 * Binding energy for nuclei.                                           *
19503 * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972)                  *
19504 *                 IA        mass number                                *
19505 *                 IZ        atomic number                              *
19506 * This version dated 5.5.95   is updated by S. Roesler.                *
19507 ************************************************************************
19508
19509       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19510       SAVE
19511
19512       PARAMETER ( LINP = 5 ,
19513      &            LOUT = 6 ,
19514      &            LDAT = 9 )
19515
19516       PARAMETER (ZERO=0.0D0)
19517
19518       DATA       A1,       A2,        A3,        A4,      A5
19519      &     / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
19520
19521       IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
19522          WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0.  ',IA,IZ
19523          DT_EBIND = ZERO
19524          RETURN
19525       ENDIF
19526       AA = IA
19527       DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
19528      &        -A4*(IA-2*IZ)**2/AA
19529       IF (MOD(IA,2).EQ.1) THEN
19530          IA5 = 0
19531       ELSEIF (MOD(IZ,2).EQ.1) THEN
19532          IA5 = 1
19533       ELSE
19534          IA5 = -1
19535       ENDIF
19536       DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
19537
19538       RETURN
19539       END
19540
19541 ************************************************************************
19542 *                                                                      *
19543 *  DPMJET 3.0:   cross section routines                                *
19544 *                                                                      *
19545 ************************************************************************
19546 *
19547 *
19548 *     SUBROUTINE DT_SHNDIF
19549 *         diffractive cross sections (all energies)
19550 *     SUBROUTINE DT_PHOXS
19551 *         total and inel. cross sections from PHOJET interpol. tables
19552 *     SUBROUTINE DT_XSHN
19553 *         total and el. cross sections for all energies
19554 *     SUBROUTINE DT_SIHNAB
19555 *         pion 2-nucleon absorption cross sections
19556 *     SUBROUTINE DT_SIGEMU
19557 *         cross section for target "compounds"
19558 *     SUBROUTINE DT_SIGGA
19559 *         photon nucleus cross sections
19560 *     SUBROUTINE DT_SIGGAT
19561 *         photon nucleus cross sections from tables
19562 *     SUBROUTINE DT_SANO
19563 *         anomalous hard photon-nucleon cross sections from tables
19564 *     SUBROUTINE DT_SIGGP
19565 *         photon nucleon cross sections
19566 *     SUBROUTINE DT_SIGVEL
19567 *         quasi-elastic vector meson prod. cross sections
19568 *     DOUBLE PRECISION FUNCTION DT_SIGVP
19569 *         sigma_VN(tilde)
19570 *     DOUBLE PRECISION FUNCTION DT_RRM2
19571 *     DOUBLE PRECISION FUNCTION DT_RM2
19572 *     DOUBLE PRECISION FUNCTION DT_SAM2
19573 *     SUBROUTINE DT_CKMT
19574 *     SUBROUTINE DT_CKMTX
19575 *     SUBROUTINE DT_PDF0
19576 *     SUBROUTINE DT_CKMTQ0
19577 *     SUBROUTINE DT_CKMTDE
19578 *     SUBROUTINE DT_CKMTPR
19579 *     FUNCTION DT_CKMTFF
19580 *
19581 *     SUBROUTINE DT_FLUINI
19582 *         total nucleon cross section fluctuation treatment
19583 *
19584 *     SUBROUTINE DT_SIGTBL
19585 *         pre-tabulation of low-energy elastic x-sec. using SIHNEL
19586 *     SUBROUTINE DT_XSTABL
19587 *         service routines
19588 *
19589 *
19590 *
19591 *===shndif===============================================================*
19592 *
19593 CDECK  ID>, DT_SHNDIF
19594       SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
19595
19596 **********************************************************************
19597 *   Single diffractive hadron-nucleon cross sections                 *
19598 *                                              S.Roesler 14/1/93     *
19599 *                                                                    *
19600 *   The cross sections are calculated from extrapolated single       *
19601 *   diffractive antiproton-proton cross sections (DTUJET92) using    *
19602 *   scaling relations between total and single diffractive cross     *
19603 *   sections.                                                        *
19604 **********************************************************************
19605
19606       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19607       SAVE
19608       PARAMETER (ZERO=0.0D0)
19609
19610 * particle properties (BAMJET index convention)
19611       CHARACTER*8  ANAME
19612       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19613      &                IICH(210),IIBAR(210),K1(210),K2(210)
19614 *
19615       CSD1   =   4.201483727D0
19616       CSD4   = -0.4763103556D-02
19617       CSD5   =  0.4324148297D0
19618 *
19619       CHMSD1 =  0.8519297242D0
19620       CHMSD4 = -0.1443076599D-01
19621       CHMSD5 =  0.4014954567D0
19622 *
19623       EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
19624       PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
19625 *
19626       SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
19627       SHMSD  = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
19628       FRAC   = SHMSD/SDIAPP
19629 *
19630       GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
19631      &     999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
19632      &      10, 10, 20, 20, 20) KPROJ
19633 *
19634    10 CONTINUE
19635 *---------------------------- p - p , n - p , sigma0+- - p ,
19636 *                             Lambda - p
19637       CSD1   =  6.004476070D0
19638       CSD4   = -0.1257784606D-03
19639       CSD5   =  0.2447335720D0
19640       SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
19641       SIGDIH = FRAC*SIGDIF
19642       RETURN
19643 *
19644    20 CONTINUE
19645 *
19646       KPSCAL = 2
19647       KTSCAL = 1
19648 C     F      = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
19649       DUMZER = ZERO
19650       CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
19651       F      = SDIAPP/SIGTO
19652       KT     = 1
19653 C     SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
19654       CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
19655       SIGDIF = SIGTO*F
19656       SIGDIH = FRAC*SIGDIF
19657       RETURN
19658 *
19659   999 CONTINUE
19660 *-------------------------- leptons..
19661       SIGDIF = 1.D-10
19662       SIGDIH = 1.D-10
19663       RETURN
19664       END
19665 *
19666 *===phoxs================================================================*
19667 *
19668 CDECK  ID>, DT_PHOXS
19669       SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
19670
19671 ************************************************************************
19672 * Total/inelastic proton-nucleon cross sections taken from PHOJET-     *
19673 * interpolation tables.                                                *
19674 * This version dated 05.11.97 is written by S. Roesler                 *
19675 ************************************************************************
19676
19677       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19678       SAVE
19679
19680       PARAMETER ( LINP = 5 ,
19681      &            LOUT = 6 ,
19682      &            LDAT = 9 )
19683
19684       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
19685       PARAMETER (TWOPI  = 6.283185307179586454D+00,
19686      &           PI     = TWOPI/TWO,
19687      &           GEV2MB = 0.38938D0)
19688
19689       LOGICAL LFIRST
19690       DATA LFIRST /.TRUE./
19691
19692 * nucleon-nucleon event-generator
19693       CHARACTER*8 CMODEL
19694       LOGICAL LPHOIN
19695       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
19696 * particle properties (BAMJET index convention)
19697       CHARACTER*8  ANAME
19698       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19699      &                IICH(210),IIBAR(210),K1(210),K2(210)
19700
19701 **PHOJET105a
19702 C     PARAMETER (IEETAB=10)
19703 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
19704 **PHOJET110
19705 C  energy-interpolation table
19706       INTEGER IEETA2
19707       PARAMETER ( IEETA2 = 20 )
19708       INTEGER ISIMAX
19709       DOUBLE PRECISION SIGTAB,SIGECM
19710       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
19711 **
19712
19713       IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
19714          WRITE(LOUT,*) MCGENE
19715  1000    FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
19716          STOP
19717       ENDIF
19718
19719       IF (ECM.LE.ZERO) THEN
19720          EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
19721          ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
19722       ENDIF
19723
19724       IF (MODE.EQ.1) THEN
19725 * DL
19726          DELDL = 0.0808D0
19727          EPSDL = -0.4525D0
19728          S     = ECM*ECM
19729          STOT  = 21.7D0*S**DELDL+56.08D0*S**EPSDL
19730          ALPHAP= 0.25D0
19731          BEL   = 8.5D0+2.D0*ALPHAP*LOG(S)
19732          SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
19733          SINE  = STOT-SIGEL
19734          SDIF1 = ZERO
19735       ELSE
19736 * Phojet
19737          IP = 1
19738          IF(ECM.LE.SIGECM(IP,1)) THEN
19739            I1 = 1
19740            I2 = 1
19741          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
19742            DO 1 I=2,ISIMAX
19743               IF (ECM.LE.SIGECM(IP,I)) GOTO 2
19744     1      CONTINUE
19745     2      CONTINUE
19746            I1 = I-1
19747            I2 = I
19748          ELSE
19749            IF (LFIRST) THEN
19750               WRITE(LOUT,'(/1X,A,2E12.3)')
19751      &          'PHOXS: warning! energy above initialization limit (',
19752      &          ECM,SIGECM(IP,ISIMAX)
19753              LFIRST = .FALSE.
19754            ENDIF
19755            I1 = ISIMAX
19756            I2 = ISIMAX
19757          ENDIF
19758          FAC2 = ZERO
19759          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
19760      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
19761          FAC1  = ONE-FAC2
19762          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
19763          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
19764          SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
19765      &           FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
19766          BEL   = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
19767       ENDIF
19768
19769       RETURN
19770       END
19771 *
19772 *===xshn===============================================================*
19773 *
19774 CDECK  ID>, DT_XSHN
19775       SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
19776
19777 ************************************************************************
19778 * Total and elastic hadron-nucleon cross section.                      *
19779 * Below 500GeV cross sections are based on the '98 data compilation    *
19780 * of the PDG. At higher energies PHOJET results are used (patched to   *
19781 * the low energy data at 500GeV).                                      *
19782 *     IP      projectile index (BAMJET numbering scheme)               *
19783 *             (should be in the range 1..25)                           *
19784 *     IT      target index (BAMJET numbering scheme)                   *
19785 *             (1 = proton, 8 = neutron)                                *
19786 *     PL      laboratory momentum                                      *
19787 *     ECM     cm. energy (ignored if PL>0)                             *
19788 *     STOT    total cross section                                      *
19789 *     SELA    elastic cross section                                    *
19790 * Last change: 24.4.99 by S. Roesler                                   *
19791 ************************************************************************
19792
19793       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19794       SAVE
19795
19796       PARAMETER ( LINP = 5 ,
19797      &            LOUT = 6 ,
19798      &            LDAT = 9 )
19799
19800       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
19801
19802       PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
19803      &           PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
19804       PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
19805
19806       LOGICAL LFIRST
19807 * particle properties (BAMJET index convention)
19808       CHARACTER*8  ANAME
19809       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19810      &                IICH(210),IIBAR(210),K1(210),K2(210)
19811 * nucleon-nucleon event-generator
19812       CHARACTER*8 CMODEL
19813       LOGICAL LPHOIN
19814       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
19815 **PHOJET105a
19816 C     PARAMETER (IEETAB=10)
19817 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
19818 **PHOJET110
19819 C  energy-interpolation table
19820       INTEGER IEETA2
19821       PARAMETER ( IEETA2 = 20 )
19822       INTEGER ISIMAX
19823       DOUBLE PRECISION SIGTAB,SIGECM
19824       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
19825
19826       DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
19827       DIMENSION IDXDAT(25,2)
19828 *
19829       DATA APL /
19830      &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
19831      &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
19832      &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
19833      &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
19834      & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
19835      & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
19836      & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
19837 *
19838 * total cross sections:
19839 * p p
19840       DATA (ASIGTO(1,K),K=1,NPOINT) /
19841      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
19842      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
19843      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
19844      & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
19845      & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
19846      & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
19847      & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
19848 * pbar p
19849       DATA (ASIGTO(2,K),K=1,NPOINT) /
19850      & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
19851      & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
19852      & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
19853      & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
19854      & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
19855      & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
19856      & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
19857 * n p
19858       DATA (ASIGTO(3,K),K=1,NPOINT) /
19859      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
19860      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
19861      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
19862      & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
19863      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
19864      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
19865      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
19866 * pi+ p
19867       DATA (ASIGTO(4,K),K=1,NPOINT) /
19868      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
19869      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
19870      & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
19871      & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
19872      & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
19873      & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
19874      & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
19875 * pi- p
19876       DATA (ASIGTO(5,K),K=1,NPOINT) /
19877      & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
19878      & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
19879      & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
19880      & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
19881      & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
19882      & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
19883      & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
19884 * K+ p
19885       DATA (ASIGTO(6,K),K=1,NPOINT) /
19886      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
19887      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
19888      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
19889      & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
19890      & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
19891      & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
19892      & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
19893 * K- p
19894       DATA (ASIGTO(7,K),K=1,NPOINT) /
19895      & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
19896      & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
19897      & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
19898      & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
19899      & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
19900      & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
19901      & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
19902 * K+ n
19903       DATA (ASIGTO(8,K),K=1,NPOINT) /
19904      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
19905      & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
19906      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
19907      & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
19908      & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
19909      & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
19910      & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
19911 * K- n
19912       DATA (ASIGTO(9,K),K=1,NPOINT) /
19913      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
19914      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
19915      & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
19916      & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
19917      & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
19918      & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
19919      & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
19920 * Lambda p
19921       DATA (ASIGTO(10,K),K=1,NPOINT) /
19922      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
19923      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
19924      & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
19925      & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
19926      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
19927      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
19928      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
19929 *
19930 * elastic cross sections:
19931 * p p
19932       DATA (ASIGEL(1,K),K=1,NPOINT) /
19933      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
19934      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
19935      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
19936      & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
19937      & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
19938      & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
19939      & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
19940 * pbar p
19941       DATA (ASIGEL(2,K),K=1,NPOINT) /
19942      & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
19943      & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
19944      & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
19945      & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
19946      & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
19947      & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
19948      & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
19949 * n p
19950       DATA (ASIGEL(3,K),K=1,NPOINT) /
19951      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
19952      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
19953      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
19954      & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
19955      & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
19956      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
19957      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
19958 * pi+ p
19959       DATA (ASIGEL(4,K),K=1,NPOINT) /
19960      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
19961      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
19962      & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
19963      & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
19964      & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
19965      & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
19966      & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
19967 * pi- p
19968       DATA (ASIGEL(5,K),K=1,NPOINT) /
19969      & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
19970      & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
19971      & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
19972      & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
19973      & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
19974      & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
19975      & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
19976 * K+ p
19977       DATA (ASIGEL(6,K),K=1,NPOINT) /
19978      & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
19979      & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
19980      & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
19981      & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
19982      & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
19983      & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
19984      & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
19985 * K- p
19986       DATA (ASIGEL(7,K),K=1,NPOINT) /
19987      & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
19988      & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
19989      & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
19990      & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
19991      & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
19992      & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
19993      & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
19994 * K+ n
19995       DATA (ASIGEL(8,K),K=1,NPOINT) /
19996      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
19997      & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
19998      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
19999      & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
20000      & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
20001      & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
20002      & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
20003 * K- n
20004       DATA (ASIGEL(9,K),K=1,NPOINT) /
20005      & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
20006      & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
20007      & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
20008      & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
20009      & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
20010      & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
20011      & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
20012 * Lambda p
20013       DATA (ASIGEL(10,K),K=1,NPOINT) /
20014      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
20015      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
20016      & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
20017      & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
20018      & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
20019      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
20020      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
20021
20022       DATA (IDXDAT(K,1),K=1,25) /
20023      &  1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
20024      &  1, 3,45, 8, 9/
20025       DATA (IDXDAT(K,2),K=1,25) /
20026      &  3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
20027      &  3, 1,45, 6, 7/
20028
20029       DATA LFIRST /.TRUE./
20030
20031       IF (LFIRST) THEN
20032          APLABL = LOG10(PLABLO)
20033          APLABH = LOG10(PLABHI)
20034          APTHRE = LOG10(PTHRE)
20035          ADP1   = (APTHRE-APLABL)/DBLE(NPOIN1)
20036          ADP2   = (APLABH-APTHRE)/DBLE(NPOIN2)
20037          DUM0   = ZERO
20038          PHOPLA = PLABHI
20039          PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
20040          ECMS   = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
20041          IF (MCGENE.EQ.2) THEN
20042             IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
20043                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
20044             ELSE
20045                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
20046             ENDIF
20047          ELSE
20048             CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
20049          ENDIF
20050          PHOSEL = PHOSTO-PHOSIN
20051          APHOST = LOG10(PHOSTO)
20052          APHOSE = LOG10(PHOSEL)
20053          LFIRST = .FALSE.
20054       ENDIF
20055       STOT = ZERO
20056       SELA = ZERO
20057       PLAB = PL
20058       ECMS = ECM
20059       IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
20060          WRITE(LOUT,1000) IP,IT
20061  1000    FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
20062      &          'proj/target',2I4)
20063          STOP
20064       ENDIF
20065
20066       IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
20067          ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
20068          PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
20069       ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
20070          WRITE(LOUT,1001) PLAB,ECMS
20071  1001    FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
20072          STOP
20073       ENDIF
20074
20075 * index of spectrum
20076       IDXP = IP
20077       IF (IP.GT.25) THEN
20078          IF (AAM(IP).GT.ZERO) THEN
20079             IF (ABS(IIBAR(IP)).GT.0) THEN
20080                IDXP = 1
20081             ELSE
20082                IDXP = 13
20083             ENDIF
20084          ELSE
20085             IDXP = 7
20086          ENDIF
20087       ENDIF
20088       IDXT = 1
20089       IF (IT.EQ.8) IDXT = 2
20090       IDXS = IDXDAT(IDXP,IDXT)
20091       IF (IDXS.EQ.0) RETURN
20092
20093 * compute momentum bin indices
20094       IF (PLAB.LT.PLABLO) THEN
20095          IDX0 = 1
20096          IDX1 = 1
20097       ELSEIF (PLAB.GE.PLABHI) THEN
20098          IDX0 = NPOINT
20099          IDX1 = NPOINT
20100       ELSE
20101          APLAB = LOG10(PLAB)
20102          IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
20103             IDX0 = INT((APLAB-APLABL)/ADP1)+1
20104          ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
20105             IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
20106          ENDIF
20107          IDX1 = IDX0+1
20108       ENDIF
20109
20110 * interpolate cross section
20111       IF (IDXS.GT.10) THEN
20112          IDXS1 = IDXS/10
20113          IDXS2 = IDXS-10*IDXS1
20114          IF (IDX0.EQ.IDX1) THEN
20115             IF (IDX0.EQ.1) THEN
20116                ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
20117                ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
20118             ELSE
20119                DUM0   = ZERO
20120                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
20121                PHOSEL = PHOSTO-PHOSIN
20122                ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
20123                ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
20124                ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
20125                ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
20126                ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
20127                ASELA  = 0.5D0*(ASELA1+ASELA2)
20128             ENDIF
20129          ELSE
20130             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
20131             ASTOT1 = ASIGTO(IDXS1,IDX0)+
20132      &               FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
20133             ASTOT2 = ASIGTO(IDXS2,IDX0)+
20134      &               FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
20135             ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
20136             ASELA1 = ASIGEL(IDXS1,IDX0)+
20137      &               FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
20138             ASELA2 = ASIGEL(IDXS2,IDX0)+
20139      &               FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
20140             ASELA  = 0.5D0*(ASELA1+ASELA2)
20141          ENDIF
20142       ELSE
20143          IF (IDX0.EQ.IDX1) THEN
20144             IF (IDX0.EQ.1) THEN
20145                ASTOT = ASIGTO(IDXS,IDX0)
20146                ASELA = ASIGEL(IDXS,IDX0)
20147             ELSE
20148                DUM0   = ZERO
20149                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
20150                PHOSEL = PHOSTO-PHOSIN
20151                ASTOT  = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
20152                ASELA  = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
20153             ENDIF
20154          ELSE
20155             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
20156             ASTOT = ASIGTO(IDXS,IDX0)+
20157      &              FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
20158             ASELA = ASIGEL(IDXS,IDX0)+
20159      &              FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
20160          ENDIF
20161       ENDIF
20162       STOT = 10.0D0**ASTOT
20163       SELA = 10.0D0**ASELA
20164
20165       RETURN
20166       END
20167 *
20168 *===sihnab===============================================================*
20169 *
20170 CDECK  ID>, DT_SIHNAB
20171       SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
20172
20173 **********************************************************************
20174 * Pion 2-nucleon absorption cross sections.                          *
20175 * (sigma_tot for pi+ d --> p p, pi- d --> n n                        *
20176 *  taken from Ritchie PRC 28 (1983) 926 )                            *
20177 * This version dated 18.05.96 is written by S. Roesler               *
20178 **********************************************************************
20179
20180       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20181       SAVE
20182       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
20183       PARAMETER (AMPR = 938.0D0,
20184      &           AMPI = 140.0D0,
20185      &           AMDE = TWO*AMPR,
20186      &           A    = -1.2D0,
20187      &           B    = 3.5D0,
20188      &           C    = 7.4D0,
20189      &           D    = 5600.0D0,
20190      &           ER   = 2136.0D0)
20191
20192       SIGABS = ZERO
20193       IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
20194      &                   .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
20195       PTOT = PLAB*1.0D3
20196       EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
20197       IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
20198       ECM  = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
20199       SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
20200 * approximate 3N-abs., I=1-abs. etc.
20201       SIGABS = SIGABS/0.40D0
20202 * pi0-absorption (rough approximation!!)
20203       IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
20204
20205       RETURN
20206       END
20207 *
20208 *===sigemu=============================================================*
20209 *
20210 CDECK  ID>, DT_SIGEMU
20211       SUBROUTINE DT_SIGEMU
20212
20213 ************************************************************************
20214 * Combined cross section for target compounds.                         *
20215 * This version dated 6.4.98   is written by S. Roesler                 *
20216 ************************************************************************
20217
20218       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20219       SAVE
20220
20221       PARAMETER ( LINP = 5 ,
20222      &            LOUT = 6 ,
20223      &            LDAT = 9 )
20224
20225       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
20226      &           OHALF=0.5D0,ONE=1.0D0)
20227
20228       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
20229
20230 * Glauber formalism: cross sections
20231       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
20232      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
20233      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
20234      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
20235      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
20236      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
20237      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
20238      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
20239      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
20240      &                BSLOPE,NEBINI,NQBINI
20241 * emulsion treatment
20242       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
20243      &                NCOMPO,IEMUL
20244 * nucleon-nucleon event-generator
20245       CHARACTER*8 CMODEL
20246       LOGICAL LPHOIN
20247       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20248
20249       IF (MCGENE.NE.4) THEN
20250          WRITE(LOUT,'(A)') ' DT_SIGEMU:    Combined cross sections'
20251          WRITE(LOUT,'(15X,A)') '-----------------------'
20252       ENDIF
20253       DO 1 IE=1,NEBINI
20254          DO 2 IQ=1,NQBINI
20255             SIGTOT = ZERO
20256             SIGELA = ZERO
20257             SIGQEP = ZERO
20258             SIGQET = ZERO
20259             SIGQE2 = ZERO
20260             SIGPRO = ZERO
20261             SIGDEL = ZERO
20262             SIGDQE = ZERO
20263             ERRTOT = ZERO
20264             ERRELA = ZERO
20265             ERRQEP = ZERO
20266             ERRQET = ZERO
20267             ERRQE2 = ZERO
20268             ERRPRO = ZERO
20269             ERRDEL = ZERO
20270             ERRDQE = ZERO
20271             IF (NCOMPO.GT.0) THEN
20272                DO 3 IC=1,NCOMPO
20273                   SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
20274                   SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
20275                   SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
20276                   SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
20277                   SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
20278                   SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
20279                   SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
20280                   SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
20281                   ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
20282                   ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
20283                   ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
20284                   ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
20285                   ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
20286                   ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
20287                   ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
20288                   ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
20289     3          CONTINUE
20290                ERRTOT = SQRT(ERRTOT)
20291                ERRELA = SQRT(ERRELA)
20292                ERRQEP = SQRT(ERRQEP)
20293                ERRQET = SQRT(ERRQET)
20294                ERRQE2 = SQRT(ERRQE2)
20295                ERRPRO = SQRT(ERRPRO)
20296                ERRDEL = SQRT(ERRDEL)
20297                ERRDQE = SQRT(ERRDQE)
20298             ELSE
20299                SIGTOT = XSTOT(IE,IQ,1)
20300                SIGELA = XSELA(IE,IQ,1)
20301                SIGQEP = XSQEP(IE,IQ,1)
20302                SIGQET = XSQET(IE,IQ,1)
20303                SIGQE2 = XSQE2(IE,IQ,1)
20304                SIGPRO = XSPRO(IE,IQ,1)
20305                SIGDEL = XSDEL(IE,IQ,1)
20306                SIGDQE = XSDQE(IE,IQ,1)
20307                ERRTOT = XETOT(IE,IQ,1)
20308                ERRELA = XEELA(IE,IQ,1)
20309                ERRQEP = XEQEP(IE,IQ,1)
20310                ERRQET = XEQET(IE,IQ,1)
20311                ERRQE2 = XEQE2(IE,IQ,1)
20312                ERRPRO = XEPRO(IE,IQ,1)
20313                ERRDEL = XEDEL(IE,IQ,1)
20314                ERRDQE = XEDQE(IE,IQ,1)
20315             ENDIF
20316             IF (MCGENE.NE.4) THEN
20317                WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
20318  1000         FORMAT(/,1X,'E_cm =',F9.1,' GeV  Q^2 =',F6.1,' GeV^2 :',/)
20319                WRITE(LOUT,1001) SIGTOT,ERRTOT
20320  1001          FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
20321                WRITE(LOUT,1002) SIGELA,ERRELA
20322  1002          FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
20323                WRITE(LOUT,1003) SIGQEP,ERRQEP
20324  1003          FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
20325      &                F11.5,' mb')
20326                WRITE(LOUT,1004) SIGQET,ERRQET
20327  1004          FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
20328      &                F11.5,' mb')
20329                WRITE(LOUT,1005) SIGQE2,ERRQE2
20330  1005          FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
20331      &                ' +-',F11.5,' mb')
20332                WRITE(LOUT,1006) SIGPRO,ERRPRO
20333  1006          FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
20334                WRITE(LOUT,1007) SIGDEL,ERRDEL
20335  1007          FORMAT(1X,'diff-el   ',27X,F10.4,' +-',F11.5,' mb')
20336                WRITE(LOUT,1008) SIGDQE,ERRDQE
20337  1008          FORMAT(1X,'diff-qel  ',27X,F10.4,' +-',F11.5,' mb')
20338             ENDIF
20339
20340     2    CONTINUE
20341     1 CONTINUE
20342
20343       RETURN
20344       END
20345 *
20346 *===sigga==============================================================*
20347 *
20348 CDECK  ID>, DT_SIGGA
20349       SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
20350
20351 ************************************************************************
20352 * Total/inelastic photon-nucleus cross sections.                       *
20353 *     !!!! Overwrites SHMAKI-initialization. Do not use it during      *
20354 *          production runs !!!!                                        *
20355 * This version dated 27.03.96 is written by S. Roesler                 *
20356 ************************************************************************
20357
20358       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20359       SAVE
20360
20361       PARAMETER ( LINP = 5 ,
20362      &            LOUT = 6 ,
20363      &            LDAT = 9 )
20364
20365       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
20366      &           OHALF=0.5D0,ONE=1.0D0)
20367       PARAMETER (AMPROT = 0.938D0)
20368
20369       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
20370
20371 * Glauber formalism: cross sections
20372       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
20373      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
20374      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
20375      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
20376      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
20377      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
20378      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
20379      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
20380      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
20381      &                BSLOPE,NEBINI,NQBINI
20382
20383       NT  = NTI
20384       X   = XI
20385       Q2  = Q2I
20386       ECM = ECMI
20387       XNU = XNUI
20388       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
20389      &   ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
20390       CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
20391       STOT  = XSTOT(1,1,1)
20392       ETOT  = XETOT(1,1,1)
20393       SIN   = XSPRO(1,1,1)
20394       EIN   = XEPRO(1,1,1)
20395
20396       RETURN
20397       END
20398 *
20399 *===siggat=============================================================*
20400 *
20401 CDECK  ID>, DT_SIGGAT
20402       SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
20403
20404 ************************************************************************
20405 * Total/inelastic photon-nucleus cross sections.                       *
20406 * Uses pre-tabulated cross section.                                    *
20407 * This version dated 29.07.96 is written by S. Roesler                 *
20408 ************************************************************************
20409
20410       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20411       SAVE
20412
20413       PARAMETER ( LINP = 5 ,
20414      &            LOUT = 6 ,
20415      &            LDAT = 9 )
20416
20417       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
20418      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
20419
20420       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
20421
20422 * Glauber formalism: cross sections
20423       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
20424      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
20425      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
20426      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
20427      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
20428      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
20429      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
20430      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
20431      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
20432      &                BSLOPE,NEBINI,NQBINI
20433
20434       NTARG = ABS(NT)
20435       I1   = 1
20436       I2   = 1
20437       RATE = ONE
20438       IF (NEBINI.GT.1) THEN
20439          IF (ECMI.GE.ECMNN(NEBINI)) THEN
20440             I1   = NEBINI
20441             I2   = NEBINI
20442             RATE = ONE
20443          ELSEIF (ECMI.GT.ECMNN(1)) THEN
20444             DO 1 I=2,NEBINI
20445                IF (ECMI.LT.ECMNN(I)) THEN
20446                   I1   = I-1
20447                   I2   = I
20448                   RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
20449                   GOTO 2
20450                ENDIF
20451     1       CONTINUE
20452     2       CONTINUE
20453          ENDIF
20454       ENDIF
20455       J1   = 1
20456       J2   = 1
20457       RATQ = ONE
20458       IF (NQBINI.GT.1) THEN
20459          IF (Q2I.GE.Q2G(NQBINI)) THEN
20460             J1   = NQBINI
20461             J2   = NQBINI
20462             RATQ = ONE
20463          ELSEIF (Q2I.GT.Q2G(1)) THEN
20464             DO 3 I=2,NQBINI
20465                IF (Q2I.LT.Q2G(I)) THEN
20466                   J1   = I-1
20467                   J2   = I
20468                   RATQ = LOG10(    Q2I/MAX(Q2G(J1),TINY14))/
20469      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
20470 C                 RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
20471                   GOTO 4
20472                ENDIF
20473     3       CONTINUE
20474     4       CONTINUE
20475          ENDIF
20476       ENDIF
20477
20478       STOT = XSTOT(I1,J1,NTARG)+
20479      &   RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
20480      &   RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
20481      &   RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
20482      &              XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
20483
20484       RETURN
20485       END
20486 *
20487 *===sigano=============================================================*
20488 *
20489 CDECK  ID>, DT_SANO
20490       DOUBLE PRECISION FUNCTION DT_SANO(ECM)
20491
20492 ************************************************************************
20493 * This version dated 31.07.96 is written by S. Roesler                 *
20494 ************************************************************************
20495
20496       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20497       SAVE
20498
20499       PARAMETER ( LINP = 5 ,
20500      &            LOUT = 6 ,
20501      &            LDAT = 9 )
20502
20503       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
20504      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
20505       PARAMETER (NE = 8)
20506
20507 * VDM parameter for photon-nucleus interactions
20508       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20509 * properties of interacting particles
20510       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
20511
20512       DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
20513       DATA ECMANO /
20514      &             0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
20515      &             0.100D+04,0.200D+04,0.500D+04
20516      &            /
20517 * fixed cut (3 GeV/c)
20518       DATA FRAANO /
20519      &             0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
20520      &             0.062D+00,0.054D+00,0.042D+00
20521      &            /
20522       DATA SIGHRD /
20523      &           4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
20524      &           3.3086D-01,7.6255D-01,2.1319D+00
20525      &            /
20526 * running cut (based on obsolete Phojet-caluclations, bugs..)
20527 C     DATA FRAANO /
20528 C    &             0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
20529 C    &             0.167E+00,0.150E+00,0.131E+00
20530 C    &            /
20531 C     DATA SIGHRD /
20532 C    &           6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
20533 C    &           2.5736E-01,4.5593E-01,8.2550E-01
20534 C    &            /
20535
20536       DT_SANO = ZERO
20537       IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
20538       J1   = 0
20539       J2   = 0
20540       RATE = ONE
20541       IF (ECM.GE.ECMANO(NE)) THEN
20542          J1 = NE
20543          J2 = NE
20544       ELSEIF (ECM.GT.ECMANO(1)) THEN
20545          DO 1 IE=2,NE
20546             IF (ECM.LT.ECMANO(IE)) THEN
20547                J1   = IE-1
20548                J2   = IE
20549                RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
20550                GOTO 2
20551             ENDIF
20552     1    CONTINUE
20553     2    CONTINUE
20554       ENDIF
20555       IF ((J1.GT.0).AND.(J2.GT.0)) THEN
20556          AFRA1  = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
20557          AFRA2  = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
20558          DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
20559       ENDIF
20560
20561       RETURN
20562       END
20563 *
20564 *===siggp==============================================================*
20565 *
20566 CDECK  ID>, DT_SIGGP
20567       SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
20568
20569 ************************************************************************
20570 * Total/inelastic photon-nucleon cross sections.                       *
20571 * This version dated 30.04.96 is written by S. Roesler                 *
20572 ************************************************************************
20573
20574       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20575       SAVE
20576
20577       PARAMETER ( LINP = 5 ,
20578      &            LOUT = 6 ,
20579      &            LDAT = 9 )
20580
20581       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
20582       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
20583      &           PI     = TWOPI/TWO,
20584      &           GEV2MB = 0.38938D0,
20585      &           ALPHEM = ONE/137.0D0)
20586
20587 * particle properties (BAMJET index convention)
20588       CHARACTER*8  ANAME
20589       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20590      &                IICH(210),IIBAR(210),K1(210),K2(210)
20591 * VDM parameter for photon-nucleus interactions
20592       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20593
20594 **PHOJET105a
20595 C     CHARACTER*8 MDLNA
20596 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
20597 C     PARAMETER (IEETAB=10)
20598 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20599 **PHOJET110
20600 C  model switches and parameters
20601       CHARACTER*8 MDLNA
20602       INTEGER ISWMDL,IPAMDL
20603       DOUBLE PRECISION PARMDL
20604       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
20605 C  energy-interpolation table
20606       INTEGER IEETA2
20607       PARAMETER ( IEETA2 = 20 )
20608       INTEGER ISIMAX
20609       DOUBLE PRECISION SIGTAB,SIGECM
20610       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20611 **
20612
20613 C     PARAMETER (NPOINT=80)
20614       PARAMETER (NPOINT=16)
20615       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
20616
20617       STOT = ZERO
20618       SINE = ZERO
20619       SDIR = ZERO
20620
20621       W2 = ECMI**2
20622       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
20623      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
20624       Q2 = Q2I
20625       X  = XI
20626 * photoprod.
20627       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
20628          Q2 = 0.0001D0
20629          X  = Q2/(W2+Q2-AAM(1)**2)
20630 * DIS
20631       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
20632          X  = Q2/(W2+Q2-AAM(1)**2)
20633       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
20634          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
20635       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
20636          W2 = Q2*(ONE-X)/X+AAM(1)**2
20637       ELSE
20638          WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
20639          STOP
20640       ENDIF
20641       ECM = SQRT(W2)
20642
20643       IF (MODEGA.EQ.1) THEN
20644          SCALE = SQRT(Q2)
20645          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
20646      &                                                       IDPDF)
20647 C        W = SQRT(W2)
20648
20649 C        ALLMF2 = PHO_ALLM97(Q2,W)
20650
20651 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
20652          STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
20653          SINE = ZERO
20654          SDIR = ZERO
20655       ELSEIF (MODEGA.EQ.2) THEN
20656          IF (INTRGE(1).EQ.1) THEN
20657             AMLO2 = (3.0D0*AAM(13))**2
20658          ELSEIF (INTRGE(1).EQ.2) THEN
20659             AMLO2 = AAM(33)**2
20660          ELSE
20661             AMLO2 = AAM(96)**2
20662          ENDIF
20663          IF (INTRGE(2).EQ.1) THEN
20664             AMHI2 = W2/TWO
20665          ELSEIF (INTRGE(2).EQ.2) THEN
20666             AMHI2 = W2/4.0D0
20667          ELSE
20668             AMHI2 = W2
20669          ENDIF
20670          AMHI20 = (ECM-AAM(1))**2
20671          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
20672          XAMLO  = LOG( AMLO2+Q2 )
20673          XAMHI  = LOG( AMHI2+Q2 )
20674 **PHOJET105a
20675 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
20676 **PHOJET112
20677
20678          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
20679
20680 **
20681          SUM  = ZERO
20682          DO 1 J=1,NPOINT
20683             AM2 = EXP(ABSZX(J))-Q2
20684             IF (AM2.LT.16.0D0) THEN
20685                R = TWO
20686             ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
20687                R = 10.0D0/3.0D0
20688             ELSE
20689                R = 11.0D0/3.0D0
20690             ENDIF
20691 C           FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
20692             FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
20693      &            * (ONE+EPSPOL*Q2/AM2)
20694             SUM = SUM+WEIGHT(J)*FAC
20695     1    CONTINUE
20696          SINE = SUM
20697          SDIR = DT_SIGVP(X,Q2)
20698          STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
20699          SDIR = SDIR/(0.588D0+RL2+Q2)
20700 C        STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
20701       ELSEIF (MODEGA.EQ.3) THEN
20702          CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
20703       ELSEIF (MODEGA.EQ.4) THEN
20704 *  load cross sections from PHOJET interpolation table
20705          IP = 1
20706          IF(ECM.LE.SIGECM(IP,1)) THEN
20707            I1 = 1
20708            I2 = 1
20709          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
20710            DO 2 I=2,ISIMAX
20711               IF (ECM.LE.SIGECM(IP,I)) GOTO 3
20712     2      CONTINUE
20713     3      CONTINUE
20714            I1 = I-1
20715            I2 = I
20716          ELSE
20717            WRITE(LOUT,'(/1X,A,2E12.3)')
20718      &       'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
20719            I1 = ISIMAX
20720            I2 = ISIMAX
20721          ENDIF
20722          FAC2 = ZERO
20723          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
20724      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
20725          FAC1 = ONE-FAC2
20726 *  cross section dependence on photon virtuality
20727          FSUP1 = ZERO
20728          DO 4 I=1,3
20729             FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
20730      &                                /(1.D0+Q2/PARMDL(30+I))**2
20731     4    CONTINUE
20732          FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
20733          FAC1  = FAC1*FSUP1
20734          FAC2  = FAC2*FSUP1
20735          FSUP2 = 1.0D0
20736          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
20737          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
20738          SDIR  = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
20739 **re:
20740          STOT  = STOT-SDIR
20741 **
20742          SDIR  = SDIR/(FSUP1*FSUP2)
20743 **re:
20744          STOT  = STOT+SDIR
20745 **
20746       ENDIF
20747
20748       RETURN
20749       END
20750 *
20751 *===sigvel=============================================================*
20752 *
20753 CDECK  ID>, DT_SIGVEL
20754       SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
20755
20756 ************************************************************************
20757 * Cross section for elastic vector meson production                    *
20758 * This version dated 10.05.96 is written by S. Roesler                 *
20759 ************************************************************************
20760
20761       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20762       SAVE
20763
20764       PARAMETER ( LINP = 5 ,
20765      &            LOUT = 6 ,
20766      &            LDAT = 9 )
20767
20768       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
20769       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
20770      &           PI     = TWOPI/TWO,
20771      &           GEV2MB = 0.38938D0,
20772      &           ALPHEM = ONE/137.0D0)
20773
20774 * particle properties (BAMJET index convention)
20775       CHARACTER*8  ANAME
20776       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20777      &                IICH(210),IIBAR(210),K1(210),K2(210)
20778 * VDM parameter for photon-nucleus interactions
20779       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20780
20781       W2 = ECMI**2
20782       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
20783      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
20784       Q2 = Q2I
20785       X  = XI
20786 * photoprod.
20787       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
20788          Q2 = 0.0001D0
20789          X  = Q2/(W2+Q2-AAM(1)**2)
20790 * DIS
20791       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
20792          X  = Q2/(W2+Q2-AAM(1)**2)
20793       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
20794          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
20795       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
20796          W2 = Q2*(ONE-X)/X+AAM(1)**2
20797       ELSE
20798          WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
20799          STOP
20800       ENDIF
20801       ECM = SQRT(W2)
20802
20803       AMV  = AAM(IDXV)
20804       AMV2 = AMV**2
20805
20806       BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
20807      &        +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
20808       ROSH   = 0.1D0
20809       STOVP  = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
20810       SELVP  = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
20811
20812       IF (IDXV.EQ.33) THEN
20813          COUPL = 0.00365D0
20814       ELSE
20815          STOP
20816       ENDIF
20817       SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
20818       SIG2 = SELVP
20819       SVEL  = COUPL * (AMV2/(AMV2+Q2))**2
20820      &              * (ONE+EPSPOL*Q2/AMV2) * SELVP
20821
20822       RETURN
20823       END
20824 *
20825 *===sigvp==============================================================*
20826 *
20827 CDECK  ID>, DT_SIGVP
20828       DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
20829
20830 ************************************************************************
20831 * sigma_Vp                                                             *
20832 ************************************************************************
20833
20834       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20835       SAVE
20836
20837       PARAMETER ( LINP = 5 ,
20838      &            LOUT = 6 ,
20839      &            LDAT = 9 )
20840
20841       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
20842       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
20843      &           PI    = TWOPI/TWO,
20844      &           GEV2MB = 0.38938D0,
20845      &           AMPROT = 0.938D0,
20846      &           ALPHEM = ONE/137.0D0)
20847 * VDM parameter for photon-nucleus interactions
20848       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20849
20850       X  = XI
20851       Q2 = Q2I
20852       IF (XI.LE.ZERO)  X  = 0.0001D0
20853       IF (Q2I.LE.ZERO) Q2 = 0.0001D0
20854
20855       ECM    = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
20856
20857       SCALE = SQRT(Q2)
20858       IF (MODEGA.EQ.1) THEN
20859          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
20860      &                                                       IDPDF)
20861 C        W = ECM
20862
20863 C        ALLMF2 = PHO_ALLM97(Q2,W)
20864
20865 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
20866 C        STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
20867 C        DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
20868          DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
20869       ELSEIF (MODEGA.EQ.4) THEN
20870          CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
20871 C        F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
20872          DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
20873       ELSE
20874          STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
20875       ENDIF
20876
20877       RETURN
20878
20879       END
20880 *
20881 *===RRM2===============================================================*
20882 *
20883 CDECK  ID>, DT_RRM2
20884       DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
20885
20886       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20887       SAVE
20888
20889       PARAMETER ( LINP = 5 ,
20890      &            LOUT = 6 ,
20891      &            LDAT = 9 )
20892
20893       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
20894       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
20895      &           PI    = TWOPI/TWO,
20896      &           GEV2MB = 0.38938D0)
20897
20898 * particle properties (BAMJET index convention)
20899       CHARACTER*8  ANAME
20900       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20901      &                IICH(210),IIBAR(210),K1(210),K2(210)
20902 * VDM parameter for photon-nucleus interactions
20903       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20904
20905       S   = Q2*(ONE-X)/X+AAM(1)**2
20906       ECM = SQRT(S)
20907
20908       IF (INTRGE(1).EQ.1) THEN
20909          AMLO2 = (3.0D0*AAM(13))**2
20910       ELSEIF (INTRGE(1).EQ.2) THEN
20911          AMLO2 = AAM(33)**2
20912       ELSE
20913          AMLO2 = AAM(96)**2
20914       ENDIF
20915       IF (INTRGE(2).EQ.1) THEN
20916          AMHI2 = S/TWO
20917       ELSEIF (INTRGE(2).EQ.2) THEN
20918          AMHI2 = S/4.0D0
20919       ELSE
20920          AMHI2 = S
20921       ENDIF
20922       AMHI20 = (ECM-AAM(1))**2
20923       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
20924
20925       AM1C2 = 16.0D0
20926       AM2C2 = 121.0D0
20927       IF (AMHI2.LE.AM1C2) THEN
20928          DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
20929       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
20930          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
20931      &          10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
20932       ELSE
20933          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
20934      &          10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
20935      &          11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
20936       ENDIF
20937
20938       RETURN
20939       END
20940 *
20941 *===RM2================================================================*
20942 *
20943 CDECK  ID>, DT_RM2
20944       DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
20945
20946       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20947       SAVE
20948
20949       PARAMETER ( LINP = 5 ,
20950      &            LOUT = 6 ,
20951      &            LDAT = 9 )
20952
20953       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
20954       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
20955      &           PI    = TWOPI/TWO,
20956      &           GEV2MB = 0.38938D0)
20957 * VDM parameter for photon-nucleus interactions
20958       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20959
20960       IF (RL2.LE.ZERO) THEN
20961          DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
20962      &        (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
20963      &         +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
20964       ELSE
20965          TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
20966          TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
20967          DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
20968      &       -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
20969      &       +EPSPOL*(
20970      &         -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
20971      &       -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
20972       ENDIF
20973
20974       RETURN
20975       END
20976 *
20977 *===SAM2===============================================================*
20978 *
20979 CDECK  ID>, DT_SAM2
20980       DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
20981
20982       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20983       SAVE
20984
20985       PARAMETER ( LINP = 5 ,
20986      &            LOUT = 6 ,
20987      &            LDAT = 9 )
20988
20989       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
20990      &           TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
20991       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
20992      &           PI    = TWOPI/TWO,
20993      &           GEV2MB = 0.38938D0)
20994
20995 * particle properties (BAMJET index convention)
20996       CHARACTER*8  ANAME
20997       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20998      &                IICH(210),IIBAR(210),K1(210),K2(210)
20999 * VDM parameter for photon-nucleus interactions
21000       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21001
21002       S = ECM**2
21003       IF (INTRGE(1).EQ.1) THEN
21004          AMLO2 = (3.0D0*AAM(13))**2
21005       ELSEIF (INTRGE(1).EQ.2) THEN
21006          AMLO2 = AAM(33)**2
21007       ELSE
21008          AMLO2 = AAM(96)**2
21009       ENDIF
21010       IF (INTRGE(2).EQ.1) THEN
21011          AMHI2 = S/TWO
21012       ELSEIF (INTRGE(2).EQ.2) THEN
21013          AMHI2 = S/4.0D0
21014       ELSE
21015          AMHI2 = S
21016       ENDIF
21017       AMHI20 = (ECM-AAM(1))**2
21018       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
21019
21020       AM1C2 = 16.0D0
21021       AM2C2 = 121.0D0
21022       YLO   = LOG(AMLO2+Q2)
21023       YC1   = LOG(AM1C2+Q2)
21024       YC2   = LOG(AM2C2+Q2)
21025       YHI   = LOG(AMHI2+Q2)
21026       IF (AMHI2.LE.AM1C2) THEN
21027          FACHI = TWO
21028       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
21029          FACHI = TENTRD
21030       ELSE
21031          FACHI = ELVTRD
21032       ENDIF
21033
21034     1 CONTINUE
21035       YSAM2  = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
21036       IF (YSAM2.LE.YC1) THEN
21037          FAC = TWO
21038       ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
21039          FAC = TENTRD
21040       ELSE
21041          FAC = ELVTRD
21042       ENDIF
21043       WEIGMX = FACHI*(ONE-Q2*EXP(  -YHI))
21044       XSAM2  = FAC  *(ONE-Q2*EXP(-YSAM2))
21045       IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
21046
21047       DT_SAM2   = EXP(YSAM2)-Q2
21048
21049       RETURN
21050       END
21051 *
21052 *===ckmt===============================================================*
21053 *
21054 CDECK  ID>, DT_CKMT
21055       SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
21056      &                F2,IPAR)
21057
21058 ************************************************************************
21059 * This version dated 31.01.96 is written by S. Roesler                 *
21060 ************************************************************************
21061
21062       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21063       SAVE
21064
21065       PARAMETER ( LINP = 5 ,
21066      &            LOUT = 6 ,
21067      &            LDAT = 9 )
21068
21069       PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
21070
21071       PARAMETER (Q02 = 2.0D0,
21072      &           DQ2 = 10.05D0,
21073      &           Q12 = Q02+DQ2)
21074
21075       DIMENSION PD(-6:6),SEA(3),VAL(2)
21076
21077       CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
21078       CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
21079       ADQ2 = LOG10(Q12)-LOG10(Q02)
21080       F2P  = (F2Q1-F2Q0)/ADQ2
21081       CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
21082       CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
21083       F2PP = (F2PQ1-F2PQ0)/ADQ2
21084       FX   = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
21085
21086       Q2     = MAX(SCALE**2.0D0,TINY10)
21087       SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
21088       IF (Q2.LT.Q02) THEN
21089          CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
21090          UPV  = VAL(1)
21091          DNV  = VAL(2)
21092          USEA = SEA(1)
21093          DSEA = SEA(2)
21094          STR  = SEA(3)
21095          CHM  = 0.0D0
21096          BOT  = 0.0D0
21097          TOP  = 0.0D0
21098          GL   = GLU
21099       ELSE
21100          CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
21101          F2 = F2*SMOOTH
21102          UPV  = PD(2)-PD(3)
21103          DNV  = PD(1)-PD(3)
21104          USEA = PD(3)
21105          DSEA = PD(3)
21106          STR  = PD(3)
21107          CHM  = PD(4)
21108          BOT  = PD(5)
21109          TOP  = PD(6)
21110          GL   = PD(0)
21111 C        UPV  = UPV*SMOOTH
21112 C        DNV  = DNV*SMOOTH
21113 C        USEA = USEA*SMOOTH
21114 C        DSEA = DSEA*SMOOTH
21115 C        STR  = STR*SMOOTH
21116 C        CHM  = CHM*SMOOTH
21117 C        GL   = GL*SMOOTH
21118       ENDIF
21119
21120       RETURN
21121       END
21122 C
21123 CDECK  ID>, DT_CKMTX
21124       SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
21125 C**********************************************************************
21126 C
21127 C     PDF based on Regge theory, evolved with .... by ....
21128 C
21129 C     input: IPAR     2212   proton (not installed)
21130 C                       45   Pomeron
21131 C                      100   Deuteron
21132 C
21133 C     output: PD(-6:6) x*f(x)  parton distribution functions
21134 C            (PDFLIB convention: d = PD(1), u = PD(2) )
21135 C
21136 C**********************************************************************
21137
21138       SAVE
21139       DOUBLE PRECISION  X,SCALE2,PD(-6:6),CDN,CUP,F2
21140
21141       PARAMETER ( LINP = 5 ,
21142      &            LOUT = 6 ,
21143      &            LDAT = 9 )
21144
21145       DIMENSION QQ(7)
21146 C
21147       Q2=SNGL(SCALE2)
21148       Q1S=Q2
21149       XX=SNGL(X)
21150 C  QCD lambda for evolution
21151       OWLAM = 0.23D0
21152       OWLAM2=OWLAM**2
21153 C  Q0**2 for evolution
21154       Q02 = 2.D0
21155 C
21156 C
21157 C  the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
21158 C                        q(6)=x*charm, q(7)=x*gluon
21159 C
21160       SB=0.
21161       IF(Q2-Q02) 1,1,2
21162     2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
21163     1 CONTINUE
21164       IF(IPAR.EQ.2212) THEN
21165         CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
21166         CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
21167         CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
21168         CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
21169         CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
21170         CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
21171         CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
21172 C     ELSEIF (IPAR.EQ.45) THEN
21173 C       CALL CKMTPO(1,0,XX,SB,QQ(1))
21174 C       CALL CKMTPO(2,0,XX,SB,QQ(2))
21175 C       CALL CKMTPO(3,0,XX,SB,QQ(3))
21176 C       CALL CKMTPO(4,0,XX,SB,QQ(4))
21177 C       CALL CKMTPO(5,0,XX,SB,QQ(5))
21178 C       CALL CKMTPO(8,0,XX,SB,QQ(6))
21179 C       CALL CKMTPO(7,0,XX,SB,QQ(7))
21180       ELSEIF (IPAR.EQ.100) THEN
21181         CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
21182         CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
21183         CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
21184         CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
21185         CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
21186         CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
21187         CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
21188       ELSE
21189         WRITE(LOUT,'(1X,A,I4,A)')
21190      &     'CKMTX:   IPAR =',IPAR,' not implemented!'
21191         STOP
21192       ENDIF
21193 C
21194       PD(-6) = 0.D0
21195       PD(-5) = 0.D0
21196       PD(-4) = DBLE(QQ(6))
21197       PD(-3) = DBLE(QQ(3))
21198       PD(-2) = DBLE(QQ(4))
21199       PD(-1) = DBLE(QQ(5))
21200       PD(0)  = DBLE(QQ(7))
21201       PD(1)  = DBLE(QQ(2))
21202       PD(2)  = DBLE(QQ(1))
21203       PD(3)  = DBLE(QQ(3))
21204       PD(4)  = DBLE(QQ(6))
21205       PD(5)  = 0.D0
21206       PD(6)  = 0.D0
21207       IF(IPAR.EQ.45) THEN
21208         CDN = (PD(1)-PD(-1))/2.D0
21209         CUP = (PD(2)-PD(-2))/2.D0
21210         PD(-1) = PD(-1) + CDN
21211         PD(-2) = PD(-2) + CUP
21212         PD(1) = PD(-1)
21213         PD(2) = PD(-2)
21214       ENDIF
21215       F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
21216      &     1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
21217      &     1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
21218       END
21219 C
21220 *
21221 *===pdf0===============================================================*
21222 *
21223 CDECK  ID>, DT_PDF0
21224       SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
21225
21226 ************************************************************************
21227 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
21228 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
21229 *                   IPAR  = 2212   proton                              *
21230 *                         =  100   deuteron                            *
21231 * This version dated 31.01.96 is written by S. Roesler                 *
21232 ************************************************************************
21233
21234       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21235       SAVE
21236
21237       PARAMETER ( LINP = 5 ,
21238      &            LOUT = 6 ,
21239      &            LDAT = 9 )
21240
21241       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
21242
21243       PARAMETER (
21244      &              AA     = 0.1502D0,
21245      &              BBDEU  = 1.2D0,
21246      &              BUD    = 0.754D0,
21247      &              BDD    = 0.4495D0,
21248      &              BUP    = 1.2064D0,
21249      &              BDP    = 0.1798D0,
21250      &              DELTA0 = 0.07684D0,
21251      &              D      = 1.117D0,
21252      &              C      = 3.5489D0,
21253      &              A      = 0.2631D0,
21254      &              B      = 0.6452D0,
21255      &              ALPHAR = 0.415D0,
21256      &              E      = 0.1D0
21257      &          )
21258
21259       PARAMETER (NPOINT=16)
21260 C     DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
21261       DIMENSION SEA(3),VAL(2)
21262
21263       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
21264       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
21265 * proton, deuteron
21266       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
21267          CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
21268          SEA(1) = 0.75D0*SEA0
21269          SEA(2) = SEA(1)
21270          SEA(3) = SEA(1)
21271          VAL(1) = 9.0D0/4.0D0*VALU0
21272          VAL(2) = 9.0D0*VALD0
21273          GLU0   = SEA(1)/(1.0D0-X)
21274          F2     = SEA0+VALU0+VALD0
21275          F2PDF  = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
21276      &            1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
21277      &            1.0D0/9.0D0*(2.0D0*SEA(3))
21278          IF (ABS(F2-F2PDF).GT.TINY9) THEN
21279             WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
21280             STOP
21281          ENDIF
21282 **PHOJET105a
21283 C        CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
21284 **PHOJET112
21285
21286 C        CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
21287
21288 **
21289 C        SUMQ = ZERO
21290 C        SUMG = ZERO
21291 C        DO 1 J=1,NPOINT
21292 C           CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
21293 C           VALU0 = 9.0D0/4.0D0*VALU0
21294 C           VALD0 = 9.0D0*VALD0
21295 C           SEA0  = 0.75D0*SEA0
21296 C           SUMQ  = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
21297 C           SUMG  = SUMG+ (SEA0/(1.0D0-ABSZX(J)))  *WEIGHT(J)
21298 C   1    CONTINUE
21299 C        GLU = GLU0*(1.0D0-SUMQ)/SUMG
21300       ELSE
21301          WRITE(LOUT,'(1X,A,I4,A)')
21302      &      'PDF0:   IPAR =',IPAR,' not implemented!'
21303          STOP
21304       ENDIF
21305
21306       RETURN
21307       END
21308 *
21309 *===ckmtq0=============================================================*
21310 *
21311 CDECK  ID>, DT_CKMTQ0
21312       SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
21313
21314 ************************************************************************
21315 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
21316 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
21317 *                   IPAR  = 2212   proton                              *
21318 *                         =  100   deuteron                            *
21319 * This version dated 31.01.96 is written by S. Roesler                 *
21320 ************************************************************************
21321
21322       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21323       SAVE
21324
21325       PARAMETER ( LINP = 5 ,
21326      &            LOUT = 6 ,
21327      &            LDAT = 9 )
21328
21329       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
21330
21331       PARAMETER (
21332      &              AA     = 0.1502D0,
21333      &              BBDEU  = 1.2D0,
21334      &              BUD    = 0.754D0,
21335      &              BDD    = 0.4495D0,
21336      &              BUP    = 1.2064D0,
21337      &              BDP    = 0.1798D0,
21338      &              DELTA0 = 0.07684D0,
21339      &              D      = 1.117D0,
21340      &              C      = 3.5489D0,
21341      &              A      = 0.2631D0,
21342      &              B      = 0.6452D0,
21343      &              ALPHAR = 0.415D0,
21344      &              E      = 0.1D0
21345      &          )
21346
21347       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
21348       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
21349 * proton, deuteron
21350       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
21351          IF (IPAR.EQ.2212) THEN
21352             BU = BUP
21353             BD = BDP
21354          ELSE
21355             BU = BUD
21356             BD = BDD
21357          ENDIF
21358          SEA0  = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
21359      &          (Q2/(Q2+A))**(1.0D0+DELTA)
21360          VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
21361      &           (Q2/(Q2+B))**(ALPHAR)
21362          VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
21363      &           (Q2/(Q2+B))**(ALPHAR)
21364       ELSE
21365          WRITE(LOUT,'(1X,A,I4,A)')
21366      &      'CKMTQ0: IPAR =',IPAR,' not implemented!'
21367          STOP
21368       ENDIF
21369       RETURN
21370       END
21371 C
21372 C
21373 CDECK  ID>, DT_CKMTDE
21374       SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
21375 C
21376 C**********************************************************************
21377 C    Deuteron - PDFs
21378 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
21379 C    ANS = PDF(I)
21380 C    This version by S. Roesler, 30.01.96
21381 C**********************************************************************
21382
21383       SAVE
21384       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
21385       EQUIVALENCE (GF(1,1,1),DL(1))
21386       DATA DELTA/.13/
21387 C
21388       DATA (DL(K),K=    1,   85) /
21389      &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
21390      &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
21391      &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
21392      &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
21393      &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
21394      &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
21395      &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
21396      &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
21397      &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
21398      &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
21399      &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
21400      &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
21401      &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
21402      &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
21403      &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
21404      &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
21405      &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
21406       DATA (DL(K),K=   86,  170) /
21407      &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
21408      &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
21409      &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
21410      &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
21411      &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
21412      &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
21413      &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21421      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21422      &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
21423      &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
21424       DATA (DL(K),K=  171,  255) /
21425      &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
21426      &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
21427      &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
21428      &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
21429      &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
21430      &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
21431      &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
21432      &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
21433      &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
21434      &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
21435      &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
21436      &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
21437      &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
21438      &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
21439      &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
21440      &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
21441      &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
21442       DATA (DL(K),K=  256,  340) /
21443      &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
21444      &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
21445      &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
21446      &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
21447      &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21455      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21456      &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
21457      &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
21458      &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
21459      &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
21460       DATA (DL(K),K=  341,  425) /
21461      &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
21462      &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
21463      &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
21464      &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
21465      &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
21466      &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
21467      &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
21468      &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
21469      &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
21470      &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
21471      &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
21472      &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
21473      &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
21474      &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
21475      &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
21476      &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
21477      &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
21478       DATA (DL(K),K=  426,  510) /
21479      &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
21480      &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
21481      &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21489      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21490      &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
21491      &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
21492      &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
21493      &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
21494      &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
21495      &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
21496       DATA (DL(K),K=  511,  595) /
21497      &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
21498      &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
21499      &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
21500      &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
21501      &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
21502      &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
21503      &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
21504      &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
21505      &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
21506      &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
21507      &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
21508      &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
21509      &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
21510      &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
21511      &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
21512      &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
21513      &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
21514       DATA (DL(K),K=  596,  680) /
21515      &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21523      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21524      &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
21525      &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
21526      &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
21527      &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
21528      &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
21529      &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
21530      &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
21531      &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
21532       DATA (DL(K),K=  681,  765) /
21533      &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
21534      &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
21535      &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
21536      &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
21537      &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
21538      &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
21539      &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
21540      &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
21541      &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
21542      &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
21543      &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
21544      &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
21545      &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
21546      &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
21547      &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
21548      &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
21549      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21550       DATA (DL(K),K=  766,  850) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21557      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21558      &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
21559      &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
21560      &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
21561      &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
21562      &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
21563      &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
21564      &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
21565      &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
21566      &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
21567      &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
21568       DATA (DL(K),K=  851,  935) /
21569      &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
21570      &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
21571      &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
21572      &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
21573      &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
21574      &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
21575      &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
21576      &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
21577      &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
21578      &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
21579      &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
21580      &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
21581      &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
21582      &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
21583      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21584      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21585      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21586       DATA (DL(K),K=  936, 1020) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21591      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21592      &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
21593      &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
21594      &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
21595      &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
21596      &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
21597      &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
21598      &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
21599      &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
21600      &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
21601      &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
21602      &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
21603      &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
21604       DATA (DL(K),K= 1021, 1105) /
21605      &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
21606      &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
21607      &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
21608      &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
21609      &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
21610      &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
21611      &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
21612      &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
21613      &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
21614      &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
21615      &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
21616      &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
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      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21621      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21622       DATA (DL(K),K= 1106, 1190) /
21623      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21624      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21625      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21626      &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
21627      &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
21628      &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
21629      &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
21630      &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
21631      &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
21632      &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
21633      &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
21634      &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
21635      &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
21636      &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
21637      &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
21638      &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
21639      &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
21640       DATA (DL(K),K= 1191, 1275) /
21641      &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
21642      &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
21643      &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
21644      &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
21645      &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
21646      &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
21647      &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
21648      &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
21649      &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
21650      &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
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      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21657      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21658       DATA (DL(K),K= 1276, 1360) /
21659      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21660      &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
21661      &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
21662      &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
21663      &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
21664      &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
21665      &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
21666      &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
21667      &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
21668      &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
21669      &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
21670      &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
21671      &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
21672      &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
21673      &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
21674      &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
21675      &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
21676       DATA (DL(K),K= 1361, 1445) /
21677      &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
21678      &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
21679      &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
21680      &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
21681      &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
21682      &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
21683      &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
21684      &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21692      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21693      &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
21694       DATA (DL(K),K= 1446, 1530) /
21695      &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
21696      &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
21697      &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
21698      &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
21699      &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
21700      &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
21701      &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
21702      &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
21703      &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
21704      &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
21705      &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
21706      &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
21707      &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
21708      &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
21709      &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
21710      &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
21711      &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
21712       DATA (DL(K),K= 1531, 1615) /
21713      &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
21714      &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
21715      &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
21716      &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
21717      &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
21718      &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21726      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21727      &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
21728      &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
21729      &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
21730       DATA (DL(K),K= 1616, 1700) /
21731      &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
21732      &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
21733      &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
21734      &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
21735      &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
21736      &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
21737      &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
21738      &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
21739      &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
21740      &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
21741      &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
21742      &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
21743      &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
21744      &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
21745      &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
21746      &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
21747      &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
21748       DATA (DL(K),K= 1701, 1785) /
21749      &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
21750      &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
21751      &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
21752      &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21760      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21761      &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
21762      &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
21763      &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
21764      &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
21765      &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
21766       DATA (DL(K),K= 1786, 1870) /
21767      &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
21768      &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
21769      &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
21770      &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
21771      &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
21772      &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
21773      &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
21774      &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
21775      &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
21776      &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
21777      &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
21778      &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
21779      &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
21780      &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
21781      &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
21782      &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
21783      &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
21784       DATA (DL(K),K= 1871, 1955) /
21785      &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
21786      &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21794      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21795      &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
21796      &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
21797      &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
21798      &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
21799      &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
21800      &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
21801      &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
21802       DATA (DL(K),K= 1956, 2040) /
21803      &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
21804      &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
21805      &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
21806      &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
21807      &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
21808      &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
21809      &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
21810      &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
21811      &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
21812      &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
21813      &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
21814      &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
21815      &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
21816      &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
21817      &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
21818      &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
21819      &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
21820       DATA (DL(K),K= 2041, 2125) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21828      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21829      &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
21830      &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
21831      &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
21832      &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
21833      &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
21834      &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
21835      &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
21836      &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
21837      &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
21838       DATA (DL(K),K= 2126, 2210) /
21839      &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
21840      &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
21841      &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
21842      &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
21843      &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
21844      &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
21845      &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
21846      &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
21847      &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
21848      &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
21849      &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
21850      &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
21851      &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
21852      &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
21853      &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
21854      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21855      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21856       DATA (DL(K),K= 2211, 2295) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21862      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21863      &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
21864      &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
21865      &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
21866      &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
21867      &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
21868      &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
21869      &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
21870      &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
21871      &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
21872      &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
21873      &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
21874       DATA (DL(K),K= 2296, 2380) /
21875      &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
21876      &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
21877      &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
21878      &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
21879      &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
21880      &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
21881      &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
21882      &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
21883      &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
21884      &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
21885      &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
21886      &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
21887      &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
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      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21891      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21892       DATA (DL(K),K= 2381, 2465) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21896      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21897      &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
21898      &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
21899      &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
21900      &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
21901      &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
21902      &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
21903      &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
21904      &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
21905      &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
21906      &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
21907      &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
21908      &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
21909      &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
21910       DATA (DL(K),K= 2466, 2550) /
21911      &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
21912      &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
21913      &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
21914      &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
21915      &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
21916      &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
21917      &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
21918      &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
21919      &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
21920      &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
21921      &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
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      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21927      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21928       DATA (DL(K),K= 2551, 2635) /
21929      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21930      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21931      &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
21932      &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
21933      &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
21934      &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
21935      &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
21936      &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
21937      &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
21938      &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
21939      &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
21940      &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
21941      &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
21942      &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
21943      &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
21944      &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
21945      &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
21946       DATA (DL(K),K= 2636, 2720) /
21947      &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
21948      &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
21949      &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
21950      &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
21951      &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
21952      &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
21953      &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
21954      &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
21955      &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
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      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21963      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21964       DATA (DL(K),K= 2721, 2805) /
21965      &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
21966      &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
21967      &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
21968      &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
21969      &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
21970      &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
21971      &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
21972      &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
21973      &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
21974      &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
21975      &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
21976      &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
21977      &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
21978      &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
21979      &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
21980      &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
21981      &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
21982       DATA (DL(K),K= 2806, 2890) /
21983      &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
21984      &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
21985      &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
21986      &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
21987      &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
21988      &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
21989      &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21997      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21998      &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
21999      &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
22000       DATA (DL(K),K= 2891, 2975) /
22001      &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
22002      &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
22003      &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
22004      &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
22005      &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
22006      &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
22007      &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
22008      &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
22009      &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
22010      &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
22011      &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
22012      &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
22013      &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
22014      &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
22015      &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
22016      &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
22017      &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
22018       DATA (DL(K),K= 2976, 3060) /
22019      &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
22020      &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
22021      &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
22022      &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
22023      &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22031      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22032      &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
22033      &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
22034      &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
22035      &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
22036       DATA (DL(K),K= 3061, 3145) /
22037      &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
22038      &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
22039      &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
22040      &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
22041      &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
22042      &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
22043      &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
22044      &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
22045      &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
22046      &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
22047      &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
22048      &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
22049      &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
22050      &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
22051      &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
22052      &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
22053      &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
22054       DATA (DL(K),K= 3146, 3230) /
22055      &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
22056      &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
22057      &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22065      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22066      &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
22067      &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
22068      &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
22069      &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
22070      &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
22071      &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
22072       DATA (DL(K),K= 3231, 3315) /
22073      &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
22074      &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
22075      &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
22076      &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
22077      &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
22078      &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
22079      &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
22080      &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
22081      &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
22082      &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
22083      &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
22084      &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
22085      &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
22086      &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
22087      &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
22088      &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
22089      &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
22090       DATA (DL(K),K= 3316, 3400) /
22091      &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22099      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22100      &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
22101      &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
22102      &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
22103      &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
22104      &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
22105      &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
22106      &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
22107      &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
22108       DATA (DL(K),K= 3401, 3485) /
22109      &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
22110      &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
22111      &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
22112      &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
22113      &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
22114      &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
22115      &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
22116      &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
22117      &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
22118      &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
22119      &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
22120      &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
22121      &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
22122      &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
22123      &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
22124      &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
22125      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22126       DATA (DL(K),K= 3486, 3570) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22133      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22134      &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
22135      &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
22136      &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
22137      &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
22138      &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
22139      &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
22140      &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
22141      &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
22142      &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
22143      &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
22144       DATA (DL(K),K= 3571, 3655) /
22145      &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
22146      &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
22147      &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
22148      &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
22149      &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
22150      &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
22151      &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
22152      &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
22153      &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
22154      &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
22155      &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
22156      &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
22157      &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
22158      &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
22159      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22160      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22161      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22162       DATA (DL(K),K= 3656, 3740) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22167      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22168      &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
22169      &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
22170      &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
22171      &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
22172      &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
22173      &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
22174      &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
22175      &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
22176      &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
22177      &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
22178      &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
22179      &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
22180       DATA (DL(K),K= 3741, 3825) /
22181      &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
22182      &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
22183      &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
22184      &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
22185      &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
22186      &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
22187      &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
22188      &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
22189      &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
22190      &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
22191      &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
22192      &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
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      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22197      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22198       DATA (DL(K),K= 3826, 3910) /
22199      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22200      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22201      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22202      &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
22203      &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
22204      &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
22205      &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
22206      &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
22207      &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
22208      &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
22209      &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
22210      &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
22211      &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
22212      &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
22213      &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
22214      &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
22215      &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
22216       DATA (DL(K),K= 3911, 3995) /
22217      &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
22218      &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
22219      &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
22220      &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
22221      &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
22222      &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
22223      &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
22224      &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
22225      &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
22226      &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
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      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22233      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22234       DATA (DL(K),K= 3996, 4000) /
22235      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22236 C
22237       ANS = 0.
22238       IF (X.GT.0.9985) RETURN
22239       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
22240 C
22241       IS  = S/DELTA+1
22242       IS1 = IS+1
22243       DO 1 L=1,25
22244          KL    = L+NDRV*25
22245          F1(L) = GF(I,IS,KL)
22246          F2(L) = GF(I,IS1,KL)
22247     1 CONTINUE
22248       A1 = DT_CKMTFF(X,F1)
22249       A2 = DT_CKMTFF(X,F2)
22250 C      A1=ALOG(A1)
22251 C      A2=ALOG(A2)
22252       S1  = (IS-1)*DELTA
22253       S2  = S1+DELTA
22254       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
22255 C      ANS=EXP(ANS)
22256       RETURN
22257       END
22258 C
22259 C
22260 CDECK  ID>, DT_CKMTPR
22261       SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
22262 C
22263 C**********************************************************************
22264 C    Proton   - PDFs
22265 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22266 C    ANS = PDF(I)
22267 C    This version by S. Roesler, 31.01.96
22268 C**********************************************************************
22269
22270       SAVE
22271       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22272       EQUIVALENCE (GF(1,1,1),DL(1))
22273       DATA DELTA/.10/
22274 C
22275       DATA (DL(K),K=    1,   85) /
22276      &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22277      &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
22278      &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
22279      &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
22280      &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
22281      &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
22282      &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
22283      &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
22284      &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
22285      &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
22286      &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
22287      &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
22288      &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
22289      &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
22290      &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
22291      &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
22292      &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
22293       DATA (DL(K),K=   86,  170) /
22294      &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
22295      &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
22296      &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
22297      &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
22298      &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
22299      &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
22300      &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
22301      &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
22302      &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
22303      &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
22304      &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
22305      &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
22306      &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
22307      &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
22308      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22309      &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22310      &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
22311       DATA (DL(K),K=  171,  255) /
22312      &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
22313      &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
22314      &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
22315      &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
22316      &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
22317      &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
22318      &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
22319      &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
22320      &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
22321      &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
22322      &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
22323      &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
22324      &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
22325      &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
22326      &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
22327      &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
22328      &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
22329       DATA (DL(K),K=  256,  340) /
22330      &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
22331      &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
22332      &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
22333      &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
22334      &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
22335      &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
22336      &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
22337      &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
22338      &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
22339      &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
22340      &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
22341      &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
22342      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22343      &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22344      &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
22345      &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
22346      &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
22347       DATA (DL(K),K=  341,  425) /
22348      &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
22349      &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
22350      &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
22351      &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
22352      &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
22353      &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
22354      &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
22355      &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
22356      &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
22357      &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
22358      &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
22359      &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
22360      &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
22361      &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
22362      &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
22363      &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
22364      &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
22365       DATA (DL(K),K=  426,  510) /
22366      &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
22367      &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
22368      &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
22369      &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
22370      &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
22371      &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
22372      &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
22373      &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
22374      &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
22375      &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22376      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22377      &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22378      &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
22379      &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
22380      &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
22381      &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
22382      &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
22383       DATA (DL(K),K=  511,  595) /
22384      &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
22385      &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
22386      &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
22387      &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
22388      &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
22389      &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
22390      &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
22391      &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
22392      &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
22393      &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
22394      &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
22395      &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
22396      &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
22397      &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
22398      &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
22399      &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
22400      &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
22401       DATA (DL(K),K=  596,  680) /
22402      &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
22403      &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
22404      &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
22405      &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
22406      &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
22407      &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
22408      &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
22409      &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22410      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22411      &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
22412      &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
22413      &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
22414      &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
22415      &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
22416      &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
22417      &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
22418      &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
22419       DATA (DL(K),K=  681,  765) /
22420      &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
22421      &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
22422      &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
22423      &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
22424      &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
22425      &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
22426      &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
22427      &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
22428      &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
22429      &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
22430      &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
22431      &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
22432      &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
22433      &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
22434      &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
22435      &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
22436      &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
22437       DATA (DL(K),K=  766,  850) /
22438      &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
22439      &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
22440      &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
22441      &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
22442      &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
22443      &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22444      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22445      &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
22446      &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
22447      &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
22448      &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
22449      &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
22450      &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
22451      &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
22452      &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
22453      &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
22454      &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
22455       DATA (DL(K),K=  851,  935) /
22456      &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
22457      &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
22458      &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
22459      &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
22460      &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
22461      &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
22462      &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
22463      &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
22464      &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
22465      &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
22466      &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
22467      &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
22468      &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
22469      &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
22470      &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
22471      &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
22472      &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
22473       DATA (DL(K),K=  936, 1020) /
22474      &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
22475      &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
22476      &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
22477      &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22478      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22479      &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
22480      &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
22481      &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
22482      &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
22483      &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
22484      &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
22485      &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
22486      &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
22487      &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
22488      &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
22489      &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
22490      &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
22491       DATA (DL(K),K= 1021, 1105) /
22492      &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
22493      &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
22494      &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
22495      &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
22496      &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
22497      &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
22498      &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
22499      &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
22500      &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
22501      &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
22502      &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
22503      &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
22504      &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
22505      &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
22506      &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
22507      &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
22508      &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
22509       DATA (DL(K),K= 1106, 1190) /
22510      &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
22511      &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
22512      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22513      &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
22514      &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
22515      &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
22516      &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
22517      &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
22518      &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
22519      &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
22520      &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
22521      &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
22522      &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
22523      &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
22524      &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
22525      &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
22526      &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
22527       DATA (DL(K),K= 1191, 1275) /
22528      &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
22529      &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
22530      &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
22531      &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
22532      &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
22533      &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
22534      &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
22535      &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
22536      &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
22537      &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
22538      &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
22539      &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
22540      &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
22541      &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
22542      &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
22543      &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
22544      &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
22545       DATA (DL(K),K= 1276, 1360) /
22546      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22547      &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
22548      &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
22549      &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
22550      &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
22551      &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
22552      &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
22553      &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
22554      &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
22555      &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
22556      &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
22557      &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
22558      &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
22559      &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
22560      &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
22561      &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
22562      &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
22563       DATA (DL(K),K= 1361, 1445) /
22564      &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
22565      &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
22566      &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
22567      &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
22568      &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
22569      &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
22570      &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
22571      &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
22572      &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
22573      &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
22574      &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
22575      &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
22576      &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
22577      &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
22578      &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
22579      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22580      &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
22581       DATA (DL(K),K= 1446, 1530) /
22582      &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
22583      &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
22584      &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
22585      &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
22586      &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
22587      &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
22588      &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
22589      &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
22590      &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
22591      &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
22592      &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
22593      &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
22594      &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
22595      &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
22596      &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
22597      &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
22598      &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
22599       DATA (DL(K),K= 1531, 1615) /
22600      &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
22601      &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
22602      &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
22603      &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
22604      &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
22605      &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
22606      &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
22607      &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
22608      &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
22609      &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
22610      &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
22611      &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
22612      &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
22613      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22614      &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
22615      &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
22616      &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
22617       DATA (DL(K),K= 1616, 1700) /
22618      &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
22619      &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
22620      &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
22621      &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
22622      &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
22623      &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
22624      &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
22625      &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
22626      &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
22627      &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
22628      &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
22629      &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
22630      &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
22631      &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
22632      &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
22633      &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
22634      &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
22635       DATA (DL(K),K= 1701, 1785) /
22636      &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
22637      &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
22638      &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
22639      &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
22640      &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
22641      &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
22642      &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
22643      &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
22644      &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
22645      &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
22646      &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
22647      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22648      &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
22649      &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
22650      &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
22651      &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
22652      &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
22653       DATA (DL(K),K= 1786, 1870) /
22654      &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
22655      &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
22656      &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
22657      &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
22658      &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
22659      &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
22660      &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
22661      &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
22662      &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
22663      &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
22664      &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
22665      &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
22666      &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
22667      &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
22668      &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
22669      &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
22670      &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
22671       DATA (DL(K),K= 1871, 1955) /
22672      &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
22673      &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
22674      &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
22675      &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
22676      &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
22677      &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
22678      &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
22679      &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
22680      &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
22681      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22682      &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
22683      &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
22684      &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
22685      &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
22686      &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
22687      &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
22688      &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
22689       DATA (DL(K),K= 1956, 2040) /
22690      &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
22691      &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
22692      &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
22693      &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
22694      &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
22695      &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
22696      &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
22697      &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
22698      &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
22699      &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
22700      &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
22701      &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
22702      &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
22703      &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
22704      &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
22705      &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
22706      &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
22707       DATA (DL(K),K= 2041, 2125) /
22708      &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
22709      &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
22710      &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
22711      &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
22712      &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
22713      &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
22714      &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
22715      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22716      &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
22717      &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
22718      &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
22719      &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
22720      &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
22721      &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
22722      &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
22723      &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
22724      &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
22725       DATA (DL(K),K= 2126, 2210) /
22726      &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
22727      &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
22728      &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
22729      &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
22730      &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
22731      &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
22732      &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
22733      &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
22734      &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
22735      &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
22736      &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
22737      &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
22738      &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
22739      &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
22740      &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
22741      &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
22742      &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
22743       DATA (DL(K),K= 2211, 2295) /
22744      &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
22745      &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
22746      &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
22747      &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
22748      &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
22749      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22750      &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
22751      &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
22752      &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
22753      &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
22754      &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
22755      &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
22756      &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
22757      &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
22758      &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
22759      &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
22760      &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
22761       DATA (DL(K),K= 2296, 2380) /
22762      &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
22763      &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
22764      &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
22765      &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
22766      &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
22767      &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
22768      &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
22769      &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
22770      &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
22771      &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
22772      &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
22773      &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
22774      &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
22775      &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
22776      &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
22777      &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
22778      &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
22779       DATA (DL(K),K= 2381, 2465) /
22780      &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
22781      &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
22782      &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
22783      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22784      &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
22785      &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
22786      &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
22787      &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
22788      &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
22789      &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
22790      &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
22791      &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
22792      &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
22793      &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
22794      &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
22795      &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
22796      &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
22797       DATA (DL(K),K= 2466, 2550) /
22798      &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
22799      &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
22800      &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
22801      &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
22802      &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
22803      &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
22804      &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
22805      &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
22806      &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
22807      &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
22808      &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
22809      &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
22810      &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
22811      &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
22812      &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
22813      &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
22814      &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
22815       DATA (DL(K),K= 2551, 2635) /
22816      &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
22817      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22818      &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
22819      &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
22820      &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
22821      &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
22822      &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
22823      &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
22824      &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
22825      &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
22826      &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
22827      &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
22828      &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
22829      &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
22830      &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
22831      &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
22832      &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
22833       DATA (DL(K),K= 2636, 2720) /
22834      &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
22835      &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
22836      &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
22837      &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
22838      &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
22839      &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
22840      &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
22841      &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
22842      &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
22843      &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
22844      &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
22845      &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
22846      &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
22847      &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
22848      &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
22849      &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
22850      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22851       DATA (DL(K),K= 2721, 2805) /
22852      &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
22853      &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
22854      &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
22855      &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
22856      &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
22857      &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
22858      &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
22859      &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
22860      &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
22861      &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
22862      &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
22863      &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
22864      &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
22865      &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
22866      &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
22867      &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
22868      &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
22869       DATA (DL(K),K= 2806, 2890) /
22870      &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
22871      &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
22872      &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
22873      &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
22874      &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
22875      &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
22876      &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
22877      &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
22878      &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
22879      &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
22880      &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
22881      &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
22882      &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
22883      &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
22884      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22885      &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
22886      &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
22887       DATA (DL(K),K= 2891, 2975) /
22888      &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
22889      &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
22890      &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
22891      &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
22892      &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
22893      &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
22894      &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
22895      &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
22896      &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
22897      &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
22898      &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
22899      &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
22900      &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
22901      &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
22902      &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
22903      &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
22904      &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
22905       DATA (DL(K),K= 2976, 3060) /
22906      &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
22907      &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
22908      &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
22909      &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
22910      &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
22911      &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
22912      &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
22913      &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
22914      &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
22915      &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
22916      &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
22917      &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
22918      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22919      &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
22920      &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
22921      &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
22922      &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
22923       DATA (DL(K),K= 3061, 3145) /
22924      &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
22925      &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
22926      &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
22927      &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
22928      &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
22929      &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
22930      &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
22931      &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
22932      &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
22933      &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
22934      &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
22935      &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
22936      &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
22937      &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
22938      &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
22939      &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
22940      &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
22941       DATA (DL(K),K= 3146, 3230) /
22942      &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
22943      &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
22944      &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
22945      &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
22946      &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
22947      &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
22948      &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
22949      &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
22950      &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
22951      &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
22952      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22953      &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
22954      &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
22955      &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
22956      &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
22957      &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
22958      &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
22959       DATA (DL(K),K= 3231, 3315) /
22960      &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
22961      &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
22962      &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
22963      &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
22964      &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
22965      &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
22966      &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
22967      &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
22968      &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
22969      &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
22970      &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
22971      &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
22972      &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
22973      &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
22974      &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
22975      &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
22976      &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
22977       DATA (DL(K),K= 3316, 3400) /
22978      &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
22979      &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
22980      &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
22981      &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
22982      &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
22983      &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
22984      &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
22985      &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
22986      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22987      &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
22988      &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
22989      &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
22990      &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
22991      &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
22992      &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
22993      &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
22994      &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
22995       DATA (DL(K),K= 3401, 3485) /
22996      &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
22997      &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
22998      &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
22999      &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
23000      &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
23001      &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
23002      &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
23003      &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
23004      &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
23005      &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
23006      &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
23007      &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
23008      &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
23009      &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
23010      &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
23011      &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
23012      &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
23013       DATA (DL(K),K= 3486, 3570) /
23014      &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
23015      &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
23016      &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
23017      &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
23018      &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
23019      &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
23020      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23021      &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
23022      &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
23023      &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
23024      &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
23025      &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
23026      &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
23027      &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
23028      &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
23029      &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
23030      &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
23031       DATA (DL(K),K= 3571, 3655) /
23032      &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
23033      &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
23034      &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
23035      &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
23036      &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
23037      &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
23038      &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
23039      &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
23040      &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
23041      &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
23042      &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
23043      &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
23044      &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
23045      &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
23046      &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
23047      &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
23048      &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
23049       DATA (DL(K),K= 3656, 3740) /
23050      &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
23051      &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
23052      &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
23053      &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
23054      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23055      &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23056      &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
23057      &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
23058      &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
23059      &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
23060      &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
23061      &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
23062      &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
23063      &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
23064      &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
23065      &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
23066      &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
23067       DATA (DL(K),K= 3741, 3825) /
23068      &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
23069      &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
23070      &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
23071      &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
23072      &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
23073      &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
23074      &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
23075      &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
23076      &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
23077      &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
23078      &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
23079      &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
23080      &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
23081      &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
23082      &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
23083      &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
23084      &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
23085       DATA (DL(K),K= 3826, 3910) /
23086      &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
23087      &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
23088      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23089      &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23090      &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
23091      &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
23092      &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
23093      &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
23094      &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
23095      &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
23096      &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
23097      &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
23098      &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
23099      &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
23100      &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
23101      &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
23102      &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
23103       DATA (DL(K),K= 3911, 3995) /
23104      &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
23105      &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
23106      &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
23107      &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
23108      &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
23109      &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
23110      &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
23111      &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
23112      &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
23113      &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
23114      &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
23115      &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
23116      &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
23117      &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
23118      &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
23119      &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
23120      &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
23121       DATA (DL(K),K= 3996, 4000) /
23122      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23123 C
23124       ANS = 0.
23125       IF (X.GT.0.9985) RETURN
23126       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23127 C
23128       IS  = S/DELTA+1
23129       IS1 = IS+1
23130       DO 1 L=1,25
23131          KL    = L+NDRV*25
23132          F1(L) = GF(I,IS,KL)
23133          F2(L) = GF(I,IS1,KL)
23134     1 CONTINUE
23135       A1 = DT_CKMTFF(X,F1)
23136       A2 = DT_CKMTFF(X,F2)
23137 C      A1=ALOG(A1)
23138 C      A2=ALOG(A2)
23139       S1  = (IS-1)*DELTA
23140       S2  = S1+DELTA
23141       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23142 C      ANS=EXP(ANS)
23143       RETURN
23144       END
23145 C
23146 CDECK  ID>, DT_CKMTFF
23147       FUNCTION DT_CKMTFF(X,FVL)
23148 C**********************************************************************
23149 C
23150 C     LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
23151 C     FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
23152 C     NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
23153 C     IN MAIN ROUTINE.
23154 C
23155 C**********************************************************************
23156
23157       SAVE
23158       DIMENSION FVL(25),XGRID(25)
23159       DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
23160      *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
23161 C
23162       DT_CKMTFF=0.
23163       DO 1 I=1,NX
23164       IF(X.LT.XGRID(I)) GO TO 2
23165     1 CONTINUE
23166     2 I=I-1
23167       IF(I.EQ.0) THEN
23168          I=I+1
23169       ELSE IF(I.GT.23) THEN
23170          I=23
23171       ENDIF
23172       J=I+1
23173       K=J+1
23174       AXI=LOG(XGRID(I))
23175       BXI=LOG(1.-XGRID(I))
23176       AXJ=LOG(XGRID(J))
23177       BXJ=LOG(1.-XGRID(J))
23178       AXK=LOG(XGRID(K))
23179       BXK=LOG(1.-XGRID(K))
23180       FI=LOG(ABS(FVL(I)) +1.E-15)
23181       FJ=LOG(ABS(FVL(J)) +1.E-16)
23182       FK=LOG(ABS(FVL(K)) +1.E-17)
23183       DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
23184       ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
23185      $ BXI))/DET
23186       ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
23187       BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
23188       IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
23189      1RETURN
23190 C      IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
23191 C         WRITE(6,2001) X,FVL
23192 C 2001    FORMAT(8E12.4)
23193 C         WRITE(6,2001) ALPHA,BETA,ALOGA,DET
23194 C      ENDIF
23195       DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
23196       RETURN
23197       END
23198 *
23199 *===fluini=============================================================*
23200 *
23201 CDECK  ID>, DT_FLUINI
23202       SUBROUTINE DT_FLUINI
23203
23204 ************************************************************************
23205 * Initialisation of the nucleon-nucleon cross section fluctuation      *
23206 * treatment. The original version by J. Ranft.                         *
23207 * This version dated 21.04.95 is revised by S. Roesler.                *
23208 ************************************************************************
23209
23210       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23211       SAVE
23212
23213       PARAMETER ( LINP = 5 ,
23214      &            LOUT = 6 ,
23215      &            LDAT = 9 )
23216
23217       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
23218
23219       PARAMETER ( A     = 0.1D0,
23220      &            B     = 0.893D0,
23221      &            OM    = 1.1D0,
23222      &            N     = 6,
23223      &            DX    = 0.003D0)
23224
23225 * n-n cross section fluctuations
23226       PARAMETER (NBINS = 1000)
23227       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
23228       DIMENSION FLUSI(NBINS),FLUIX(NBINS)
23229
23230       WRITE(LOUT,1000)
23231  1000 FORMAT(/,1X,'FLUINI:  hadronic cross section fluctuations ',
23232      &       'treated')
23233
23234       FLUSU  = ZERO
23235       FLUSUU = ZERO
23236
23237       DO 1 I=1,NBINS
23238          X        = DBLE(I)*DX
23239          FLUIX(I) = X
23240          FLUS     = ((X-B)/(OM*B))**N
23241          IF (FLUS.LE.20.0D0) THEN
23242             FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
23243          ELSE
23244             FLUSI(I) = ZERO
23245          ENDIF
23246          FLUSU = FLUSU+FLUSI(I)
23247     1 CONTINUE
23248       DO 2 I=1,NBINS
23249          FLUSUU   = FLUSUU+FLUSI(I)/FLUSU
23250          FLUSI(I) = FLUSUU
23251     2 CONTINUE
23252
23253 C     WRITE(LOUT,1001)
23254 C1001 FORMAT(1X,'FLUCTUATIONS')
23255 C     CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
23256
23257       DO 3 I=1,NBINS
23258          AF = DBLE(I)*0.001D0
23259          DO 4 J=1,NBINS
23260             IF (AF.LE.FLUSI(J)) THEN
23261                FLUIXX(I) = FLUIX(J)
23262                GOTO 5
23263             ENDIF
23264     4    CONTINUE
23265     5    CONTINUE
23266     3 CONTINUE
23267       FLUIXX(1)     = FLUIX(1)
23268       FLUIXX(NBINS) = FLUIX(NBINS)
23269
23270       RETURN
23271       END
23272 *
23273 *===sigtab=============================================================*
23274 *
23275 CDECK  ID>, DT_SIGTBL
23276       SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
23277
23278 ************************************************************************
23279 * This version dated 18.11.95 is written by S. Roesler                 *
23280 ************************************************************************
23281
23282       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23283       SAVE
23284
23285       PARAMETER ( LINP = 5 ,
23286      &            LOUT = 6 ,
23287      &            LDAT = 9 )
23288
23289       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
23290      &           OHALF=0.5D0,ONE=1.0D0)
23291       PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
23292
23293       LOGICAL LINIT
23294
23295 * particle properties (BAMJET index convention)
23296       CHARACTER*8  ANAME
23297       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
23298      &                IICH(210),IIBAR(210),K1(210),K2(210)
23299
23300       DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
23301       DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
23302      &             0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
23303      &             0, 0, 5/
23304       DATA LINIT /.FALSE./
23305
23306 * precalculation and tabulation of elastic cross sections
23307       IF (ABS(MODE).EQ.1) THEN
23308          IF (MODE.EQ.1)
23309      &      OPEN(LDAT,FILE='sigtab.out',STATUS='UNKNOWN')
23310          PLABLX = LOG10(PLO)
23311          PLABHX = LOG10(PHI)
23312          DPLAB  = (PLABHX-PLABLX)/DBLE(NBINS)
23313          DO 1 I=1,NBINS+1
23314             PLAB = PLABLX+DBLE(I-1)*DPLAB
23315             PLAB = 10**PLAB
23316             DO 2 IPROJ=1,23
23317                IDX = IDSIG(IPROJ)
23318                IF (IDX.GT.0) THEN
23319 C                 CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
23320 C                 CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
23321                   DUMZER = ZERO
23322                   CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
23323                   CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
23324                ENDIF
23325     2       CONTINUE
23326             IF (MODE.EQ.1) THEN
23327                WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
23328      &                                (SIGEN(IDX,I),IDX=1,5)
23329  1000          FORMAT(F5.1,10F7.2)
23330             ENDIF
23331     1    CONTINUE
23332          IF (MODE.EQ.1) CLOSE(LDAT)
23333          LINIT = .TRUE.
23334       ELSE
23335          SIGE = -ONE
23336          IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
23337      &                           .AND.(PTOT.LE.PHI) ) THEN
23338             IDX = IDSIG(JP)
23339             IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
23340                PLABX = LOG10(PTOT)
23341                IF (PLABX.LE.PLABLX) THEN
23342                   I1 = 1
23343                   I2 = 1
23344                ELSEIF (PLABX.GE.PLABHX) THEN
23345                   I1 = NBINS+1
23346                   I2 = NBINS+1
23347                ELSE
23348                   I1 = INT((PLABX-PLABLX)/DPLAB)+1
23349                   I2 = I1+1
23350                ENDIF
23351                PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
23352                PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
23353                PBIN   = PLAB2X-PLAB1X
23354                IF (PBIN.GT.TINY10) THEN
23355                   RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
23356                ELSE
23357                   RATX = ZERO
23358                ENDIF
23359                IF (JT.EQ.1) THEN
23360                   SIG1 = SIGEP(IDX,I1)
23361                   SIG2 = SIGEP(IDX,I2)
23362                ELSE
23363                   SIG1 = SIGEN(IDX,I1)
23364                   SIG2 = SIGEN(IDX,I2)
23365                ENDIF
23366                SIGE = SIG1+RATX*(SIG2-SIG1)
23367             ENDIF
23368          ENDIF
23369       ENDIF
23370
23371       RETURN
23372       END
23373 *
23374 *===xstabl=============================================================*
23375 *
23376 CDECK  ID>, DT_XSTABL
23377       SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
23378
23379       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23380       SAVE
23381
23382       PARAMETER ( LINP = 5 ,
23383      &            LOUT = 6 ,
23384      &            LDAT = 9 )
23385
23386       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
23387      &           OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
23388       LOGICAL LLAB,LELOG,LQLOG
23389
23390 * particle properties (BAMJET index convention)
23391       CHARACTER*8  ANAME
23392       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
23393      &                IICH(210),IIBAR(210),K1(210),K2(210)
23394 * properties of interacting particles
23395       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
23396
23397       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
23398
23399 * Glauber formalism: cross sections
23400       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
23401      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
23402      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
23403      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
23404      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
23405      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
23406      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
23407      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
23408      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
23409      &                BSLOPE,NEBINI,NQBINI
23410 * emulsion treatment
23411       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
23412      &                NCOMPO,IEMUL
23413
23414       DIMENSION WHAT(6)
23415
23416       LLAB   = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
23417       ELO    = ABS(WHAT(1))
23418       EHI    = ABS(WHAT(2))
23419       IF (ELO.GT.EHI) ELO = EHI
23420       LELOG  = WHAT(3).LT.ZERO
23421       NEBINS = MAX(INT(ABS(WHAT(3))),1)
23422       DEBINS = (EHI-ELO)/DBLE(NEBINS)
23423       IF (LELOG) THEN
23424          AELO   = LOG10(ELO)
23425          AEHI   = LOG10(EHI)
23426          ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
23427       ENDIF
23428       Q2LO   = WHAT(4)
23429       Q2HI   = WHAT(5)
23430       IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
23431       LQLOG  = WHAT(6).LT.ZERO
23432       NQBINS = MAX(INT(ABS(WHAT(6))),1)
23433       DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
23434       IF (LQLOG) THEN
23435          AQ2LO  = LOG10(Q2LO)
23436          AQ2HI  = LOG10(Q2HI)
23437          ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
23438       ENDIF
23439
23440       IF ( ELO.EQ. EHI) NEBINS = 0
23441       IF (Q2LO.EQ.Q2HI) NQBINS = 0
23442
23443       WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
23444  1000 FORMAT(/,1X,'XSTABL:  E_lo  =',E10.3,' GeV  E_hi  =',E10.3,
23445      &       ' GeV     Lab = ',L1,'  qel: ',I2,/,10X,'Q2_lo =',F10.5,
23446      &       ' GeV^2  Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
23447      &       '   A_p = ',I3,'   A_t = ',I3,/)
23448
23449 C     IF (IJPROJ.NE.7) THEN
23450          WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
23451 * normalize fractions of emulsion components
23452          IF (NCOMPO.GT.0) THEN
23453             SUMFRA = ZERO
23454             DO 10 I=1,NCOMPO
23455                SUMFRA = SUMFRA+EMUFRA(I)
23456    10       CONTINUE
23457             IF (SUMFRA.GT.ZERO) THEN
23458                DO 11 I=1,NCOMPO
23459                   EMUFRA(I) = EMUFRA(I)/SUMFRA
23460    11          CONTINUE
23461             ENDIF
23462          ENDIF
23463 C     ELSE
23464 C        WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
23465 C     ENDIF
23466       DO 1 I=1,NEBINS+1
23467          IF (LELOG) THEN
23468             E = 10**(AELO+DBLE(I-1)*ADEBIN)
23469          ELSE
23470             E = ELO+DBLE(I-1)*DEBINS
23471          ENDIF
23472          DO 2 J=1,NQBINS+1
23473             IF (LQLOG) THEN
23474                Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
23475             ELSE
23476                Q2 = Q2LO+DBLE(J-1)*DQBINS
23477             ENDIF
23478 c            IF (IJPROJ.NE.7) THEN
23479                IF (LLAB) THEN
23480                   PLAB = ZERO
23481                   ECM  = ZERO
23482                   CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
23483                ELSE
23484                   ECM = E
23485                ENDIF
23486                XI  = ZERO
23487                Q2I = ZERO
23488                IF (IJPROJ.EQ.7) Q2I = Q2
23489                IF (NCOMPO.GT.0) THEN
23490                   DO 20 IC=1,NCOMPO
23491                      IIT = IEMUMA(IC)
23492                      CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
23493    20             CONTINUE
23494                ELSE
23495                   CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
23496 C                 CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
23497                ENDIF
23498                IF (NCOMPO.GT.0) THEN
23499                   XTOT = ZERO
23500                   ETOT = ZERO
23501                   XELA = ZERO
23502                   EELA = ZERO
23503                   XQEP = ZERO
23504                   EQEP = ZERO
23505                   XQET = ZERO
23506                   EQET = ZERO
23507                   XQE2 = ZERO
23508                   EQE2 = ZERO
23509                   XPRO = ZERO
23510                   EPRO = ZERO
23511                   XPRO1= ZERO
23512                   XDEL = ZERO
23513                   EDEL = ZERO
23514                   XDQE = ZERO
23515                   EDQE = ZERO
23516                   DO 21 IC=1,NCOMPO
23517                      XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
23518                      ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
23519                      XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
23520                      EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
23521                      XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
23522                      EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
23523                      XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
23524                      EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
23525                      XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
23526                      EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
23527                      XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
23528                      EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
23529                      XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
23530                      EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
23531                      XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
23532                      EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
23533                      YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
23534      &                     -XSQEP(1,1,IC)-XSQET(1,1,IC)
23535      &                     -XSQE2(1,1,IC)
23536                      XPRO1= XPRO1+EMUFRA(IC)*YPRO
23537    21             CONTINUE
23538                   ETOT = SQRT(ETOT)
23539                   EELA = SQRT(EELA)
23540                   EQEP = SQRT(EQEP)
23541                   EQET = SQRT(EQET)
23542                   EQE2 = SQRT(EQE2)
23543                   EPRO = SQRT(EPRO)
23544                   EDEL = SQRT(EDEL)
23545                   EDQE = SQRT(EDQE)
23546                   WRITE(LOUT,'(8E9.3)')
23547      &               E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
23548 C                 WRITE(LOUT,'(4E9.3)')
23549 C    &               E,XDEL,XDQE,XDEL+XDQE
23550                ELSE
23551                   WRITE(LOUT,'(11E10.3)')
23552      &              E,
23553      &              XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
23554      &              XSQE2(1,1,1),XSPRO(1,1,1),
23555      &              XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
23556      &             -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
23557      &              XSDEL(1,1,1)+XSDQE(1,1,1)
23558 C                 WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
23559 C    &                                    XSDEL(1,1,1)+XSDQE(1,1,1)
23560                ENDIF
23561 c            ELSE
23562 c               IF (LLAB) THEN
23563 c                  IF (IT.GT.1) THEN
23564 c                     IF (IXSQEL.EQ.0) THEN
23565 cC                       CALL DT_SIGGA(IT,  Q2, E,ZERO,ZERO,
23566 cC                       CALL DT_SIGGA(IT,   E,Q2,ZERO,ZERO,
23567 c                        CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
23568 c     &                             STOT,ETOT,SIN,EIN,STOT0)
23569 c                        IF (IRATIO.EQ.1) THEN
23570 c                           CALL DT_SIGGP(  Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
23571 cC                          CALL DT_SIGGP(   E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
23572 cC                          CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
23573 c*!! save cross sections
23574 c                           STOTA = STOT
23575 c                           ETOTA = ETOT
23576 c                           STOTP = STGP
23577 c*!!
23578 c                           STOT  = STOT/(DBLE(IT)*STGP)
23579 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
23580 c                           STOT0 = STGP
23581 c                           ETOT  = ZERO
23582 c                           EIN   = ZERO
23583 c                        ENDIF
23584 c                     ELSE
23585 c                        WRITE(LOUT,*)
23586 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
23587 c                        STOP
23588 c                     ENDIF
23589 c                  ELSE
23590 c                     ETOT = ZERO
23591 c                     EIN  = ZERO
23592 c                     STOT0= ZERO
23593 c                     IF (IXSQEL.EQ.0) THEN
23594 c                        CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
23595 c                     ELSE
23596 c                       SIN = ZERO
23597 c                       CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
23598 c                     ENDIF
23599 c                  ENDIF
23600 c               ELSE
23601 c                  IF (IT.GT.1) THEN
23602 c                     IF (IXSQEL.EQ.0) THEN
23603 c                        CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
23604 c     &                             STOT,ETOT,SIN,EIN,STOT0)
23605 c                        IF (IRATIO.EQ.1) THEN
23606 c                           CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
23607 c*!! save cross sections
23608 c                           STOTA = STOT
23609 c                           ETOTA = ETOT
23610 c                           STOTP = STGP
23611 c*!!
23612 c                           STOT  = STOT/(DBLE(IT)*STGP)
23613 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
23614 c                           STOT0 = STGP
23615 c                           ETOT  = ZERO
23616 c                           EIN   = ZERO
23617 c                        ENDIF
23618 c                     ELSE
23619 c                        WRITE(LOUT,*)
23620 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
23621 c                        STOP
23622 c                     ENDIF
23623 c                  ELSE
23624 c                     ETOT = ZERO
23625 c                     EIN  = ZERO
23626 c                     STOT0= ZERO
23627 c                     IF (IXSQEL.EQ.0) THEN
23628 c                        CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
23629 c                     ELSE
23630 c                       SIN = ZERO
23631 c                       CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
23632 c                     ENDIF
23633 c                  ENDIF
23634 c               ENDIF
23635 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
23636 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
23637 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
23638 c               WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
23639 c            ENDIF
23640     2    CONTINUE
23641     1 CONTINUE
23642
23643       RETURN
23644       END
23645 *
23646 *===testxs=============================================================*
23647 *
23648 CDECK  ID>, DT_TESTXS
23649       SUBROUTINE DT_TESTXS
23650
23651       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23652       SAVE
23653
23654       DIMENSION XSTOT(26,2),XSELA(26,2)
23655
23656       OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
23657       OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
23658       OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
23659       OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
23660       DUMECM = 0.0D0
23661       PLABL = 0.01D0
23662       PLABH = 10000.0D0
23663       NBINS = 120
23664       APLABL = LOG10(PLABL)
23665       APLABH = LOG10(PLABH)
23666       ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
23667       DO 1 I=1,NBINS+1
23668          ADP = APLABL+DBLE(I-1)*ADPLAB
23669          P = 10.0D0**ADP
23670          DO 2 J=1,26
23671             CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
23672             CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
23673     2    CONTINUE
23674          WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
23675          WRITE(11,1000) P,(XSELA(K,1),K=1,26)
23676          WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
23677          WRITE(13,1000) P,(XSELA(K,2),K=1,26)
23678     1 CONTINUE
23679  1000 FORMAT(F8.3,26F9.3)
23680
23681       RETURN
23682       END
23683 ************************************************************************
23684 *                                                                      *
23685 *  DTUNUC 2.0:   library routines                                      *
23686 *                                   processed by S. Roesler, 6.5.95    *
23687 *                                                                      *
23688 ************************************************************************
23689 *
23690 *     1) Handling of parton momenta
23691 *          SUBROUTINE MASHEL
23692 *          SUBROUTINE DFERMI
23693 *
23694 *     2) Handling of parton flavors and particle indices
23695 *          INTEGER FUNCTION IPDG2B
23696 *          INTEGER FUNCTION IB2PDG
23697 *          INTEGER FUNCTION IQUARK
23698 *          INTEGER FUNCTION IBJQUA
23699 *          INTEGER FUNCTION ICIHAD
23700 *          INTEGER FUNCTION IPDGHA
23701 *          INTEGER FUNCTION MCHAD
23702 *          SUBROUTINE FLAHAD
23703 *
23704 *     3) Energy-momentum and quantum number conservation check routines
23705 *          SUBROUTINE EMC1
23706 *          SUBROUTINE EMC2
23707 *          SUBROUTINE EVTEMC
23708 *          SUBROUTINE EVTFLC
23709 *          SUBROUTINE EVTCHG
23710 *
23711 *     4) Transformations
23712 *          SUBROUTINE LTINI
23713 *          SUBROUTINE LTRANS
23714 *          SUBROUTINE LTNUC
23715 *          SUBROUTINE DALTRA
23716 *          SUBROUTINE DTRAFO
23717 *          SUBROUTINE STTRAN
23718 *          SUBROUTINE MYTRAN
23719 *          SUBROUTINE LT2LAO
23720 *          SUBROUTINE LT2LAB
23721 *
23722 *     5) Sampling from distributions
23723 *          INTEGER FUNCTION NPOISS
23724 *          DOUBLE PRECISION FUNCTION SAMPXB
23725 *          DOUBLE PRECISION FUNCTION SAMPEX
23726 *          DOUBLE PRECISION FUNCTION SAMSQX
23727 *          DOUBLE PRECISION FUNCTION BETREJ
23728 *          DOUBLE PRECISION FUNCTION DGAMRN
23729 *          DOUBLE PRECISION FUNCTION DBETAR
23730 *          SUBROUTINE RANNOR
23731 *          SUBROUTINE DPOLI
23732 *          SUBROUTINE DSFECF
23733 *          SUBROUTINE RACO
23734 *
23735 *     6) Special functions, algorithms and service routines
23736 *          DOUBLE PRECISION FUNCTION YLAMB
23737 *          SUBROUTINE SORT
23738 *          SUBROUTINE SORT1
23739 *          SUBROUTINE DT_XTIME
23740 *
23741 *     7) Random number generator package
23742 *          DOUBLE PRECISION FUNCTION DT_RNDM
23743 *          SUBROUTINE DT_RNDMST
23744 *          SUBROUTINE DT_RNDMIN
23745 *          SUBROUTINE DT_RNDMOU
23746 *          SUBROUTINE DT_RNDMTE
23747 *
23748 ************************************************************************
23749 *                                                                      *
23750 *                 1) Handling of parton momenta                        *
23751 *                                                                      *
23752 ************************************************************************
23753 *
23754 *===mashel=============================================================*
23755 *
23756 CDECK  ID>, DT_MASHEL
23757       SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
23758
23759 ************************************************************************
23760 *                                                                      *
23761 *    rescaling of momenta of two partons to put both                   *
23762 *                                       on mass shell                  *
23763 *                                                                      *
23764 *    input:       PA1,PA2   input momentum vectors                     *
23765 *                 XM1,2     desired masses of particles afterwards     *
23766 *                 P1,P2     changed momentum vectors                   *
23767 *                                                                      *
23768 * The original version is written by R. Engel.                         *
23769 * This version dated 12.12.94 is modified by S. Roesler.               *
23770 ************************************************************************
23771
23772       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23773       SAVE
23774
23775       PARAMETER ( LINP = 5 ,
23776      &            LOUT = 6 ,
23777      &            LDAT = 9 )
23778
23779       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
23780
23781       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
23782
23783       IREJ = 0
23784
23785 * Lorentz transformation into system CMS
23786       PX  = PA1(1)+PA2(1)
23787       PY  = PA1(2)+PA2(2)
23788       PZ  = PA1(3)+PA2(3)
23789       EE  = PA1(4)+PA2(4)
23790       XPTOT = SQRT(PX**2+PY**2+PZ**2)
23791       XMS   = (EE-XPTOT)*(EE+XPTOT)
23792       IF(XMS.LT.(XM1+XM2)**2) THEN
23793 C        WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
23794          GOTO 9999
23795       ENDIF
23796       XMS = SQRT(XMS)
23797       BGX = PX/XMS
23798       BGY = PY/XMS
23799       BGZ = PZ/XMS
23800       GAM = EE/XMS
23801       CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
23802      &           PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
23803 * rotation angles
23804       COD = P1(3)/PTOT1
23805 C     SID = SQRT((ONE-COD)*(ONE+COD))
23806       PPT = SQRT(P1(1)**2+P1(2)**2)
23807       SID = PPT/PTOT1
23808       COF = ONE
23809       SIF = ZERO
23810       IF(PTOT1*SID.GT.TINY10) THEN
23811          COF   = P1(1)/(SID*PTOT1)
23812          SIF   = P1(2)/(SID*PTOT1)
23813          ANORF = SQRT(COF*COF+SIF*SIF)
23814          COF   = COF/ANORF
23815          SIF   = SIF/ANORF
23816       ENDIF
23817 * new CM momentum and energies (for masses XM1,XM2)
23818       XM12 = SIGN(XM1**2,XM1)
23819       XM22 = SIGN(XM2**2,XM2)
23820       SS   = XMS**2
23821       PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
23822       EE1  = SQRT(XM12+PCMP**2)
23823       EE2  = XMS-EE1
23824 * back rotation
23825       MODE = 1
23826       CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
23827       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
23828      &            PTOT1,P1(1),P1(2),P1(3),P1(4))
23829       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
23830      &            PTOT2,P2(1),P2(2),P2(3),P2(4))
23831 * check consistency
23832       DEL = XMS*0.0001D0
23833       IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
23834         IDEV = 1
23835       ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
23836         IDEV = 2
23837       ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
23838         IDEV = 3
23839       ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
23840         IDEV = 4
23841       ELSE
23842         IDEV = 0
23843       ENDIF
23844       IF (IDEV.NE.0) THEN
23845          WRITE(LOUT,'(/1X,A,I3)')
23846      &      'MASHEL: inconsistent transformation',IDEV
23847          WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
23848          WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
23849          WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
23850          WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
23851          WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
23852          WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
23853       ENDIF
23854       RETURN
23855
23856  9999 CONTINUE
23857       IREJ = 1
23858       RETURN
23859       END
23860 *
23861 *===dfermi=============================================================*
23862 *
23863 CDECK  ID>, DT_DFERMI
23864       SUBROUTINE DT_DFERMI(GPART)
23865
23866 ************************************************************************
23867 * Find largest of three random numbers.                                *
23868 ************************************************************************
23869
23870       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23871       SAVE
23872
23873       DIMENSION G(3)
23874
23875       DO 10 I=1,3
23876         G(I)=DT_RNDM(GPART)
23877    10 CONTINUE
23878       IF (G(3).LT.G(2)) GOTO 40
23879       IF (G(3).LT.G(1)) GOTO 30
23880       GPART = G(3)
23881    20 RETURN
23882    30 GPART = G(1)
23883       GOTO 20
23884    40 IF (G(2).LT.G(1)) GOTO 30
23885       GPART = G(2)
23886       GOTO 20
23887
23888       END
23889
23890 ************************************************************************
23891 *                                                                      *
23892 *         2) Handling of parton flavors and particle indices           *
23893 *                                                                      *
23894 ************************************************************************
23895 *
23896 *===ipdg2b=============================================================*
23897 *
23898 CDECK  ID>, IDT_IPDG2B
23899       INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
23900
23901 ************************************************************************
23902 *                                                                      *
23903 *     conversion of quark numbering scheme                             *
23904 *                                                                      *
23905 *     input:   PDG parton numbering                                    *
23906 *              for diquarks:  NN number of the constituent quark       *
23907 *                             (e.g. ID=2301,NN=1 -> ICONV2=1)          *
23908 *                                                                      *
23909 *     output:  BAMJET particle codes                                   *
23910 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
23911 *              2 d     8 a-d             -2 a-d                        *
23912 *              3 s     9 a-s             -3 a-s                        *
23913 *              4 c    10 a-c             -4 a-c                        *
23914 *                                                                      *
23915 * This is a modified version of ICONV2 written by R. Engel.            *
23916 * This version dated 13.12.94 is written by S. Roesler.                *
23917 ************************************************************************
23918
23919       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23920       SAVE
23921
23922       PARAMETER ( LINP = 5 ,
23923      &            LOUT = 6 ,
23924      &            LDAT = 9 )
23925
23926       IDA = ABS(ID)
23927 * diquarks
23928       IF (IDA.GT.6) THEN
23929         KF  = 3
23930         IF (IDA.GE.1000) KF = 4
23931         IDA = IDA/(10**(KF-NN))
23932         IDA = MOD(IDA,10)
23933       ENDIF
23934 * exchange up and dn quarks
23935       IF (IDA.EQ.1) THEN
23936         IDA = 2
23937       ELSEIF (IDA.EQ.2) THEN
23938         IDA = 1
23939       ENDIF
23940 * antiquarks
23941       IF (ID.LT.0) THEN
23942          IF (MODE.EQ.1) THEN
23943             IDA = IDA+6
23944          ELSE
23945             IDA = -IDA
23946          ENDIF
23947       ENDIF
23948       IDT_IPDG2B = IDA
23949
23950       RETURN
23951       END
23952 *
23953 *===ib2pdg=============================================================*
23954 *
23955 CDECK  ID>, IDT_IB2PDG
23956       INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
23957
23958 ************************************************************************
23959 *                                                                      *
23960 *     conversion of quark numbering scheme                             *
23961 *                                                                      *
23962 *     input:   BAMJET particle codes                                   *
23963 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
23964 *              2 d     8 a-d             -2 a-d                        *
23965 *              3 s     9 a-s             -3 a-s                        *
23966 *              4 c    10 a-c             -4 a-c                        *
23967 *                                                                      *
23968 *     output:  PDG parton numbering                                    *
23969 *                                                                      *
23970 * This version dated 13.12.94 is written by S. Roesler.                *
23971 ************************************************************************
23972
23973       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23974       SAVE
23975
23976       PARAMETER ( LINP = 5 ,
23977      &            LOUT = 6 ,
23978      &            LDAT = 9 )
23979
23980       DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
23981       DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
23982       DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
23983      &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
23984      &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
23985
23986       IDA = ID1
23987       IDB = ID2
23988       IF (MODE.EQ.1) THEN
23989          IF (ID1.GT.6) IDA = -(ID1-6)
23990          IF (ID2.GT.6) IDB = -(ID2-6)
23991       ENDIF
23992       IF (ID2.EQ.0) THEN
23993          IDT_IB2PDG = IHKKQ(IDA)
23994       ELSE
23995          IDT_IB2PDG = IHKKQQ(IDA,IDB)
23996       ENDIF
23997
23998       RETURN
23999       END
24000 *
24001 *===ipdgqu=============================================================*
24002 *
24003 CDECK  ID>, IDT_IQUARK
24004       INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
24005
24006 ************************************************************************
24007 *                                                                      *
24008 *     quark contents according to PDG conventions                      *
24009 *     (random selection in case of quark mixing)                       *
24010 *                                                                      *
24011 *     input:   IDBAMJ BAMJET particle code                             *
24012 *              K      1..3   quark number                              *
24013 *                                                                      *
24014 *     output:  1   d  (anti --> neg.)                                  *
24015 *              2   u                                                   *
24016 *              3   s                                                   *
24017 *              4   c                                                   *
24018 *                                                                      *
24019 * This version written by R. Engel.                                    *
24020 ************************************************************************
24021
24022       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24023       SAVE
24024
24025       IQ = IDT_IBJQUA(K,IDBAMJ)
24026 * quark-antiquark
24027       IF (IQ.GT.6) THEN
24028          IQ = 6-IQ
24029       ENDIF
24030 * exchange of up and down
24031       IF (ABS(IQ).EQ.1) THEN
24032          IQ = SIGN(2,IQ)
24033       ELSEIF (ABS(IQ).EQ.2) THEN
24034          IQ = SIGN(1,IQ)
24035       ENDIF
24036       IDT_IQUARK = IQ
24037
24038       RETURN
24039       END
24040 *
24041 *===ibamq==============================================================*
24042 *
24043 CDECK  ID>, IDT_IBJQUA
24044       INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
24045
24046 ************************************************************************
24047 *                                                                      *
24048 *     quark contents according to BAMJET conventions                   *
24049 *     (random selection in case of quark mixing)                       *
24050 *                                                                      *
24051 *     input:   IDBAMJ BAMJET particle code                             *
24052 *              K      1..3   quark number                              *
24053 *                                                                      *
24054 *     output:  1   u      7   u bar                                    *
24055 *              2   d      8   d bar                                    *
24056 *              3   s      9   s bar                                    *
24057 *              4   c     10   c bar                                    *
24058 *                                                                      *
24059 * This version written by R. Engel.                                    *
24060 ************************************************************************
24061
24062       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24063       SAVE
24064
24065       DIMENSION ITAB(3,210)
24066       DATA ((ITAB(I,K),I=1,3),K=1,30) /
24067      &    1,  1,  2,   7,  7,  8,   0,  0,  0,
24068      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24069      &    0,  0,  0,   1,  2,  2,   7,  8,  8,
24070 *sr 10.1.94
24071 C    &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24072      &    0,  0,  0,   0,  0,  0,   3,  8,  0,
24073 *
24074      &    1,  8,  0,   2,  7,  0,   1,  9,  0,
24075 *sr 10.1.94
24076 C    &    3,  7,  0,   0,  0,  0,   0,  0,  0,
24077      &    3,  7,  0,   3,  1,  2,   9,  7,  8,
24078 *sr 10.1.94
24079 C    &    0,  0,  0,   2,  2,  3,   1,  1,  3,
24080      &    2,  9,  0,   2,  2,  3,   1,  1,  3,
24081 *
24082      &    1,  2,  3, 201,202,  0,   2,  9,  0,
24083      &    3,  8,  0,   0,  0,  0,   0,  0,  0,
24084      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
24085       DATA ((ITAB(I,K),I=1,3),K=31,60) /
24086      &    3,  9,  0,   1,  8,  0, 203,204,  0,
24087      &    2,  7,  0,   0,  0,  0,   1,  9,  0,
24088      &    2,  9,  0,   3,  7,  0,   3,  8,  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,   0,  0,  0,   0,  0,  0,
24092      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24093      &    0,  0,  0,   1,  1,  1,   1,  1,  2,
24094      &    1,  2,  2,   2,  2,  2,   0,  0,  0,
24095      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
24096       DATA ((ITAB(I,K),I=1,3),K=61,90) /
24097      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24098      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24099      &    7,  7,  7,   7,  7,  8,   7,  8,  8,
24100      &    8,  8,  8,   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      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24106      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
24107       DATA ((ITAB(I,K),I=1,3),K=91,120) /
24108      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24109      &    0,  0,  0,   0,  0,  0,   3,  9,  0,
24110      &    1,  3,  3,   2,  3,  3,   7,  7,  9,
24111      &    7,  8,  9,   8,  8,  9,   7,  9,  9,
24112      &    8,  9,  9,   1,  1,  3,   1,  2,  3,
24113      &    2,  2,  3,   1,  3,  3,   2,  3,  3,
24114      &    3,  3,  3,   7,  7,  9,   7,  8,  9,
24115      &    8,  8,  9,   7,  9,  9,   8,  9,  9,
24116      &    9,  9,  9,   4,  7,  0,   4,  8,  0,
24117      &    2, 10,  0,   1, 10,  0,   4,  9,  0 /
24118       DATA ((ITAB(I,K),I=1,3),K=121,150) /
24119      &    3, 10,  0,   4, 10,  0,   4,  7,  0,
24120      &    4,  8,  0,   2, 10,  0,   1, 10,  0,
24121      &    4,  9,  0,   3, 10,  0,   4, 10,  0,
24122      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24123      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24124      &    0,  0,  0,   1,  2,  4,   1,  3,  4,
24125      &    2,  3,  4,   1,  1,  4,   0,  0,  0,
24126      &    2,  2,  4,   0,  0,  0,   0,  0,  0,
24127      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
24128      &    3,  4,  4,   7,  8, 10,   7,  9, 10 /
24129       DATA ((ITAB(I,K),I=1,3),K=151,180) /
24130      &    8,  9, 10,   7,  7, 10,   0,  0,  0,
24131      &    8,  8, 10,   0,  0,  0,   0,  0,  0,
24132      &    9,  9, 10,   7, 10, 10,   8, 10, 10,
24133      &    9, 10, 10,   1,  1,  4,   1,  2,  4,
24134      &    2,  2,  4,   1,  3,  4,   2,  3,  4,
24135      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
24136      &    3,  4,  4,   4,  4,  4,   7,  7, 10,
24137      &    7,  8, 10,   8,  8, 10,   7,  9, 10,
24138      &    8,  9, 10,   9,  9, 10,   7, 10, 10,
24139      &    8, 10, 10,   9, 10, 10,  10, 10, 10 /
24140       DATA ((ITAB(I,K),I=1,3),K=181,210) /
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,   0,  0,  0,
24146      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24147      &    0,  0,  0,   0,  0,  0,   1,  7,  0,
24148      &    2,  8,  0,   1,  7,  0,   2,  8,  0,
24149      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
24150      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
24151       DATA IDOLD /0/
24152
24153       ONE = 1.0D0
24154       IF (ITAB(1,IDBAMJ).LE.200) THEN
24155          ID = ITAB(K,IDBAMJ)
24156       ELSE
24157          IF(IDOLD.NE.IDBAMJ) THEN
24158             IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
24159      &           DT_RNDM(ONE)+ITAB(1,IDBAMJ))
24160         ELSE
24161            IDOLD = 0
24162         ENDIF
24163         ID = ITAB(K,IT)
24164       ENDIF
24165       IDOLD  = IDBAMJ
24166       IDT_IBJQUA = ID
24167
24168       RETURN
24169       END
24170 *
24171 *===icihad=============================================================*
24172 *
24173 CDECK  ID>, IDT_ICIHAD
24174       INTEGER FUNCTION IDT_ICIHAD(MCIND)
24175
24176 ************************************************************************
24177 * Conversion of particle index PDG proposal --> BAMJET-index scheme    *
24178 * This is a completely new version dated 25.10.95.                     *
24179 * Renamed to be not in conflict with the modified PHOJET-version       *
24180 ************************************************************************
24181
24182       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24183       SAVE
24184
24185 * hadron index conversion (BAMJET <--> PDG)
24186       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
24187      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
24188      &                IAMCIN(210)
24189
24190       IDT_ICIHAD = 0
24191       KPDG   = ABS(MCIND)
24192       IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
24193       IF (MCIND.LT.0) THEN
24194          JSIGN = 1
24195       ELSE
24196          JSIGN = 2
24197       ENDIF
24198       IF (KPDG.GE.10000) THEN
24199          DO 1 I=1,19
24200             IDT_ICIHAD = IBAM5(JSIGN,I)
24201             IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
24202             IDT_ICIHAD = 0
24203     1    CONTINUE
24204       ELSEIF (KPDG.GE.1000) THEN
24205          DO 2 I=1,29
24206             IDT_ICIHAD = IBAM4(JSIGN,I)
24207             IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
24208             IDT_ICIHAD = 0
24209     2    CONTINUE
24210       ELSEIF (KPDG.GE.100) THEN
24211          DO 3 I=1,22
24212             IDT_ICIHAD = IBAM3(JSIGN,I)
24213             IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
24214             IDT_ICIHAD = 0
24215     3    CONTINUE
24216       ELSEIF (KPDG.GE.10) THEN
24217          DO 4 I=1,7
24218             IDT_ICIHAD = IBAM2(JSIGN,I)
24219             IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
24220             IDT_ICIHAD = 0
24221     4    CONTINUE
24222       ENDIF
24223     5 CONTINUE
24224
24225       RETURN
24226       END
24227 *
24228 *===ipdgha=============================================================*
24229 *
24230 CDECK  ID>, IDT_IPDGHA
24231       INTEGER FUNCTION IDT_IPDGHA(MCIND)
24232
24233 ************************************************************************
24234 * Conversion of particle index BAMJET-index scheme --> PDG proposal    *
24235 * Adopted from the original by S. Roesler. This version dated 12.5.95  *
24236 * Renamed to be not in conflict with the modified PHOJET-version       *
24237 ************************************************************************
24238
24239       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24240       SAVE
24241
24242 * hadron index conversion (BAMJET <--> PDG)
24243       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
24244      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
24245      &                IAMCIN(210)
24246
24247       IDT_IPDGHA = IAMCIN(MCIND)
24248
24249       RETURN
24250       END
24251 *
24252 *===flahad=============================================================*
24253 *
24254 CDECK  ID>, DT_FLAHAD
24255       SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
24256
24257 ************************************************************************
24258 * sampling of FLAvor composition for HADrons/photons                   *
24259 *              ID         BAMJET-id of hadron                          *
24260 *              IF1,2,3    flavor content                               *
24261 *                         (u,d,s: 1,2,3;  au,ad,as: -1,-1,-3)          *
24262 * Note:  -  u,d numbering as in BAMJET                                 *
24263 *        -  ID .le. 30 !!                                              *
24264 * This version dated 12.03.96 is written by S. Roesler                 *
24265 ************************************************************************
24266
24267       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24268       SAVE
24269
24270 * auxiliary common for reggeon exchange (DTUNUC 1.x)
24271       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
24272      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
24273      &                IQTCHR(-6:6),MQUARK(3,39)
24274
24275       DIMENSION JSEL(3,6)
24276       DATA JSEL/ 1,2,3,  2,3,1,  3,1,2,  1,3,2,   2,1,3,   3,2,1/
24277
24278       ONE = 1.0D0
24279       IF (ID.EQ.7) THEN
24280 * photon (charge dependent flavour sampling)
24281          K = INT(DT_RNDM(ONE)*6.D0+1.D0)
24282          IF (K.LE.4) THEN
24283             IF1 = 2
24284             IF2 = -2
24285          ELSE IF(K.EQ.5) THEN
24286             IF1 = 1
24287             IF2 = -1
24288          ELSE
24289             IF1 = 3
24290             IF2 = -3
24291          ENDIF
24292          IF(DT_RNDM(ONE).LT.0.5D0) THEN
24293             K   = IF1
24294             IF1 = IF2
24295             IF2 = K
24296          ENDIF
24297          IF3 = 0
24298       ELSE
24299 * hadron
24300          IX  = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
24301          IF1 = MQUARK(JSEL(1,IX),ID)
24302          IF2 = MQUARK(JSEL(2,IX),ID)
24303          IF3 = MQUARK(JSEL(3,IX),ID)
24304          IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
24305             IF1 = IF3
24306             IF3 = 0
24307          ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
24308             IF2 = IF3
24309             IF3 = 0
24310          ENDIF
24311       ENDIF
24312
24313       RETURN
24314       END
24315 *
24316 *===mchad==============================================================*
24317 *
24318 CDECK  ID>, IDT_MCHAD
24319       INTEGER FUNCTION IDT_MCHAD(ITDTU)
24320
24321 ************************************************************************
24322 * Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
24323 * Adopted from the original by S. Roesler. This version dated 6.5.95   *
24324 ************************************************************************
24325
24326       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24327       SAVE
24328
24329       DIMENSION ITRANS(210)
24330       DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
24331      &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
24332      &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
24333      &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
24334      &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
24335      &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
24336      &9, 9, 9, 85*- 1,7*-1,1,8,-1/
24337
24338       IDT_MCHAD = ITRANS(ITDTU)
24339
24340       RETURN
24341       END
24342
24343 ************************************************************************
24344 *                                                                      *
24345 *   3) Energy-momentum and quantum number conservation check routines  *
24346 *                                                                      *
24347 ************************************************************************
24348 *
24349 *===emc1===============================================================*
24350 *
24351 CDECK  ID>, DT_EMC1
24352       SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
24353
24354 ************************************************************************
24355 * This version dated 15.12.94 is written by S. Roesler                 *
24356 ************************************************************************
24357
24358       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24359       SAVE
24360
24361       PARAMETER ( LINP = 5 ,
24362      &            LOUT = 6 ,
24363      &            LDAT = 9 )
24364
24365       PARAMETER (TINY10=1.0D-10)
24366
24367       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
24368
24369       IREJ = 0
24370
24371       IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
24372      &   WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
24373
24374       IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
24375          IF (MODE.EQ.1) THEN
24376             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
24377          ELSEIF (MODE.EQ.2) THEN
24378             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
24379          ENDIF
24380          CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
24381          CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
24382          CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
24383       ELSEIF (MODE.LT.0) THEN
24384          IF (MODE.EQ.-1) THEN
24385             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
24386          ELSEIF (MODE.EQ.-2) THEN
24387             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
24388          ENDIF
24389          CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
24390          CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
24391          CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
24392       ENDIF
24393
24394       IF (ABS(MODE).EQ.3) THEN
24395          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
24396          IF (IREJ1.NE.0) GOTO 9999
24397       ENDIF
24398       RETURN
24399
24400  9999 CONTINUE
24401       IREJ = 1
24402       RETURN
24403       END
24404 *
24405 *===emc2===============================================================*
24406 *
24407 CDECK  ID>, DT_EMC2
24408       SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
24409      &                                                MODE,IPOS,IREJ)
24410
24411 ************************************************************************
24412 *             MODE = 1   energy-momentum cons. check                   *
24413 *                  = 2   flavor-cons. check                            *
24414 *                  = 3   energy-momentum & flavor cons. check          *
24415 *                  = 4   energy-momentum & charge cons. check          *
24416 *                  = 5   energy-momentum & flavor & charge cons. check *
24417 * This version dated 16.01.95 is written by S. Roesler                 *
24418 ************************************************************************
24419
24420       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24421       SAVE
24422
24423       PARAMETER ( LINP = 5 ,
24424      &            LOUT = 6 ,
24425      &            LDAT = 9 )
24426
24427       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
24428
24429 * event history
24430
24431       PARAMETER (NMXHKK=200000)
24432
24433       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
24434      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
24435      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
24436 * extended event history
24437       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
24438      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
24439      &                IHIST(2,NMXHKK)
24440
24441       IREJ  = 0
24442       IREJ1 = 0
24443       IREJ2 = 0
24444       IREJ3 = 0
24445
24446       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
24447      &                CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
24448       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
24449      &                                CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
24450       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
24451       DO 1 I=1,NHKK
24452          IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
24453      &       (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
24454      &       (ISTHKK(I).EQ.IP5))                          THEN
24455             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
24456      &                                    .OR.(MODE.EQ.5))
24457      &      CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
24458      &                                               2,IDUM,IDUM)
24459             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
24460      &         CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
24461             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
24462      &                            CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
24463          ENDIF
24464          IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
24465      &       (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
24466      &       (ISTHKK(I).EQ.IN5))                          THEN
24467             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
24468      &                                    .OR.(MODE.EQ.5))
24469      &      CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
24470      &                                                   2,IDUM,IDUM)
24471             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
24472      &         CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
24473             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
24474      &                            CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
24475          ENDIF
24476     1 CONTINUE
24477       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
24478      &   CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
24479       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
24480      &   CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
24481       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
24482       IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
24483
24484       RETURN
24485
24486  9999 CONTINUE
24487       IREJ = 1
24488       RETURN
24489       END
24490 *
24491 *===evtemc=============================================================*
24492 *
24493 CDECK  ID>, DT_EVTEMC
24494       SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
24495
24496 ************************************************************************
24497 * This version dated 13.12.94 is written by S. Roesler                 *
24498 ************************************************************************
24499
24500       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24501       SAVE
24502
24503       PARAMETER ( LINP = 5 ,
24504      &            LOUT = 6 ,
24505      &            LDAT = 9 )
24506
24507       PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
24508      &           ZERO=0.0D0)
24509
24510 * event history
24511
24512       PARAMETER (NMXHKK=200000)
24513
24514       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
24515      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
24516      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
24517 * flags for input different options
24518       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
24519       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
24520      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
24521
24522       IREJ = 0
24523
24524       MODE = IMODE
24525       CHKLEV = TINY10
24526       IF (MODE.EQ.4) THEN
24527          CHKLEV = TINY2
24528          MODE   = 3
24529       ELSEIF (MODE.EQ.5) THEN
24530          CHKLEV = TINY1
24531          MODE   = 3
24532       ELSEIF (MODE.EQ.-1) THEN
24533          CHKLEV = EIO
24534          MODE   = 3
24535       ENDIF
24536
24537       IF (ABS(MODE).EQ.3) THEN
24538          PXDEV = PX
24539          PYDEV = PY
24540          PZDEV = PZ
24541          EDEV  = E
24542          IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
24543          IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
24544      &       (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
24545             IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
24546      &         'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
24547      &         '  event  ',NEVHKK,
24548      &         ' ! ',PXDEV,PYDEV,PZDEV,EDEV
24549             PX   = 0.0D0
24550             PY   = 0.0D0
24551             PZ   = 0.0D0
24552             E    = 0.0D0
24553             GOTO 9999
24554          ENDIF
24555          PX   = 0.0D0
24556          PY   = 0.0D0
24557          PZ   = 0.0D0
24558          E    = 0.0D0
24559          RETURN
24560       ENDIF
24561
24562       IF (MODE.EQ.1) THEN
24563          PX = 0.0D0
24564          PY = 0.0D0
24565          PZ = 0.0D0
24566          E  = 0.0D0
24567       ENDIF
24568
24569       PX = PX+PXIO
24570       PY = PY+PYIO
24571       PZ = PZ+PZIO
24572       E  = E+EIO
24573
24574       RETURN
24575
24576  9999 CONTINUE
24577       IREJ = 1
24578       RETURN
24579       END
24580 *
24581 *===evtflc=============================================================*
24582 *
24583 CDECK  ID>, DT_EVTFLC
24584       SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
24585
24586 ************************************************************************
24587 * Flavor conservation check.                                           *
24588 *        ID       identity of particle                                 *
24589 *        ID1 = 1  ID for q,aq,qq,aqaq in PDG-numbering scheme          *
24590 *            = 2  ID for particle/resonance in BAMJET numbering scheme *
24591 *            = 3  ID for particle/resonance in PDG    numbering scheme *
24592 *        MODE = 1 initialization and add ID                            *
24593 *             =-1 initialization and subtract ID                       *
24594 *             = 2 add ID                                               *
24595 *             =-2 subtract ID                                          *
24596 *             = 3 check flavor cons.                                   *
24597 *        IPOS     flag to give position of call of EVTFLC to output    *
24598 *                 unit in case of violation                            *
24599 * This version dated 10.01.95 is written by S. Roesler                 *
24600 ************************************************************************
24601
24602       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24603       SAVE
24604
24605       PARAMETER ( LINP = 5 ,
24606      &            LOUT = 6 ,
24607      &            LDAT = 9 )
24608
24609       PARAMETER (TINY10=1.0D-10)
24610
24611       IREJ = 0
24612
24613       IF (MODE.EQ.3) THEN
24614          IF (IFL.NE.0) THEN
24615             WRITE(LOUT,'(1X,A,I3,A,I3)')
24616      &         'EVTFLC: flavor-conservation failure at pos. ',IPOS,
24617      &         ' !  IFL = ',IFL
24618             IFL = 0
24619             GOTO 9999
24620          ENDIF
24621          IFL = 0
24622          RETURN
24623       ENDIF
24624
24625       IF (MODE.EQ.1) IFL = 0
24626       IF (ID.EQ.0)   RETURN
24627
24628       IF (ID1.EQ.1) THEN
24629          IDD = ABS(ID)
24630          NQ  = 1
24631          IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
24632          IF (IDD.GE.1000) NQ = 3
24633          DO 1 I=1,NQ
24634             IFBAM = IDT_IPDG2B(ID,I,2)
24635             IF (ABS(IFBAM).EQ.1) THEN
24636                IFBAM = SIGN(2,IFBAM)
24637             ELSEIF (ABS(IFBAM).EQ.2) THEN
24638                IFBAM = SIGN(1,IFBAM)
24639             ENDIF
24640             IF (MODE.GT.0) THEN
24641                IFL = IFL+IFBAM
24642             ELSE
24643                IFL = IFL-IFBAM
24644             ENDIF
24645     1    CONTINUE
24646          RETURN
24647       ENDIF
24648
24649       IDD = ID
24650       IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
24651       IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
24652          DO 2 I=1,3
24653             IF (MODE.GT.0) THEN
24654                IFL = IFL+IDT_IQUARK(I,IDD)
24655             ELSE
24656                IFL = IFL-IDT_IQUARK(I,IDD)
24657             ENDIF
24658     2    CONTINUE
24659       ENDIF
24660       RETURN
24661
24662  9999 CONTINUE
24663       IREJ = 1
24664       RETURN
24665       END
24666 *
24667 *===evtchg=============================================================*
24668 *
24669 CDECK  ID>, DT_EVTCHG
24670       SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
24671
24672 ************************************************************************
24673 * Charge conservation check.                                           *
24674 *        ID       identity of particle (PDG-numbering scheme)          *
24675 *        MODE = 1 initialization                                       *
24676 *             =-2 subtract ID-charge                                   *
24677 *             = 2 add ID-charge                                        *
24678 *             = 3 check charge cons.                                   *
24679 *        IPOS     flag to give position of call of EVTCHG to output    *
24680 *                 unit in case of violation                            *
24681 * This version dated 10.01.95 is written by S. Roesler                 *
24682 * Last change: s.r. 21.01.01                                           *
24683 ************************************************************************
24684
24685       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24686       SAVE
24687
24688       PARAMETER ( LINP = 5 ,
24689      &            LOUT = 6 ,
24690      &            LDAT = 9 )
24691
24692 * event history
24693
24694       PARAMETER (NMXHKK=200000)
24695
24696       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
24697      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
24698      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
24699 * particle properties (BAMJET index convention)
24700       CHARACTER*8  ANAME
24701       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24702      &                IICH(210),IIBAR(210),K1(210),K2(210)
24703
24704       IREJ = 0
24705
24706       IF (MODE.EQ.1) THEN
24707          ICH  = 0
24708          IBAR = 0
24709          RETURN
24710       ENDIF
24711
24712       IF (MODE.EQ.3) THEN
24713          IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
24714             WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
24715      &         'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
24716      &         '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
24717             ICH  = 0
24718             IBAR = 0
24719             GOTO 9999
24720          ENDIF
24721          ICH  = 0
24722          IBAR = 0
24723          RETURN
24724       ENDIF
24725
24726       IF (ID.EQ.0)   RETURN
24727
24728       IDD = IDT_ICIHAD(ID)
24729 * modification 21.1.01: use intrinsic phojet-functions to determine charge
24730 * and baryon number
24731 C     IF (IDD.GT.0) THEN
24732 C        IF (MODE.EQ.2) THEN
24733 C           ICH  = ICH+IICH(IDD)
24734 C           IBAR = IBAR+IIBAR(IDD)
24735 C        ELSEIF (MODE.EQ.-2) THEN
24736 C           ICH  = ICH-IICH(IDD)
24737 C           IBAR = IBAR-IIBAR(IDD)
24738 C        ENDIF
24739 C     ELSE
24740 C        WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
24741 C        CALL DT_EVTOUT(4)
24742 C        STOP
24743 C     ENDIF
24744       IF (MODE.EQ.2) THEN
24745          ICH  = ICH+IPHO_CHR3(ID,1)/3
24746          IBAR = IBAR+IPHO_BAR3(ID,1)/3
24747       ELSEIF (MODE.EQ.-2) THEN
24748          ICH  = ICH-IPHO_CHR3(ID,1)/3
24749          IBAR = IBAR-IPHO_BAR3(ID,1)/3
24750       ENDIF
24751
24752       RETURN
24753
24754  9999 CONTINUE
24755       IREJ = 1
24756       RETURN
24757       END
24758
24759 ************************************************************************
24760 *                                                                      *
24761 *                 4) Transformations                                   *
24762 *                                                                      *
24763 ************************************************************************
24764 *
24765 *===ltini==============================================================*
24766 *
24767 CDECK  ID>, DT_LTINI
24768       SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
24769
24770 ************************************************************************
24771 * Initializations of Lorentz-transformations, calculation of Lorentz-  *
24772 * parameters.                                                          *
24773 * This version dated 13.11.95 is written by  S. Roesler.               *
24774 ************************************************************************
24775
24776       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24777       SAVE
24778
24779       PARAMETER ( LINP = 5 ,
24780      &            LOUT = 6 ,
24781      &            LDAT = 9 )
24782
24783       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
24784      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
24785
24786 * Lorentz-parameters of the current interaction
24787       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
24788      &                UMO,PPCM,EPROJ,PPROJ
24789 * properties of photon/lepton projectiles
24790       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
24791 * particle properties (BAMJET index convention)
24792       CHARACTER*8  ANAME
24793       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24794      &                IICH(210),IIBAR(210),K1(210),K2(210)
24795 * nucleon-nucleon event-generator
24796       CHARACTER*8 CMODEL
24797       LOGICAL LPHOIN
24798       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
24799
24800       Q2   = VIRT
24801       IDP  = IDPR
24802       IF (MCGENE.NE.3) THEN
24803 * lepton-projectiles and PHOJET: initialize real photon instead
24804          IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
24805      &       (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
24806      &       (IDPR.EQ. 5).OR.(IDPR.EQ. 6))   THEN
24807             IDP = 7
24808             Q2  = ZERO
24809          ENDIF
24810       ENDIF
24811       IDT  = IDTA
24812       EPN  = EPN0
24813       PPN  = PPN0
24814       ECM  = ECM0
24815       AMP  = AAM(IDP)-SQRT(ABS(Q2))
24816       AMT  = AAM(IDT)
24817       AMP2 = SIGN(AMP**2,AMP)
24818       AMT2 = AMT**2
24819       IF (ECM0.GT.ZERO) THEN
24820          EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
24821          IF (AMP2.GT.ZERO) THEN
24822             PPN = SQRT((EPN+AMP)*(EPN-AMP))
24823          ELSE
24824             PPN = SQRT(EPN**2-AMP2)
24825          ENDIF
24826       ELSE
24827          IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
24828             IF (IDP.EQ.7) EPN = ABS(EPN)
24829             IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
24830             IF (AMP2.GT.ZERO) THEN
24831                PPN = SQRT((EPN+AMP)*(EPN-AMP))
24832             ELSE
24833                PPN = SQRT(EPN**2-AMP2)
24834             ENDIF
24835          ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
24836             IF (AMP2.GT.ZERO) THEN
24837                EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
24838             ELSE
24839                EPN = SQRT(PPN**2+AMP2)
24840             ENDIF
24841          ENDIF
24842          ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
24843       ENDIF
24844       UMO   = ECM
24845       EPROJ = EPN
24846       PPROJ = PPN
24847       IF (AMP2.GT.ZERO) THEN
24848          ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
24849          PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
24850       ELSE
24851          ETARG = TINY10
24852          PTARG = TINY10
24853       ENDIF
24854 * photon-projectiles (get momentum in cm-frame for virtuality Q^2)
24855       IF (IDP.EQ.7) THEN
24856          PGAMM(1) = ZERO
24857          PGAMM(2) = ZERO
24858          AMGAM  = AMP
24859          AMGAM2 = AMP2
24860          IF (ECM0.GT.ZERO) THEN
24861             S = ECM0**2
24862          ELSE
24863             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
24864                S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
24865             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
24866                S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
24867             ENDIF
24868          ENDIF
24869          PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
24870      &                     +AMGAM2**2+AMT2**2)/(4.0D0*S) )
24871          PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
24872          IF (MODE.EQ.1) THEN
24873             PNUCL(1) = ZERO
24874             PNUCL(2) = ZERO
24875             PNUCL(3) = -PGAMM(3)
24876             PNUCL(4) = SQRT(S)-PGAMM(4)
24877          ENDIF
24878       ENDIF
24879       IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
24880      &    (IDPR.EQ.10).OR.(IDPR.EQ.11))   THEN
24881          PLEPT0(1) = ZERO
24882          PLEPT0(2) = ZERO
24883 * neglect lepton masses
24884 C        AMLPT2   = AAM(IDPR)**2
24885          AMLPT2   = ZERO
24886 *
24887          IF (ECM0.GT.ZERO) THEN
24888             S = ECM0**2
24889          ELSE
24890             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
24891                S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
24892             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
24893                S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
24894             ENDIF
24895          ENDIF
24896          PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
24897      &                     +AMLPT2**2+AMT2**2)/(4.0D0*S) )
24898          PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
24899          PNUCL(1) = ZERO
24900          PNUCL(2) = ZERO
24901          PNUCL(3) = -PLEPT0(3)
24902          PNUCL(4) = SQRT(S)-PLEPT0(4)
24903       ENDIF
24904 * Lorentz-parameter for transformation Lab. - projectile rest system
24905       IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
24906          GALAB = TINY10
24907          BGLAB = TINY10
24908          BLAB  = TINY10
24909       ELSE
24910          GALAB = EPROJ/AMP
24911          BGLAB = PPROJ/AMP
24912          BLAB  = BGLAB/GALAB
24913       ENDIF
24914 * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
24915       IF (IDP.EQ.7) THEN
24916          GACMS(1) = TINY10
24917          BGCMS(1) = TINY10
24918       ELSE
24919          GACMS(1) = (ETARG+AMP)/UMO
24920          BGCMS(1) = PTARG/UMO
24921       ENDIF
24922 * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
24923       GACMS(2) = (EPROJ+AMT)/UMO
24924       BGCMS(2) = PPROJ/UMO
24925       PPCM     = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
24926
24927       EPN0 = EPN
24928       PPN0 = PPN
24929       ECM0 = ECM
24930
24931       RETURN
24932       END
24933 *
24934 *===ltrans=============================================================*
24935 *
24936 CDECK  ID>, DT_LTRANS
24937       SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
24938
24939 ************************************************************************
24940 * Lorentz-transformations.                                             *
24941 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
24942 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
24943 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
24944 * This version dated 01.11.95 is written by  S. Roesler.               *
24945 ************************************************************************
24946
24947       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24948       SAVE
24949
24950       PARAMETER ( LINP = 5 ,
24951      &            LOUT = 6 ,
24952      &            LDAT = 9 )
24953
24954       PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
24955
24956       PARAMETER (SQTINF=1.0D+15)
24957
24958 * particle properties (BAMJET index convention)
24959       CHARACTER*8  ANAME
24960       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24961      &                IICH(210),IIBAR(210),K1(210),K2(210)
24962
24963       PXO = PXI
24964       PYO = PYI
24965       CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
24966
24967 * check particle mass for consistency (numerical rounding errors)
24968       PO     = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
24969       AMO2   = (PEO-PO)*(PEO+PO)
24970       AMORQ2 = AAM(ID)**2
24971       AMDIF2 = ABS(AMO2-AMORQ2)
24972       IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
24973          DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
24974          PEO   = PEO+DELTA
24975          PO1   = PO -DELTA
24976          PXO   = PXO*PO1/PO
24977          PYO   = PYO*PO1/PO
24978          PZO   = PZO*PO1/PO
24979 C        WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
24980       ENDIF
24981
24982       RETURN
24983       END
24984 *
24985 *===ltnuc==============================================================*
24986 *
24987 CDECK  ID>, DT_LTNUC
24988       SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
24989
24990 ************************************************************************
24991 * Lorentz-transformations.                                             *
24992 *   PIN        longitudnal momentum       (input)                      *
24993 *   EIN        energy                     (input)                      *
24994 *   POUT       transformed long. momentum (output)                     *
24995 *   EOUT       transformed energy         (output)                     *
24996 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
24997 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
24998 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
24999 * This version dated 01.11.95 is written by  S. Roesler.               *
25000 ************************************************************************
25001
25002       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25003       SAVE
25004
25005       PARAMETER ( LINP = 5 ,
25006      &            LOUT = 6 ,
25007      &            LDAT = 9 )
25008
25009       PARAMETER (ZERO=0.0D0)
25010
25011 * Lorentz-parameters of the current interaction
25012       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
25013      &                UMO,PPCM,EPROJ,PPROJ
25014
25015       BDUM1 = ZERO
25016       BDUM2 = ZERO
25017       PDUM1 = ZERO
25018       PDUM2 = ZERO
25019       IF (ABS(MODE).EQ.1) THEN
25020          BG = -SIGN(BGLAB,DBLE(MODE))
25021          CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
25022      &                               DUM1,DUM2,DUM3,POUT,EOUT)
25023       ELSEIF (ABS(MODE).EQ.2) THEN
25024          BG = SIGN(BGCMS(1),DBLE(MODE))
25025          CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
25026      &                               DUM1,DUM2,DUM3,POUT,EOUT)
25027       ELSEIF (ABS(MODE).EQ.3) THEN
25028          BG = -SIGN(BGCMS(2),DBLE(MODE))
25029          CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
25030      &                               DUM1,DUM2,DUM3,POUT,EOUT)
25031       ELSE
25032          WRITE(LOUT,1000) MODE
25033  1000    FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
25034          EOUT = EIN
25035          POUT = PIN
25036       ENDIF
25037
25038       RETURN
25039       END
25040 *
25041 *===daltra=============================================================*
25042 *
25043 CDECK  ID>, DT_DALTRA
25044       SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
25045
25046 ************************************************************************
25047 * Arbitrary Lorentz-transformation.                                    *
25048 * Adopted from the original by S. Roesler. This version dated 15.01.95 *
25049 ************************************************************************
25050
25051       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25052       SAVE
25053       PARAMETER (ONE=1.0D0)
25054
25055       EP = PCX*BGX+PCY*BGY+PCZ*BGZ
25056       PE = EP/(GA+ONE)+EC
25057       PX = PCX+BGX*PE
25058       PY = PCY+BGY*PE
25059       PZ = PCZ+BGZ*PE
25060       P  = SQRT(PX*PX+PY*PY+PZ*PZ)
25061       E  = GA*EC+EP
25062
25063       RETURN
25064       END
25065 *
25066 *====dtrafo============================================================*
25067 *
25068 CDECK  ID>, DT_DTRAFO
25069       SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
25070      &                                    PL,CXL,CYL,CZL,EL)
25071
25072 C     LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
25073
25074       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25075       SAVE
25076
25077       IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
25078       SID  = SQRT(1.D0-COD*COD)
25079       PLX  = P*SID*COF
25080       PLY  = P*SID*SIF
25081       PCMZ = P*COD
25082       PLZ  = GAM*PCMZ+BGAM*ECM
25083       PL   = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
25084       EL   = GAM*ECM+BGAM*PCMZ
25085 C     ROTATION INTO THE ORIGINAL DIRECTION
25086       COZ  = PLZ/PL
25087       SIZ  = SQRT(1.D0-COZ**2)
25088       CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
25089
25090       RETURN
25091       END
25092 *
25093 *====sttran============================================================*
25094 *
25095 CDECK  ID>, DT_STTRAN
25096       SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
25097
25098       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25099       SAVE
25100       DATA ANGLSQ/1.D-30/
25101 ************************************************************************
25102 *     VERSION BY                     J. RANFT                          *
25103 *                                    LEIPZIG                           *
25104 *                                                                      *
25105 *     THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES      *
25106 *                                                                      *
25107 *     INPUT VARIABLES:                                                 *
25108 *        XO,YO,ZO = ORIGINAL DIRECTION COSINES                         *
25109 *        CDE,SDE  = COSINE AND SINE OF THE POLAR (THETA)               *
25110 *                   ANGLE OF "SCATTERING"                              *
25111 *        SDE      = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING"    *
25112 *        SFE,CFE  = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE       *
25113 *                   OF "SCATTERING"                                    *
25114 *                                                                      *
25115 *     OUTPUT VARIABLES:                                                *
25116 *        X,Y,Z     = NEW DIRECTION COSINES                             *
25117 *                                                                      *
25118 *     ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 )                  *
25119 ************************************************************************
25120 *
25121 *
25122 *  Changed by A. Ferrari
25123 *
25124 *     IF (ABS(XO)-0.0001D0) 1,1,2
25125 *   1 IF (ABS(YO)-0.0001D0) 3,3,2
25126 *   3 CONTINUE
25127       A = XO**2 + YO**2
25128       IF ( A .LT. ANGLSQ ) THEN
25129          X=SDE*CFE
25130          Y=SDE*SFE
25131          Z=CDE*ZO
25132       ELSE
25133          XI=SDE*CFE
25134          YI=SDE*SFE
25135          ZI=CDE
25136          A=SQRT(A)
25137          X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
25138          Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
25139          Z=A*YI+ZO*ZI
25140       ENDIF
25141
25142       RETURN
25143       END
25144 *
25145 *===mytran=============================================================*
25146 *
25147 CDECK  ID>, DT_MYTRAN
25148       SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
25149
25150 ************************************************************************
25151 * This subroutine rotates the coordinate frame                         *
25152 *    a) theta  around y                                                *
25153 *    b) phi    around z      if IMODE = 1                              *
25154 *                                                                      *
25155 *     x'          cos(ph) -sin(ph) 0      cos(th)  0  sin(th)   x      *
25156 *     y' = A B =  sin(ph) cos(ph)  0  .   0        1        0   y      *
25157 *     z'          0       0        1     -sin(th)  0  cos(th)   z      *
25158 *                                                                      *
25159 * and vice versa if IMODE = 0.                                         *
25160 * This version dated 5.4.94 is based on the original version DTRAN     *
25161 * by J. Ranft and is written by S. Roesler.                            *
25162 ************************************************************************
25163
25164       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25165       SAVE
25166
25167       PARAMETER ( LINP = 5 ,
25168      &            LOUT = 6 ,
25169      &            LDAT = 9 )
25170
25171       IF (IMODE.EQ.1) THEN
25172          X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
25173          Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
25174          Z=-SDE    *XO       +CDE    *ZO
25175       ELSE
25176          X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
25177          Y= -SFE*XO+CFE*YO
25178          Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
25179       ENDIF
25180       RETURN
25181       END
25182 *
25183 *===lt2lab=============================================================*
25184 *
25185 CDECK  ID>, DT_LT2LAO
25186       SUBROUTINE DT_LT2LAO
25187
25188 ************************************************************************
25189 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
25190 * for final state particles/fragments defined in nucleon-nucleon-cms   *
25191 * and transforms them back to the lab.                                 *
25192 * This version dated 16.11.95 is written by S. Roesler                 *
25193 ************************************************************************
25194
25195       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25196       SAVE
25197
25198       PARAMETER ( LINP = 5 ,
25199      &            LOUT = 6 ,
25200      &            LDAT = 9 )
25201
25202 * event history
25203
25204       PARAMETER (NMXHKK=200000)
25205
25206       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25207      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25208      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25209 * extended event history
25210       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25211      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25212      &                IHIST(2,NMXHKK)
25213
25214       NEND      = NHKK
25215       NPOINT(5) = NHKK+1
25216       IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
25217       DO 1 I=NPOINT(4),NEND
25218 C     DO 1 I=1,NEND
25219          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
25220      &                                (ISTHKK(I).EQ.1001)) THEN
25221             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
25222             NOB = NOBAM(I)
25223             CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
25224      &                            PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
25225             IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
25226                ISTHKK(I) = 3*ISTHKK(I)
25227                NOBAM(NHKK)  = NOB
25228             ELSE
25229                IF (ISTHKK(I).EQ.-1) NOBAM(NHKK)  = NOB
25230                ISTHKK(I) = SIGN(3,ISTHKK(I))
25231             ENDIF
25232             JDAHKK(1,I) = NHKK
25233          ENDIF
25234     1 CONTINUE
25235
25236       RETURN
25237       END
25238 *
25239 *===lt2lab=============================================================*
25240 *
25241 CDECK  ID>, DT_LT2LAB
25242       SUBROUTINE DT_LT2LAB
25243
25244 ************************************************************************
25245 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
25246 * for final state particles/fragments defined in nucleon-nucleon-cms   *
25247 * and transforms them to the lab.                                      *
25248 * This version dated 07.01.96 is written by S. Roesler                 *
25249 ************************************************************************
25250
25251       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25252       SAVE
25253
25254       PARAMETER ( LINP = 5 ,
25255      &            LOUT = 6 ,
25256      &            LDAT = 9 )
25257
25258 * event history
25259
25260       PARAMETER (NMXHKK=200000)
25261
25262       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25263      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25264      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25265 * extended event history
25266       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25267      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25268      &                IHIST(2,NMXHKK)
25269
25270       IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
25271       DO 1 I=NPOINT(4),NHKK
25272          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
25273      &                                (ISTHKK(I).EQ.1001)) THEN
25274             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
25275             PHKK(3,I) = PZ
25276             PHKK(4,I) = PE
25277          ENDIF
25278     1 CONTINUE
25279
25280       RETURN
25281       END
25282
25283 ************************************************************************
25284 *                                                                      *
25285 *                 5) Sampling from distributions                       *
25286 *                                                                      *
25287 ************************************************************************
25288 *
25289 *===npoiss=============================================================*
25290 *
25291 CDECK  ID>, IDT_NPOISS
25292       INTEGER FUNCTION IDT_NPOISS(AVN)
25293
25294 ************************************************************************
25295 * Sample according to Poisson distribution with Poisson parameter AVN. *
25296 * The original version written by J. Ranft.                            *
25297 * This version dated 11.1.95 is written by S. Roesler.                 *
25298 ************************************************************************
25299
25300       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25301       SAVE
25302
25303       PARAMETER ( LINP = 5 ,
25304      &            LOUT = 6 ,
25305      &            LDAT = 9 )
25306
25307       EXPAVN = EXP(-AVN)
25308       K = 1
25309       A = 1.0D0
25310
25311    10 CONTINUE
25312       A = DT_RNDM(A)*A
25313       IF (A.GE.EXPAVN) THEN
25314          K = K+1
25315          GOTO 10
25316       ENDIF
25317       IDT_NPOISS = K-1
25318
25319       RETURN
25320       END
25321 *
25322 *===sampxb=============================================================*
25323 *
25324 CDECK  ID>, DT_SAMPXB
25325       DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
25326
25327 ************************************************************************
25328 * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2.             *
25329 * Processed by S. Roesler, 6.5.95                                      *
25330 ************************************************************************
25331
25332       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25333       SAVE
25334       PARAMETER (TWO=2.0D0)
25335
25336       A1 = LOG(X1+SQRT(X1**2+B**2))
25337       A2 = LOG(X2+SQRT(X2**2+B**2))
25338       AN = A2-A1
25339       A  = AN*DT_RNDM(A1)+A1
25340       BB = EXP(A)
25341       DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
25342
25343       RETURN
25344       END
25345 *
25346 *===sampex=============================================================*
25347 *
25348 CDECK  ID>, DT_SAMPEX
25349       DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
25350
25351 ************************************************************************
25352 * Sampling from f(x)=1./x between x1 and x2.                           *
25353 * Processed by S. Roesler, 6.5.95                                      *
25354 ************************************************************************
25355
25356       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25357       SAVE
25358       PARAMETER (ONE=1.0D0)
25359
25360       R   = DT_RNDM(X1)
25361       AL1 = LOG(X1)
25362       AL2 = LOG(X2)
25363       DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
25364
25365       RETURN
25366       END
25367 *
25368 *===samsqx=============================================================*
25369 *
25370 CDECK  ID>, DT_SAMSQX
25371       DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
25372
25373 ************************************************************************
25374 * Sampling from f(x)=1./x^0.5 between x1 and x2.                       *
25375 * Processed by S. Roesler, 6.5.95                                      *
25376 ************************************************************************
25377
25378       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25379       SAVE
25380       PARAMETER (ONE=1.0D0)
25381
25382       R = DT_RNDM(X1)
25383       DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
25384
25385       RETURN
25386       END
25387 *
25388 *===samplw=============================================================*
25389 *
25390 CDECK  ID>, DT_SAMPLW
25391       DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
25392
25393 ************************************************************************
25394 * Sampling from f(x)=1/x^b between x_min and x_max.                    *
25395 * S. Roesler, 18.4.98                                                  *
25396 ************************************************************************
25397
25398       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25399       SAVE
25400       PARAMETER (ONE=1.0D0)
25401
25402       R = DT_RNDM(B)
25403       IF (B.EQ.ONE) THEN
25404          DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
25405       ELSE
25406          ONEMB  = ONE-B
25407          DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
25408       ENDIF
25409
25410       RETURN
25411       END
25412 *
25413 *===betrej=============================================================*
25414 *
25415 CDECK  ID>, DT_BETREJ
25416       DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
25417
25418       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25419       SAVE
25420
25421       PARAMETER ( LINP = 5 ,
25422      &            LOUT = 6 ,
25423      &            LDAT = 9 )
25424
25425       PARAMETER (ONE=1.0D0)
25426
25427       IF (XMIN.GE.XMAX)THEN
25428          WRITE (LOUT,500) XMIN,XMAX
25429   500    FORMAT(1X,'DT_BETREJ:  XMIN<XMAX execution stopped ',2F10.5)
25430          STOP
25431       ENDIF
25432
25433    10 CONTINUE
25434       XX     = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
25435       BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
25436       YY     = BETMAX*DT_RNDM(XX)
25437       BETXX  = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
25438       IF (YY.GT.BETXX) GOTO 10
25439       DT_BETREJ = XX
25440
25441       RETURN
25442       END
25443 *
25444 *===dgamrn=============================================================*
25445 *
25446 CDECK  ID>, DT_DGAMRN
25447       DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
25448
25449 ************************************************************************
25450 * Sampling from Gamma-distribution.                                    *
25451 *       F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)            *
25452 * Processed by S. Roesler, 6.5.95                                      *
25453 ************************************************************************
25454
25455       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25456       SAVE
25457       PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
25458
25459       NCOU = 0
25460       N    = INT(ETA)
25461       F    = ETA-DBLE(N)
25462       IF (F.EQ.ZERO) GOTO 20
25463    10 R = DT_RNDM(F)
25464       NCOU = NCOU+1
25465       IF (NCOU.GE.11) GOTO 20
25466       IF (R.LT.F/(F+2.71828D0)) GOTO 30
25467       YYY = LOG(DT_RNDM(R)+TINY9)/F
25468       IF (ABS(YYY).GT.50.0D0) GOTO 20
25469       Y = EXP(YYY)
25470       IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
25471       GOTO 40
25472    20 Y = 0.0D0
25473       GOTO 50
25474    30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
25475       IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
25476    40 IF (N.EQ.0) GOTO 70
25477    50 Z = 1.0D0
25478       DO 60 I = 1,N
25479    60 Z = Z*DT_RNDM(Z)
25480       Y = Y-LOG(Z+TINY9)
25481    70 DT_DGAMRN = Y/ALAM
25482
25483       RETURN
25484       END
25485 *
25486 *===dbetar=============================================================*
25487 *
25488 CDECK  ID>, DT_DBETAR
25489       DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
25490
25491 ************************************************************************
25492 * Sampling from Beta -distribution between 0.0 and 1.0                 *
25493 *  F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
25494 * Processed by S. Roesler, 6.5.95                                      *
25495 ************************************************************************
25496
25497       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25498       SAVE
25499
25500       Y = DT_DGAMRN(1.0D0,GAM)
25501       Z = DT_DGAMRN(1.0D0,ETA)
25502       DT_DBETAR = Y/(Y+Z)
25503
25504       RETURN
25505       END
25506 *
25507 *===rannor=============================================================*
25508 *
25509 CDECK  ID>, DT_RANNOR
25510       SUBROUTINE DT_RANNOR(X,Y)
25511
25512 ************************************************************************
25513 * Sampling from Gaussian distribution.                                 *
25514 * Processed by S. Roesler, 6.5.95                                      *
25515 ************************************************************************
25516
25517       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25518       SAVE
25519       PARAMETER (TINY10=1.0D-10)
25520
25521       CALL DT_DSFECF(SFE,CFE)
25522       V = MAX(TINY10,DT_RNDM(X))
25523       A = SQRT(-2.D0*LOG(V))
25524       X = A*SFE
25525       Y = A*CFE
25526
25527       RETURN
25528       END
25529 *
25530 *===dpoli==============================================================*
25531 *
25532 CDECK  ID>, DT_DPOLI
25533       SUBROUTINE DT_DPOLI(CS,SI)
25534
25535       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25536       SAVE
25537
25538       U  = DT_RNDM(CS)
25539       CS = DT_RNDM(U)
25540       IF (U.LT.0.5D0) CS=-CS
25541       SI = SQRT(1.0D0-CS*CS+1.0D-10)
25542
25543       RETURN
25544       END
25545 *
25546 *===dsfecf=============================================================*
25547 *
25548 CDECK  ID>, DT_DSFECF
25549       SUBROUTINE DT_DSFECF(SFE,CFE)
25550
25551       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25552       SAVE
25553       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
25554
25555     1 CONTINUE
25556       X  = DT_RNDM(SFE)
25557       Y  = DT_RNDM(X)
25558       XX = X*X
25559       YY = Y*Y
25560       XY = XX+YY
25561       IF (XY.GT.ONE) GOTO 1
25562       CFE = (XX-YY)/XY
25563       SFE = TWO*X*Y/XY
25564       IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
25565       RETURN
25566       END
25567 *
25568 *===raco===============================================================*
25569 *
25570 CDECK  ID>, DT_RACO
25571       SUBROUTINE DT_RACO(WX,WY,WZ)
25572
25573 ************************************************************************
25574 * Direction cosines of random uniform (isotropic) direction in three   *
25575 * dimensional space                                                    *
25576 * Processed by S. Roesler, 20.11.95                                    *
25577 ************************************************************************
25578
25579       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25580       SAVE
25581       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
25582
25583   10  CONTINUE
25584       X  = TWO*DT_RNDM(WX)-ONE
25585       Y  = DT_RNDM(X)
25586       X2 = X*X
25587       Y2 = Y*Y
25588       IF (X2+Y2.GT.ONE) GOTO 10
25589
25590       CFE = (X2-Y2)/(X2+Y2)
25591       SFE = TWO*X*Y/(X2+Y2)
25592 * z = 1/2 [ 1 + cos (theta) ]
25593       Z   = DT_RNDM(X)
25594 * 1/2 sin (theta)
25595       WZ = SQRT(Z*(ONE-Z))
25596       WX = TWO*WZ*CFE
25597       WY = TWO*WZ*SFE
25598       WZ = TWO*Z-ONE
25599
25600       RETURN
25601       END
25602
25603 ************************************************************************
25604 *                                                                      *
25605 *           6) Special functions, algorithms and service routines      *
25606 *                                                                      *
25607 ************************************************************************
25608 *
25609 *===ylamb==============================================================*
25610 *
25611 CDECK  ID>, DT_YLAMB
25612       DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
25613
25614 ************************************************************************
25615 *                                                                      *
25616 *     auxiliary function for three particle decay mode                 *
25617 *     (standard LAMBDA**(1/2) function)                                *
25618 *                                                                      *
25619 * Adopted from an original version written by R. Engel.                *
25620 * This version dated 12.12.94 is written by S. Roesler.                *
25621 ************************************************************************
25622
25623       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25624       SAVE
25625
25626       YZ   = Y-Z
25627       XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
25628       IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
25629       DT_YLAMB = SQRT(XLAM)
25630
25631       RETURN
25632       END
25633 *
25634 *===sort1==============================================================*
25635 *
25636 CDECK  ID>, DT_SORT
25637       SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
25638
25639 ************************************************************************
25640 * This subroutine sorts entries in A in increasing/decreasing order    *
25641 * of A(3,i).                                                           *
25642 *              MODE  = 1     increasing in A(3,i=1..N)                 *
25643 *                    = 2     decreasing in A(3,i=1..N)                 *
25644 * This version dated 21.04.95 is revised by S. Roesler                 *
25645 ************************************************************************
25646
25647       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25648       SAVE
25649
25650       DIMENSION A(3,N)
25651
25652       M = I1
25653    10 CONTINUE
25654       M = I1-1
25655       IF (M.LE.0) RETURN
25656       L = 0
25657       DO 20 I=I0,M
25658          J = I+1
25659          IF (MODE.EQ.1) THEN
25660             IF (A(3,I).LE.A(3,J)) GOTO 20
25661          ELSE
25662             IF (A(3,I).GE.A(3,J)) GOTO 20
25663          ENDIF
25664          B = A(3,I)
25665          C = A(1,I)
25666          D = A(2,I)
25667          A(3,I) = A(3,J)
25668          A(2,I) = A(2,J)
25669          A(1,I) = A(1,J)
25670          A(3,J) = B
25671          A(1,J) = C
25672          A(2,J) = D
25673          L = 1
25674    20 CONTINUE
25675       IF (L.EQ.1) GOTO 10
25676
25677       RETURN
25678       END
25679 *
25680 *===sort1==============================================================*
25681 *
25682 CDECK  ID>, DT_SORT1
25683       SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
25684
25685 ************************************************************************
25686 * This subroutine sorts entries in A in increasing/decreasing order    *
25687 * of A(i).                                                             *
25688 *              MODE  = 1     increasing in A(i=1..N)                   *
25689 *                    = 2     decreasing in A(i=1..N)                   *
25690 * This version dated 21.04.95 is revised by S. Roesler                 *
25691 ************************************************************************
25692
25693       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25694       SAVE
25695
25696       DIMENSION A(N),IDX(N)
25697
25698       M = I1
25699    10 CONTINUE
25700       M = I1-1
25701       IF (M.LE.0) RETURN
25702       L = 0
25703       DO 20 I=I0,M
25704          J = I+1
25705          IF (MODE.EQ.1) THEN
25706             IF (A(I).LE.A(J)) GOTO 20
25707          ELSE
25708             IF (A(I).GE.A(J)) GOTO 20
25709          ENDIF
25710          B    = A(I)
25711          A(I) = A(J)
25712          A(J) = B
25713          IX     = IDX(I)
25714          IDX(I) = IDX(J)
25715          IDX(J) = IX
25716          L = 1
25717    20 CONTINUE
25718       IF (L.EQ.1) GOTO 10
25719
25720       RETURN
25721       END
25722 *
25723 *===xtime==============================================================*
25724 *
25725 CDECK  ID>, DT_XTIME
25726       SUBROUTINE DT_XTIME
25727
25728       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25729       SAVE
25730
25731       PARAMETER ( LINP = 5 ,
25732      &            LOUT = 6 ,
25733      &            LDAT = 9 )
25734
25735       CHARACTER DAT*9,TIM*11
25736
25737       DAT = '         '
25738       TIM = '           '
25739 C     CALL GETDAT(IYEAR,IMONTH,IDAY)
25740 C     CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
25741
25742 C     CALL DATE(DAT)
25743 C     CALL TIME(TIM)
25744 C     WRITE(LOUT,1000) DAT,TIM
25745  1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
25746
25747       RETURN
25748       END
25749
25750 ************************************************************************
25751 *                                                                      *
25752 *                 7) Random number generator package                   *
25753 *                                                                      *
25754 *    THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND        *
25755 *    SERVICE ROUTINES.                                                 *
25756 *    THE ALGORITHM IS FROM                                             *
25757 *      'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR'                     *
25758 *      G.MARSAGLIA, A.ZAMAN ;  FSU-SCRI-87-50                          *
25759 *    IMPLEMENTATION BY K. HAHN  DEC. 88,                               *
25760 *    THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
25761 *    AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ),        *
25762 *    THE PERIOD IS ABOUT 2**144,                                       *
25763 *    TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS,            *
25764 *    THE PACKAGE CONTAINS                                              *
25765 *      FUNCTION DT_RNDM(I)                  : GENERATOR                *
25766 *      SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION           *
25767 *      SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)  : PUT SEED TO GENERATOR    *
25768 *      SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)  : TAKE SEED FROM GENERATOR *
25769 *      SUBROUTINE DT_RNDMTE(IO)             : TEST OF GENERATOR        *
25770 *---                                                                   *
25771 *    FUNCTION DT_RNDM(I)                                               *
25772 *       GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS  IN (0..1)          *
25773 *       I  - DUMMY VARIABLE, NOT USED                                  *
25774 *    SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)                             *
25775 *       INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
25776 *       NA1,NA2,NA3,NB1  - VALUES FOR INITIALIZING THE GENERATOR       *
25777 *                          NA? MUST BE IN 1..178 AND NOT ALL 1         *
25778 *                          12,34,56  ARE THE STANDARD VALUES           *
25779 *                          NB1 MUST BE IN 1..168                       *
25780 *                          78  IS THE STANDARD VALUE                   *
25781 *    SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)                               *
25782 *       PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS   *
25783 *       AS AFTER THE LAST DT_RNDMOU CALL )                             *
25784 *       U(97),C,CD,CM,I,J  - SEED VALUES AS TAKEN FROM DT_RNDMOU       *
25785 *    SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)                               *
25786 *       TAKES SEED FROM GENERATOR                                      *
25787 *       U(97),C,CD,CM,I,J  - SEED VALUES                               *
25788 *    SUBROUTINE DT_RNDMTE(IO)                                          *
25789 *       TEST OF THE GENERATOR                                          *
25790 *       IO     - DEFINES OUTPUT                                        *
25791 *                  = 0  OUTPUT ONLY IF AN ERROR IS DETECTED            *
25792 *                  = 1  OUTPUT INDEPENDEND ON AN ERROR                 *
25793 *       DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO   *
25794 *       SAME STATUS                                                    *
25795 *       AS BEFORE CALL OF DT_RNDMTE                                    *
25796 ************************************************************************
25797 *
25798 *===rndm===============================================================*
25799 *
25800 CDECK  ID>, DT_RNDM
25801       DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
25802
25803       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25804       SAVE
25805
25806 * counter of calls to random number generator
25807 * uncomment if needed
25808 C     COMMON /DTRNCT/ IRNCT0,IRNCT1
25809 C     LOGICAL LFIRST
25810 C     DATA LFIRST /.TRUE./
25811
25812 * counter of calls to random number generator
25813 * uncomment if needed
25814 C     IF (LFIRST) THEN
25815 C        IRNCT0 = 0
25816 C        IRNCT1 = 0
25817 C        LFIRST = .FALSE.
25818 C     ENDIF
25819
25820       DT_RNDM = FLRNDM(VDUMMY)
25821 * counter of calls to random number generator
25822 * uncomment if needed
25823 C     IRNCT1 = IRNCT1+1
25824
25825       RETURN
25826       END
25827 *
25828 *===rndmst=============================================================*
25829 *
25830 CDECK  ID>, DT_RNDMST
25831       SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
25832
25833       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25834       SAVE
25835
25836 * random number generator
25837       COMMON /DTRAND/ U(97),C,CD,CM,I,J
25838
25839       MA1 = NA1
25840       MA2 = NA2
25841       MA3 = NA3
25842       MB1 = NB1
25843       I   = 97
25844       J   = 33
25845       DO 20 II2 = 1,97
25846         S = 0
25847         T = 0.5D0
25848         DO 10 II1 = 1,24
25849           MAT  = MOD(MOD(MA1*MA2,179)*MA3,179)
25850           MA1  = MA2
25851           MA2  = MA3
25852           MA3  = MAT
25853           MB1  = MOD(53*MB1+1,169)
25854           IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
25855    10   T = 0.5D0*T
25856    20 U(II2) = S
25857       C  =   362436.0D0/16777216.0D0
25858       CD =  7654321.0D0/16777216.0D0
25859       CM = 16777213.0D0/16777216.0D0
25860       RETURN
25861       END
25862 *
25863 *===rndmin=============================================================*
25864 *
25865 CDECK  ID>, DT_RNDMIN
25866       SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
25867
25868       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25869       SAVE
25870
25871 * random number generator
25872       COMMON /DTRAND/ U(97),C,CD,CM,I,J
25873
25874       DIMENSION UIN(97)
25875
25876       DO 10 KKK = 1,97
25877    10 U(KKK) = UIN(KKK)
25878       C  = CIN
25879       CD = CDIN
25880       CM = CMIN
25881       I  = IIN
25882       J  = JIN
25883
25884       RETURN
25885       END
25886 *
25887 *===rndmou=============================================================*
25888 *
25889 CDECK  ID>, DT_RNDMOU
25890       SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
25891
25892       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25893       SAVE
25894
25895 * random number generator
25896       COMMON /DTRAND/ U(97),C,CD,CM,I,J
25897
25898       DIMENSION UOUT(97)
25899
25900       DO 10 KKK = 1,97
25901    10 UOUT(KKK) = U(KKK)
25902       COUT  = C
25903       CDOUT = CD
25904       CMOUT = CM
25905       IOUT  = I
25906       JOUT  = J
25907
25908       RETURN
25909       END
25910 *
25911 *===rndmte=============================================================*
25912 *
25913 CDECK  ID>, DT_RNDMTE
25914       SUBROUTINE DT_RNDMTE(IO)
25915
25916       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25917       SAVE
25918
25919       DIMENSION UU(97),U(6),X(6),D(6)
25920       DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
25921      +8354498.D0, 10633180.D0/
25922
25923       CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
25924       CALL DT_RNDMST(12,34,56,78)
25925       DO 10 II1 = 1,20000
25926    10 XX = DT_RNDM(XX)
25927       SD        = 0.0D0
25928       DO 20 II2 = 1,6
25929         X(II2)  = 4096.D0*(4096.D0*DT_RNDM(SD))
25930         D(II2)  = X(II2)-U(II2)
25931    20 SD = SD+D(II2)
25932       CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
25933 **sr 24.01.95
25934 C     IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
25935       IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
25936 C        WRITE(6,1000)
25937  1000    FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
25938      &          ' passed')
25939       ENDIF
25940 **
25941       RETURN
25942   500 FORMAT('  === TEST OF THE RANDOM-GENERATOR ===',/,
25943      &'    EXPECTED VALUE    CALCULATED VALUE     DIFFERENCE',/, 6(F17.
25944      &1,F20.1,F15.3,/), '  === END OF TEST ;',
25945      &'  GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
25946       END
25947 *
25948 *
25949 *===title==============================================================*
25950 *
25951 CDECK  ID>, DT_TITLE
25952       SUBROUTINE DT_TITLE
25953
25954       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25955       SAVE
25956
25957       PARAMETER ( LINP = 5 ,
25958      &            LOUT = 6 ,
25959      &            LDAT = 9 )
25960
25961       CHARACTER*6 CVERSI
25962       CHARACTER*11 CCHANG
25963       DATA CVERSI,CCHANG /'3.0-4 ','18 Sep 2001'/
25964
25965       CALL DT_XTIME
25966       WRITE(LOUT,1000) CVERSI,CCHANG
25967  1000 FORMAT(1X,'+-------------------------------------------------',
25968      &                  '----------------------+',/,
25969      &     1X,'|',71X,'|',/,
25970      &     1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
25971      &     1X,'|',71X,'|',/,
25972      &     1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
25973      &     1X,'|',71X,'|',/,
25974      &     1X,'|',12X,'Authors: Stefan Roesler   (CERN)',27X,'|',/,
25975      &     1X,'|',21X,'Ralph Engel      (Bartol Res. Inst.)',14X,'|',/,
25976      &     1X,'|',21X,'Johannes Ranft   (Siegen Univ.)',19X,'|',/,
25977      &     1X,'|',71X,'|',/,
25978      &     1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
25979      &                                              17X,'|',/,
25980      &     1X,'|',71X,'|',/,
25981      &     1X,'+-------------------------------------------------',
25982      &                '----------------------+',/,
25983      &     1X,'| Please send suggestions, bug reports, etc. to: ',
25984      &                                  'Stefan.Roesler@cern.ch |',/,
25985      &     1X,'+-------------------------------------------------',
25986      &                '----------------------+',/)
25987
25988       RETURN
25989       END
25990 *
25991 *===evtini=============================================================*
25992 *
25993 CDECK  ID>, DT_EVTINI
25994       SUBROUTINE DT_EVTINI
25995
25996 ************************************************************************
25997 * Initialization of DTEVT1.                                            *
25998 * This version dated 15.01.94 is written by S. Roesler                 *
25999 ************************************************************************
26000
26001       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26002       SAVE
26003
26004       PARAMETER ( LINP = 5 ,
26005      &            LOUT = 6 ,
26006      &            LDAT = 9 )
26007
26008 * event history
26009
26010       PARAMETER (NMXHKK=200000)
26011
26012       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26013      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26014      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26015 * extended event history
26016       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26017      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26018      &                IHIST(2,NMXHKK)
26019 * event flag
26020       COMMON /DTEVNO/ NEVENT,ICASCA
26021
26022       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
26023
26024 * emulsion treatment
26025       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
26026      &                NCOMPO,IEMUL
26027
26028 * initialization of DTEVT1/DTEVT2
26029       NEND = NHKK
26030       IF (NEVENT.EQ.1) NEND = NMXHKK
26031       NHKK   = 0
26032       NEVHKK = NEVENT
26033       DO 1 I=1,NEND
26034          ISTHKK(I)   = 0
26035          IDHKK(I)    = 0
26036          JMOHKK(1,I) = 0
26037          JMOHKK(2,I) = 0
26038          JDAHKK(1,I) = 0
26039          JDAHKK(2,I) = 0
26040          IDRES(I)    = 0
26041          IDXRES(I)   = 0
26042          NOBAM(I)    = 0
26043          IDCH(I)     = 0
26044          IHIST(1,I)  = 0
26045          IHIST(2,I)  = 0
26046          DO 2 J=1,4
26047             PHKK(J,I) = 0.0D0
26048             VHKK(J,I) = 0.0D0
26049             WHKK(J,I) = 0.0D0
26050     2    CONTINUE
26051          PHKK(5,I) = 0.0D0
26052     1 CONTINUE
26053       DO 3 I=1,10
26054          NPOINT(I) = 0
26055     3 CONTINUE
26056       CALL DT_CHASTA(-1)
26057
26058 C* initialization of DTLTRA
26059 C      IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
26060
26061       RETURN
26062       END
26063 *
26064 *===statis=============================================================*
26065 *
26066 CDECK  ID>, DT_STATIS
26067       SUBROUTINE DT_STATIS(MODE)
26068
26069 ************************************************************************
26070 * Initialization and output of run-statistics.                         *
26071 *              MODE  = 1     initialization                            *
26072 *                    = 2     output                                    *
26073 * This version dated 23.01.94 is written by S. Roesler                 *
26074 ************************************************************************
26075
26076       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26077       SAVE
26078
26079       PARAMETER ( LINP = 5 ,
26080      &            LOUT = 6 ,
26081      &            LDAT = 9 )
26082
26083       PARAMETER (TINY3=1.0D-3)
26084
26085 * statistics
26086       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
26087      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
26088      &                ICEVTG(8,0:30)
26089 * rejection counter
26090       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
26091      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
26092      &                IREXCI(3),IRDIFF(2),IRINC
26093 * central particle production, impact parameter biasing
26094       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
26095 * various options for treatment of partons (DTUNUC 1.x)
26096 * (chain recombination, Cronin,..)
26097       LOGICAL LCO2CR,LINTPT
26098       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
26099      &                LCO2CR,LINTPT
26100 * nucleon-nucleon event-generator
26101       CHARACTER*8 CMODEL
26102       LOGICAL LPHOIN
26103       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26104 * flags for particle decays
26105       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
26106      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
26107      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
26108 * diquark-breaking mechanism
26109       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
26110
26111       DIMENSION PP(4),PT(4)
26112
26113       GOTO (1,2) MODE
26114
26115 * initialization
26116     1 CONTINUE
26117
26118 *   initialize statistics counter
26119       ICREQU = 0
26120       ICSAMP = 0
26121       ICCPRO = 0
26122       ICDPR  = 0
26123       ICDTA  = 0
26124       ICRJSS = 0
26125       ICVV2S = 0
26126       DO 10 I=1,9
26127          ICRES(I)    = 0
26128          ICCHAI(1,I) = 0
26129          ICCHAI(2,I) = 0
26130    10 CONTINUE
26131 *   initialize rejection counter
26132       IRPT      = 0
26133       IRHHA     = 0
26134       LOMRES    = 0
26135       LOBRES    = 0
26136       IRFRAG    = 0
26137       IREVT     = 0
26138       IRRES(1)  = 0
26139       IRRES(2)  = 0
26140       IRCHKI(1) = 0
26141       IRCHKI(2) = 0
26142       IRCRON(1) = 0
26143       IRCRON(2) = 0
26144       IRCRON(3) = 0
26145       IRDIFF(1) = 0
26146       IRDIFF(2) = 0
26147       IRINC     = 0
26148       DO 11 I=1,5
26149          ICDIFF(I) = 0
26150    11 CONTINUE
26151       DO 12 I=1,8
26152          DO 13 J=0,30
26153             ICEVTG(I,J) = 0
26154    13    CONTINUE
26155    12 CONTINUE
26156
26157       RETURN
26158
26159 * output
26160     2 CONTINUE
26161
26162 *   statistics counter
26163       WRITE(LOUT,1000)
26164  1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
26165      &       28X,'---------------------')
26166       WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
26167  1001 FORMAT(/,1X,'number of events requested / sampled',13X,
26168      &       I8,' / ',I8,/,1X,'number of samp. evts per requested ',
26169      &       'event',11X,F9.1)
26170       IF (ICDIFF(1).NE.0) THEN
26171          WRITE(LOUT,1009) ICDIFF
26172  1009    FORMAT(/,1X,'diffractive events:    total   ',I8,/,49X,
26173      &          'low mass   high mass',/,24X,'single diffraction',
26174      &          7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
26175       ENDIF
26176       IF (ICENTR.GT.0) THEN
26177          WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
26178      &                    DBLE(ICSAMP)/DBLE(ICCPRO)
26179  1002    FORMAT(/,1X,'central production:',/,2X,'mean number',
26180      &          ' of sampled Glauber-events per event',9X,F9.1,/,
26181      &          2X,'fraction of production cross section',21X,F10.6)
26182       ENDIF
26183       WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
26184      &                 DBLE(ICDTA)/DBLE(ICSAMP)
26185  1003 FORMAT(/,54X,'proj.    targ.',/,1X,'average number of wounded',
26186      &       ' nucleons after x-sampling',2(4X,F6.2))
26187
26188       IF (MCGENE.EQ.1) THEN
26189          WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
26190  1004    FORMAT(/,1X,'mean number of sea-sea chain rejections per',
26191      &          ' event',3X,F9.1)
26192          IF (ISICHA.EQ.1) THEN
26193             WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
26194  1005       FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
26195      &             'of single chains  per event',13X,F9.1)
26196          ENDIF
26197          WRITE(LOUT,1006)
26198  1006    FORMAT(/,1X,'chain system statistics:  (per event)',/,
26199      &       23X,'mean number of chains      mean number of chains',/,
26200      &       23X,'sampled    hadronized      having mass of a reso.')
26201          WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
26202      &                     DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
26203      &                     DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
26204      &                  DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
26205  1007    FORMAT(1X,'sea     - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26206      &          1X,'disea   - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26207      &          1X,'sea     - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26208      &          1X,'sea     - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26209      &          1X,'disea   - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26210      &          1X,'valence - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26211      &          1X,'valence - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26212      &          1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26213      &          1X,'fused chains      ',18X,F4.1,17X,F4.1,/)
26214          WRITE(LOUT,1008)
26215      &     (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
26216      &     DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
26217      &     DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
26218      &     (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
26219      &     (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
26220      &     DBLE(IRHHA)/DBLE(ICREQU),
26221      &     DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
26222      &     (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
26223  1008    FORMAT(/,1X,'Rejection counter:  (NEVT = no. of events)',/,/,
26224      &       1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
26225      &       F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
26226      &       'Intrins. p_t (GETSPT)',21X,'IRPT     /NEVT = ',F7.2,/,
26227      &       1X,'Chain mass corr. for resonances (EVTRES)',2X,
26228      &       'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES)  IRRES(2) /',
26229      &       'NEVT = ',F7.2,/,43X,'LOMRES   /NEVT = ',F7.2,/,
26230      &       43X,'LOBRES   /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
26231      &       ' 2-chain systems (CHKINE)  IRCHKI(1)/NEVT = ',F7.2,/,
26232      &       43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
26233      &       'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
26234      &       F7.2,/,1X,'Total no. of rej.',
26235      &       ' in chain-systems treatment (GETCSY)',/,43X,
26236      &       'IRHHA    /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
26237      &       ' (not yet used!)',4X,'IRFRAG   /NEVT = ',F7.2,/,
26238      &       1X,'Total no. of rej. in DPM-treatment of one event',
26239      &       ' (EVENTA)',/,43X,'IREVT    /NEVT = ',F7.2,/,1X,
26240      &       'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
26241      &       ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
26242      &       'IREXCI(3) = ',I5,/)
26243       ELSEIF (MCGENE.EQ.2) THEN
26244 C *** Commented by Chiara
26245 C         WRITE(LOUT,1010) ELOJET
26246 C 1010    FORMAT(/,/,1X,'PHOJET-treatment of chain systems above  ',
26247 C     &          F4.1,' GeV')
26248 C         WRITE(LOUT,1011)
26249 C 1011    FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
26250 C     &          30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
26251 C     &          5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
26252 C         WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
26253 C     &                    (INT(ICCHAI(2,I)/2.0D0),I=1,8),
26254 C     &                    (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
26255 C     &                    ((ICEVTG(I,J),I=1,8),J=3,7),
26256 C     &                    ((ICEVTG(I,J),I=1,8),J=19,21),
26257 C     &                    (ICEVTG(I,8),I=1,8),
26258 C     &                    ((ICEVTG(I,J),I=1,8),J=22,24),
26259 C     &                    (ICEVTG(I,9),I=1,8),
26260 C     &                    ((ICEVTG(I,J),I=1,8),J=25,28),
26261 C     &                    ((ICEVTG(I,J),I=1,8),J=10,18)
26262 C 1012    FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
26263 C     &          8I8,/,/,1X,'PHOJET ',8I8,/,'   sngl ',8I8,/,/,
26264 C     &          ' no-dif.',8I8,/,
26265 C     &          ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
26266 C     &          ' diff-1 ',8I8,/,'  low   ',8I8,/,'  high  ',8I8,/,
26267 C     &          '  h-diff',8I8,/,' diff-2 ',8I8,/,'  low   ',8I8,/,
26268 C     &          '  high  ',8I8,/,'  h-diff',8I8,/,' dbl-di.',8I8,/,
26269 C     &          '  lo-lo ',8I8,/,'  hi-hi ',8I8,/,'  lo-hi ',8I8,/,
26270 C     &          '  hi-lo ',8I8,/,
26271 C     &          ' dir-ga.',8I8,/,/,' dir-1  ',8I8,/,' dir-2  ',8I8,/,
26272 C     &          ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
26273 C     &          ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
26274 C         WRITE(LOUT,1013)
26275 C 1013    FORMAT(/,1X,'2. chain system statistics -',
26276 C     &          ' mean numbers per evt:',/,30X,'---------------------',
26277 C     &          /,/,16X,'s-s',7X,'d-s',7X,'s-d')
26278 C         WRITE(LOUT,1014)
26279 C     &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
26280 C     &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
26281 C     &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
26282 C 1014    FORMAT(/,1X,'req.to.    ',3E10.2,/,/,1X,'low rq.    ',3E10.2,/,
26283 C     &          1X,'low ac.    ',3E10.2,/,/,1X,'PHOJET     ',3E10.2,/,/,
26284 C     &          ' no-dif.    ',3E10.2,/,' el-sca.    ',3E10.2,/,
26285 C     &          ' qel-sc.    ',3E10.2,/,' dbl-Po.    ',3E10.2,/,
26286 C     &          ' diff-1     ',3E10.2,/,' diff-2     ',3E10.2,/,
26287 C     &          ' dbl-di.    ',3E10.2,/,' dir-ga.    ',3E10.2,/,/,
26288 C     &          ' dir-1      ',3E10.2,/,' dir-2      ',3E10.2,/,
26289 C     &          ' dbl-dir    ',3E10.2,/,' s-Pom.     ',3E10.2,/,
26290 C     &          ' h-Pom.     ',3E10.2,/,' s-Reg.     ',3E10.2,/,
26291 C     &          ' enh-trg    ',3E10.2,/,' enh-log    ',3E10.2)
26292 C         WRITE(LOUT,1015)
26293 C 1015    FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
26294 C         WRITE(LOUT,1016)
26295 C     &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
26296 C     &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
26297 C     &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
26298 C 1016    FORMAT(/,1X,'req.to.    ',5E10.2,/,/,1X,'low rq.    ',5E10.2,/,
26299 C     &          1X,'low ac.    ',5E10.2,/,/,1X,'PHOJET     ',5E10.2,/,/,
26300 C     &          ' no-dif.    ',5E10.2,/,' el-sca.    ',5E10.2,/,
26301 C     &          ' qel-sc.    ',5E10.2,/,' dbl-Po.    ',5E10.2,/,
26302 C     &          ' diff-1     ',5E10.2,/,' diff-2     ',5E10.2,/,
26303 C     &          ' dbl-di.    ',5E10.2,/,' dir-ga.    ',5E10.2,/,/,
26304 C     &          ' dir-1      ',5E10.2,/,' dir-2      ',5E10.2,/,
26305 C     &          ' dbl-dir    ',5E10.2,/,' s-Pom.     ',5E10.2,/,
26306 C     &          ' h-Pom.     ',5E10.2,/,' s-Reg.     ',5E10.2,/,
26307 C     &          ' enh-trg    ',5E10.2,/,' enh-log    ',5E10.2)
26308
26309       ENDIF
26310       CALL DT_CHASTA(1)
26311
26312       IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
26313      &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
26314          WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
26315      &    DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
26316      &    DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
26317          WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
26318      &    DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
26319      &    DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
26320          WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
26321      &    DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
26322      &    DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
26323          WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
26324      &    DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
26325      &    DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
26326          WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
26327      &    DBRKA(3,1),DBRKA(3,2),
26328      &    DBRKA(3,3),DBRKA(3,4)
26329          WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
26330      &    DBRKR(3,1),DBRKR(3,2),
26331      &    DBRKR(3,3),DBRKR(3,4)
26332          WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
26333      &    DBRKA(3,5),DBRKA(3,6),
26334      &    DBRKA(3,7),DBRKA(3,8)
26335          WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
26336      &    DBRKR(3,5),DBRKR(3,6),
26337      &    DBRKR(3,7),DBRKR(3,8)
26338       ENDIF
26339
26340       FAC = 1.0D0
26341       IF (MCGENE.EQ.2) THEN
26342
26343 C        CALL PHO_PHIST(-2,SIGMAX)
26344          CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
26345
26346       ENDIF
26347
26348       CALL DT_XTIME
26349
26350       RETURN
26351       END
26352 *
26353 *===evtout=============================================================*
26354 *
26355 CDECK  ID>, DT_EVTOUT
26356       SUBROUTINE DT_EVTOUT(MODE)
26357
26358 ************************************************************************
26359 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
26360 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
26361 *                    4  plot entries of DTEVT1 and DTEVT2              *
26362 * This version dated 11.12.94 is written by S. Roesler                 *
26363 ************************************************************************
26364
26365       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26366       SAVE
26367
26368       PARAMETER ( LINP = 5 ,
26369      &            LOUT = 6 ,
26370      &            LDAT = 9 )
26371
26372 * event history
26373
26374       PARAMETER (NMXHKK=200000)
26375
26376       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26377      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26378      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26379
26380       DIMENSION IRANGE(NMXHKK)
26381
26382       IF (MODE.EQ.2) RETURN
26383
26384       CALL DT_EVTPLO(IRANGE,MODE)
26385
26386       RETURN
26387       END
26388 *
26389 *===evtplo=============================================================*
26390 *
26391 CDECK  ID>, DT_EVTPLO
26392       SUBROUTINE DT_EVTPLO(IRANGE,MODE)
26393
26394 ************************************************************************
26395 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
26396 *                    2  plot entries of DTEVT1 given by IRANGE         *
26397 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
26398 *                    4  plot entries of DTEVT1 and DTEVT2              *
26399 *                    5  plot rejection counter                         *
26400 * This version dated 11.12.94 is written by S. Roesler                 *
26401 ************************************************************************
26402
26403       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26404       SAVE
26405
26406       PARAMETER ( LINP = 5 ,
26407      &            LOUT = 6 ,
26408      &            LDAT = 9 )
26409
26410       CHARACTER*16 CHAU
26411
26412 * event history
26413
26414       PARAMETER (NMXHKK=200000)
26415
26416       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26417      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26418      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26419 * extended event history
26420       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26421      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26422      &                IHIST(2,NMXHKK)
26423 * rejection counter
26424       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
26425      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
26426      &                IREXCI(3),IRDIFF(2),IRINC
26427
26428       DIMENSION IRANGE(NMXHKK)
26429
26430       IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
26431          WRITE(LOUT,1000)
26432  1000    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTEVT1/',/,
26433      &         15X,'           --------------------------',/,/,
26434      &             '       ST    ID  M1   M2   D1   D2     PX     PY',
26435      &             '     PZ      E       M',/)
26436          DO 1 I=1,NHKK
26437             WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
26438      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
26439      &                       PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
26440      &                       PHKK(5,I)
26441 C           WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
26442 C    &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
26443 C    &                       PHKK(3,I),PHKK(4,I)
26444 C           WRITE(LOUT,'(4E15.4)')
26445 C    &         VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
26446  1001       FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
26447  1011       FORMAT(I5,I5,I6,4I5,2E15.5)
26448     1    CONTINUE
26449          WRITE(LOUT,*)
26450 C        DO 4 I=1,NHKK
26451 C           WRITE(LOUT,1006) I,ISTHKK(I),
26452 C    &                    VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
26453 C    &                    WHKK(2,I),WHKK(3,I)
26454 C1006       FORMAT(1X,I4,I6,6E10.3)
26455 C   4    CONTINUE
26456       ENDIF
26457
26458       IF (MODE.EQ.2) THEN
26459          WRITE(LOUT,1000)
26460          NC = 0
26461     2    CONTINUE
26462          NC = NC+1
26463          IF (IRANGE(NC).EQ.-100) GOTO 9999
26464          I = IRANGE(NC)
26465          WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
26466      &                    JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
26467      &                    PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
26468      &                    PHKK(5,I)
26469          GOTO 2
26470       ENDIF
26471
26472       IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
26473          WRITE(LOUT,1002)
26474  1002    FORMAT(/,1X,'EVTPLO:',14X,
26475      &         ' content of COMMON /DTEVT1/,/DTEVT2/',/,
26476      &         15X,'        -----------------------------------',/,/,
26477      &             '       ST    ID   M1   M2   D1   D2  IDR  IDXR',
26478      &             ' NOBAM IDCH    M',/)
26479          DO 3 I=1,NHKK
26480 C           IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
26481                KF    = IDHKK(I)
26482                IDCHK = KF/10000
26483                IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
26484      &            (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
26485
26486                CALL PYNAME(KF,CHAU)
26487
26488                WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
26489      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
26490      &                       IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
26491      &                       PHKK(5,I),CHAU
26492  1003          FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
26493 C           ENDIF
26494     3    CONTINUE
26495       ENDIF
26496
26497       IF (MODE.EQ.5) THEN
26498          WRITE(LOUT,1004)
26499  1004    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTREJC/',/,
26500      &         15X,'           --------------------------',/)
26501          WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
26502      &                    IRSEA,IRCRON
26503  1005    FORMAT(1X,'IRPT   = ',I5,'  IRHHA = ',I5,/,
26504      &          1X,'IRRES  = ',2I5,'  LOMRES = ',I5,'  LOBRES = ',I5,/,
26505      &          1X,'IREMC  = ',10I5,/,
26506      &          1X,'IRFRAG = ',I5,'  IRSEA = ',I5,' IRCRON = ',I5,/)
26507       ENDIF
26508
26509  9999 RETURN
26510       END
26511 *
26512 *===evtput=============================================================*
26513 *
26514 CDECK  ID>, DT_EVTPUT
26515       SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
26516
26517       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26518       SAVE
26519
26520       PARAMETER ( LINP = 5 ,
26521      &            LOUT = 6 ,
26522      &            LDAT = 9 )
26523
26524       PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
26525      &           TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
26526
26527 * event history
26528
26529       PARAMETER (NMXHKK=200000)
26530
26531       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26532      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26533      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26534 * extended event history
26535       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26536      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26537      &                IHIST(2,NMXHKK)
26538 * Lorentz-parameters of the current interaction
26539       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26540      &                UMO,PPCM,EPROJ,PPROJ
26541 * particle properties (BAMJET index convention)
26542       CHARACTER*8  ANAME
26543       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26544      &                IICH(210),IIBAR(210),K1(210),K2(210)
26545
26546 C     IF (MODE.GT.100) THEN
26547 C        WRITE(LOUT,'(1X,A,I5,A,I5)')
26548 C    &        'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
26549 C        NHKK = NHKK-MODE+100
26550 C        RETURN
26551 C     ENDIF
26552       MO1  = M1
26553       MO2  = M2
26554       NHKK = NHKK+1
26555
26556       IF (NHKK.GT.NMXHKK) THEN
26557          WRITE(LOUT,1000) NHKK
26558  1000    FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
26559      &             '! program execution stopped..')
26560          STOP
26561       ENDIF
26562       IF (M1.LT.0) MO1 = NHKK+M1
26563       IF (M2.LT.0) MO2 = NHKK+M2
26564       ISTHKK(NHKK)   = IST
26565       IDHKK(NHKK)    = ID
26566       JMOHKK(1,NHKK) = MO1
26567       JMOHKK(2,NHKK) = MO2
26568       JDAHKK(1,NHKK) = 0
26569       JDAHKK(2,NHKK) = 0
26570       IDRES(NHKK)    = IDR
26571       IDXRES(NHKK)   = IDXR
26572       IDCH(NHKK)     = IDC
26573 ** here we need to do something..
26574       IF (ID.EQ.88888) THEN
26575          IDMO1 = ABS(IDHKK(MO1))
26576          IDMO2 = ABS(IDHKK(MO2))
26577          IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
26578          IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
26579          IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
26580          IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
26581       ELSE
26582          NOBAM(NHKK) = 0
26583       ENDIF
26584       IDBAM(NHKK) = IDT_ICIHAD(ID)
26585       IF (MO1.GT.0) THEN
26586          IF (JDAHKK(1,MO1).NE.0) THEN
26587             JDAHKK(2,MO1) = NHKK
26588          ELSE
26589             JDAHKK(1,MO1) = NHKK
26590          ENDIF
26591       ENDIF
26592       IF (MO2.GT.0) THEN
26593          IF (JDAHKK(1,MO2).NE.0) THEN
26594             JDAHKK(2,MO2) = NHKK
26595          ELSE
26596             JDAHKK(1,MO2) = NHKK
26597          ENDIF
26598       ENDIF
26599 C      IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
26600 C         PTOT   = SQRT(PX**2+PY**2+PZ**2)
26601 C         AM0    = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
26602 C         AMRQ   = AAM(IDBAM(NHKK))
26603 C         AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
26604 C         IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
26605 C     &       (PTOT.GT.ZERO)) THEN
26606 C            DELTA = -AMDIF2/(2.0D0*(E+PTOT))
26607 CC           DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
26608 C            E     = E+DELTA
26609 C            PTOT1 = PTOT-DELTA
26610 C            PX    = PX*PTOT1/PTOT
26611 C            PY    = PY*PTOT1/PTOT
26612 C            PZ    = PZ*PTOT1/PTOT
26613 C         ENDIF
26614 C      ENDIF
26615       PHKK(1,NHKK) = PX
26616       PHKK(2,NHKK) = PY
26617       PHKK(3,NHKK) = PZ
26618       PHKK(4,NHKK) = E
26619       PTOT = SQRT( PX**2+PY**2+PZ**2 )
26620       IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
26621          PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
26622          PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
26623       ELSE
26624          PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
26625 C        IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
26626 C    &      WRITE(LOUT,'(1X,A,G10.3)')
26627 C    &        'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
26628          PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
26629       ENDIF
26630       IDCHK = ID/10000
26631       IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
26632 * special treatment for chains:
26633 *    z coordinate of chain in Lab  = pos. of target nucleon
26634 *    time of chain-creation in Lab = time of passage of projectile
26635 *                                    nucleus at pos. of taget nucleus
26636 C        VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
26637 C        VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
26638          VHKK(1,NHKK) = VHKK(1,MO2)
26639          VHKK(2,NHKK) = VHKK(2,MO2)
26640          VHKK(3,NHKK) = VHKK(3,MO2)
26641          VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
26642 C        WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
26643 C        WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
26644          WHKK(1,NHKK) = WHKK(1,MO1)
26645          WHKK(2,NHKK) = WHKK(2,MO1)
26646          WHKK(3,NHKK) = WHKK(3,MO1)
26647          WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
26648       ELSE
26649          IF (MO1.GT.0) THEN
26650             DO 1 I=1,4
26651                VHKK(I,NHKK) = VHKK(I,MO1)
26652                WHKK(I,NHKK) = WHKK(I,MO1)
26653     1       CONTINUE
26654          ELSE
26655             DO 2 I=1,4
26656                VHKK(I,NHKK) = ZERO
26657                WHKK(I,NHKK) = ZERO
26658     2       CONTINUE
26659          ENDIF
26660       ENDIF
26661
26662       RETURN
26663       END
26664 *
26665 *===chasta=============================================================*
26666 *
26667 CDECK  ID>, DT_CHASTA
26668       SUBROUTINE DT_CHASTA(MODE)
26669
26670 ************************************************************************
26671 * This subroutine performs CHAin STAtistics and checks sequence of     *
26672 * partons in dtevt1 and sorts them with projectile partons coming      *
26673 * first if necessary.                                                  *
26674 *                                                                      *
26675 * This version dated  8.5.00  is written by S. Roesler.                *
26676 ************************************************************************
26677
26678       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26679       SAVE
26680
26681       PARAMETER ( LINP = 5 ,
26682      &            LOUT = 6 ,
26683      &            LDAT = 9 )
26684
26685       CHARACTER*5 CCHTYP
26686
26687 * event history
26688
26689       PARAMETER (NMXHKK=200000)
26690
26691       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26692      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26693      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26694 * extended event history
26695       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26696      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26697      &                IHIST(2,NMXHKK)
26698 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
26699       PARAMETER (MAXCHN=10000)
26700       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
26701
26702       DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
26703      &          CCHTYP(9),ICHSTA(10),ITOT(10)
26704       DATA ICHCFG /1800*0/
26705       DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
26706       DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
26707       DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
26708       DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
26709       DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
26710       DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
26711       DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
26712      &              'ad aq',' d ad','ad d ',' g g '/
26713 *
26714 * initialization
26715 *
26716       IF (MODE.EQ.-1) THEN
26717          NCHAIN = 0
26718 *
26719 * loop over DTEVT1 and analyse chain configurations
26720 *
26721       ELSEIF (MODE.EQ.0) THEN
26722          DO 21 IDX=NPOINT(3),NHKK
26723             IDCHK = IDHKK(IDX)/10000
26724             IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
26725      &          (IDHKK(IDX).NE.80000).AND.
26726      &          (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
26727                IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
26728                   WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
26729      &                          ' at entry ',IDX
26730                   GOTO 21
26731                ENDIF
26732 *
26733                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
26734                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
26735                IMO1 = IST1/10
26736                IMO1 = IST1-10*IMO1
26737                IMO2 = IST2/10
26738                IMO2 = IST2-10*IMO2
26739 *   swop parton entries if necessary since we need projectile partons
26740 *   to come first in the common
26741                IF (IMO1.GT.IMO2) THEN
26742                   NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
26743                   DO 22 K=1,NPTN/2
26744                      I0 = JMOHKK(1,IDX)-1+K
26745                      I1 = JMOHKK(2,IDX)+1-K
26746                      ITMP = ISTHKK(I0)
26747                      ISTHKK(I0) = ISTHKK(I1)
26748                      ISTHKK(I1) = ITMP
26749                      ITMP = IDHKK(I0)
26750                      IDHKK(I0) = IDHKK(I1)
26751                      IDHKK(I1) = ITMP
26752                      IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
26753      &                  JDAHKK(1,JMOHKK(1,I0)) = I1
26754                      IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
26755      &                  JDAHKK(2,JMOHKK(1,I0)) = I1
26756                      IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
26757      &                  JDAHKK(1,JMOHKK(2,I0)) = I1
26758                      IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
26759      &                  JDAHKK(2,JMOHKK(2,I0)) = I1
26760                      IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
26761      &                  JDAHKK(1,JMOHKK(1,I1)) = I0
26762                      IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
26763      &                  JDAHKK(2,JMOHKK(1,I1)) = I0
26764                      IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
26765      &                  JDAHKK(1,JMOHKK(2,I1)) = I0
26766                      IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
26767      &                  JDAHKK(2,JMOHKK(2,I1)) = I0
26768                      ITMP = JMOHKK(1,I0)
26769                      JMOHKK(1,I0) = JMOHKK(1,I1)
26770                      JMOHKK(1,I1) = ITMP
26771                      ITMP = JMOHKK(2,I0)
26772                      JMOHKK(2,I0) = JMOHKK(2,I1)
26773                      JMOHKK(2,I1) = ITMP
26774                      ITMP = JDAHKK(1,I0)
26775                      JDAHKK(1,I0) = JDAHKK(1,I1)
26776                      JDAHKK(1,I1) = ITMP
26777                      ITMP = JDAHKK(2,I0)
26778                      JDAHKK(2,I0) = JDAHKK(2,I1)
26779                      JDAHKK(2,I1) = ITMP
26780                      DO 23 J=1,4
26781                         RTMP1 = PHKK(J,I0)
26782                         RTMP2 = VHKK(J,I0)
26783                         RTMP3 = WHKK(J,I0)
26784                         PHKK(J,I0) = PHKK(J,I1)
26785                         VHKK(J,I0) = VHKK(J,I1)
26786                         WHKK(J,I0) = WHKK(J,I1)
26787                         PHKK(J,I1) = RTMP1
26788                         VHKK(J,I1) = RTMP2
26789                         WHKK(J,I1) = RTMP3
26790    23                CONTINUE
26791                      RTMP1 = PHKK(5,I0)
26792                      PHKK(5,I0) = PHKK(5,I1)
26793                      PHKK(5,I1) = RTMP1
26794                      ITMP = IDRES(I0)
26795                      IDRES(I0) = IDRES(I1)
26796                      IDRES(I1) = ITMP
26797                      ITMP = IDXRES(I0)
26798                      IDXRES(I0) = IDXRES(I1)
26799                      IDXRES(I1) = ITMP
26800                      ITMP = NOBAM(I0)
26801                      NOBAM(I0) = NOBAM(I1)
26802                      NOBAM(I1) = ITMP
26803                      ITMP = IDBAM(I0)
26804                      IDBAM(I0) = IDBAM(I1)
26805                      IDBAM(I1) = ITMP
26806                      ITMP = IDCH(I0)
26807                      IDCH(I0) = IDCH(I1)
26808                      IDCH(I1) = ITMP
26809                      ITMP = IHIST(1,I0)
26810                      IHIST(1,I0) = IHIST(1,I1)
26811                      IHIST(1,I1) = ITMP
26812                      ITMP = IHIST(2,I0)
26813                      IHIST(2,I0) = IHIST(2,I1)
26814                      IHIST(2,I1) = ITMP
26815    22             CONTINUE
26816                ENDIF
26817                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
26818                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
26819 *
26820 *   parton 1 (projectile side)
26821                IF (IST1.EQ.21) THEN
26822                   IDX1 = 1
26823                ELSEIF (IST1.EQ.22) THEN
26824                   IDX1 = 2
26825                ELSEIF (IST1.EQ.31) THEN
26826                   IDX1 = 3
26827                ELSEIF (IST1.EQ.32) THEN
26828                   IDX1 = 4
26829                ELSEIF (IST1.EQ.41) THEN
26830                   IDX1 = 5
26831                ELSEIF (IST1.EQ.42) THEN
26832                   IDX1 = 6
26833                ELSEIF (IST1.EQ.51) THEN
26834                   IDX1 = 7
26835                ELSEIF (IST1.EQ.52) THEN
26836                   IDX1 = 8
26837                ELSEIF (IST1.EQ.61) THEN
26838                   IDX1 = 9
26839                ELSEIF (IST1.EQ.62) THEN
26840                   IDX1 = 10
26841                ELSE
26842 c                 WRITE(LOUT,*)
26843 c    &               ' CHASTA: unknown parton status flag (',
26844 c    &               IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
26845                   GOTO 21
26846                ENDIF
26847                ID = IDHKK(JMOHKK(1,IDX))
26848                IF (ABS(ID).LE.4) THEN
26849                   IF (ID.GT.0) THEN
26850                      ITYP1 = 1
26851                   ELSE
26852                      ITYP1 = 2
26853                   ENDIF
26854                ELSEIF (ABS(ID).GE.1000) THEN
26855                   IF (ID.GT.0) THEN
26856                      ITYP1 = 3
26857                   ELSE
26858                      ITYP1 = 4
26859                   ENDIF
26860                ELSEIF (ID.EQ.21) THEN
26861                   ITYP1 = 5
26862                ELSE
26863                   WRITE(LOUT,*)
26864      &               ' CHASTA: inconsistent parton identity (',
26865      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
26866                   GOTO 21
26867                ENDIF
26868 *
26869 *   parton 2 (target side)
26870                IF (IST2.EQ.21) THEN
26871                   IDX2 = 1
26872                ELSEIF (IST2.EQ.22) THEN
26873                   IDX2 = 2
26874                ELSEIF (IST2.EQ.31) THEN
26875                   IDX2 = 3
26876                ELSEIF (IST2.EQ.32) THEN
26877                   IDX2 = 4
26878                ELSEIF (IST2.EQ.41) THEN
26879                   IDX2 = 5
26880                ELSEIF (IST2.EQ.42) THEN
26881                   IDX2 = 6
26882                ELSEIF (IST2.EQ.51) THEN
26883                   IDX2 = 7
26884                ELSEIF (IST2.EQ.52) THEN
26885                   IDX2 = 8
26886                ELSEIF (IST2.EQ.61) THEN
26887                   IDX2 = 9
26888                ELSEIF (IST2.EQ.62) THEN
26889                   IDX2 = 10
26890                ELSE
26891 c                 WRITE(LOUT,*)
26892 c    &               ' CHASTA: unknown parton status flag (',
26893 c    &               IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
26894                   GOTO 21
26895                ENDIF
26896                ID = IDHKK(JMOHKK(2,IDX))
26897                IF (ABS(ID).LE.4) THEN
26898                   IF (ID.GT.0) THEN
26899                      ITYP2 = 1
26900                   ELSE
26901                      ITYP2 = 2
26902                   ENDIF
26903                ELSEIF (ABS(ID).GE.1000) THEN
26904                   IF (ID.GT.0) THEN
26905                      ITYP2 = 3
26906                   ELSE
26907                      ITYP2 = 4
26908                   ENDIF
26909                ELSEIF (ID.EQ.21) THEN
26910                   ITYP2 = 5
26911                ELSE
26912                   WRITE(LOUT,*)
26913      &               ' CHASTA: inconsistent parton identity (',
26914      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
26915                   GOTO 21
26916                ENDIF
26917 *
26918 *   fill counter
26919                ITYPE = ICHTYP(ITYP1,ITYP2)
26920                IF (ITYPE.NE.0) THEN
26921                   ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
26922                   NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
26923                   ICHCFG(IDX1,IDX2,ITYPE,2) =
26924      &               ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
26925
26926                   NCHAIN = NCHAIN+1
26927                   IF (NCHAIN.GT.MAXCHN) THEN
26928                      WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
26929      &                  NCHAIN,MAXCHN
26930                      STOP
26931                   ENDIF
26932                   IDXCHN(1,NCHAIN) = IDX
26933                   IDXCHN(2,NCHAIN) = ITYPE
26934                ELSE
26935                   WRITE(LOUT,*)
26936      &               ' CHASTA: inconsistent chain at entry ',IDX
26937                   GOTO 21
26938                ENDIF
26939             ENDIF
26940    21    CONTINUE
26941 *
26942 * write statistics to output unit
26943 *
26944       ELSEIF (MODE.EQ.1) THEN
26945 C *** Commented by Chiara
26946 C         WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
26947          DO 31 I=1,10
26948 C            WRITE(LOUT,'(/,2A)')
26949 C     &         ' -----------------------------------------',
26950 C     &         '------------------------------------'
26951 C            WRITE(LOUT,'(2A)')
26952 C     &         ' p\\t         21     22     31     32     41',
26953 C     &         '     42     51     52     61     62'
26954 C            WRITE(LOUT,'(2A)')
26955 C     &         ' -----------------------------------------',
26956 C     &         '------------------------------------'
26957             DO 32 J=1,10
26958                ITOT(J) = 0
26959                DO 33 K=1,9
26960                   ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
26961    33          CONTINUE
26962    32       CONTINUE
26963 C *** Commented by Chiara
26964 c            WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
26965             DO 34 K=1,9
26966                ISUM = 0
26967                DO 35 J=1,10
26968                   ISUM = ISUM+ICHCFG(I,J,K,1)
26969    35          CONTINUE
26970 C *** Commented by Chiara
26971 C               IF (ISUM.GT.0)
26972 C     &            WRITE(LOUT,'(1X,A5,2X,10I7)')
26973 C     &               CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
26974    34       CONTINUE
26975 C           WRITE(LOUT,'(2A)')
26976 C    &         ' -----------------------------------------',
26977 C    &         '-------------------------------'
26978    31    CONTINUE
26979 *
26980       ELSE
26981          WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
26982          STOP
26983       ENDIF
26984
26985       RETURN
26986       END
26987 *
26988 *===pohist=============================================================*
26989 *
26990
26991 CDECK  ID>, PHO_PHIST
26992       SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
26993
26994       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
26995       SAVE
26996
26997       PARAMETER ( LINP = 5 ,
26998      &            LOUT = 6 ,
26999      &            LDAT = 9 )
27000
27001       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27002
27003 * Glauber formalism: cross sections
27004       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
27005      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
27006      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
27007      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
27008      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
27009      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
27010      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
27011      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
27012      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
27013      &                BSLOPE,NEBINI,NQBINI
27014
27015       ILAB = 0
27016       IF (IMODE.EQ.10) THEN
27017          IMODE = 1
27018          ILAB  = 1
27019       ENDIF
27020       IF (ABS(IMODE).LT.1000) THEN
27021 * PHOJET-statistics
27022 C        CALL POHISX(IMODE,WEIGHT)
27023          IF (IMODE.EQ.-1) THEN
27024             MODE = 1
27025             XSTOT(1,1,1) = WEIGHT
27026          ENDIF
27027          IF (IMODE.EQ. 1) MODE = 2
27028          IF (IMODE.EQ.-2) MODE = 3
27029          IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
27030 C        IF (MODE.EQ.3) WRITE(LOUT,*)
27031 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
27032          CALL DT_HISTOG(MODE)
27033          CALL DT_USRHIS(MODE)
27034       ELSE
27035 * DTUNUC-statistics
27036          MODE = IMODE/1000
27037 C        IF (MODE.EQ.3) WRITE(LOUT,*)
27038 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
27039          CALL DT_HISTOG(MODE)
27040          CALL DT_USRHIS(MODE)
27041       ENDIF
27042
27043       RETURN
27044       END
27045 *
27046 *===swppho=============================================================*
27047 *
27048 CDECK  ID>, DT_SWPPHO
27049       SUBROUTINE DT_SWPPHO(ILAB)
27050
27051       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
27052       SAVE
27053
27054       PARAMETER ( LINP = 5 ,
27055      &            LOUT = 6 ,
27056      &            LDAT = 9 )
27057
27058       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
27059
27060       LOGICAL LSTART
27061
27062 * event history
27063
27064       PARAMETER (NMXHKK=200000)
27065
27066       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27067      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27068      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27069 * extended event history
27070       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27071      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27072      &                IHIST(2,NMXHKK)
27073 * flags for input different options
27074       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
27075       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
27076      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
27077 * properties of photon/lepton projectiles
27078       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
27079
27080 **PHOJET105a
27081 C     PARAMETER (NMXHEP=2000)
27082 C     COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27083 C    &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
27084 C     COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
27085 C     COMMON /PLASAV/ PLAB
27086 **PHOJET110
27087
27088 C  standard particle data interface
27089       INTEGER NMXHEP
27090
27091       PARAMETER (NMXHEP=4000)
27092
27093       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27094       DOUBLE PRECISION PHEP,VHEP
27095       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27096      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27097      &                VHEP(4,NMXHEP)
27098 C  extension to standard particle data interface (PHOJET specific)
27099       INTEGER IMPART,IPHIST,ICOLOR
27100       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27101
27102 C  global event kinematics and particle IDs
27103       INTEGER IFPAP,IFPAB
27104       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
27105       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
27106 **
27107       DATA ICOUNT/0/
27108
27109       DATA LSTART /.TRUE./
27110
27111 C     IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
27112       IF ((IFRAME.EQ.1).AND.LSTART) THEN
27113          UMO  = ECM
27114          ELA  = ZERO
27115          PLA  = ZERO
27116          IDP  = IDT_ICIHAD(IFPAP(1))
27117          IDT  = IDT_ICIHAD(IFPAP(2))
27118          VIRT = PVIRT(1)
27119          CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
27120          PLAB = PLA
27121          LSTART = .FALSE.
27122       ENDIF
27123
27124       NHKK   = 0
27125       ICOUNT = ICOUNT+1
27126 C     NEVHKK = NEVHEP
27127       NEVHKK = ICOUNT
27128       IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
27129       DO 1 I=3,NHEP
27130          IF (ISTHEP(I).EQ.1) THEN
27131             NHKK = NHKK+1
27132             ISTHKK(NHKK) = 1
27133             IDHKK(NHKK)  = IDHEP(I)
27134             JMOHKK(1,NHKK) = 0
27135             JMOHKK(2,NHKK) = 0
27136             JDAHKK(1,NHKK) = 0
27137             JDAHKK(2,NHKK) = 0
27138             DO 2 K=1,4
27139                PHKK(K,NHKK) = PHEP(K,I)
27140                VHKK(K,NHKK) = ZERO
27141                WHKK(K,NHKK) = ZERO
27142     2       CONTINUE
27143             IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
27144      &         CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
27145      &                    PHKK(3,NHKK),PHKK(4,NHKK),-3)
27146             PHKK(5,NHKK) = PHEP(5,I)
27147             IDRES(NHKK)  = 0
27148             IDXRES(NHKK) = 0
27149             NOBAM(NHKK)  = 0
27150             IDBAM(NHKK)  = IDT_ICIHAD(IDHEP(I))
27151             IDCH(NHKK)   = 0
27152          ENDIF
27153     1 CONTINUE
27154
27155       RETURN
27156       END
27157 *
27158 *===histog=============================================================*
27159 *
27160 CDECK  ID>, DT_HISTOG
27161       SUBROUTINE DT_HISTOG(MODE)
27162
27163 ************************************************************************
27164 * This version dated 25.03.96 is written by S. Roesler                 *
27165 ************************************************************************
27166
27167       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27168       SAVE
27169
27170       PARAMETER ( LINP = 5 ,
27171      &            LOUT = 6 ,
27172      &            LDAT = 9 )
27173
27174       LOGICAL LFSP,LRNL
27175
27176 * event history
27177
27178       PARAMETER (NMXHKK=200000)
27179
27180       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27181      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27182      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27183 * extended event history
27184       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27185      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27186      &                IHIST(2,NMXHKK)
27187 * event flag used for histograms
27188       COMMON /DTNORM/ ICEVT,IEVHKK
27189 * flags for activated histograms
27190       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
27191
27192       IEVHKK = NEVHKK
27193       GOTO (1,2,3) MODE
27194
27195 *------------------------------------------------------------------
27196 * initialization
27197     1 CONTINUE
27198       ICEVT = 0
27199       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
27200       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
27201
27202       RETURN
27203 *------------------------------------------------------------------
27204 * filling of histogram with event-record
27205     2 CONTINUE
27206       ICEVT = ICEVT+1
27207
27208       DO 20 I=1,NHKK
27209          CALL DT_SWPFSP(I,LFSP,LRNL)
27210          IF (LFSP) THEN
27211             IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
27212             IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
27213          ENDIF
27214          IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
27215    20 CONTINUE
27216       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
27217
27218       RETURN
27219 *------------------------------------------------------------------
27220 * output
27221     3 CONTINUE
27222       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
27223       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
27224
27225       RETURN
27226       END
27227 *
27228 *===swpfsp=============================================================*
27229 *
27230 CDECK  ID>, DT_SWPFSP
27231       SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
27232
27233       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27234       SAVE
27235       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
27236       PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
27237      &           PI   =TWOPI/TWO,
27238      &           BOG  =TWOPI/360.0D0)
27239
27240 * event history
27241
27242       PARAMETER (NMXHKK=200000)
27243
27244       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27245      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27246      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27247 * extended event history
27248       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27249      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27250      &                IHIST(2,NMXHKK)
27251 * particle properties (BAMJET index convention)
27252       CHARACTER*8  ANAME
27253       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27254      &                IICH(210),IIBAR(210),K1(210),K2(210)
27255 * Lorentz-parameters of the current interaction
27256       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
27257      &                UMO,PPCM,EPROJ,PPROJ
27258 * flags for input different options
27259       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
27260       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
27261      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
27262
27263       INCLUDE '(DIMPAR)'
27264       INCLUDE '(PAREVT)'
27265
27266 * temporary storage for one final state particle
27267       LOGICAL LFRAG,LGREY,LBLACK
27268       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
27269      &                SINTHE,COSTHE,THETA,THECMS,
27270      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
27271      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
27272      &                LFRAG,LGREY,LBLACK
27273
27274       LOGICAL LFSP,LRNL
27275
27276       LFSP = .FALSE.
27277       LRNL = .FALSE.
27278       ISTRNL = 1000
27279       MULDEF = 1
27280       IF (LEVPRT) ISTRNL = 1001
27281
27282       IF (ABS(ISTHKK(IDX)).EQ.1) THEN
27283          IST    = ISTHKK(IDX)
27284          IDPDG  = IDHKK(IDX)
27285          LFRAG  = .FALSE.
27286          IF (IDHKK(IDX).LT.80000) THEN
27287             IDBJT  = IDBAM(IDX)
27288             IBARY  = IIBAR(IDBJT)
27289             ICHAR  = IICH(IDBJT)
27290             AMASS  = AAM(IDBJT)
27291          ELSEIF (IDHKK(IDX).EQ.80000) THEN
27292             IDBJT  = 0
27293             IBARY  = IDRES(IDX)
27294             ICHAR  = IDXRES(IDX)
27295             AMASS  = PHKK(5,IDX)
27296             INUT   = IBARY-ICHAR
27297             IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
27298             IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
27299             IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
27300             IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
27301             IF (IDBJT.EQ.0) LFRAG = .TRUE.
27302          ELSE
27303             GOTO 9999
27304          ENDIF
27305          PE     = PHKK(4,IDX)
27306          PX     = PHKK(1,IDX)
27307          PY     = PHKK(2,IDX)
27308          PZ     = PHKK(3,IDX)
27309          PT2    = PX**2+PY**2
27310          PT     = SQRT(PT2)
27311          PTOT   = SQRT(PT2+PZ**2)
27312          SINTHE = PT/MAX(PTOT,TINY14)
27313          COSTHE = PZ/MAX(PTOT,TINY14)
27314          IF (COSTHE.GT.ONE) THEN
27315             THETA = ZERO
27316          ELSEIF (COSTHE.LT.-ONE) THEN
27317             THETA = TWOPI/2.0D0
27318          ELSE
27319             THETA = ACOS(COSTHE)
27320          ENDIF
27321          EKIN   = PE-AMASS
27322 **sr 15.4.96 new E_t-definition
27323          IF (IBARY.GT.0) THEN
27324             ET = EKIN*SINTHE
27325          ELSEIF (IBARY.LT.0) THEN
27326             ET = (EKIN+TWO*AMASS)*SINTHE
27327          ELSE
27328             ET = PE*SINTHE
27329          ENDIF
27330 **
27331          XLAB   = PZ/MAX(PPROJ,TINY14)
27332 C        XLAB   = PE/MAX(EPROJ,TINY14)
27333          BETA   = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
27334      &                     *(ONE+AMASS/MAX(PE,TINY14)) ))
27335          PPLUS  = PE+PZ
27336          PMINUS = PE-PZ
27337          IF (PMINUS.GT.TINY14) THEN
27338             YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
27339          ELSE
27340             YY = 100.0D0
27341          ENDIF
27342          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
27343             ETA = -LOG(TAN(THETA/TWO))
27344          ELSE
27345             ETA = 100.0D0
27346          ENDIF
27347          IF (IFRAME.EQ.1) THEN
27348             CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
27349             PPLUS  = EECMS+PZCMS
27350             PMINUS = EECMS-PZCMS
27351             IF ((PPLUS*PMINUS).GT.TINY14) THEN
27352                YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
27353             ELSE
27354                YYCMS = 100.0D0
27355             ENDIF
27356             PTOTCM = SQRT(PT2+PZCMS**2)
27357             COSTH = PZCMS/MAX(PTOTCM,TINY14)
27358             IF (COSTH.GT.ONE) THEN
27359                THECMS = ZERO
27360             ELSEIF (COSTH.LT.-ONE) THEN
27361                THECMS = TWOPI/2.0D0
27362             ELSE
27363                THECMS = ACOS(COSTH)
27364             ENDIF
27365             IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
27366                ETACMS = -LOG(TAN(THECMS/TWO))
27367             ELSE
27368                ETACMS = 100.0D0
27369             ENDIF
27370             XF = PZCMS/MAX(PPCM,TINY14)
27371             THECMS = THECMS/BOG
27372          ELSE
27373             PZCMS  = PZ
27374             EECMS  = PE
27375             YYCMS  = YY
27376             ETACMS = ETA
27377             XF     = XLAB
27378             THECMS = THETA/BOG
27379          ENDIF
27380          THETA  = THETA/BOG
27381
27382 * set flag for "grey/black"
27383          LGREY  = .FALSE.
27384          LBLACK = .FALSE.
27385          EK     = EKIN
27386          IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
27387          IF (MULDEF.EQ.1) THEN
27388 *  EMU01-Def.
27389             IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
27390      &                              (EK.LE.375.0D-3)      ).OR.
27391      &           ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
27392      &                              (EK.LE. 56.0D-3)      ).OR.
27393      &           ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
27394      &                              (EK.LE. 56.0D-3)      ).OR.
27395      &           ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
27396      &                              (EK.LE.198.0D-3)      ).OR.
27397      &           ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
27398      &                              (EK.LE.198.0D-3)      ).OR.
27399      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
27400      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
27401      &             (IDBJT.NE.16).AND.
27402      &             (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)    ) )
27403      &         LGREY = .TRUE.
27404             IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
27405      &           ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
27406      &           ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
27407      &           ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
27408      &           ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
27409      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
27410      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
27411      &             (IDBJT.NE.16).AND.(BETA.LE.0.23D0)  ) )
27412      &         LBLACK = .TRUE.
27413          ELSE
27414 *  common Def.
27415             IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
27416             IF (BETA.LE.0.23D0) LBLACK=.TRUE.
27417          ENDIF
27418          LFSP = .TRUE.
27419       ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
27420          IST    = ISTHKK(IDX)
27421          IDPDG  = IDHKK(IDX)
27422          LFRAG  = .TRUE.
27423          IDBJT  = 0
27424          IBARY  = IDRES(IDX)
27425          ICHAR  = IDXRES(IDX)
27426          AMASS  = PHKK(5,IDX)
27427          PE     = PHKK(4,IDX)
27428          PX     = PHKK(1,IDX)
27429          PY     = PHKK(2,IDX)
27430          PZ     = PHKK(3,IDX)
27431          PT2    = PX**2+PY**2
27432          PT     = SQRT(PT2)
27433          PTOT   = SQRT(PT2+PZ**2)
27434          SINTHE = PT/MAX(PTOT,TINY14)
27435          COSTHE = PZ/MAX(PTOT,TINY14)
27436          IF (COSTHE.GT.ONE) THEN
27437             THETA = ZERO
27438          ELSEIF (COSTHE.LT.-ONE) THEN
27439             THETA = TWOPI/2.0D0
27440          ELSE
27441             THETA  = ACOS(COSTHE)
27442          ENDIF
27443          EKIN   = PE-AMASS
27444 **sr 15.4.96 new E_t-definition
27445 C        ET     = PE*SINTHE
27446          ET     = EKIN*SINTHE
27447 **
27448          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
27449             ETA = -LOG(TAN(THETA/TWO))
27450          ELSE
27451             ETA = 100.0D0
27452          ENDIF
27453          THETA  = THETA/BOG
27454          LRNL   = .TRUE.
27455       ENDIF
27456
27457  9999 CONTINUE
27458       RETURN
27459       END
27460 *
27461 *===himult=============================================================*
27462 *
27463 CDECK  ID>, DT_HIMULT
27464       SUBROUTINE DT_HIMULT(MODE)
27465
27466 ************************************************************************
27467 * Tables of average energies/multiplicities.                           *
27468 * This version dated 30.08.2000 is written by S. Roesler               *
27469 ************************************************************************
27470
27471       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27472       SAVE
27473
27474       PARAMETER ( LINP = 5 ,
27475      &            LOUT = 6 ,
27476      &            LDAT = 9 )
27477
27478       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
27479
27480       PARAMETER (SWMEXP=1.7D0)
27481
27482       CHARACTER*8 ANAMEH(4)
27483
27484 * particle properties (BAMJET index convention)
27485       CHARACTER*8  ANAME
27486       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27487      &                IICH(210),IIBAR(210),K1(210),K2(210)
27488 * temporary storage for one final state particle
27489       LOGICAL LFRAG,LGREY,LBLACK
27490       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
27491      &                SINTHE,COSTHE,THETA,THECMS,
27492      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
27493      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
27494      &                LFRAG,LGREY,LBLACK
27495 * event flag used for histograms
27496       COMMON /DTNORM/ ICEVT,IEVHKK
27497 * Lorentz-parameters of the current interaction
27498       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
27499      &                UMO,PPCM,EPROJ,PPROJ
27500
27501       PARAMETER (NOPART=210)
27502       DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
27503      &          AVPT(4,NOPART),IAVPT(4,NOPART)
27504       DATA ANAMEH /'DEUTERON','3-H     ','3-HE    ','4-HE    '/
27505
27506       GOTO (1,2,3) MODE
27507
27508 *------------------------------------------------------------------
27509 * initialization
27510     1 CONTINUE
27511       DO 10 I=1,NOPART
27512          DO 11 J=1,4
27513             AVMULT(J,I) = ZERO
27514             AVE(J,I)    = ZERO
27515             AVSWM(J,I)  = ZERO
27516             AVPT(J,I)   = ZERO
27517             IAVPT(J,I)  = 0
27518    11    CONTINUE
27519    10 CONTINUE
27520
27521       RETURN
27522
27523 *------------------------------------------------------------------
27524 * filling of histogram with event-record
27525     2 CONTINUE
27526       IF (PE.LT.0.0D0) THEN
27527          WRITE(LOUT,*) ' HIMULT:  PE < 0 ! ',PE
27528          RETURN
27529       ENDIF
27530       IF (.NOT.LFRAG) THEN
27531          IVEL = 2
27532          IF (LGREY)  IVEL = 3
27533          IF (LBLACK) IVEL = 4
27534          AVE(1,IDBJT)       = AVE(1,IDBJT)   +PE
27535          AVE(IVEL,IDBJT)    = AVE(IVEL,IDBJT)+PE
27536          AVPT(1,IDBJT)     = AVPT(1,IDBJT)   +PT
27537          AVPT(IVEL,IDBJT)  = AVPT(IVEL,IDBJT)+PT
27538          IAVPT(1,IDBJT)    = IAVPT(1,IDBJT)   +1
27539          IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
27540          AVSWM(1,IDBJT)     = AVSWM(1,IDBJT)   +PE**SWMEXP
27541          AVSWM(IVEL,IDBJT)  = AVSWM(IVEL,IDBJT)+PE**SWMEXP
27542          AVMULT(1,IDBJT)    = AVMULT(1,IDBJT)   +ONE
27543          AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
27544          IF (IDBJT.LT.116) THEN
27545 *   total energy, multiplicity
27546             AVE(1,30)       = AVE(1,30)   +PE
27547             AVE(IVEL,30)    = AVE(IVEL,30)+PE
27548             AVPT(1,30)     = AVPT(1,30)   +PT
27549             AVPT(IVEL,30)  = AVPT(IVEL,30)+PT
27550             IAVPT(1,30)    = IAVPT(1,30)   +1
27551             IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
27552             AVSWM(1,30)     = AVSWM(1,30)+PE**SWMEXP
27553             AVSWM(IVEL,30)  = AVSWM(IVEL,30)+PE**SWMEXP
27554             AVMULT(1,30)    = AVMULT(1,30)   +ONE
27555             AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
27556 *   charged energy, multiplicity
27557             IF (ICHAR.LT.0) THEN
27558                AVE(1,26)       = AVE(1,26)   +PE
27559                AVE(IVEL,26)    = AVE(IVEL,26)+PE
27560                AVPT(1,26)     = AVPT(1,26)   +PT
27561                AVPT(IVEL,26)  = AVPT(IVEL,26)+PT
27562                IAVPT(1,26)    = IAVPT(1,26)   +1
27563                IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
27564                AVSWM(1,26)     = AVSWM(1,26)   +PE**SWMEXP
27565                AVSWM(IVEL,26)  = AVSWM(IVEL,26)+PE**SWMEXP
27566                AVMULT(1,26)    = AVMULT(1,26)   +ONE
27567                AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
27568             ENDIF
27569             IF (ICHAR.NE.0) THEN
27570                AVE(1,27)       = AVE(1,27)   +PE
27571                AVE(IVEL,27)    = AVE(IVEL,27)+PE
27572                AVPT(1,27)     = AVPT(1,27)   +PT
27573                AVPT(IVEL,27)  = AVPT(IVEL,27)+PT
27574                IAVPT(1,27)    = IAVPT(1,27)   +1
27575                IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
27576                AVSWM(1,27)     = AVSWM(1,27)   +PE**SWMEXP
27577                AVSWM(IVEL,27)  = AVSWM(IVEL,27)+PE**SWMEXP
27578                AVMULT(1,27)    = AVMULT(1,27)   +ONE
27579                AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
27580             ENDIF
27581          ENDIF
27582       ENDIF
27583
27584       RETURN
27585
27586 *------------------------------------------------------------------
27587 * output
27588     3 CONTINUE
27589       WRITE(LOUT,3000)
27590  3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
27591      &       29X,'---------------------',/)
27592       PRINT*,' MULDEF = ',MULDEF
27593       IF (MULDEF.EQ.1) THEN
27594          WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
27595       ELSE
27596          BETGRE = 0.7D0
27597          BETBLC = 0.23D0
27598          WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
27599  3002    FORMAT(1X,'fast:  beta > ',F4.2,'    grey:  ',F4.2,' > beta > '
27600      &          ,F4.2,'    black:  beta < ',F4.2,/)
27601       ENDIF
27602       WRITE(LOUT,3003) SWMEXP
27603  3003 FORMAT(1X,'particle    |',12X,'average multiplicity',/,
27604      &      13X,'|     total         fast',
27605 C    &      '       grey     black      K      f(',F3.1,')',/,1X,
27606      &      '       grey     black    <pt>     f(',F3.1,')',/,1X,
27607      &      '------------+--------------',
27608      &      '-------------------------------------------------')
27609       DO 30 I=1,NOPART
27610          DO 31 J=1,4
27611             AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
27612             AVE(J,I)    = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
27613             AVPT(J,I)   = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
27614             AVSWM(J,I)  = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
27615    31    CONTINUE
27616          IF (I.LE.115) THEN
27617             WRITE(LOUT,3004) ANAME(I),I,
27618      &                       AVMULT(1,I),AVMULT(2,I),
27619      &                       AVMULT(3,I),AVMULT(4,I),
27620 C    &                       AVE(1,I),AVSWM(1,I)
27621      &                       AVPT(1,I),AVSWM(1,I)
27622          ELSEIF (I.LE.119) THEN
27623             WRITE(LOUT,3004) ANAMEH(I-115),I,
27624      &                       AVMULT(1,I),AVMULT(2,I),
27625      &                       AVMULT(3,I),AVMULT(4,I),
27626 C    &                       AVE(1,I),AVSWM(1,I)
27627      &                       AVPT(1,I),AVSWM(1,I)
27628          ENDIF
27629  3004    FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
27630    30 CONTINUE
27631 **temporary
27632 C     WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
27633 C    &               AVMULT(3,27)+AVMULT(4,27)
27634 **
27635
27636       RETURN
27637       END
27638 *
27639 *===histat=============================================================*
27640 *
27641 CDECK  ID>, DT_HISTAT
27642       SUBROUTINE DT_HISTAT(IDX,MODE)
27643
27644 ************************************************************************
27645 * This version dated 26.02.96 is written by S. Roesler                 *
27646 ************************************************************************
27647
27648       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27649       SAVE
27650
27651       PARAMETER ( LINP = 5 ,
27652      &            LOUT = 6 ,
27653      &            LDAT = 9 )
27654
27655       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
27656       PARAMETER (NDIM=199)
27657
27658 * event history
27659
27660       PARAMETER (NMXHKK=200000)
27661
27662       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27663      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27664      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27665 * extended event history
27666       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27667      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27668      &                IHIST(2,NMXHKK)
27669 * particle properties (BAMJET index convention)
27670       CHARACTER*8  ANAME
27671       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27672      &                IICH(210),IIBAR(210),K1(210),K2(210)
27673
27674       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27675
27676 * Glauber formalism: cross sections
27677       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
27678      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
27679      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
27680      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
27681      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
27682      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
27683      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
27684      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
27685      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
27686      &                BSLOPE,NEBINI,NQBINI
27687 * emulsion treatment
27688       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27689      &                NCOMPO,IEMUL
27690 * properties of interacting particles
27691       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
27692 * rejection counter
27693       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27694      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27695      &                IREXCI(3),IRDIFF(2),IRINC
27696 * statistics: residual nuclei
27697       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
27698      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
27699      &                NINCST(2,4),NINCEV(2),
27700      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
27701      &                NRESPB(2),NRESCH(2),NRESEV(4),
27702      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
27703      &                NEVAFI(2,2)
27704 * parameter for intranuclear cascade
27705       LOGICAL LPAULI
27706       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
27707
27708       INCLUDE '(DIMPAR)'
27709       INCLUDE '(PAREVT)'
27710       INCLUDE '(FRBKCM)'
27711       INCLUDE '(EVAPAR)'
27712
27713 * temporary storage for one final state particle
27714       LOGICAL LFRAG,LGREY,LBLACK
27715       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
27716      &                SINTHE,COSTHE,THETA,THECMS,
27717      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
27718      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
27719      &                LFRAG,LGREY,LBLACK
27720 * event flag used for histograms
27721       COMMON /DTNORM/ ICEVT,IEVHKK
27722 * statistics: double-Pomeron exchange
27723       COMMON /DTFLG2/ INTFLG,IPOPO
27724
27725       DIMENSION EMUSAM(NCOMPX)
27726
27727       CHARACTER*13 CMSG(3)
27728       DATA CMSG /'not requested','not requested','not requested'/
27729
27730       GOTO (1,2,3,4,5) MODE
27731
27732 *------------------------------------------------------------------
27733 * initialization
27734     1 CONTINUE
27735 *  emulsion treatment
27736       IF (NCOMPO.GT.0) THEN
27737          DO 10 I=1,NCOMPX
27738             EMUSAM(I) = ZERO
27739    10    CONTINUE
27740       ENDIF
27741 * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
27742       NINCGE = 0
27743       DO 11 I=1,2
27744          EXCDPM(I)   = ZERO
27745          EXCDPM(I+2) = ZERO
27746          EXCEVA(I)   = ZERO
27747          NINCWO(I)   = 0
27748          NINCEV(I)   = 0
27749          NRESTO(I)   = 0
27750          NRESPR(I)   = 0
27751          NRESNU(I)   = 0
27752          NRESBA(I)   = 0
27753          NRESPB(I)   = 0
27754          NRESCH(I)   = 0
27755          NRESEV(I)   = 0
27756          NRESEV(I+2) = 0
27757          NEVAGA(I)   = 0
27758          NEVAHT(I)   = 0
27759          NEVAFI(1,I) = 0
27760          NEVAFI(2,I) = 0
27761          DO 12 J=1,6
27762             IF (J.LE.2) NINCHR(I,J) = 0
27763             IF (J.LE.3) NINCCO(I,J) = 0
27764             IF (J.LE.4) NINCST(I,J) = 0
27765             NEVA(I,J) = 0
27766    12    CONTINUE
27767          DO 13 J=1,210
27768             NEVAHY(1,I,J) = 0
27769             NEVAHY(2,I,J) = 0
27770    13    CONTINUE
27771    11 CONTINUE
27772       MAXGEN = 0
27773 **dble Po statistics.
27774       KPOPO = 0
27775
27776       RETURN
27777 *------------------------------------------------------------------
27778 * filling of histogram with event-record
27779     2 CONTINUE
27780       IF (IST.EQ.-1) THEN
27781          IF (.NOT.LFRAG) THEN
27782             IF (IDPDG.EQ.2212) THEN
27783                NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
27784             ELSEIF (IDPDG.EQ.2112) THEN
27785                NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
27786             ELSEIF (IDPDG.EQ.22) THEN
27787                NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
27788             ELSEIF (IDPDG.EQ.80000) THEN
27789                IF (IDBJT.EQ.116) THEN
27790                   NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
27791                ELSEIF (IDBJT.EQ.117) THEN
27792                   NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
27793                ELSEIF (IDBJT.EQ.118) THEN
27794                   NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
27795                ELSEIF (IDBJT.EQ.119) THEN
27796                   NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
27797                ENDIF
27798             ENDIF
27799          ELSE
27800 *   heavy fragments (here: fission products only)
27801             NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
27802             NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
27803             NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
27804          ENDIF
27805       ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
27806          IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
27807       ENDIF
27808
27809       RETURN
27810 *------------------------------------------------------------------
27811 * output
27812     3 CONTINUE
27813
27814 **dble Po statistics.
27815 C     WRITE(LOUT,'(1X,A,2I7,2E12.4)')
27816 C    &   '# evts. / # dble-Po. evts / s_in / s_popo :',
27817 C    & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
27818
27819 *  emulsion treatment
27820       IF (NCOMPO.GT.0) THEN
27821          WRITE(LOUT,3000)
27822  3000    FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
27823      &          22X,'----------------------------',/,/,19X,
27824      &          'mass    charge          fraction',/,39X,
27825      &          'input     treated',/)
27826          DO 30 I=1,NCOMPO
27827             WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
27828      &                       EMUSAM(I)/DBLE(ICEVT)
27829  3013       FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
27830    30    CONTINUE
27831       ENDIF
27832
27833 *  i.n.c. statistics: output
27834       WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
27835  3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
27836      &       22X,'---------------------------------',/,/,1X,
27837      &       'no. of events for normalization: (accepted final events,',
27838      &       ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
27839      &       /,1X,'no. of rejected events due to intranuclear',
27840      &       ' cascade',15X,I6,/)
27841       ICEV  = MAX(ICEVT,1)
27842       ICEV1 = ICEV
27843       IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
27844       WRITE(LOUT,3002)
27845      &     (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
27846      &     ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
27847      &     KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
27848      &    (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
27849      &     (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
27850      &     (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
27851      &     (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
27852  3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
27853      &       5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
27854      &       ' proj./ target (mean per evt)',/,8X,'baryons:  pos. ',
27855      &       F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,/,8X,
27856      &       'mesons:   pos. ',F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,
27857      &       /,1X,'maximum no. of generations treated (maximum allowed:'
27858      &       ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
27859      &       ' interactions in proj./ target (mean per evt1)',
27860      &       F7.3,' /',F7.3,/,8X,'out of which by inelastic',
27861      &       ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
27862      &       'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
27863      &       '(ap, K-, pi- only)     ',F7.3,' /',F7.3,/)
27864       WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
27865      &                 IREXCI(1)+IREXCI(2)+IREXCI(3)
27866  3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
27867      &       'evaporation',/,22X,'-----------------------------',
27868      &       '------------',/,/,1X,'no. of events for normal.: ',
27869      &       '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
27870      &       ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
27871      &       ' rejected events     (',I4,',',I4,',',I4,')',22X,I6,/)
27872
27873       WRITE(LOUT,3004)
27874  3004 FORMAT(/,22X,'1) before evaporation-step:',/)
27875       ICEV  = MAX(NRESEV(2),1)
27876       WRITE(LOUT,3005)
27877      &     (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
27878      &     (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
27879      &     (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
27880      &     (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
27881      &     (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
27882      &     (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
27883      &     (EXCDPM(I)/DBLE(ICEV),I=1,2),
27884      &     (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
27885  3005    FORMAT(1X,'residual nuclei:  (mean values per evt)',12X,
27886      &       'proj. / target',/,/,8X,'total number of particles',15X,
27887      &       2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
27888      &       'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
27889      &       'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
27890      &       /,8X,'excitation energy (bef. evap.-step)   ',2E11.3,/,
27891      &       8X,'excitation energy per nucleon         ',2E11.3,/,/)
27892
27893 * evaporation / fission / fragmentation statistics: output
27894       ICEV  = MAX(NRESEV(2),1)
27895       ICEV1 = MAX(NRESEV(4),1)
27896       NTEVA1 =
27897      &   NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
27898       NTEVA2 =
27899      &   NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
27900       IF (LEVPRT) THEN
27901          IF (IFISS.EQ.1) CMSG(1) = 'requested    '
27902          IF (LFRMBK)     CMSG(2) = 'requested    '
27903          IF (LDEEXG)     CMSG(3) = 'requested    '
27904          WRITE(LOUT,3006)
27905      &        CMSG,
27906      &        DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
27907      &        (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
27908      &        (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
27909      &        (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
27910      &        (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
27911      &        (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
27912      &        (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
27913      &        (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
27914      &        (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
27915  3006    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,'Fission:',
27916      &       13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
27917      &       'deexcitation:',2X,A13,/,/,
27918      &       1X,'evaporation/deexcitation:  (mean values per evt1)  ',
27919      &       'proj. / target',/,/,8X,'total number of evap. particles',
27920      &       9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
27921      &       'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
27922      &       '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
27923      &       2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
27924      &       'heavy fragments',25X,2F9.3,/)
27925          IF (IFISS.EQ.1) THEN
27926             WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
27927      &                       NEVAFI(2,1),NEVAFI(2,2),
27928      &             DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
27929      &             DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
27930  3007       FORMAT(1X,'Fission:   total number of events',14X,2I9,/
27931      &             12X,'out of which fission occured',8X,2I9,/,
27932      &             50X,'(',F5.2,'%) (',F5.2,'%)',/)
27933          ENDIF
27934 C        IF ((LFRMBK).OR.(IFISS.EQ.1)) THEN
27935 C           WRITE(LOUT,3008)
27936 C3008       FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
27937 C    &             '       proj.   / target',/)
27938 C           DO 31 I=1,210
27939 C              IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
27940 C                 WRITE(LOUT,3009) I,
27941 C    &            (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
27942 C3009             FORMAT(38X,I3,3X,2E12.3)
27943 C              ENDIF
27944 C  31       CONTINUE
27945 C           WRITE(LOUT,3010)
27946 C3010       FORMAT(1X,'heavy fragments - statistics:',7X,'mass  ',
27947 C    &             '       proj.   / target',/)
27948 C           DO 32 I=1,210
27949 C              IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
27950 C                 WRITE(LOUT,3011) I,
27951 C    &            (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
27952 C3011             FORMAT(38X,I3,3X,2E12.3)
27953 C              ENDIF
27954 C  32       CONTINUE
27955 C           WRITE(LOUT,*)
27956 C        ENDIF
27957       ELSE
27958          WRITE(LOUT,3012)
27959  3012    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,
27960      &       'Evaporation:         not requested',/)
27961       ENDIF
27962
27963       RETURN
27964 *------------------------------------------------------------------
27965 * filling of histogram with event-record
27966     4 CONTINUE
27967 *  emulsion treatment
27968       IF (NCOMPO.GT.0) THEN
27969          DO 40 I=1,NCOMPO
27970             IF (IT.EQ.IEMUMA(I)) THEN
27971                EMUSAM(I) = EMUSAM(I)+ONE
27972             ENDIF
27973    40    CONTINUE
27974       ENDIF
27975       NINCGE = NINCGE+MAXGEN
27976       MAXGEN = 0
27977 **dble Po statistics.
27978       IF (IPOPO.EQ.1) KPOPO = KPOPO+1
27979
27980       RETURN
27981 *------------------------------------------------------------------
27982 * filling of histogram with event-record
27983     5 CONTINUE
27984       IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
27985          IB = IIBAR(IDBAM(IDX))
27986          IC = IICH(IDBAM(IDX))
27987          J  = ISTHKK(IDX)-14
27988          IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
27989             NINCST(J,1) = NINCST(J,1)+1
27990          ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
27991             NINCST(J,2) = NINCST(J,2)+1
27992          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
27993             NINCST(J,3) = NINCST(J,3)+1
27994          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
27995             NINCST(J,4) = NINCST(J,4)+1
27996          ENDIF
27997       ELSEIF (ISTHKK(IDX).EQ.17) THEN
27998          NINCWO(1) = NINCWO(1)+1
27999       ELSEIF (ISTHKK(IDX).EQ.18) THEN
28000          NINCWO(2) = NINCWO(2)+1
28001       ELSEIF (ISTHKK(IDX).EQ.1001) THEN
28002          IB = IDRES(IDX)
28003          IC = IDXRES(IDX)
28004          IF (IC.GT.0) THEN
28005             NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
28006             NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
28007          ENDIF
28008          NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
28009       ENDIF
28010
28011       RETURN
28012       END
28013 *
28014 *===newhgr=============================================================*
28015 *
28016 CDECK  ID>, DT_NEWHGR
28017       SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
28018
28019 ************************************************************************
28020 *                                                                      *
28021 *     Histogram initialization.                                        *
28022 *                                                                      *
28023 *     input:  XLIM1/XLIM2  lower/upper edge of histogram-window        *
28024 *             XLIM3        bin size                                    *
28025 *             IBIN    > 0  number of bins in equidistant lin. binning  *
28026 *                     = -1 reset histograms                            *
28027 *                     < -1 |IBIN| number of bins in equidistant log.   *
28028 *                          binning or log. binning in user def. struc. *
28029 *             XLIMB(*)     user defined bin structure                  *
28030 *                                                                      *
28031 *     The bin structure is sensitive to                                *
28032 *             XLIM1, XLIM3, IBIN     if     XLIM3 > 0   (lin.)         *
28033 *             XLIM1, XLIM2, IBIN     if     XLIM3 = 0   (lin. & log.)  *
28034 *             XLIMB, IBIN            if     XLIM3 < 0                  *
28035 *                                                                      *
28036 *                                                                      *
28037 *     output: IREFN        histogram index                             *
28038 *                          (= -1 for inconsistent histogr. request)    *
28039 *                                                                      *
28040 * This subroutine is based on a original version by R. Engel.          *
28041 * This version dated 22.4.95 is written  by S. Roesler.                *
28042 ************************************************************************
28043
28044       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28045       SAVE
28046
28047       PARAMETER ( LINP = 5 ,
28048      &            LOUT = 6 ,
28049      &            LDAT = 9 )
28050
28051       LOGICAL LSTART
28052
28053       PARAMETER (ZERO   =  0.0D0,
28054      &           TINY   =  1.0D-10)
28055
28056       DIMENSION XLIMB(*)
28057
28058 * histograms
28059
28060       PARAMETER (NHIS=150, NDIM=250)
28061
28062       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28063      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28064 * auxiliary common for histograms
28065       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
28066
28067       DATA LSTART /.TRUE./
28068
28069 * reset histogram counter
28070       IF (LSTART.OR.(IBIN.EQ.-1)) THEN
28071          IHISL  = 0
28072          IF (IBIN.EQ.-1) RETURN
28073          LSTART = .FALSE.
28074       ENDIF
28075
28076       IHIS  = IHISL+1
28077 * check for maximum number of allowed histograms
28078       IF (IHIS.GT.NHIS) THEN
28079          WRITE(LOUT,1003) IHIS,NHIS,IHIS
28080  1003    FORMAT(1X,'NEWHGR:   warning!  number of histograms (',
28081      &          I4,') exceeds array size (',I4,')',/,21X,
28082      &          'histogram',I3,' skipped!')
28083          GOTO 9999
28084       ENDIF
28085
28086       IREFN = IHIS
28087       IBINS(IHIS) = ABS(IBIN)
28088 * check requested number of bins
28089       IF (IBINS(IHIS).GE.NDIM) THEN
28090          WRITE(LOUT,1000) IBIN,NDIM,NDIM
28091  1000    FORMAT(1X,'NEWHGR:   warning!  number of bins (',
28092      &          I3,') exceeds array size (',I3,')',/,21X,
28093      &          'and will be reset to ',I3)
28094          IBINS(IHIS) = NDIM
28095       ENDIF
28096       IF (IBINS(IHIS).EQ.0) THEN
28097          WRITE(LOUT,1001) IBIN,IHIS
28098  1001    FORMAT(1X,'NEWHGR:   warning!  inconsistent number of',
28099      &          ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
28100          GOTO 9999
28101       ENDIF
28102
28103 * initialize arrays
28104       DO 1 I=1,NDIM
28105          DO 2 K=1,3
28106             HIST(K,IHIS,I)   = ZERO
28107             HIST(K+3,IHIS,I) = ZERO
28108             TMPHIS(K,IHIS,I) = ZERO
28109     2    CONTINUE
28110          HIST(7,IHIS,I)   = ZERO
28111     1 CONTINUE
28112       DENTRY(1,IHIS)= ZERO
28113       DENTRY(2,IHIS)= ZERO
28114       OVERF(IHIS)   = ZERO
28115       UNDERF(IHIS)  = ZERO
28116       TMPUFL(IHIS)  = ZERO
28117       TMPOFL(IHIS)  = ZERO
28118
28119 * bin str. sensitive to lower edge, bin size, and numb. of bins
28120       IF (XLIM3.GT.ZERO) THEN
28121          DO 3 K=1,IBINS(IHIS)+1
28122             HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
28123     3    CONTINUE
28124          ISWI(IHIS) = 1
28125 * bin str. sensitive to lower/upper edge and numb. of bins
28126       ELSEIF (XLIM3.EQ.ZERO) THEN
28127 *   linear binning
28128          IF (IBIN.GT.0) THEN
28129             XLOW = XLIM1
28130             XHI  = XLIM2
28131             IF (XLIM2.LE.XLIM1) THEN
28132                WRITE(LOUT,1002) XLIM1,XLIM2
28133  1002          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
28134      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
28135                GOTO 9999
28136             ENDIF
28137             ISWI(IHIS) = 1
28138          ELSEIF (IBIN.LT.-1) THEN
28139 *   logarithmic binning
28140             IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
28141                WRITE(LOUT,1004) XLIM1,XLIM2
28142  1004          FORMAT(1X,'NEWHGR:   warning!  inconsistent log. ',
28143      &                'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
28144                GOTO 9999
28145             ENDIF
28146             IF (XLIM2.LE.XLIM1) THEN
28147                WRITE(LOUT,1005) XLIM1,XLIM2
28148  1005          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
28149      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
28150                GOTO 9999
28151             ENDIF
28152             XLOW = LOG10(XLIM1)
28153             XHI  = LOG10(XLIM2)
28154             ISWI(IHIS) = 3
28155          ENDIF
28156          DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
28157          DO 4 K=1,IBINS(IHIS)+1
28158             HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
28159     4    CONTINUE
28160       ELSE
28161 * user defined bin structure
28162          DO 5 K=1,IBINS(IHIS)+1
28163             IF (IBIN.GT.0) THEN
28164                HIST(1,IHIS,K) = XLIMB(K)
28165                ISWI(IHIS) = 2
28166             ELSEIF (IBIN.LT.-1) THEN
28167                HIST(1,IHIS,K) = LOG10(XLIMB(K))
28168                ISWI(IHIS) = 4
28169             ENDIF
28170     5    CONTINUE
28171       ENDIF
28172
28173 * histogram accepted
28174       IHISL = IHIS
28175
28176       RETURN
28177
28178  9999 CONTINUE
28179       IREFN = -1
28180       RETURN
28181       END
28182 *
28183 *===filhgr=============================================================*
28184 *
28185 CDECK  ID>, DT_FILHGR
28186       SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
28187
28188 ************************************************************************
28189 *                                                                      *
28190 *     Scoring for histogram IHIS.                                      *
28191 *                                                                      *
28192 * This subroutine is based on a original version by R. Engel.          *
28193 * This version dated 23.4.95 is written  by S. Roesler.                *
28194 ************************************************************************
28195
28196       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28197       SAVE
28198
28199       PARAMETER ( LINP = 5 ,
28200      &            LOUT = 6 ,
28201      &            LDAT = 9 )
28202
28203       PARAMETER (ZERO = 0.0D0,
28204      &           ONE  = 1.0D0,
28205      &           TINY = 1.0D-10)
28206
28207 * histograms
28208
28209       PARAMETER (NHIS=150, NDIM=250)
28210
28211       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28212      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28213 * auxiliary common for histograms
28214       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
28215
28216       DATA NCEVT /1/
28217
28218       X = XI
28219       Y = YI
28220
28221 * dump content of temorary arrays into histograms
28222       IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
28223          CALL DT_EVTHIS(IDUM)
28224          NCEVT = NEVT
28225       ENDIF
28226
28227 * check histogram index
28228       IF (IHIS.EQ.-1) RETURN
28229       IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
28230 C        WRITE(LOUT,1000) IHIS,IHISL
28231  1000    FORMAT(1X,'FILHGR:   warning!  histogram index',I4,
28232      &          ' out of range (1..',I3,')')
28233          RETURN
28234       ENDIF
28235
28236       IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
28237 * bin structure not explicitly given
28238          IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
28239          DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
28240          IF (X.LT.HIST(1,IHIS,1)) THEN
28241             I1 = 0
28242          ELSE
28243             I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
28244          ENDIF
28245
28246       ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
28247 * user defined bin structure
28248          IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
28249          IF (X.LT.HIST(1,IHIS,1)) THEN
28250             I1 = 0
28251          ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
28252             I1 = IBINS(IHIS)+1
28253          ELSE
28254 *   binary sort algorithm
28255             KMIN = 0
28256             KMAX = IBINS(IHIS)+1
28257     1       CONTINUE
28258             IF ((KMAX-KMIN).EQ.1) GOTO 2
28259             KK = (KMAX+KMIN)/2
28260             IF (X.LE.HIST(1,IHIS,KK)) THEN
28261                KMAX=KK
28262             ELSE
28263                KMIN=KK
28264             ENDIF
28265             GOTO 1
28266     2       CONTINUE
28267             I1 = KMIN
28268          ENDIF
28269
28270       ELSE
28271          WRITE(LOUT,1001)
28272  1001    FORMAT(1X,'FILHGR:   warning!  histogram not initialized')
28273          RETURN
28274       ENDIF
28275
28276 * scoring
28277       IF (I1.LE.0) THEN
28278          TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
28279       ELSEIF (I1.LE.IBINS(IHIS)) THEN
28280          TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
28281          IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
28282             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
28283          ELSE
28284             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
28285          ENDIF
28286          TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
28287       ELSE
28288          TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
28289       ENDIF
28290
28291       RETURN
28292       END
28293 *
28294 *===evthis=============================================================*
28295 *
28296 CDECK  ID>, DT_EVTHIS
28297       SUBROUTINE DT_EVTHIS(NEVT)
28298
28299 ************************************************************************
28300 * Dump content of temorary histograms into /DTHIS1/. This subroutine   *
28301 * is called after each event and for the last event before any call    *
28302 * to OUTHGR.                                                           *
28303 *         NEVT   number of events dumped, this is only needed to       *
28304 *                get the normalization after the last event            *
28305 * This version dated 23.4.95 is written  by S. Roesler.                *
28306 ************************************************************************
28307
28308       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28309       SAVE
28310
28311       PARAMETER ( LINP = 5 ,
28312      &            LOUT = 6 ,
28313      &            LDAT = 9 )
28314
28315       LOGICAL LNOETY
28316
28317       PARAMETER (ZERO = 0.0D0,
28318      &           ONE  = 1.0D0,
28319      &           TINY = 1.0D-10)
28320
28321 * histograms
28322
28323       PARAMETER (NHIS=150, NDIM=250)
28324
28325       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28326      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28327 * auxiliary common for histograms
28328       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
28329
28330       DATA NCEVT /0/
28331
28332       NCEVT = NCEVT+1
28333       NEVT  = NCEVT
28334
28335       DO 1 I=1,IHISL
28336          LNOETY = .TRUE.
28337          DO 2 J=1,IBINS(I)
28338             IF (TMPHIS(1,I,J).GT.ZERO) THEN
28339                LNOETY = .FALSE.
28340                HIST(2,I,J)   = HIST(2,I,J)+ONE
28341                HIST(7,I,J)   = HIST(7,I,J)+TMPHIS(1,I,J)
28342                DENTRY(2,I)   = DENTRY(2,I)+TMPHIS(1,I,J)
28343                AVX           = TMPHIS(2,I,J)/TMPHIS(1,I,J)
28344                HIST(3,I,J)   = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
28345                HIST(4,I,J)   = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
28346                HIST(5,I,J)   = HIST(5,I,J)+TMPHIS(3,I,J)
28347                HIST(6,I,J)   = HIST(6,I,J)+TMPHIS(3,I,J)**2
28348                TMPHIS(1,I,J) = ZERO
28349                TMPHIS(2,I,J) = ZERO
28350                TMPHIS(3,I,J) = ZERO
28351             ENDIF
28352     2    CONTINUE
28353          IF (LNOETY) THEN
28354             IF (TMPUFL(I).GT.ZERO) THEN
28355                UNDERF(I) = UNDERF(I)+ONE
28356                TMPUFL(I) = ZERO
28357             ELSEIF (TMPOFL(I).GT.ZERO) THEN
28358                OVERF(I)  = OVERF(I)+ONE
28359                TMPOFL(I) = ZERO
28360             ENDIF
28361          ELSE
28362             DENTRY(1,I) = DENTRY(1,I)+ONE
28363          ENDIF
28364     1 CONTINUE
28365
28366       RETURN
28367       END
28368 *
28369 *===outhgr=============================================================*
28370 *
28371 CDECK  ID>, DT_OUTHGR
28372       SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
28373      &                  ILOGY,INORM,NMODE)
28374
28375 ************************************************************************
28376 *                                                                      *
28377 *     Plot histogram(s) to standard output unit                        *
28378 *                                                                      *
28379 *         I1..6         indices of histograms to be plotted            *
28380 *         CHEAD,IHEAD   header string,integer                          *
28381 *         NEVTS         number of events                               *
28382 *         FAC           scaling factor                                 *
28383 *         ILOGY   = 1   logarithmic y-axis                             *
28384 *         INORM         normalization                                  *
28385 *                 = 0   no further normalization (FAC is obsolete)     *
28386 *                 = 1   per event and bin width                        *
28387 *                 = 2   per entry and bin width                        *
28388 *                 = 3   per bin entry                                  *
28389 *                 = 4   per event and "bin width" x1^2...x2^2          *
28390 *                 = 5   per event and "log. bin width" ln x1..ln x2    *
28391 *                 = 6   per event                                      *
28392 *         MODE    = 0   no output but normalization applied            *
28393 *                 = 1   all valid histograms separately (small frame)  *
28394 *                       all valid histograms separately (small frame)  *
28395 *                 = -1  and tables as histograms                       *
28396 *                 = 2   all valid histograms (one plot, wide frame)    *
28397 *                       all valid histograms (one plot, wide frame)    *
28398 *                 = -2  and tables as histograms                       *
28399 *                                                                      *
28400 *                                                                      *
28401 *     Note: All histograms to be plotted with one call to this         *
28402 *           subroutine and |MODE|=2 must have the same bin structure!  *
28403 *           There is no test included ensuring this fact.              *
28404 *                                                                      *
28405 * This version dated 23.4.95 is written  by S. Roesler.                *
28406 ************************************************************************
28407
28408       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28409       SAVE
28410
28411       PARAMETER ( LINP = 5 ,
28412      &            LOUT = 6 ,
28413      &            LDAT = 9 )
28414
28415       CHARACTER*72 CHEAD
28416
28417       PARAMETER (ZERO   =  0.0D0,
28418      &           IZERO  =  0,
28419      &           ONE    =  1.0D0,
28420      &           TWO    =  2.0D0,
28421      &           OHALF  =  0.5D0,
28422      &           EPS    =  1.0D-5,
28423      &           TINY   =  1.0D-8,
28424      &           SMALL  =  -1.0D8,
28425      &           RLARGE =  1.0D8 )
28426
28427 * histograms
28428
28429       PARAMETER (NHIS=150, NDIM=250)
28430
28431       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28432      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28433
28434       PARAMETER (NDIM2 = 2*NDIM)
28435       DIMENSION XX(NDIM2),YY(NDIM2)
28436
28437       PARAMETER (NHISTO = 6)
28438       DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
28439      &          IDX(NHISTO)
28440
28441       CHARACTER*43 CNORM(0:8)
28442       DATA CNORM /'no further normalization                   ',
28443      &            'per event and bin width                    ',
28444      &            'per entry1 and bin width                   ',
28445      &            'per bin entry                              ',
28446      &            'per event and "bin width" x1^2...x2^2      ',
28447      &            'per event and "log. bin width" ln x1..ln x2',
28448      &            'per event                                  ',
28449      &            'per bin entry1                             ',
28450      &            'per entry2 and bin width                   '/
28451
28452       IDX1(1) = I1
28453       IDX1(2) = I2
28454       IDX1(3) = I3
28455       IDX1(4) = I4
28456       IDX1(5) = I5
28457       IDX1(6) = I6
28458
28459       MODE = NMODE
28460
28461 * initialization if "wide frame" is requested
28462       IF (ABS(MODE).EQ.2) THEN
28463          DO 1 I=1,NHISTO
28464             DO 2 J=1,NDIM
28465                XX1(J,I) = ZERO
28466                YY1(J,I) = ZERO
28467     2       CONTINUE
28468     1    CONTINUE
28469       ENDIF
28470
28471 * plot header
28472       WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
28473
28474 * check histogram indices
28475       NHI = 0
28476       DO 3 I=1,NHISTO
28477          IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
28478             IF (ISWI(IDX1(I)).NE.0) THEN
28479                IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
28480                   WRITE(LOUT,1000)
28481      &                 IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
28482  1000             FORMAT(/,1X,'OUTHGR:   warning!  no entries in',
28483      &                   ' histogram ',I3,/,21X,'underflows:',F10.0,
28484      &                   '   overflows:  ',F10.0)
28485                ELSE
28486                   NHI = NHI+1
28487                   IDX(NHI) = IDX1(I)
28488                ENDIF
28489             ENDIF
28490          ENDIF
28491     3 CONTINUE
28492       IF (NHI.EQ.0) THEN
28493          WRITE(LOUT,1001)
28494  1001    FORMAT(/,1X,'OUTHGR:   warning!  histogram indices not valid')
28495          RETURN
28496       ENDIF
28497
28498 * check normalization request
28499       IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
28500      &     ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
28501      &                        (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
28502      &     (INORM.LT.0).OR.(INORM.GT.8) ) THEN
28503          WRITE(LOUT,1002) NEVTS,INORM,FAC
28504  1002    FORMAT(/,1X,'OUTHGR:   warning!  normalization request not ',
28505      &          'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
28506      &          'FAC = ',E11.4)
28507          RETURN
28508       ENDIF
28509
28510       WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
28511
28512 * apply normalization
28513       DO 4 N=1,NHI
28514
28515          I = IDX(N)
28516
28517          IF (ISWI(I).EQ.1) THEN
28518             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
28519  1003       FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
28520      &             ' to',2X,E10.4,',',2X,I3,' bins')
28521          ELSEIF (ISWI(I).EQ.2) THEN
28522             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
28523             WRITE(LOUT,1007)
28524  1007       FORMAT(1X,'user defined bin structure')
28525          ELSEIF (ISWI(I).EQ.3) THEN
28526             WRITE(LOUT,1004)
28527      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
28528  1004       FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
28529      &             ' to',2X,E10.4,',',2X,I3,' bins')
28530          ELSEIF (ISWI(I).EQ.4) THEN
28531             WRITE(LOUT,1004)
28532      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
28533             WRITE(LOUT,1007)
28534          ELSE
28535             WRITE(LOUT,1008) ISWI(I)
28536  1008       FORMAT(/,1X,'warning!  inconsistent bin structure flag ',I4)
28537          ENDIF
28538          WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
28539  1005    FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
28540      &          ' overfl.:',F8.0)
28541          WRITE(LOUT,1009) CNORM(INORM)
28542  1009    FORMAT(1X,'normalization: ',A,/)
28543
28544          DO 5 K=1,IBINS(I)
28545             CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
28546             YMEAN = FAC*YMEAN
28547             YERR  = FAC*YERR
28548             WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
28549             WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
28550  1006       FORMAT(1X,5E11.3)
28551 *    small frame
28552             II = 2*K
28553             XX(II-1) = HIST(1,I,K)
28554             XX(II)   = HIST(1,I,K+1)
28555             YY(II-1) = YMEAN
28556             YY(II)   = YMEAN
28557 *    wide frame
28558             XX1(K,N) = XMEAN
28559             IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
28560      &         XX1(K,N) = LOG10(XMEAN)
28561             YY1(K,N) = YMEAN
28562     5    CONTINUE
28563
28564 * plot small frame
28565          IF (ABS(MODE).EQ.1) THEN
28566             IBIN2 = 2*IBINS(I)
28567             WRITE(LOUT,'(/,1X,A)') 'Preview:'
28568             IF(ILOGY.EQ.1) THEN
28569               CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
28570             ELSE
28571               CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
28572             ENDIF
28573          ENDIF
28574
28575     4 CONTINUE
28576
28577 * plot wide frame
28578       IF (ABS(MODE).EQ.2) THEN
28579          WRITE(LOUT,'(/,1X,A)') 'Preview:'
28580          NSIZE = NDIM*NHISTO
28581          DXLOW = HIST(1,IDX(1),1)
28582          DDX   = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
28583          YLOW  = RLARGE
28584          YHI   = SMALL
28585          DO 6 I=1,NHISTO
28586             DO 7 J=1,NDIM
28587                IF (YY1(J,I).LT.YLOW) THEN
28588                   IF (ILOGY.EQ.1) THEN
28589                      IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
28590                   ELSE
28591                      YLOW = YY1(J,I)
28592                   ENDIF
28593                ENDIF
28594                IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
28595     7       CONTINUE
28596     6    CONTINUE
28597          DY = (YHI-YLOW)/DBLE(NDIM)
28598          IF (DY.LE.ZERO) THEN
28599             WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
28600      &         'OUTHGR:   warning! zero bin width for histograms ',
28601      &         IDX,': ',YLOW,YHI
28602             RETURN
28603          ENDIF
28604          IF (ILOGY.EQ.1) THEN
28605             YLOW = LOG10(YLOW)
28606             DY   = (LOG10(YHI)-YLOW)/100.0D0
28607             DO 8 I=1,NHISTO
28608                DO 9 J=1,NDIM
28609                   IF (YY1(J,I).LE.ZERO) THEN
28610                      YY1(J,I) = YLOW
28611                   ELSE
28612                      YY1(J,I) = LOG10(YY1(J,I))
28613                   ENDIF
28614     9          CONTINUE
28615     8       CONTINUE
28616          ENDIF
28617          CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
28618       ENDIF
28619
28620       RETURN
28621       END
28622 *
28623 *===getbin=============================================================*
28624 *
28625 CDECK  ID>, DT_GETBIN
28626       SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
28627      &                  XMEAN,YMEAN,YERR)
28628
28629 ************************************************************************
28630 * This version dated 23.4.95 is written  by S. Roesler.                *
28631 ************************************************************************
28632
28633       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28634       SAVE
28635
28636       PARAMETER ( LINP = 5 ,
28637      &            LOUT = 6 ,
28638      &            LDAT = 9 )
28639
28640       PARAMETER (ZERO   = 0.0D0,
28641      &           ONE    = 1.0D0,
28642      &           TINY35 = 1.0D-35)
28643
28644 * histograms
28645
28646       PARAMETER (NHIS=150, NDIM=250)
28647
28648       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28649      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28650
28651       XLOW = HIST(1,IHIS,IBIN)
28652       XHI  = HIST(1,IHIS,IBIN+1)
28653       IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
28654          XLOW = 10**XLOW
28655          XHI  = 10**XHI
28656       ENDIF
28657       IF (NORM.EQ.2) THEN
28658          DX   = XHI-XLOW
28659          NEVT = INT(DENTRY(1,IHIS))
28660       ELSEIF (NORM.EQ.3) THEN
28661          DX   = ONE
28662          NEVT = INT(HIST(2,IHIS,IBIN))
28663       ELSEIF (NORM.EQ.4) THEN
28664          DX   = XHI**2-XLOW**2
28665          NEVT = KEVT
28666       ELSEIF (NORM.EQ.5) THEN
28667          DX   = LOG(ABS(XHI))-LOG(ABS(XLOW))
28668          NEVT = KEVT
28669       ELSEIF (NORM.EQ.6) THEN
28670          DX   = ONE
28671          NEVT = KEVT
28672       ELSEIF (NORM.EQ.7) THEN
28673          DX   = ONE
28674          NEVT = INT(HIST(7,IHIS,IBIN))
28675       ELSEIF (NORM.EQ.8) THEN
28676          DX   = XHI-XLOW
28677          NEVT = INT(DENTRY(2,IHIS))
28678       ELSE
28679          DX   = ABS(XHI-XLOW)
28680          NEVT = KEVT
28681       ENDIF
28682       IF (ABS(DX).LT.TINY35) DX = ONE
28683       NEVT   = MAX(NEVT,1)
28684       YMEAN  = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
28685       YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
28686       YERR   = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
28687       YSUM   = HIST(5,IHIS,IBIN)
28688       IF (ABS(YSUM).LT.TINY35) YSUM = ONE
28689 C     XMEAN  = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
28690       XMEAN  = HIST(3,IHIS,IBIN)/YSUM
28691       IF (XMEAN.EQ.ZERO) XMEAN = XLOW
28692
28693       RETURN
28694       END
28695 *
28696 *===joihis=============================================================*
28697 *
28698 CDECK  ID>, DT_JOIHIS
28699       SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
28700
28701 ************************************************************************
28702 *                                                                      *
28703 *     Operation on histograms.                                         *
28704 *                                                                      *
28705 *     input:  IH1,IH2      histogram indices to be joined              *
28706 *             COPER        character defining the requested operation, *
28707 *                          i.e. '+', '-', '*', '/'                     *
28708 *             FAC1,FAC2    factors for joining, i.e.                   *
28709 *                          FAC1*histo1 COPER FAC2*histo2               *
28710 *                                                                      *
28711 * This version dated 23.4.95 is written  by S. Roesler.                *
28712 ************************************************************************
28713
28714       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28715       SAVE
28716
28717       PARAMETER ( LINP = 5 ,
28718      &            LOUT = 6 ,
28719      &            LDAT = 9 )
28720
28721       CHARACTER COPER*1
28722
28723       PARAMETER (ZERO   =  0.0D0,
28724      &           ONE    =  1.0D0,
28725      &           OHALF  =  0.5D0,
28726      &           TINY8  =  1.0D-8,
28727      &           SMALL  =  -1.0D8,
28728      &           RLARGE =  1.0D8 )
28729
28730 * histograms
28731
28732       PARAMETER (NHIS=150, NDIM=250)
28733
28734       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28735      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28736
28737       PARAMETER (NDIM2 = 2*NDIM)
28738       DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
28739
28740       CHARACTER*43 CNORM(0:6)
28741       DATA CNORM /'no further normalization                   ',
28742      &            'per event and bin width                    ',
28743      &            'per entry and bin width                    ',
28744      &            'per bin entry                              ',
28745      &            'per event and "bin width" x1^2...x2^2      ',
28746      &            'per event and "log. bin width" ln x1..ln x2',
28747      &            'per event                                  '/
28748
28749 * check histogram indices
28750       IF ((IH1.LT.    1).OR.(IH2.LT.    1).OR.
28751      &    (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
28752          WRITE(LOUT,1000) IH1,IH2,IHISL
28753  1000    FORMAT(1X,'JOIHIS:   warning!  inconsistent histogram ',
28754      &          'indices (',I3,',',I3,'),',/,21X,'valid range:  1,',I3)
28755          GOTO 9999
28756       ENDIF
28757
28758 * check bin structure of histograms to be joined
28759       IF (IBINS(IH1).NE.IBINS(IH2)) THEN
28760          WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
28761  1001    FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
28762      &          ' and ',I3,' failed',/,21X,
28763      &          'due to different numbers of bins (',I3,',',I3,')')
28764          GOTO 9999
28765       ENDIF
28766       DO 1 K=1,IBINS(IH1)+1
28767          IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
28768             WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
28769  1002       FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
28770      &             ' and ',I3,' failed at bin edge ',I3,/,21X,
28771      &             'X1,X2 = ',2E11.4)
28772             GOTO 9999
28773          ENDIF
28774     1 CONTINUE
28775
28776       WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
28777  1003 FORMAT(1X,'JOIHIS:   joining histograms ',I3,',',I3,' with ',
28778      &       'operation ',A,/,11X,'and factors ',2E11.4)
28779       WRITE(LOUT,1004) CNORM(NORM)
28780  1004 FORMAT(1X,'normalization: ',A,/)
28781
28782       DO 2 K=1,IBINS(IH1)
28783          CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
28784          CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
28785          XLOW  = XLOW1
28786          XHI   = XHI1
28787          XMEAN = OHALF*(XMEAN1+XMEAN2)
28788          IF (COPER.EQ.'+') THEN
28789             YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
28790          ELSEIF (COPER.EQ.'*') THEN
28791             YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
28792          ELSEIF (COPER.EQ.'/') THEN
28793             IF (YMEAN2.EQ.ZERO) THEN
28794                YMEAN = ZERO
28795             ELSE
28796                IF (FAC2.EQ.ZERO) FAC2 = ONE
28797                YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
28798             ENDIF
28799          ELSE
28800             GOTO 9998
28801          ENDIF
28802          WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
28803          WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
28804  1006    FORMAT(1X,5E11.3)
28805 *    small frame
28806          II = 2*K
28807          XX(II-1) = HIST(1,IH1,K)
28808          XX(II)   = HIST(1,IH1,K+1)
28809          YY(II-1) = YMEAN
28810          YY(II)   = YMEAN
28811 *    wide frame
28812          XX1(K) = XMEAN
28813          IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
28814          YY1(K) = YMEAN
28815     2 CONTINUE
28816
28817 * plot small frame
28818       IF (ABS(MODE).EQ.1) THEN
28819          IBIN2 = 2*IBINS(IH1)
28820          WRITE(LOUT,'(/,1X,A)') 'Preview:'
28821          IF(ILOGY.EQ.1) THEN
28822            CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
28823          ELSE
28824            CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
28825          ENDIF
28826       ENDIF
28827
28828 * plot wide frame
28829       IF (ABS(MODE).EQ.2) THEN
28830          WRITE(LOUT,'(/,1X,A)') 'Preview:'
28831          NSIZE = NDIM
28832          DXLOW = HIST(1,IH1,1)
28833          DDX   = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
28834          YLOW  = RLARGE
28835          YHI   = SMALL
28836          DO 3 I=1,NDIM
28837             IF (YY1(I).LT.YLOW) THEN
28838                IF (ILOGY.EQ.1) THEN
28839                   IF (YY1(I).GT.ZERO) YLOW = YY1(I)
28840                ELSE
28841                   YLOW = YY1(I)
28842                ENDIF
28843             ENDIF
28844             IF (YY1(I).GT.YHI) YHI = YY1(I)
28845     3    CONTINUE
28846          DY = (YHI-YLOW)/DBLE(NDIM)
28847          IF (DY.LE.ZERO) THEN
28848             WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
28849      &         'JOIHIS:   warning! zero bin width for histograms ',
28850      &         IH1,IH2,': ',YLOW,YHI
28851             RETURN
28852          ENDIF
28853          IF (ILOGY.EQ.1) THEN
28854             YLOW = LOG10(YLOW)
28855             DY   = (LOG10(YHI)-YLOW)/100.0D0
28856             DO 4 I=1,NDIM
28857                IF (YY1(I).LE.ZERO) THEN
28858                   YY1(I) = YLOW
28859                ELSE
28860                   YY1(I) = LOG10(YY1(I))
28861                ENDIF
28862     4       CONTINUE
28863          ENDIF
28864          CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
28865       ENDIF
28866
28867       RETURN
28868
28869  9998 CONTINUE
28870       WRITE(LOUT,1005) COPER
28871  1005 FORMAT(1X,'JOIHIS:   unknown operation ',A)
28872
28873  9999 CONTINUE
28874       RETURN
28875       END
28876 *
28877 *===qgraph=============================================================*
28878 *
28879 CDECK  ID>, DT_XGRAPH
28880       SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
28881 C***********************************************************************
28882 C
28883 C     calculate quasi graphic picture with 25 lines and 79 columns
28884 C     ranges will be chosen automatically
28885 C
28886 C     input     N          dimension of input fields
28887 C               IARG       number of curves (fields) to plot
28888 C               X          field of X
28889 C               Y1         field of Y1
28890 C               Y2         field of Y2
28891 C
28892 C This subroutine is written by R. Engel.
28893 C***********************************************************************
28894       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28895       SAVE
28896
28897       PARAMETER ( LINP = 5 ,
28898      &            LOUT = 6 ,
28899      &            LDAT = 9 )
28900
28901 C
28902       DIMENSION X(N),Y1(N),Y2(N)
28903       PARAMETER (EPS=1.D-30)
28904       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
28905       CHARACTER SYMB(5)
28906       CHARACTER COL(0:149,0:49)
28907 C
28908       DATA SYMB /'0','e','z','#','x'/
28909 C
28910       ISPALT=IBREIT-10
28911 C
28912 C***  automatic range fitting
28913 C
28914       XMAX=X(1)
28915       XMIN=X(1)
28916       DO 600 I=1,N
28917          XMAX=MAX(X(I),XMAX)
28918          XMIN=MIN(X(I),XMIN)
28919  600  CONTINUE
28920       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
28921 C
28922       ITEST=0
28923       DO 1100 K=0,IZEIL-1
28924          ITEST=ITEST+1
28925          IF (ITEST.EQ.IYRAST) THEN
28926             DO 1010 L=1,ISPALT-1
28927                COL(L,K)='-'
28928 1010        CONTINUE
28929             COL(ISPALT,K)='+'
28930             ITEST=0
28931             DO 1020 L=0,ISPALT-1,IXRAST
28932                COL(L,K)='+'
28933 1020        CONTINUE
28934          ELSE
28935             DO 1030 L=1,ISPALT-1
28936                COL(L,K)=' '
28937 1030        CONTINUE
28938             DO 1040 L=0,ISPALT-1,IXRAST
28939                COL(L,K)='|'
28940 1040        CONTINUE
28941             COL(ISPALT,K)='|'
28942          ENDIF
28943 1100  CONTINUE
28944 C
28945 C***  plot curve Y1
28946 C
28947       YMAX=Y1(1)
28948       YMIN=Y1(1)
28949       DO 500 I=1,N
28950          YMAX=MAX(Y1(I),YMAX)
28951          YMIN=MIN(Y1(I),YMIN)
28952 500   CONTINUE
28953       IF(IARG.GT.1) THEN
28954         DO 550 I=1,N
28955            YMAX=MAX(Y2(I),YMAX)
28956            YMIN=MIN(Y2(I),YMIN)
28957 550     CONTINUE
28958       ENDIF
28959       YMAX=(YMAX-YMIN)/40.0D0+YMAX
28960       YMIN=YMIN-(YMAX-YMIN)/40.0D0
28961       YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
28962       IF(YZOOM.LT.EPS) THEN
28963         WRITE(LOUT,'(1X,A)')
28964      &    'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
28965         RETURN
28966       ENDIF
28967 C
28968 C***  plot curve Y1
28969 C
28970       ILAST=-1
28971       LLAST=-1
28972       DO 1200 K=1,N
28973          L=NINT((X(K)-XMIN)/XZOOM)
28974          I=NINT((YMAX-Y1(K))/YZOOM)
28975          IF(ILAST.GE.0) THEN
28976            LD = L-LLAST
28977            ID = I-ILAST
28978            DO 55 II=0,LD,SIGN(1,LD)
28979              DO 66 KK=0,ID,SIGN(1,ID)
28980                COL(II+LLAST,KK+ILAST)=SYMB(1)
28981  66          CONTINUE
28982  55        CONTINUE
28983          ELSE
28984            COL(L,I)=SYMB(1)
28985          ENDIF
28986          ILAST = I
28987          LLAST = L
28988 1200  CONTINUE
28989 C
28990       IF(IARG.GT.1) THEN
28991 C
28992 C***  plot curve Y2
28993 C
28994         DO 1250 K=1,N
28995            L=NINT((X(K)-XMIN)/XZOOM)
28996            I=NINT((YMAX-Y2(K))/YZOOM)
28997            COL(L,I)=SYMB(2)
28998 1250    CONTINUE
28999       ENDIF
29000 C
29001 C***  write it
29002 C
29003       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
29004 C
29005 C***  write range of X
29006 C
29007       XZOOM = (XMAX-XMIN)/DBLE(7)
29008       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
29009 C
29010       DO 1300 K=0,IZEIL-1
29011          YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
29012          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
29013  110     FORMAT(1X,1PE9.2,70A1)
29014 1300  CONTINUE
29015 C
29016 C***  write range of X
29017 C
29018       XZOOM = (XMAX-XMIN)/DBLE(7)
29019       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
29020       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
29021  120  FORMAT(6X,7(1PE10.3))
29022       END
29023 *
29024 *===qglogy=============================================================*
29025 *
29026 CDECK  ID>, DT_XGLOGY
29027       SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
29028 C***********************************************************************
29029 C
29030 C     calculate quasi graphic picture with 25 lines and 79 columns
29031 C     logarithmic y axis
29032 C     ranges will be chosen automatically
29033 C
29034 C     input     N          dimension of input fields
29035 C               IARG       number of curves (fields) to plot
29036 C               X          field of X
29037 C               Y1         field of Y1
29038 C               Y2         field of Y2
29039 C
29040 C This subroutine is written by R. Engel.
29041 C***********************************************************************
29042 C
29043       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29044       SAVE
29045
29046       PARAMETER ( LINP = 5 ,
29047      &            LOUT = 6 ,
29048      &            LDAT = 9 )
29049
29050       DIMENSION X(N),Y1(N),Y2(N)
29051       PARAMETER (EPS=1.D-30)
29052       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
29053       CHARACTER SYMB(5)
29054       CHARACTER COL(0:149,0:49)
29055       PARAMETER (DEPS = 1.D-10)
29056 C
29057       DATA SYMB /'0','e','z','#','x'/
29058 C
29059       ISPALT=IBREIT-10
29060 C
29061 C***  automatic range fitting
29062 C
29063       XMAX=X(1)
29064       XMIN=X(1)
29065       DO 600 I=1,N
29066          XMAX=MAX(X(I),XMAX)
29067          XMIN=MIN(X(I),XMIN)
29068  600  CONTINUE
29069       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
29070 C
29071       ITEST=0
29072       DO 1100 K=0,IZEIL-1
29073          ITEST=ITEST+1
29074          IF (ITEST.EQ.IYRAST) THEN
29075             DO 1010 L=1,ISPALT-1
29076                COL(L,K)='-'
29077 1010        CONTINUE
29078             COL(ISPALT,K)='+'
29079             ITEST=0
29080             DO 1020 L=0,ISPALT-1,IXRAST
29081                COL(L,K)='+'
29082 1020        CONTINUE
29083          ELSE
29084             DO 1030 L=1,ISPALT-1
29085                COL(L,K)=' '
29086 1030        CONTINUE
29087             DO 1040 L=0,ISPALT-1,IXRAST
29088                COL(L,K)='|'
29089 1040        CONTINUE
29090             COL(ISPALT,K)='|'
29091          ENDIF
29092 1100  CONTINUE
29093 C
29094 C***  plot curve Y1
29095 C
29096       YMAX=Y1(1)
29097       YMIN=MAX(Y1(1),EPS)
29098       DO 500 I=1,N
29099          YMAX =MAX(Y1(I),YMAX)
29100          IF(Y1(I).GT.EPS) THEN
29101            IF(YMIN.EQ.EPS) THEN
29102              YMIN = Y1(I)/10.D0
29103            ELSE
29104              YMIN = MIN(Y1(I),YMIN)
29105            ENDIF
29106          ENDIF
29107 500   CONTINUE
29108       IF(IARG.GT.1) THEN
29109         DO 550 I=1,N
29110            YMAX=MAX(Y2(I),YMAX)
29111            IF(Y2(I).GT.EPS) THEN
29112              IF(YMIN.EQ.EPS) THEN
29113                YMIN = Y2(I)
29114              ELSE
29115                YMIN = MIN(Y2(I),YMIN)
29116              ENDIF
29117            ENDIF
29118 550     CONTINUE
29119       ENDIF
29120 C
29121       DO 560 I=1,N
29122         Y1(I) = MAX(Y1(I),YMIN)
29123  560  CONTINUE
29124       IF(IARG.GT.1) THEN
29125         DO 570 I=1,N
29126           Y2(I) = MAX(Y2(I),YMIN)
29127  570    CONTINUE
29128       ENDIF
29129 C
29130       IF(YMAX.LE.YMIN) THEN
29131         WRITE(LOUT,'(/1X,A,2E12.3,/)')
29132      &     'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
29133         WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
29134         RETURN
29135       ENDIF
29136 C
29137       YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
29138       YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
29139       YZOOM=(YMA-YMI)/DBLE(IZEIL)
29140       IF(YZOOM.LT.EPS) THEN
29141         WRITE(LOUT,'(1X,A)')
29142      &    'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
29143         RETURN
29144       ENDIF
29145 C
29146 C***  plot curve Y1
29147 C
29148       ILAST=-1
29149       LLAST=-1
29150       DO 1200 K=1,N
29151          L=NINT((X(K)-XMIN)/XZOOM)
29152          I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
29153          IF(ILAST.GE.0) THEN
29154            LD = L-LLAST
29155            ID = I-ILAST
29156            DO 55 II=0,LD,SIGN(1,LD)
29157              DO 66 KK=0,ID,SIGN(1,ID)
29158                COL(II+LLAST,KK+ILAST)=SYMB(1)
29159  66          CONTINUE
29160  55        CONTINUE
29161          ELSE
29162            COL(L,I)=SYMB(1)
29163          ENDIF
29164          ILAST = I
29165          LLAST = L
29166 1200  CONTINUE
29167 C
29168       IF(IARG.GT.1) THEN
29169 C
29170 C***  plot curve Y2
29171 C
29172         DO 1250 K=1,N
29173            L=NINT((X(K)-XMIN)/XZOOM)
29174            I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
29175            COL(L,I)=SYMB(2)
29176 1250    CONTINUE
29177       ENDIF
29178 C
29179 C***  write it
29180 C
29181       WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
29182       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
29183 C
29184 C***  write range of X
29185 C
29186       XZOOM1 = (XMAX-XMIN)/DBLE(7)
29187       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
29188 C
29189       DO 1300 K=0,IZEIL-1
29190          YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
29191          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
29192  110     FORMAT(1X,1PE9.2,70A1)
29193 1300  CONTINUE
29194 C
29195 C***  write range of X
29196 C
29197       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
29198       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
29199  120  FORMAT(6X,7(1PE10.3))
29200 C
29201       END
29202 *
29203 *===plot===============================================================*
29204 *
29205 CDECK  ID>, DT_SRPLOT
29206       SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
29207
29208       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29209       SAVE
29210
29211       PARAMETER ( LINP = 5 ,
29212      &            LOUT = 6 ,
29213      &            LDAT = 9 )
29214
29215 *
29216 *     initial version
29217 *     J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
29218 *     This is a subroutine of fluka to plot Y across the page
29219 *     as a function of X down the page. Up to 37 curves can be
29220 *     plotted in the same picture with different plotting characters.
29221 *     Output of first 10 overprinted characters addad by FB 88
29222 *  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
29223 *
29224 *     Input Variables:
29225 *        X   = array containing the values of X
29226 *        Y   = array containing the values of Y
29227 *        N   = number of values in X and in Y
29228 *              can exceed the fixed number of lines
29229 *        M   = number of different curves X,Y are containing
29230 *        MM  = number of points in each curve i.e. N=M*MM
29231 *        XO  = smallest value of X to be plotted
29232 *        DX  = increment of X between subsequent lines
29233 *        YO  = smallest value of Y to be plotted
29234 *        DY  = increment of Y between subsequent character spaces
29235 *
29236 *        other variables used inside:
29237 *        XX  = numbers along the X-coordinate axis
29238 *        YY  = numbers along the Y-coordinate axis
29239 *        LL  = ten lines temporary storage for the plot
29240 *        L   = character set used to plot different curves
29241 *        LOV = memorizes overprinted symbols
29242 *              the first 10 overprinted symbols are printed on
29243 *              the end of the line to avoid ambiguities
29244 *              (added by FB as considered quite helpful)
29245 *
29246 *********************************************************************
29247 *
29248       DIMENSION XX(61),YY(61),LL(101,10)
29249       DIMENSION X(N),Y(N),L(40),LOV(40,10)
29250       DATA  L/
29251      11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
29252      21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
29253      31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
29254      41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H  /
29255 *
29256 *
29257       MN=51
29258       DO 10 I=1,MN
29259         AI=I-1
29260    10 XX(I)=XO+AI*DX
29261       DO 20 I=1,11
29262         AI=I-1
29263    20 YY(I)=YO+10.0D0*AI*DY
29264       WRITE(LOUT, 500) (YY(I),I=1,11)
29265       MMN=MN-1
29266 *
29267 *
29268       DO 90 JJ=1,MMN,10
29269         JJJ=JJ-1
29270         DO 30 I=1,101
29271           DO 30 J=1,10
29272    30   LL(I,J)=L(40)
29273         DO 40 I=1,101
29274    40   LL(I,1)=L(39)
29275         DO 50 I=1,101,10
29276           DO 50 J=1,10
29277    50   LL(I,J)=L(38)
29278         DO 60 I=1,40
29279           DO 60 J=1,10
29280    60   LOV(I,J)=L(40)
29281 *
29282 *
29283         DO 70 I=1,M
29284           DO 70 J=1,MM
29285             II=J+(I-1)*MM
29286             AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
29287             AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
29288             AIX=AIX-DBLE(JJJ)
29289 *           changed Sept.88 by FB to avoid INTEGER OVERFLOW
29290             IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
29291      +      . AIY .LT. 102.D0) THEN
29292               IX=INT(AIX)
29293               IY=INT(AIY)
29294               IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
29295      +        THEN
29296                 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
29297      +          =LL(IY,IX)
29298                 LL(IY,IX)=L(I)
29299               ENDIF
29300             ENDIF
29301    70   CONTINUE
29302 *
29303 *
29304         DO 80 I=1,10
29305           II=I+JJJ
29306           III=II+1
29307           WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
29308      &                    (LOV(J,I),J=1,10)
29309    80   CONTINUE
29310    90 CONTINUE
29311 *
29312 *
29313       WRITE(LOUT, 520)
29314       WRITE(LOUT, 500) (YY(I),I=1,11)
29315       RETURN
29316 *
29317   500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
29318   510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
29319   520 FORMAT(20X,10('1---------'),'1')
29320       END
29321 *
29322 *===defset=============================================================*
29323 *
29324 CDECK  ID>, DT_DEFSET
29325       BLOCK DATA DT_DEFSET
29326
29327       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29328       SAVE
29329
29330 * flags for input different options
29331       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
29332       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
29333      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
29334
29335       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29336
29337 * emulsion treatment
29338       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29339      &                NCOMPO,IEMUL
29340
29341 * / DTFLG1 /
29342       DATA IFRAG  / 2, 1 /
29343       DATA IRESCO / 1 /
29344       DATA IMSHL  / 1 /
29345       DATA IRESRJ / 0 /
29346       DATA IOULEV / -1, -1, -1, -1, -1, -1 /
29347       DATA LEMCCK / .FALSE. /
29348       DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
29349      &              .TRUE.,.TRUE.,.TRUE./
29350       DATA LSEADI / .TRUE. /
29351       DATA LEVAPO / .TRUE. /
29352       DATA IFRAME / 1 /
29353 * Introduced by Chiara -> Forcing CMS-system
29354 *      DATA IFRAME / 2 /
29355       DATA ITRSPT / 0 /
29356
29357 * / DTCOMP /
29358       DATA EMUFRA / NCOMPX*0.0D0 /
29359       DATA IEMUMA / NCOMPX*1 /
29360       DATA IEMUCH / NCOMPX*1 /
29361       DATA NCOMPO / 0 /
29362       DATA IEMUL  / 0 /
29363
29364       END
29365 *
29366 *
29367 *===hadprp=============================================================*
29368 *
29369 CDECK  ID>, DT_HADPRP
29370       BLOCK DATA DT_HADPRP
29371
29372       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29373       SAVE
29374
29375 * auxiliary common for reggeon exchange (DTUNUC 1.x)
29376       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
29377      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
29378      &                IQTCHR(-6:6),MQUARK(3,39)
29379 * hadron index conversion (BAMJET <--> PDG)
29380       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
29381      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
29382      &                IAMCIN(210)
29383 * names of hadrons used in input-cards
29384       CHARACTER*8 BTYPE
29385       COMMON /DTPAIN/ BTYPE(30)
29386
29387 * / DTQUAR /
29388 *----------------------------------------------------------------------*
29389 *                                                                      *
29390 *     Quark content of particles:                                      *
29391 *          index   quark   el. charge  bar. charge  isospin  isospin3  *
29392 *              1 = u          2/3          1/3        1/2       1/2    *
29393 *             -1 = ubar      -2/3         -1/3        1/2      -1/2    *
29394 *              2 = d         -1/3          1/3        1/2      -1/2    *
29395 *             -2 = dbar       1/3         -1/3        1/2       1/2    *
29396 *              3 = s         -1/3          1/3         0         0     *
29397 *             -3 = sbar       1/3         -1/3         0         0     *
29398 *              4 = c          2/3          1/3         0         0     *
29399 *             -4 = cbar      -2/3         -1/3         0         0     *
29400 *              5 = b         -1/3          1/3         0         0     *
29401 *             -5 = bbar       1/3         -1/3         0         0     *
29402 *              6 = t          2/3          1/3         0         0     *
29403 *             -6 = tbar      -2/3         -1/3         0         0     *
29404 *                                                                      *
29405 *         Mquark = particle quark composition (Paprop numbering)       *
29406 *         Iqechr = electric charge ( in 1/3 unit )                     *
29407 *         Iqbchr = baryonic charge ( in 1/3 unit )                     *
29408 *         Iqichr = isospin ( in 1/2 unit ), z component                *
29409 *         Iqschr = strangeness                                         *
29410 *         Iqcchr = charm                                               *
29411 *         Iquchr = beauty                                              *
29412 *         Iqtchr = ......                                              *
29413 *                                                                      *
29414 *----------------------------------------------------------------------*
29415       DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
29416       DATA IQBCHR / 6*-1, 0, 6*1 /
29417       DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
29418       DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
29419       DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
29420       DATA IQUCHR / 0, 1, 9*0, -1, 0 /
29421       DATA IQTCHR / -1, 11*0, 1 /
29422       DATA MQUARK /
29423      &   2, 1, 1,   -2,-1,-1,    0, 0, 0,    0, 0, 0,    0, 0, 0,
29424      &   0, 0, 0,    0, 0, 0,    2, 2, 1,   -2,-2,-1,    0, 0, 0,
29425      &   0, 0, 0,    0, 0, 0,    1,-2, 0,    2,-1, 0,    1,-3, 0,
29426      &   3,-1, 0,    1, 2, 3,   -1,-2,-3,    0, 0, 0,    2, 2, 3,
29427      &   1, 1, 3,    1, 2, 3,    1,-1, 0,    2,-3, 0,    3,-2, 0,
29428      &   2,-2, 0,    3,-3, 0,    0, 0, 0,    0, 0, 0,    0, 0, 0,
29429      &  -1,-1,-3,   -1,-2,-3,   -2,-2,-3,    1, 3, 3,   -1,-3,-3,
29430      &   2, 3, 3,   -2,-3,-3,    3, 3, 3,   -3,-3,-3 /
29431
29432 * / DTHAIC /
29433 * (renamed) (HAdron InDex COnversion)
29434 * translation table version filled up by r.e. 25.01.94                 *
29435       DATA IAMCIN /
29436      &2212,-2212,11,-11,12,              -12,22,2112,-2112,-13,
29437      &13,130,211,-211,321,               -321,3122,-3122,310,3112,
29438      &3222,3212,111,311,-311,            0,0,0,0,0,
29439      &221,213,113,-213,223,              323,313,-323,-313,10323,
29440      &10313,-10323,-10313,30323,30313,   -30323,-30313,3224,3214,3114,
29441      &3216,3218,2224,2214,2114,          1114,12224,12214,12114,11114,
29442      &99999,99999,22212,22112,32124,     31214,-2224,-2214,-2114,-1114,
29443      &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
29444      &5*99999,                           5*99999,
29445      &4*99999,331,                       333,3322,3312,-3222,-3212,
29446      &-3112,-3322,-3312,3224,3214,       3114,3324,3314,3334,-3224,
29447      &-3214,-3114,-3324,-3314,-3334,     421,411,-411,-421,431,
29448      &-431,441,423,413,-413,             -423,433,-433,20443,443,
29449      &-15,15,16,-16,14,                  -14,4122,4232,4132,4222,
29450      &4212,4112,3*99999,                 3*99999,-4122,-4232,
29451      &-4132,-4222,-4212,-4112,99999,     5*99999,
29452      &5*99999,                           5*99999,
29453      &10*99999,
29454      &5*99999 , 20211,20111,-20211,99999,20321,
29455      &-20321,20311,-20311,7*99999 ,
29456      &7*99999,12212,12112,99999/
29457
29458 * / DTHAIC /
29459 * (HAdron InDex COnversion)
29460       DATA (IPDG2(1,K),K=1,7)
29461      &   /   -11,   -12,   -13,   -15,   -16,   -14,     0/
29462       DATA (IBAM2(1,K),K=1,7)
29463      &   /     4,     6,    10,   131,   134,   136,     0/
29464       DATA (IPDG2(2,K),K=1,7)
29465      &   /    11,    12,    22,    13,    15,    16,    14/
29466       DATA (IBAM2(2,K),K=1,7)
29467      &   /     3,     5,     7,    11,   132,   133,   135/
29468       DATA (IPDG3(1,K),K=1,22)
29469      &   /  -211,  -321,  -311,  -213,  -323,  -313,  -411,  -421,
29470      &      -431,  -413,  -423,  -433,     0,     0,     0,     0,
29471      &         0,     0,     0,     0,     0,     0/
29472       DATA (IBAM3(1,K),K=1,22)
29473      &   /    14,    16,    25,    34,    38,    39,   118,   119,
29474      &       121,   125,   126,   128,     0,     0,     0,     0,
29475      &         0,     0,     0,     0,     0,     0/
29476       DATA (IPDG3(2,K),K=1,22)
29477      &   /   130,   211,   321,   310,   111,   311,   221,   213,
29478      &       113,   223,   323,   313,   331,   333,   421,   411,
29479      &       431,   441,   423,   413,   433,   443/
29480       DATA (IBAM3(2,K),K=1,22)
29481      &   /    12,    13,    15,    19,    23,    24,    31,    32,
29482      &        33,    35,    36,    37,    95,    96,   116,   117,
29483      &       120,   122,   123,   124,   127,   130/
29484       DATA (IPDG4(1,K),K=1,29)
29485      &   / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
29486      &     -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
29487      &     -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
29488      &     -4212, -4112,     0,     0,     0/
29489       DATA (IBAM4(1,K),K=1,29)
29490      &   /     2,     9,    18,    67,    68,    69,    70,    75,
29491      &        76,    99,   100,   101,   102,   103,   110,   111,
29492      &       112,   113,   114,   115,   149,   150,   151,   152,
29493      &       153,   154,     0,     0,     0/
29494       DATA (IPDG4(2,K),K=1,29)
29495      &   /  2212,  2112,  3122,  3112,  3222,  3212,  3224,  3214,
29496      &      3114,  3216,  3218,  2224,  2214,  2114,  1114,  3322,
29497      &      3312,  3224,  3214,  3114,  3324,  3314,  3334,  4122,
29498      &      4232,  4132,  4222,  4212,  4112/
29499       DATA (IBAM4(2,K),K=1,29)
29500      &   /     1,     8,    17,    20,    21,    22,    48,    49,
29501      &        50,    51,    52,    53,    54,    55,    56,    97,
29502      &        98,   104,   105,   106,   107,   108,   109,   137,
29503      &       138,   139,   140,   141,   142/
29504       DATA (IPDG5(1,K),K=1,19)
29505      &   /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
29506      &    -20211,-20321,-20311,     0,     0,     0,     0,     0,
29507      &         0,     0,     0/
29508       DATA (IBAM5(1,K),K=1,19)
29509      &   /    42,    43,    46,    47,    71,    72,    73,    74,
29510      &       188,   191,   193,     0,     0,     0,     0,     0,
29511      &         0,     0,     0/
29512       DATA (IPDG5(2,K),K=1,19)
29513      &   / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
29514      &     22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
29515      &     20311, 12212, 12112/
29516       DATA (IBAM5(2,K),K=1,19)
29517      &   /    40,    41,    44,    45,    57,    58,    59,    60,
29518      &        63,    64,    65,    66,   129,   186,   187,   190,
29519      &       192,   208,   209/
29520
29521 * / DTPAIN /
29522 * internal particle names
29523       DATA BTYPE / 'PROTON  ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
29524      &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON  ' , 'NEUTRON ' , 'ANEUTRON' ,
29525      &'MUON+   ' , 'MUON-   ' , 'KAONLONG' , 'PION+   ' , 'PION-   ' ,
29526      &'KAON+   ' , 'KAON-   ' , 'LAMBDA  ' , 'ALAMBDA ' , 'KAONSHRT' ,
29527      &'SIGMA-  ' , 'SIGMA+  ' , 'SIGMAZER' , 'PIZERO  ' , 'KAONZERO' ,
29528      &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
29529      &'BLANK   ' /
29530
29531       END
29532 *
29533 *===blkd46=============================================================*
29534 *
29535 CDECK  ID>, DT_BLKD46
29536       BLOCK DATA DT_BLKD46
29537
29538       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29539       SAVE
29540
29541       PARAMETER ( AMELCT = 0.51099906         D-03 )
29542       PARAMETER ( AMMUON = 0.105658389        D+00 )
29543
29544 * particle properties (BAMJET index convention)
29545       CHARACTER*8  ANAME
29546       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29547      &                IICH(210),IIBAR(210),K1(210),K2(210)
29548
29549 * / DTPART /
29550 * Particle  masses Engel version JETSET compatible
29551       DATA (AAM(K),K=1,85) /
29552      &   .9383D+00, .9383D+00,  AMELCT  ,  AMELCT  , .0000D+00,
29553      &   .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON   ,
29554      &   AMMUON   , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
29555      &   .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
29556      &   .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
29557      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29558      &   .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
29559      &   .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
29560      &   .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
29561      &   .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
29562      &   .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
29563      &   .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
29564      &   .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
29565      &   .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
29566      &   .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
29567      &   .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
29568      &   .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01  /
29569       DATA (AAM(K),K=86,183) /
29570      &   .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
29571      &   .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
29572      &   .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
29573      &   .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
29574      &   .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
29575      &   .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
29576      &   .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
29577      &   .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
29578      &   .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
29579      &   .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
29580      &   .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
29581      &   .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
29582      &   .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
29583      &   .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
29584      &   .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
29585      &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
29586      &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
29587      &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
29588      &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
29589      &   .1250D+01, .1250D+01, .1250D+01  /
29590       DATA (AAM ( I ), I = 184,210 ) /
29591      & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
29592      & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
29593      & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
29594      & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
29595      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
29596      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
29597      & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
29598      & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
29599      & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
29600 * Particle  mean lives
29601       DATA (TAU(K),K=1,183) /
29602      &   .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
29603      &   .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
29604      &   .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
29605      &   .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
29606      &   .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
29607      &   70*.0000D+00,
29608      &   .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
29609      &   .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
29610      &   .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
29611      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
29612      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29613      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29614      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29615      &   .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
29616      &   .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29617      &   40*.0000D+00,
29618      &   .0000D+00, .0000D+00, .0000D+00  /
29619       DATA ( TAU ( I ), I = 184,210 ) /
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      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
29628      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
29629 * Resonance width Gamma in GeV
29630       DATA (GA(K),K=  1,85) /
29631      &    30*.0000D+00,
29632      &   .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
29633      &   .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
29634      &   .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
29635      &   .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
29636      &   .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
29637      &   .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
29638      &   .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
29639      &   .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
29640      &   .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
29641      &   .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
29642      &   .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00  /
29643       DATA (GA(K),K= 86,183) /
29644      &   .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
29645      &   .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
29646      &   .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29647      &   .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
29648      &   .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
29649      &   .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
29650      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29651      &   .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
29652      &   .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
29653      &   50*.0000D+00,
29654      &   .3000D+00, .3000D+00, .3000D+00  /
29655       DATA ( GA ( I ), I = 184,210 ) /
29656      & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
29657      & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
29658      & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
29659      & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
29660      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
29661      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
29662      & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
29663      & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
29664      & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
29665 * Particle  names
29666 * S+1385+Sigma+(1385)    L02030+Lambda0(2030)
29667 * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
29668 * designation N*@@ means N*@1(@2)
29669       DATA (ANAME(K),K=1,85) /
29670      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
29671      &  'ANUE    ','GAM     ','NEU     ','ANEU    ','MUE+    ',
29672      &  'MUE-    ','K0L     ','PI+     ','PI-     ','K+      ',
29673      &  'K-      ','LAM     ','ALAM    ','K0S     ','SIGM-   ',
29674      &  'SIGM+   ','SIGM0   ','PI0     ','K0      ','AK0     ',
29675      &  'BLANK   ','BLANK   ','BLANK   ','BLANK   ','BLANK   ',
29676      &  'ETA550  ','RHO+77  ','RHO077  ','RHO-77  ','OM0783  ',
29677      &  'K*+892  ','K*0892  ','K*-892  ','AK*089  ','KA+125  ',
29678      &  'KA0125  ','KA-125  ','AKA012  ','K*+142  ','K*0142  ',
29679      &  'K*-142  ','AK*014  ','S+1385  ','S01385  ','S-1385  ',
29680      &  'L01820  ','L02030  ','N*++12  ','N*+ 12  ','N*012   ',
29681      &  'N*-12   ','N*++16  ','N*+16   ','N*016   ','N*-16   ',
29682      &  'N*+14   ','N*014   ','N*+15   ','N*015   ','N*+18   ',
29683      &  'N*018   ','AN--12  ','AN*-12  ','AN*012  ','AN*+12  ',
29684      &  'AN--16  ','AN*-16  ','AN*016  ','AN*+16  ','AN*-15  ',
29685      &  'AN*015  ','DE*=24  ','RPI+49  ','RPI049  ','RPI-49  ',
29686      &  'PIN++   ','PIN+0   ','PIN+-   ','PIN-0   ','PPPI    ' /
29687       DATA (ANAME(K),K=86,183) /
29688      &  'PNPI    ','APPPI   ','APNPI   ','K+PPI   ','K-PPI   ',
29689      &  'K+NPI   ','K-NPI   ','S+1820  ','S-2030  ','ETA*    ',
29690      &  'PHI     ','TETA0   ','TETA-   ','ASIG-   ','ASIG0   ',
29691      &  'ASIG+   ','ATETA0  ','ATETA+  ','SIG*+   ','SIG*0   ',
29692      &  'SIG*-   ','TETA*0  ','TETA*   ','OMEGA-  ','ASIG*-  ',
29693      &  'ASIG*0  ','ASIG*+  ','ATET*0  ','ATET*+  ','OMEGA+  ',
29694      &  'D0      ','D+      ','D-      ','AD0     ','F+      ',
29695      &  'F-      ','ETAC    ','D*0     ','D*+     ','D*-     ',
29696      &  'AD*0    ','F*+     ','F*-     ','PSI     ','JPSI    ',
29697      &  'TAU+    ','TAU-    ','NUET    ','ANUET   ','NUEM    ',
29698      &  'ANUEM   ','C0+     ','A+      ','A0      ','C1++    ',
29699      &  'C1+     ','C10     ','S+      ','S0      ','T0      ',
29700      &  'XU++    ','XD+     ','XS+     ','AC0-    ','AA-     ',
29701      &  'AA0     ','AC1--   ','AC1-    ','AC10    ','AS-     ',
29702      &  'AS0     ','AT0     ','AXU--   ','AXD-    ','AXS     ',
29703      &  'C1*++   ','C1*+    ','C1*0    ','S*+     ','S*0     ',
29704      &  'T*0     ','XU*++   ','XD*+    ','XS*+    ','TETA++  ',
29705      &  'AC1*--  ','AC1*-   ','AC1*0   ','AS*-    ','AS*0    ',
29706      &  'AT*0    ','AXU*--  ','AXD*-   ','AXS*-   ','ATET--  ',
29707      &  'RO      ','R+      ','R-      '  /
29708       DATA (    ANAME ( I ), I = 184,210 ) /
29709      &'AN*-14  ','AN*014  ','PI+130  ','PI0130  ','PI-130  ','F01400  ',
29710      &'K*+146  ','K*-146  ','K*0146  ','AK0146  ','L01600  ','AL0160  ',
29711      &'S+1660  ','S01660  ','S-1660  ','AS-166  ','AS0166  ','AS+166  ',
29712      &'X01950  ','X-1950  ','AX0195  ','AX+195  ','OM-225  ','AOM+22  ',
29713      &'N*+14   ','N*014   ','BLANK   '/
29714 * Charge of particles and resonances
29715       DATA (IICH ( I ), I =   1,210 ) /
29716      &  1, -1, -1,  1,  0,  0,  0,  0,  0,  1, -1,  0,  1, -1,  1,
29717      & -1,  0,  0,  0, -1,  1,  0,  0,  0,  0,  0,  0,  0,  0,  0,
29718      &  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0,
29719      & -1,  0,  1,  0, -1,  0,  0,  2,  1,  0, -1,  2,  1,  0, -1,
29720      &  1,  0,  1,  0,  1,  0, -2, -1,  0,  1, -2, -1,  0,  1, -1,
29721      &  0,  1,  1,  0, -1,  2,  1,  0, -1,  2,  1,  0, -1,  2,  0,
29722      &  1, -1,  1, -1,  0,  0,  0, -1, -1,  0,  1,  0,  1,  1,  0,
29723      & -1,  0, -1, -1, -1,  0,  1,  0,  1,  1,  0,  1, -1,  0,  1,
29724      & -1,  0,  0,  1, -1,  0,  1, -1,  0,  0,  1, -1,  0,  0,  0,
29725      &  0,  1,  1,  0,  2,  1,  0,  1,  0,  0,  2,  1,  1, -1, -1,
29726      &  0, -2, -1,  0, -1,  0,  0, -2, -1, -1,  2,  1,  0,  1,  0,
29727      &  0,  2,  1,  1,  2, -2, -1,  0, -1,  0,  0, -2, -1, -1, -2,
29728      &  0,  1, -1, -1,  0,  1,  0, -1,  0,  1, -1,  0,  0,  0,  0,
29729      &  1,  0, -1, -1,  0,  1,  0, -1,  0,  1, -1,  1,  1,  0,  0/
29730 * Particle  baryonic charges
29731       DATA (IIBAR ( I ), I =   1,210 ) /
29732      &  1, -1,  0,  0,  0,  0,  0,  1, -1,  0,  0,  0,  0,  0,  0,
29733      &  0,  1, -1,  0,  1,  1,  1,  0,  0,  0,  0,  0,  0,  0,  0,
29734      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
29735      &  0,  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
29736      &  1,  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
29737      & -1,  2,  0,  0,  0,  1,  1,  1,  1,  2,  2,  0,  0,  1,  1,
29738      &  1,  1,  1,  1,  0,  0,  1,  1, -1, -1, -1, -1, -1,  1,  1,
29739      &  1,  1,  1,  1, -1, -1, -1, -1, -1, -1,  0,  0,  0,  0,  0,
29740      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
29741      &  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1, -1, -1,
29742      & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,  1,  1,  1,  1,  1,
29743      &  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
29744      &  0,  0,  0, -1, -1,  0,  0,  0,  0,  0,  0,  0,  0,  1, -1,
29745      &  1,  1,  1, -1, -1, -1,  1,  1, -1, -1,  1, -1,  1,  1,  0/
29746 * First number of decay channels used for resonances
29747 * and decaying particles
29748       DATA K1/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 16, 17,
29749      &  18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
29750      &   2*330, 46, 51, 52, 54, 55, 58,
29751 *                                                             50
29752      &  60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
29753      & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
29754      & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
29755 *                                         85
29756      & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
29757      & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
29758      & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
29759      & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
29760      & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
29761      & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
29762      & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
29763      & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
29764      & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
29765      & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
29766      & 590, 596, 602 /
29767 * Last number of decay channels used for resonances
29768 * and decaying particles
29769       DATA K2/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 15, 16, 17,
29770      & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
29771      & 2* 330, 50, 51, 53, 54, 57,
29772 *                                                                 50
29773      & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
29774      & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
29775      & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
29776 *                                              85
29777      & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
29778      & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
29779      & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
29780      & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
29781      & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
29782      & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
29783      & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
29784      & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
29785      & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
29786      & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
29787      & 589, 595, 601, 602 /
29788
29789        END
29790 *
29791 *===blkd47=============================================================*
29792 *
29793 CDECK  ID>, DT_BLKD47
29794       BLOCK DATA DT_BLKD47
29795
29796       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29797       SAVE
29798
29799 * HADRIN: decay channel information
29800       PARAMETER (IDMAX9=602)
29801       CHARACTER*8 ZKNAME
29802       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
29803
29804 * Name of decay channel
29805 * Designation N*@ means N*@1(1236)
29806 * @1=# means ++,  @1 = = means --
29807 * Designation  P+/0/- means Pi+/Pi0/Pi- , respectively
29808       DATA (ZKNAME(K),K=  1, 85) /
29809      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
29810      &  'ANUE    ','GAM     ','PE-NUE  ','APEANU  ','EANUNU  ',
29811      &  'E-NUAN  ','3PI0    ','PI+-0   ','PIMUNU  ','PIE-NU  ',
29812      &  'MU+NUE  ','MU-NUE  ','MU+NUE  ','PI+PI0  ','PI++-   ',
29813      &  'PI+00   ','M+P0NU  ','E+P0NU  ','MU-NU   ','PI-0    ',
29814      &  'PI+--   ','PI-00   ','M-P0NU  ','E-P0NU  ','PPI-    ',
29815      &  'NPI0    ','PD-NUE  ','PM-NUE  ','APPI+   ','ANPI0   ',
29816      &  'APE+NU  ','APM+NU  ','PI+PI-  ','PI0PI0  ','NPI-    ',
29817      &  'PPI0    ','NPI+    ','LAGA    ','GAGA    ','GAE+E-  ',
29818      &  'GAGA    ','GAGAP0  ','PI000   ','PI+-0   ','PI+-GA  ',
29819      &  'PI+0    ','PI+-    ','PI00    ','PI-0    ','PI+-0   ',
29820      &  'PI+-    ','PI0GA   ','K+PI0   ','K0PI+   ','KOPI0   ',
29821      &  'K+PI-   ','K-PI0   ','AK0PI-  ','AK0PI0  ','K-PI+   ',
29822      &  'K+PI0   ','K0PI+   ','K0PI0   ','K+PI-   ','K-PI0   ',
29823      &  'K0PI-   ','AK0PI0  ','K-PI+   ','K+PI0   ','K0PI+   ',
29824      &  'K+89P0  ','K08PI+  ','K+RO77  ','K0RO+7  ','K+OM07  ',
29825      &  'K+E055  ','K0PI0   ','K+PI+   ','K089P0  ','K+8PI-  '  /
29826       DATA (ZKNAME(K),K= 86,170) /
29827      &  'K0R077  ','K+R-77  ','K+R-77  ','K0OM07  ','K0E055  ',
29828      &  'K-PI0   ','K0PI-   ','K-89P0  ','AK08P-  ','K-R077  ',
29829      &  'AK0R-7  ','K-OM07  ','K-E055  ','AK0PI0  ','K-PI+   ',
29830      &  'AK08P0  ','K-8PI+  ','AK0R07  ','AK0OM7  ','AK0E05  ',
29831      &  'LA0PI+  ','SI0PI+  ','SI+PI0  ','LA0PI0  ','SI+PI-  ',
29832      &  'SI-PI+  ','LA0PI-  ','SI0PI-  ','NEUAK0  ','PK-     ',
29833      &  'SI+PI-  ','SI0PI0  ','SI-PI+  ','LA0ET0  ','S+1PI-  ',
29834      &  'S-1PI+  ','SO1PI0  ','NEUAK0  ','PK-     ','LA0PI0  ',
29835      &  'LA0OM0  ','LA0RO0  ','SI+RO-  ','SI-RO+  ','SI0RO0  ',
29836      &  'LA0ET0  ','SI0ET0  ','SI+PI-  ','SI-PI+  ','SI0PI0  ',
29837      &  'K0S     ','K0L     ','K0S     ','K0L     ','P PI+   ',
29838      &  'P PI0   ','N PI+   ','P PI-   ','N PI0   ','N PI-   ',
29839      &  'P PI+   ','N*#PI0  ','N*+PI+  ','PRHO+   ','P PI0   ',
29840      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
29841      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
29842      &  'N*-PI+  ','PRHO-   ','NRHO0   ','N PI-   ','N*0PI-  ',
29843      &  'N*-PI0  ','NRHO-   ','PETA0   ','N*#PI-  ','N*+PI0  '  /
29844       DATA (ZKNAME(K),K=171,255) /
29845      &  'N*0PI+  ','PRHO0   ','NRHO+   ','NETA0   ','N*+PI-  ',
29846      &  'N*0PI0  ','N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ',
29847      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
29848      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
29849      &  'N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ','N PI+   ',
29850      &  'PRHO0   ','NRHO+   ','LAMK+   ','S+ K0   ','S0 K+   ',
29851      &  'PETA0   ','P PI-   ','N PI0   ','PRHO-   ','NRHO0   ',
29852      &  'LAMK0   ','S0 K0   ','S- K+   ','NETA/   ','APPI-   ',
29853      &  'APPI0   ','ANPI-   ','APPI+   ','ANPI0   ','ANPI+   ',
29854      &  'APPI-   ','AN*=P0  ','AN*-P-  ','APRHO-  ','APPI0   ',
29855      &  'ANPI-   ','AN*=P+  ','AN*-P0  ','AN*0P-  ','APRHO0  ',
29856      &  'ANRHO-  ','APPI+   ','ANPI0   ','AN*-P+  ','AN*0P0  ',
29857      &  'AN*+P-  ','APRHO+  ','ANRHO0  ','ANPI+   ','AN*0P+  ',
29858      &  'AN*+P0  ','ANRHO+  ','APPI0   ','ANPI-   ','AN*=P+  ',
29859      &  'AN*-P0  ','AN*0P-  ','APRHO0  ','ANRHO-  ','APPI+,  ',
29860      &  'ANPI0   ','AN*-P+  ','AN*0P0  ','AN*+P-  ','APRHO+  ',
29861      &  'ANRHO0  ','PN*014  ','NN*=14  ','PI+0    ','PI+-    '  /
29862       DATA (ZKNAME(K),K=256,340) /
29863      &  'PI-0    ','P+0     ','N++     ','P+-     ','P00     ',
29864      &  'N+0     ','N+-     ','N00     ','P-0     ','N-0     ',
29865      &  'P--     ','PPPI0   ','PNPI+   ','PNPI0   ','PPPI-   ',
29866      &  'NNPI+   ','APPPI0  ','APNPI+  ','ANNPI0  ','ANPPI-  ',
29867      &  'APNPI0  ','APPPI-  ','ANNPI-  ','K+PPI0  ','K+NPI+  ',
29868      &  'K0PPI0  ','K-PPI0  ','K-NPI+  ','AKPPI-  ','AKNPI0  ',
29869      &  'K+NPI0  ','K+PPI-  ','K0PPI0  ','K0NPI+  ','K-NPI0  ',
29870      &  'K-PPI-  ','AKNPI-  ','PAK0    ','SI+PI0  ','SI0PI+  ',
29871      &  'SI+ETA  ','S+1PI0  ','S01PI+  ','NEUK-   ','LA0PI-  ',
29872      &  'SI-OM0  ','LA0RO-  ','SI0RO-  ','SI-RO0  ','SI-ET0  ',
29873      &  'SI0PI-  ','SI-0    ','BLANC   ','BLANC   ','BLANC   ',
29874      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
29875      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
29876      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
29877      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
29878      &  'EPI+-   ','EPI00   ','GAPI+-  ','GAGA*   ','K+-     ',
29879      &  'KLKS    ','PI+-0   ','EGA     ','LPI0    ','LPI     '  /
29880       DATA (ZKNAME(K),K=341,425) /
29881      &  'APPI0   ','ANPI-   ','ALAGA   ','ANPI    ','ALPI0   ',
29882      &  'ALPI+   ','LAPI+   ','SI+PI0  ','SI0PI+  ','LAPI0   ',
29883      &  'SI+PI-  ','SI-PI+  ','LAPI-   ','SI-PI0  ','SI0PI-  ',
29884      &  'TE0PI0  ','TE-PI+  ','TE0PI-  ','TE-PI0  ','TE0PI   ',
29885      &  'TE-PI   ','LAK-    ','ALPI-   ','AS-PI0  ','AS0PI-  ',
29886      &  'ALPI0   ','AS+PI-  ','AS-PI+  ','ALPI+   ','AS+PI0  ',
29887      &  'AS0PI+  ','AT0PI0  ','AT+PI-  ','AT0PI+  ','AT+PI0  ',
29888      &  'AT0PI   ','AT+PI   ','ALK+    ','K-PI+   ','K-PI+0  ',
29889      &  'K0PI+-  ','K0PI0   ','K-PI++  ','AK0PI+  ','K+PI--  ',
29890      &  'K0PI-   ','K+PI-   ','K+PI-0  ','AKPI-+  ','AK0PI0  ',
29891      &  'ETAPIF  ','K++-    ','K+AK0   ','ETAPI-  ','K--+    ',
29892      &  'K-K0    ','PI00    ','PI+-    ','GAGA    ','D0PI0   ',
29893      &  'D0GA    ','D0PI+   ','D+PI0   ','DFGA    ','AD0PI-  ',
29894      &  'D-PI0   ','D-GA    ','AD0PI0  ','AD0GA   ','F+GA    ',
29895      &  'F+GA    ','F-GA    ','F-GA    ','PSPI+-  ','PSPI00  ',
29896      &  'PSETA   ','E+E-    ','MUE+-   ','PI+-0   ','M+NN    ',
29897      &  'E+NN    ','RHO+NT  ','PI+ANT  ','K*+ANT  ','M-NN    '  /
29898       DATA (ZKNAME(K),K=426,510) /
29899      &  'E-NN    ','RHO-NT  ','PI-NT   ','K*-NT   ','NUET    ',
29900      &  'ANUET   ','NUEM    ','ANUEM   ','SI+ETA  ','SI+ET*  ',
29901      &  'PAK0    ','TET0K+  ','SI*+ET  ','N*+AK0  ','N*++K-  ',
29902      &  'LAMRO+  ','SI0RO+  ','SI+RO0  ','SI+OME  ','PAK*0   ',
29903      &  'N*+AK*  ','N*++K*  ','SI+AK0  ','TET0PI  ','SI+AK*  ',
29904      &  'TET0RO  ','SI0AK*  ','SI+K*-  ','TET0OM  ','TET-RO  ',
29905      &  'SI*0AK  ','C0+PI+  ','C0+PI0  ','C0+PI-  ','A+GAM   ',
29906      &  'A0GAM   ','TET0AK  ','TET0K*  ','OM-RO+  ','OM-PI+  ',
29907      &  'C1++AK  ','A+PI+   ','C0+AK0  ','A0PI+   ','A+AK0   ',
29908      &  'T0PI+   ','ASI-ET  ','ASI-E*  ','APK0    ','ATET0K  ',
29909      &  'ASI*-E  ','AN*-K0  ','AN*--K  ','ALAMRO  ','ASI0RO  ',
29910      &  'ASI-RO  ','ASI-OM  ','APK*0   ','AN*-K*  ','AN*--K  ',
29911      &  'ASI-K0  ','ATETPI  ','ASI-K*  ','ATETRO  ','ASI0K*  ',
29912      &  'ASI-K*  ','ATE0OM  ','ATE+RO  ','ASI*0K  ','AC-PI-  ',
29913      &  'AC-PI0  ','AC-PI+  ','AA-GAM  ','AA0GAM  ','ATET0K  ',
29914      &  'ATE0K*  ','AOM+RO  ','AOM+PI  ','AC1--K  ','AA-PI-  ',
29915      &  'AC0-K0  ','AA0PI-  ','AA-K0   ','AT0PI-  ','C1++GA  '  /
29916       DATA (ZKNAME(K),K=511,540) /
29917      &  'C1++GA  ','C10GAM  ','S+GAM   ','S0GAM   ','T0GAM   ',
29918      &  'XU++GA  ','XD+GAM  ','XS+GAM  ','A+AKPI  ','T02PI+  ',
29919      &  'C1++2K  ','AC1--G  ','AC1-GA  ','AC10GA  ','AS-GAM  ',
29920      &  'AS0GAM  ','AT0GAM  ','AXU--G  ','AXD-GA  ','AXS-GA  ',
29921      &  'AA-KPI  ','AT02PI  ','AC1--K  ','RH-PI+  ','RH+PI-  ',
29922      &  'RH3PI0  ','RH0PI+  ','RH+PI0  ','RH0PI-  ','RH-PI0  '  /
29923       DATA (ZKNAME(I),I=541,602)/
29924      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
29925      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
29926      & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
29927      & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
29928      & 'PI+PI-','K+K-  ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
29929      & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
29930      & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
29931      & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
29932      & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
29933 * Weight of decay channel
29934       DATA (WT(K),K=  1, 85) /
29935      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
29936      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
29937      &   .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
29938      &   .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
29939      &   .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
29940      &   .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
29941      &   .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
29942      &   .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
29943      &   .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
29944      &   .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
29945      &   .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
29946      &   .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
29947      &   .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
29948      &   .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
29949      &   .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
29950      &   .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
29951      &   .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00  /
29952       DATA (WT(K),K= 86,170) /
29953      &   .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
29954      &   .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
29955      &   .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
29956      &   .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
29957      &   .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
29958      &   .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
29959      &   .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
29960      &   .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
29961      &   .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
29962      &   .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
29963      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
29964      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
29965      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
29966      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
29967      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
29968      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
29969      &   .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00  /
29970       DATA (WT(K),K=171,255) /
29971      &   .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
29972      &   .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
29973      &   .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
29974      &   .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
29975      &   .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
29976      &   .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
29977      &   .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
29978      &   .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
29979      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
29980      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
29981      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
29982      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
29983      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
29984      &   .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
29985      &   .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
29986      &   .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
29987      &   .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01  /
29988       DATA (WT(K),K=256,340) /
29989      &   .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
29990      &   .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
29991      &   .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
29992      &   .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
29993      &   .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
29994      &   .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
29995      &   .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
29996      &   .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
29997      &   .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
29998      &   .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
29999      &   .5000D-01, .5000D-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      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30003      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30004      &   .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
30005      &   .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01  /
30006       DATA (WT(K),K=341,425) /
30007      &   .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
30008      &   .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
30009      &   .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
30010      &   .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
30011      &   .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
30012      &   .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
30013      &   .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
30014      &   .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
30015      &   .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
30016      &   .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
30017      &   .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
30018      &   .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
30019      &   .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
30020      &   .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
30021      &   .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
30022      &   .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
30023      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00  /
30024       DATA (WT(K),K=426,510) /
30025      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
30026      &   .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
30027      &   .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
30028      &   .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
30029      &   .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
30030      &   .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
30031      &   .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30032      &   .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
30033      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
30034      &   .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
30035      &   .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
30036      &   .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
30037      &   .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
30038      &   .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
30039      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
30040      &   .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
30041      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01  /
30042       DATA (WT(K),K=511,540) /
30043      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30044      &   .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
30045      &   .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30046      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30047      &   .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
30048      &   .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00  /
30049 C
30050       DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
30051      & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
30052      & .125D+00,  0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
30053      & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
30054      & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
30055      & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
30056      & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
30057 * Particle numbers in decay channel
30058       DATA (NZK(K,1),K=  1,170) /
30059      &     1,   2,   3,   4,   5,   6,   7,   1,   2,   4,
30060      &     3,  23,  13,  13,  13,  10,  11,  10,  13,  13,
30061      &    13,  10,   4,  11,  14,  14,  14,  11,   3,   1,
30062      &     8,   1,   1,   2,   9,   2,   2,  13,  23,   8,
30063      &     1,   8,  17,   7,   7,   7,  23,  23,  13,  13,
30064      &    13,  13,  23,  14,  13,  13,  23,  15,  24,  24,
30065      &    15,  16,  25,  25,  16,  15,  24,  24,  15,  16,
30066      &    24,  25,  16,  15,  24,  36,  37,  15,  24,  15,
30067      &    15,  24,  15,  37,  36,  24,  15,  24,  24,  16,
30068      &    24,  38,  39,  16,  25,  16,  16,  25,  16,  39,
30069      &    38,  25,  16,  25,  25,  17,  22,  21,  17,  21,
30070      &    20,  17,  22,   8,   1,  21,  22,  20,  17,  48,
30071      &    50,  49,   8,   1,  17,  17,  17,  21,  20,  22,
30072      &    17,  22,  21,  20,  22,  19,  12,  19,  12,   1,
30073      &     1,   8,   1,   8,   8,   1,  53,  54,   1,   1,
30074      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
30075      &    56,   1,   8,   8,  55,  56,   8,   1,  53,  54  /
30076       DATA (NZK(K,1),K=171,340) /
30077      &    55,   1,   8,   8,  54,  55,  56,   1,   8,   1,
30078      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
30079      &    56,   1,   8,   1,   8,   1,   8,  17,  21,  22,
30080      &     1,   1,   8,   1,   8,  17,  22,  20,   8,   2,
30081      &     2,   9,   2,   9,   9,   2,  67,  68,   2,   2,
30082      &     9,  67,  68,  69,   2,   9,   2,   9,  68,  69,
30083      &    70,   2,   9,   9,  69,  70,   9,   2,   9,  67,
30084      &    68,  69,   2,   9,   2,   9,  68,  69,  70,   2,
30085      &     9,   1,   8,  13,  13,  14,   1,   8,   1,   1,
30086      &     8,   8,   8,   1,   8,   1,   1,   1,   1,   1,
30087      &     8,   2,   2,   9,   9,   2,   2,   9,  15,  15,
30088      &    24,  16,  16,  25,  25,  15,  15,  24,  24,  16,
30089      &    16,  25,   1,  21,  22,  21,  48,  49,   8,  17,
30090      &    20,  17,  22,  20,  20,  22,  20,   0,   0,   0,
30091      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
30092      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
30093      &    31,  31,  13,   7,  15,  12,  13,  31,  17,  17  /
30094       DATA (NZK(K,1),K=341,510) /
30095      &     2,   9,  18,   9,  18,  18,  17,  21,  22,  17,
30096      &    21,  20,  17,  20,  22,  97,  98,  97,  98,  97,
30097      &    98,  17,  18,  99, 100,  18, 101,  99,  18, 101,
30098      &   100, 102, 103, 102, 103, 102, 103,  18,  16,  16,
30099      &    24,  24,  16,  25,  15,  24,  15,  15,  25,  25,
30100      &    31,  15,  15,  31,  16,  16,  23,  13,   7, 116,
30101      &   116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
30102      &   120, 121, 121, 130, 130, 130,   4,  10,  13,  10,
30103      &     4,  32,  13,  36,  11,   3,  34,  14,  38, 133,
30104      &   134, 135, 136,  21,  21,   1,  97, 104,  54,  53,
30105      &    17,  22,  21,  21,   1,  54,  53,  21,  97,  21,
30106      &    97,  22,  21,  97,  98, 105, 137, 137, 137, 138,
30107      &   139,  97,  97, 109, 109, 140, 138, 137, 139, 138,
30108      &   145,  99,  99,   2, 102, 110,  68,  67,  18, 100,
30109      &    99,  99,   2,  68,  67,  99, 102,  99, 102, 100,
30110      &    99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
30111      &   113, 115, 115, 152, 150, 149, 151, 150, 157, 140  /
30112       DATA (NZK(K,1),K=511,540) /
30113      &   141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
30114      &   140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
30115      &   150, 157, 152,  34,  32,  33,  33,  32,  33,  34  /
30116       DATA (NZK(I,1),I=541,602) /  2, 67, 68, 69,  2,  9,  9, 68, 69,
30117      & 70,  2,  9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
30118      & 14, 189, 23, 13, 15, 24,  36,  38,  37,  39, 194, 195, 196, 197,
30119      & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
30120      & 55, 8, 1, 8, 8, 54, 55, 210/
30121       DATA (NZK(K,2),K=  1,170) /
30122      &     0,   0,   0,   0,   0,   0,   0,   3,   4,   6,
30123      &     5,  23,  14,  11,   3,   5,   5,   5,  23,  13,
30124      &    23,  23,  23,   5,  23,  13,  23,  23,  23,  14,
30125      &    23,   3,  11,  13,  23,   4,  10,  14,  23,  14,
30126      &    23,  13,   7,   7,   4,   7,   7,  23,  14,  14,
30127      &    23,  14,  23,  23,  14,  14,   7,  23,  13,  23,
30128      &    14,  23,  14,  23,  13,  23,  13,  23,  14,  23,
30129      &    14,  23,  13,  23,  13,  23,  13,  33,  32,  35,
30130      &    31,  23,  14,  23,  14,  33,  34,  35,  31,  23,
30131      &    14,  23,  14,  33,  34,  35,  31,  23,  13,  23,
30132      &    13,  33,  32,  35,  31,  13,  13,  23,  23,  14,
30133      &    13,  14,  14,  25,  16,  14,  23,  13,  31,  14,
30134      &    13,  23,  25,  16,  23,  35,  33,  34,  32,  33,
30135      &    31,  31,  14,  13,  23,   0,   0,   0,   0,  13,
30136      &    23,  13,  14,  23,  14,  13,  23,  13,  78,  23,
30137      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
30138      &    13,  80,  79,  14,  14,  23,  80,  31,  14,  23  /
30139       DATA (NZK(K,2),K=171,340) /
30140      &    13,  79,  78,  31,  14,  23,  13,  80,  79,  23,
30141      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
30142      &    13,  80,  79,  23,  13,  33,  32,  15,  24,  15,
30143      &    31,  14,  23,  34,  33,  24,  24,  15,  31,  14,
30144      &    23,  14,  13,  23,  13,  14,  23,  14,  80,  23,
30145      &    14,  13,  23,  14,  79,  80,  13,  23,  13,  23,
30146      &    14,  78,  79,  13,  13,  23,  78,  23,  14,  13,
30147      &    23,  14,  79,  80,  13,  23,  13,  23,  14,  78,
30148      &    79,  62,  61,  23,  14,  23,  13,  13,  13,  23,
30149      &    13,  13,  23,  14,  14,  14,   1,   8,   8,   1,
30150      &     8,   1,   8,   8,   1,   8,   1,   8,   1,   8,
30151      &     1,   1,   8,   1,   8,   8,   1,   1,   8,   8,
30152      &     1,   8,  25,  23,  13,  31,  23,  13,  16,  14,
30153      &    35,  34,  34,  33,  31,  14,  23,   0,   0,   0,
30154      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
30155      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
30156      &    13,  23,  14,   7,  16,  19,  14,   7,  23,  14  /
30157       DATA (NZK(K,2),K=341,510) /
30158      &    23,  14,   7,  13,  23,  13,  13,  23,  13,  23,
30159      &    14,  13,  14,  23,  14,  23,  13,  14,  23,  14,
30160      &    23,  16,  14,  23,  14,  23,  14,  13,  13,  23,
30161      &    13,  23,  14,  13,  23,  13,  23,  15,  13,  13,
30162      &    13,  23,  13,  13,  14,  14,  14,  14,  14,  23,
30163      &    13,  16,  25,  14,  15,  24,  23,  14,   7,  23,
30164      &     7,  13,  23,   7,  14,  23,   7,  23,   7,   7,
30165      &     7,   7,   7,  13,  23,  31,   3,  11,  14, 135,
30166      &     5, 134, 134, 134, 136,   6, 133, 133, 133,   0,
30167      &     0,   0,   0,  31,  95,  25,  15,  31,  95,  16,
30168      &    32,  32,  33,  35,  39,  39,  38,  25,  13,  39,
30169      &    32,  39,  38,  35,  32,  39,  13,  23,  14,   7,
30170      &     7,  25,  37,  32,  13,  25,  13,  25,  13,  25,
30171      &    13,  31,  95,  24,  16,  31,  24,  15,  34,  34,
30172      &    33,  35,  37,  37,  36,  24,  14,  37,  34,  37,
30173      &    36,  35,  34,  37,  14,  23,  13,   7,   7,  24,
30174      &    39,  34,  14,  24,  14,  24,  14,  24,  14,   7  /
30175       DATA (NZK(K,2),K=511,540) /
30176      &     7,   7,   7,   7,   7,   7,   7,   7,  25,  13,
30177      &    25,   7,   7,   7,   7,   7,   7,   7,   7,   7,
30178      &    24,  14,  24,  13,  14,  23,  13,  23,  14,  23  /
30179       DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
30180      & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
30181      & 14, 14, 23, 14, 16, 25,
30182      & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
30183      & 23, 13, 14, 23,  0 /
30184       DATA (NZK(K,3),K=  1,170) /
30185      &     0,   0,   0,   0,   0,   0,   0,   5,   6,   5,
30186      &     6,  23,  23,   5,   5,   0,   0,   0,   0,  14,
30187      &    23,   5,   5,   0,   0,  14,  23,   5,   5,   0,
30188      &     0,   5,   5,   0,   0,   5,   5,   0,   0,   0,
30189      &     0,   0,   0,   0,   3,   0,   7,  23,  23,   7,
30190      &     0,   0,   0,   0,  23,   0,   0,   0,   0,   0,
30191      &     110*0   /
30192       DATA (NZK(K,3),K=171,340) /
30193      &     80*0,
30194      &     0,   0,   0,   0,   0,   0,  23,  13,  14,  23,
30195      &    23,  14,  23,  23,  23,  14,  23,  13,  23,  14,
30196      &    13,  23,  13,  23,  14,  23,  14,  14,  23,  13,
30197      &    13,  23,  13,  14,  23,  23,  14,  23,  13,  23,
30198      &    14,  14,   0,   0,   0,   0,   0,   0,   0,   0,
30199      &     30*0,
30200      &    14,  23,   7,   0,   0,   0,  23,   0,   0,   0  /
30201       DATA (NZK(K,3),K=341,510) /
30202      &     30*0,
30203      &     0,   0,   0,   0,   0,   0,   0,   0,   0,  23,
30204      &    14,   0,  13,   0,  14,   0,   0,  23,  13,   0,
30205      &     0,  15,   0,   0,  16,   0,   0,   0,   0,   0,
30206      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
30207      &     0,   0,   0,  14,  23,   0,   0,   0,  23, 134,
30208      &   134,   0,   0,   0, 133, 133,   0,   0,   0,   0,
30209      &     80*0  /
30210       DATA (NZK(K,3),K=511,540) /
30211      &     0,   0,   0,   0,   0,   0,   0,   0,  13,  13,
30212      &    25,   0,   0,   0,   0,   0,   0,   0,   0,   0,
30213      &    14,  14,  24,   0,   0,   0,   0,   0,   0,   0  /
30214       DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
30215      & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
30216
30217       END
30218
30219 *
30220 *====phoini============================================================*
30221 *
30222 CDECK  ID>, DT_XHOINI
30223       SUBROUTINE DT_XHOINI
30224 C     SUBROUTINE DT_PHOINI
30225
30226       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30227       SAVE
30228
30229       PARAMETER ( LINP = 5 ,
30230      &            LOUT = 6 ,
30231      &            LDAT = 9 )
30232
30233       RETURN
30234       END
30235 *
30236 *====eventb============================================================*
30237 *
30238 CDECK  ID>, DT_XVENTB
30239       SUBROUTINE DT_XVENTB(NCSY,IREJ)
30240 C     SUBROUTINE DT_EVENTB(NCSY,IREJ)
30241
30242       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30243       SAVE
30244
30245       PARAMETER ( LINP = 5 ,
30246      &            LOUT = 6 ,
30247      &            LDAT = 9 )
30248
30249       WRITE(LOUT,1000)
30250  1000 FORMAT(1X,'EVENTB:   PHOJET-package requested but not linked!')
30251       STOP
30252
30253       END
30254 *
30255 *===event==============================================================*
30256 *
30257 CDECK  ID>, DT_XVENT
30258       SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
30259 C     SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
30260
30261       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30262       SAVE
30263
30264       DIMENSION PP(4),PT(4)
30265
30266       RETURN
30267       END
30268 *
30269 *===pohisx=============================================================*
30270 *
30271 CDECK  ID>, DT_XOHISX
30272       SUBROUTINE DT_XOHISX(I,X)
30273 C     SUBROUTINE POHISX(I,X)
30274
30275       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30276       SAVE
30277
30278       RETURN
30279       END
30280 *
30281 *===poluhi=============================================================*
30282 *
30283 **PHOJET105a
30284 C     SUBROUTINE XOLUHI(I,X)
30285 **PHOJET112
30286
30287 CDECK  ID>, PHO_LHIST
30288       SUBROUTINE PHO_LHIST(I,X)
30289
30290 **
30291
30292       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30293       SAVE
30294
30295       RETURN
30296       END
30297 *
30298 CDECK  ID>, PDFSET
30299 C**********************************************************************
30300 C
30301 C   dummy subroutines, remove to link PDFLIB
30302 C
30303 C**********************************************************************
30304       SUBROUTINE PDFSET(PARAM,VALUE)
30305       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30306       DIMENSION PARAM(20),VALUE(20)
30307       CHARACTER*20 PARAM
30308       END
30309 CDECK  ID>, STRUCTM
30310       SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
30311       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30312       END
30313 CDECK  ID>, STRUCTP
30314       SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
30315       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30316       END
30317 *
30318 *===diqbrk=============================================================*
30319 *
30320 CDECK  ID>, DT_DIQBRK
30321       SUBROUTINE DT_XIQBRK
30322 C     SUBROUTINE DT_DIQBRK
30323
30324       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30325       SAVE
30326
30327       STOP 'diquark-breaking not implemeted !'
30328
30329       RETURN
30330       END
30331 *
30332 *===pho_rndm===========================================================*
30333 *
30334 CDECK  ID>, PHO_RNDM
30335       DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
30336
30337       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30338       SAVE
30339
30340       PHO_RNDM = DT_RNDM(DUMMY)
30341
30342       RETURN
30343       END
30344 *
30345 *===pyr================================================================*
30346 *
30347 CDECK  ID>, PYR
30348       DOUBLE PRECISION FUNCTION PYR(IDUMMY)
30349
30350       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30351       SAVE
30352
30353       DUMMY = DBLE(IDUMMY)
30354       PYR = DT_RNDM(DUMMY)
30355
30356       RETURN
30357       END
30358 *
30359 *===elhain=============================================================*
30360 *
30361 CDECK  ID>, DT_ELHAIN
30362       SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
30363
30364 ************************************************************************
30365 * Elastic hadron-hadron scattering.                                    *
30366 * This is a revised version of the original.                           *
30367 * This version dated 03.04.98 is written by S. Roesler                 *
30368 ************************************************************************
30369
30370       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30371       SAVE
30372
30373       PARAMETER ( LINP = 5 ,
30374      &            LOUT = 6 ,
30375      &            LDAT = 9 )
30376
30377       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
30378      &           TINY10=1.0D-10)
30379
30380       PARAMETER (ENNTHR = 3.5D0)
30381       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
30382      &           BLOWB=0.05D0,BHIB=0.2D0,
30383      &           BLOWM=0.1D0, BHIM=2.0D0)
30384
30385 * particle properties (BAMJET index convention)
30386       CHARACTER*8  ANAME
30387       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
30388      &                IICH(210),IIBAR(210),K1(210),K2(210)
30389 * final state from HADRIN interaction
30390       PARAMETER (MAXFIN=10)
30391       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
30392      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
30393
30394 C     DATA TSLOPE /10.0D0/
30395
30396       IREJ = 0
30397
30398     1 CONTINUE
30399
30400       PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
30401       EKIN = ELAB-AAM(IP)
30402 *   kinematical quantities in cms of the hadrons
30403       AMP2 = AAM(IP)**2
30404       AMT2 = AAM(IT)**2
30405       S    = AMP2+AMT2+TWO*ELAB*AAM(IT)
30406       ECM  = SQRT(S)
30407       ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
30408       PCM  = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
30409
30410 * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
30411       IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
30412      &     ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
30413 *   TSAMCS treats pp and np only, therefore change pn into np and
30414 *   nn into pp
30415          IF (IT.EQ.1) THEN
30416             KPROJ = IP
30417          ELSE
30418             KPROJ = 8
30419             IF (IP.EQ.8) KPROJ = 1
30420          ENDIF
30421          CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
30422          T = TWO*PCM**2*(CTCMS-ONE)
30423
30424 * very crude treatment otherwise: sample t from exponential dist.
30425       ELSE
30426 *   momentum transfer t
30427          TMAX = TWO*TWO*PCM**2
30428          RR = (PLAB-PLOWH)/(PHIH-PLOWH)
30429          IF (IIBAR(IP).NE.0) THEN
30430             TSLOPE = BLOWB+RR*(BHIB-BLOWB)
30431          ELSE
30432             TSLOPE = BLOWM+RR*(BHIM-BLOWM)
30433          ENDIF
30434          FMAX = EXP(-TSLOPE*TMAX)-ONE
30435          R = DT_RNDM(RR)
30436          T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
30437          IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
30438       ENDIF
30439
30440 *   target hadron in Lab after scattering
30441       ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
30442       PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
30443       IF (PLRH(2).LE.TINY10) THEN
30444 C        WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
30445          GOTO 1
30446       ENDIF
30447 *   projectile hadron in Lab after scattering
30448       ELRH(1) = ELAB+AAM(IT)-ELRH(2)
30449       PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
30450 *   scattering angle of projectile in Lab
30451       CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
30452       STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
30453       CALL DT_DSFECF(SPLABP,CPLABP)
30454 *   direction cosines of projectile in Lab
30455       CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
30456      &                          CXRH(1),CYRH(1),CZRH(1))
30457 *   scattering angle of target in Lab
30458       PLLABT = PLAB-CTLABP*PLRH(1)
30459       CTLABT = PLLABT/PLRH(2)
30460       STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
30461 *   direction cosines of target in Lab
30462       CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
30463      &                            CXRH(2),CYRH(2),CZRH(2))
30464 *   fill /HNFSPA/
30465       IRH = 2
30466       ITRH(1) = IP
30467       ITRH(2) = IT
30468
30469       RETURN
30470       END
30471 *
30472 *===tsamcs=============================================================*
30473 *
30474 CDECK  ID>, DT_TSAMCS
30475       SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
30476
30477 ************************************************************************
30478 * Sampling of cos(theta) for nucleon-proton scattering according to    *
30479 * hetkfa2/bertini parametrization.                                     *
30480 * This is a revised version of the original (HJM 24/10/88)             *
30481 * This version dated 28.10.95 is written by S. Roesler                 *
30482 ************************************************************************
30483
30484       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30485       SAVE
30486
30487       PARAMETER ( LINP = 5 ,
30488      &            LOUT = 6 ,
30489      &            LDAT = 9 )
30490
30491       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
30492      &           TINY10=1.0D-10)
30493
30494       DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
30495       DIMENSION PDCI(60),PDCH(55)
30496
30497       DATA (DCLIN(I),I=1,80) /
30498      &     5.000D-01,  1.000D+00,  0.000D+00,  1.000D+00,  0.000D+00,
30499      &     4.993D-01,  9.881D-01,  5.963D-02,  9.851D-01,  5.945D-02,
30500      &     4.936D-01,  8.955D-01,  5.224D-01,  8.727D-01,  5.091D-01,
30501      &     4.889D-01,  8.228D-01,  8.859D-01,  7.871D-01,  8.518D-01,
30502      &     4.874D-01,  7.580D-01,  1.210D+00,  7.207D-01,  1.117D+00,
30503      &     4.912D-01,  6.969D-01,  1.516D+00,  6.728D-01,  1.309D+00,
30504      &     5.075D-01,  6.471D-01,  1.765D+00,  6.667D-01,  1.333D+00,
30505      &     5.383D-01,  6.054D-01,  1.973D+00,  7.059D-01,  1.176D+00,
30506      &     5.397D-01,  5.990D-01,  2.005D+00,  7.023D-01,  1.191D+00,
30507      &     5.336D-01,  6.083D-01,  1.958D+00,  6.959D-01,  1.216D+00,
30508      &     5.317D-01,  6.075D-01,  1.962D+00,  6.897D-01,  1.241D+00,
30509      &     5.300D-01,  6.016D-01,  1.992D+00,  6.786D-01,  1.286D+00,
30510      &     5.281D-01,  6.063D-01,  1.969D+00,  6.786D-01,  1.286D+00,
30511      &     5.280D-01,  5.960D-01,  2.020D+00,  6.667D-01,  1.333D+00,
30512      &     5.273D-01,  5.920D-01,  2.040D+00,  6.604D-01,  1.358D+00,
30513      &     5.273D-01,  5.862D-01,  2.069D+00,  6.538D-01,  1.385D+00/
30514       DATA (DCLIN(I),I=81,160) /
30515      &     5.223D-01,  5.980D-01,  2.814D+00,  6.538D-01,  1.385D+00,
30516      &     5.202D-01,  5.969D-01,  2.822D+00,  6.471D-01,  1.412D+00,
30517      &     5.183D-01,  5.881D-01,  2.883D+00,  6.327D-01,  1.469D+00,
30518      &     5.159D-01,  5.866D-01,  2.894D+00,  6.250D-01,  1.500D+00,
30519      &     5.133D-01,  5.850D-01,  2.905D+00,  6.170D-01,  1.532D+00,
30520      &     5.106D-01,  5.833D-01,  2.917D+00,  6.087D-01,  1.565D+00,
30521      &     5.084D-01,  5.801D-01,  2.939D+00,  6.000D-01,  1.600D+00,
30522      &     5.063D-01,  5.763D-01,  2.966D+00,  5.909D-01,  1.636D+00,
30523      &     5.036D-01,  5.730D-01,  2.989D+00,  5.814D-01,  1.674D+00,
30524      &     5.014D-01,  5.683D-01,  3.022D+00,  5.714D-01,  1.714D+00,
30525      &     4.986D-01,  5.641D-01,  3.051D+00,  5.610D-01,  1.756D+00,
30526      &     4.964D-01,  5.580D-01,  3.094D+00,  5.500D-01,  1.800D+00,
30527      &     4.936D-01,  5.573D-01,  3.099D+00,  5.431D-01,  1.827D+00,
30528      &     4.909D-01,  5.509D-01,  3.144D+00,  5.313D-01,  1.875D+00,
30529      &     4.885D-01,  5.512D-01,  3.142D+00,  5.263D-01,  1.895D+00,
30530      &     4.857D-01,  5.437D-01,  3.194D+00,  5.135D-01,  1.946D+00/
30531       DATA (DCLIN(I),I=161,195) /
30532      &     4.830D-01,  5.353D-01,  3.253D+00,  5.000D-01,  2.000D+00,
30533      &     4.801D-01,  5.323D-01,  3.274D+00,  4.915D-01,  2.034D+00,
30534      &     4.770D-01,  5.228D-01,  3.341D+00,  4.767D-01,  2.093D+00,
30535      &     4.738D-01,  5.156D-01,  3.391D+00,  4.643D-01,  2.143D+00,
30536      &     4.701D-01,  5.010D-01,  3.493D+00,  4.444D-01,  2.222D+00,
30537      &     4.672D-01,  4.990D-01,  3.507D+00,  4.375D-01,  2.250D+00,
30538      &     4.634D-01,  4.856D-01,  3.601D+00,  4.194D-01,  2.323D+00/
30539
30540       DATA PDCI /
30541      &     4.400D+02,  1.896D-01,  1.931D-01,  1.982D-01,  1.015D-01,
30542      &     1.029D-01,  4.180D-02,  4.228D-02,  4.282D-02,  4.350D-02,
30543      &     2.204D-02,  2.236D-02,  5.900D+02,  1.433D-01,  1.555D-01,
30544      &     1.774D-01,  1.000D-01,  1.128D-01,  5.132D-02,  5.600D-02,
30545      &     6.158D-02,  6.796D-02,  3.660D-02,  3.820D-02,  6.500D+02,
30546      &     1.192D-01,  1.334D-01,  1.620D-01,  9.527D-02,  1.141D-01,
30547      &     5.283D-02,  5.952D-02,  6.765D-02,  7.878D-02,  4.796D-02,
30548      &     6.957D-02,  8.000D+02,  4.872D-02,  6.694D-02,  1.152D-01,
30549      &     9.348D-02,  1.368D-01,  6.912D-02,  7.953D-02,  9.577D-02,
30550      &     1.222D-01,  7.755D-02,  9.525D-02,  1.000D+03,  3.997D-02,
30551      &     5.456D-02,  9.804D-02,  8.084D-02,  1.208D-01,  6.520D-02,
30552      &     8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,  1.093D-01/
30553
30554       DATA PDCH /
30555      &     1.000D+03,  9.453D-02,  9.804D-02,  8.084D-02,  1.208D-01,
30556      &     6.520D-02,  8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,
30557      &     1.093D-01,  1.400D+03,  1.072D-01,  7.450D-02,  6.645D-02,
30558      &     1.136D-01,  6.750D-02,  8.580D-02,  1.110D-01,  1.530D-01,
30559      &     1.010D-01,  1.350D-01,  2.170D+03,  4.004D-02,  3.013D-02,
30560      &     2.664D-02,  5.511D-02,  4.240D-02,  7.660D-02,  1.364D-01,
30561      &     2.300D-01,  1.670D-01,  2.010D-01,  2.900D+03,  1.870D-02,
30562      &     1.804D-02,  1.320D-02,  2.970D-02,  2.860D-02,  5.160D-02,
30563      &     1.020D-01,  2.400D-01,  2.250D-01,  3.370D-01,  4.400D+03,
30564      &     1.196D-03,  8.784D-03,  1.517D-02,  2.874D-02,  2.488D-02,
30565      &     4.464D-02,  8.330D-02,  2.008D-01,  2.360D-01,  3.567D-01/
30566
30567       DATA (DCHN(I),I=1,90) /
30568      &     4.770D-01,  4.750D-01,  4.715D-01,  4.685D-01,  4.650D-01,
30569      &     4.610D-01,  4.570D-01,  4.550D-01,  4.500D-01,  4.450D-01,
30570      &     4.405D-01,  4.350D-01,  4.300D-01,  4.250D-01,  4.200D-01,
30571      &     4.130D-01,  4.060D-01,  4.000D-01,  3.915D-01,  3.840D-01,
30572      &     3.760D-01,  3.675D-01,  3.580D-01,  3.500D-01,  3.400D-01,
30573      &     3.300D-01,  3.200D-01,  3.100D-01,  3.000D-01,  2.900D-01,
30574      &     2.800D-01,  2.700D-01,  2.600D-01,  2.500D-01,  2.400D-01,
30575      &     2.315D-01,  2.240D-01,  2.150D-01,  2.060D-01,  2.000D-01,
30576      &     1.915D-01,  1.850D-01,  1.780D-01,  1.720D-01,  1.660D-01,
30577      &     1.600D-01,  1.550D-01,  1.500D-01,  1.450D-01,  1.400D-01,
30578      &     1.360D-01,  1.320D-01,  1.280D-01,  1.250D-01,  1.210D-01,
30579      &     1.180D-01,  1.150D-01,  1.120D-01,  1.100D-01,  1.070D-01,
30580      &     1.050D-01,  1.030D-01,  1.010D-01,  9.900D-02,  9.700D-02,
30581      &     9.550D-02,  9.480D-02,  9.400D-02,  9.200D-02,  9.150D-02,
30582      &     9.100D-02,  9.000D-02,  8.990D-02,  8.900D-02,  8.850D-02,
30583      &     8.750D-02,  8.700D-02,  8.650D-02,  8.550D-02,  8.500D-02,
30584      &     8.499D-02,  8.450D-02,  8.350D-02,  8.300D-02,  8.250D-02,
30585      &     8.150D-02,  8.100D-02,  8.030D-02,  8.000D-02,  7.990D-02/
30586       DATA (DCHN(I),I=91,143) /
30587      &     7.980D-02,  7.950D-02,  7.900D-02,  7.860D-02,  7.800D-02,
30588      &     7.750D-02,  7.650D-02,  7.620D-02,  7.600D-02,  7.550D-02,
30589      &     7.530D-02,  7.500D-02,  7.499D-02,  7.498D-02,  7.480D-02,
30590      &     7.450D-02,  7.400D-02,  7.350D-02,  7.300D-02,  7.250D-02,
30591      &     7.230D-02,  7.200D-02,  7.100D-02,  7.050D-02,  7.020D-02,
30592      &     7.000D-02,  6.999D-02,  6.995D-02,  6.993D-02,  6.991D-02,
30593      &     6.990D-02,  6.870D-02,  6.850D-02,  6.800D-02,  6.780D-02,
30594      &     6.750D-02,  6.700D-02,  6.650D-02,  6.630D-02,  6.600D-02,
30595      &     6.550D-02,  6.525D-02,  6.510D-02,  6.500D-02,  6.499D-02,
30596      &     6.498D-02,  6.496D-02,  6.494D-02,  6.493D-02,  6.490D-02,
30597      &     6.488D-02,  6.485D-02,  6.480D-02/
30598
30599       DATA DCHNA /
30600      &     6.300D+02,  7.810D-02,  1.421D-01,  1.979D-01,  2.479D-01,
30601      &     3.360D-01,  5.400D-01,  7.236D-01,  1.000D+00,  1.540D+03,
30602      &     2.225D-01,  3.950D-01,  5.279D-01,  6.298D-01,  7.718D-01,
30603      &     9.405D-01,  9.835D-01,  1.000D+00,  2.560D+03,  2.625D-01,
30604      &     4.550D-01,  5.963D-01,  7.020D-01,  8.380D-01,  9.603D-01,
30605      &     9.903D-01,  1.000D+00,  3.520D+03,  4.250D-01,  6.875D-01,
30606      &     8.363D-01,  9.163D-01,  9.828D-01,  1.000D+00,  1.000D+00,
30607      &     1.000D+00/
30608
30609       DATA DCHNB /
30610      &     6.300D+02,  3.800D-02,  7.164D-02,  1.275D-01,  2.171D-01,
30611      &     3.227D-01,  4.091D-01,  5.051D-01,  6.061D-01,  7.074D-01,
30612      &     8.434D-01,  1.000D+00,  2.040D+03,  1.200D-01,  2.115D-01,
30613      &     3.395D-01,  5.295D-01,  7.251D-01,  8.511D-01,  9.487D-01,
30614      &     9.987D-01,  1.000D+00,  1.000D+00,  1.000D+00,  2.200D+03,
30615      &     1.344D-01,  2.324D-01,  3.754D-01,  5.674D-01,  7.624D-01,
30616      &     8.896D-01,  9.808D-01,  1.000D+00,  1.000D+00,  1.000D+00,
30617      &     1.000D+00,  2.850D+03,  2.330D-01,  4.130D-01,  6.610D-01,
30618      &     9.010D-01,  9.970D-01,  1.000D+00,  1.000D+00,  1.000D+00,
30619      &     1.000D+00,  1.000D+00,  1.000D+00,  3.500D+03,  3.300D-01,
30620      &     5.450D-01,  7.950D-01,  1.000D+00,  1.000D+00,  1.000D+00,
30621      &     1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00/
30622
30623       CST = ONE
30624       IF (EKIN.GT.3.5D0) RETURN
30625 C
30626       IF(KPROJ.EQ.8) GOTO 101
30627       IF(KPROJ.EQ.1) GOTO 102
30628 C*                                             INVALID REACTION
30629       WRITE(LOUT,'(A,I5/A)')
30630      &        ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
30631      &        ' COS(THETA) = 1D0 RETURNED'
30632       RETURN
30633 C-------------------------------- NP ELASTIC SCATTERING----------
30634 101   CONTINUE
30635       IF (EKIN.GT.0.740D0)GOTO 1000
30636       IF (EKIN.LT.0.300D0)THEN
30637 C                                 EKIN .LT. 300 MEV
30638          IDAT=1
30639       ELSE
30640 C                                 300 MEV < EKIN < 740 MEV
30641          IDAT=6
30642       END IF
30643 C
30644       ENER=EKIN
30645       IE=INT(ABS(ENER/0.020D0))
30646       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
30647 C                                            FORWARD/BACKWARD DECISION
30648       K=IDAT+5*IE
30649       BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
30650       IF (DT_RNDM(CST).LT.BWFW)THEN
30651          VALUE2=-1D0
30652          K=K+1
30653       ELSE
30654          VALUE2=1D0
30655          K=K+3
30656       END IF
30657 C
30658       COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
30659       RND=DT_RNDM(COEF)
30660 C
30661       IF(RND.LT.COEF)THEN
30662          CST=DT_RNDM(RND)
30663          CST=CST*VALUE2
30664       ELSE
30665          R1=DT_RNDM(CST)
30666          R2=DT_RNDM(R1)
30667          R3=DT_RNDM(R2)
30668          R4=DT_RNDM(R3)
30669 C
30670          IF(VALUE2.GT.0.0)THEN
30671             CST=MAX(R1,R2,R3,R4)
30672             GOTO 1500
30673          ELSE
30674             R5=DT_RNDM(R4)
30675 C
30676             IF (IDAT.EQ.1)THEN
30677                CST=-MAX(R1,R2,R3,R4,R5)
30678             ELSE
30679                R6=DT_RNDM(R5)
30680                R7=DT_RNDM(R6)
30681                CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
30682             END IF
30683 C
30684          END IF
30685 C
30686       END IF
30687 C
30688       GOTO 1500
30689 C
30690 C********                                EKIN  .GT.  0.74 GEV
30691 C
30692 1000  ENER=EKIN - 0.66D0
30693 C     IE=ABS(ENER/0.02)
30694       IE=INT(ENER/0.02D0)
30695       EMEV=EKIN*1D3
30696 C
30697       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
30698       K=IE
30699       BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
30700       RND=DT_RNDM(BWFW)
30701 C                                        FORWARD NEUTRON
30702       IF (RND.GE.BWFW)THEN
30703          DO 1200 K=10,36,9
30704            IF (DCHNA(K).GT.EMEV) THEN
30705               UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
30706               UNIV=DT_RNDM(UNIVE)
30707               DO 1100 I=1,8
30708                  II=K+I
30709                  P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
30710 C
30711                  IF (P.GT.UNIV)THEN
30712                     UNIV=DT_RNDM(UNIVE)
30713                     FLTI=DBLE(I)-UNIV
30714                     GOTO(290,290,290,290,330,340,350,360) I
30715                  END IF
30716  1100         CONTINUE
30717            END IF
30718  1200    CONTINUE
30719 C
30720       ELSE
30721 C                                        BACKWARD NEUTRON
30722          DO 1400 K=13,60,12
30723             IF (DCHNB(K).GT.EMEV) THEN
30724                UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
30725                UNIV=DT_RNDM(UNIVE)
30726                DO 1300 I=1,11
30727                  II=K+I
30728                  P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
30729 C
30730                  IF (P.GT.UNIV)THEN
30731                    UNIV=DT_RNDM(P)
30732                    FLTI=DBLE(I)-UNIV
30733                    GOTO(120,120,140,150,160,160,180,190,200,210,220) I
30734                  END IF
30735  1300          CONTINUE
30736             END IF
30737  1400    CONTINUE
30738       END IF
30739 C
30740 120   CST=1.0D-2*FLTI-1.0D0
30741       GOTO 1500
30742 140   CST=2.0D-2*UNIV-0.98D0
30743       GOTO 1500
30744 150   CST=4.0D-2*UNIV-0.96D0
30745       GOTO 1500
30746 160   CST=6.0D-2*FLTI-1.16D0
30747       GOTO 1500
30748 180   CST=8.0D-2*UNIV-0.80D0
30749       GOTO 1500
30750 190   CST=1.0D-1*UNIV-0.72D0
30751       GOTO 1500
30752 200   CST=1.2D-1*UNIV-0.62D0
30753       GOTO 1500
30754 210   CST=2.0D-1*UNIV-0.50D0
30755       GOTO 1500
30756 220   CST=3.0D-1*(UNIV-1.0D0)
30757       GOTO 1500
30758 C
30759 290   CST=1.0D0-2.5d-2*FLTI
30760       GOTO 1500
30761 330   CST=0.85D0+0.5D-1*UNIV
30762       GOTO 1500
30763 340   CST=0.70D0+1.5D-1*UNIV
30764       GOTO 1500
30765 350   CST=0.50D0+2.0D-1*UNIV
30766       GOTO 1500
30767 360   CST=0.50D0*UNIV
30768 C
30769 1500  RETURN
30770 C
30771 C-----------------------------------  PP ELASTIC SCATTERING -------
30772 C
30773  102  CONTINUE
30774       EMEV=EKIN*1D3
30775 C
30776       IF (EKIN.LE.0.500D0) THEN
30777          RND=DT_RNDM(EMEV)
30778          CST=2.0D0*RND-1.0D0
30779          RETURN
30780 C
30781       ELSEIF (EKIN.LT.1.0D0) THEN
30782          DO 2200 K=13,60,12
30783             IF (PDCI(K).GT.EMEV) THEN
30784                UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
30785                UNIV=DT_RNDM(UNIVE)
30786                SUM=0
30787                DO 2100 I=1,11
30788                  II=K+I
30789                  SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
30790 C
30791                  IF (UNIV.LT.SUM)THEN
30792                    UNIV=DT_RNDM(SUM)
30793                    FLTI=DBLE(I)-UNIV
30794                    GOTO(55,55,55,60,60,65,65,65,65,70,70) I
30795                  END IF
30796  2100          CONTINUE
30797             END IF
30798  2200    CONTINUE
30799       ELSE
30800          DO 2400 K=12,55,11
30801             IF (PDCH(K).GT.EMEV) THEN
30802               UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
30803               UNIV=DT_RNDM(UNIVE)
30804               SUM=0.0D0
30805               DO 2300 I=1,10
30806                 II=K+I
30807                 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
30808 C
30809                 IF (UNIV.LT.SUM)THEN
30810                   UNIV=DT_RNDM(SUM)
30811                   FLTI=UNIV+DBLE(I)
30812                   GOTO(50,55,60,60,65,65,65,65,70,70) I
30813                 END IF
30814  2300         CONTINUE
30815             END IF
30816  2400    CONTINUE
30817       END IF
30818 C
30819 50    CST=0.4D0*UNIV
30820       GOTO 2500
30821 55    CST=0.2D0*FLTI
30822       GOTO 2500
30823 60    CST=0.3D0+0.1D0*FLTI
30824       GOTO 2500
30825 65    CST=0.6D0+0.04D0*FLTI
30826       GOTO 2500
30827 70    CST=0.78D0+0.02D0*FLTI
30828 C
30829 2500  CONTINUE
30830       IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
30831 C
30832       RETURN
30833       END
30834 *
30835 *===dhadri=============================================================*
30836 *
30837 CDECK  ID>, DT_DHADRI
30838       SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
30839
30840       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30841       SAVE
30842
30843       PARAMETER ( LINP = 5 ,
30844      &            LOUT = 6 ,
30845      &            LDAT = 9 )
30846
30847 C
30848 C-----------------------------
30849 C*** INPUT VARIABLES LIST:
30850 C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
30851 C*** GEV/C LABORATORY MOMENTUM REGION
30852 C*** N    - PROJECTILE HADRON INDEX
30853 C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
30854 C*** ELAB - LABORATORY ENERGY OF N (GEV)
30855 C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
30856 C*** ITTA - TARGET NUCLEON INDEX
30857 C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
30858 C  IR COUNTS THE NUMBER OF PRODUCED PARTICLES
30859 C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
30860 C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
30861 C*** RESPECT., UNITS (GEV/C AND GEV)
30862 C----------------------------
30863
30864       COMMON /HNGAMR/ REDU,AMO,AMM(15)
30865       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
30866       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
30867      &                NRK(2,268),NURE(30,2)
30868 * particle properties (BAMJET index convention),
30869 * (dublicate of DTPART for HADRIN)
30870       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
30871      &                K1H(110),K2H(110)
30872       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
30873       COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
30874      &                ITS(149),IS
30875       COMMON /HNDRUN/ RUNTES,EFTES
30876 * particle properties (BAMJET index convention)
30877       CHARACTER*8  ANAME
30878       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
30879      &                IICH(210),IIBAR(210),K1(210),K2(210)
30880 * final state from HADRIN interaction
30881       PARAMETER (MAXFIN=10)
30882       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
30883      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
30884
30885       DIMENSION ITPRF(110)
30886       DATA NNN/0/
30887       DATA UMODA/0./
30888       DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
30889       LOWP=0
30890       IF (N.LE.0.OR.N.GE.111)N=1
30891       IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
30892         GOTO 280
30893 *       WRITE (6,1000)
30894 *    +  ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
30895 *       STOP
30896 *1000   FORMAT (3(5H ****/),A,2I4,3(5H ****/))
30897 *    +  45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
30898       ENDIF
30899       IATMPT=0
30900       IF (ABS(PLAB-5.0D0).LT.4.99999D0)                        GO TO 20
30901 C     IF(IPRI.GE.1) WRITE (6,1010) PLAB
30902 C     STOP
30903  1010 FORMAT ( '  PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
30904      + ALLOWED REGION, PLAB=',1E15.5)
30905
30906    20 CONTINUE
30907       UMODAT=N*1.11111D0+ITTA*2.19291D0
30908       IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
30909       UMODA=UMODAT
30910    30 IATMPT=0
30911       LOWP=LOWP+1
30912    40 CONTINUE
30913       IMACH=0
30914       REDU=2.0D0
30915       IF (LOWP.GT.20) THEN
30916 C        WRITE(LOUT,*) ' jump 1'
30917          GO TO 280
30918       ENDIF
30919       NNN=N
30920       IF (NNN.EQ.N)                                             GO TO 50
30921       RUNTES=0.0D0
30922       EFTES=0.0D0
30923    50 CONTINUE
30924       IS=1
30925       IRH=0
30926       IST=1
30927       NSTAB=23
30928       IRE=NURE(N,1)
30929       IF(ITTA.GT.1) IRE=NURE(N,2)
30930 C
30931 C-----------------------------
30932 C*** IE,AMT,ECM,SI DETERMINATION
30933 C----------------------------
30934       CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
30935       IANTH=-1
30936 **sr
30937 C     IF (AMH(1).NE.0.93828D0) IANTH=1
30938       IF (AMH(1).NE.0.9383D0) IANTH=1
30939 **
30940       IF (IANTH.GE.0) SI=1.0D0
30941       ECMMH=ECM
30942 C
30943 C-----------------------------
30944 C    ENERGY INDEX
30945 C  IRE CHARACTERIZES THE REACTION
30946 C  IE IS THE ENERGY INDEX
30947 C----------------------------
30948       IF (SI.LT.1.D-6) THEN
30949 C        WRITE(LOUT,*) ' jump 2'
30950          GO TO 280
30951       ENDIF
30952       IF (N.LE.NSTAB)                                           GO TO 60
30953       RUNTES=RUNTES+1.0D0
30954       IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
30955  1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
30956       IF(IBARH(N).EQ.1) N=8
30957       IF(IBARH(N).EQ.-1)  N=9
30958    60 CONTINUE
30959       IMACH=IMACH+1
30960 **sr 19.2.97: loop for direct channel suppression
30961 C     IF (IMACH.GT.10) THEN
30962       IF (IMACH.GT.1000) THEN
30963 **
30964 C        WRITE(LOUT,*) ' jump 3'
30965          GO TO 280
30966       ENDIF
30967       ECM =ECMMH
30968       AMN2=AMN**2
30969       AMT2=AMT**2
30970       ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM    )
30971       IF(ECMN.LE.AMN) ECMN=AMN
30972       PCMN=SQRT(ECMN**2-AMN2)
30973       GAM=(ELAB+AMT)/ECM
30974       BGAM=PLAB/ECM
30975       IF (IANTH.GE.0) ECM=2.1D0
30976 C
30977 C-----------------------------
30978 C*** RANDOM CHOICE OF REACTION CHANNEL
30979 C----------------------------
30980       IST=0
30981       VV=DT_RNDM(AMN2)
30982       VV=VV-1.D-17
30983 C
30984 C-----------------------------
30985 C***  PLACE REDUCED VERSION
30986 C----------------------------
30987       IIEI=IEII(IRE)
30988       IDWK=IEII(IRE+1)-IIEI
30989       IIWK=IRII(IRE)
30990       IIKI=IKII(IRE)
30991 C
30992 C-----------------------------
30993 C***  SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
30994 C----------------------------
30995       HECM=ECM
30996       HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
30997       IF (HUMO.LT.ECM) ECM=HUMO
30998 C
30999 C-----------------------------
31000 C*** INTERPOLATION PREPARATION
31001 C----------------------------
31002       ECMO=UMO(IE)
31003       ECM1=UMO(IE-1)
31004       DECM=ECMO-ECM1
31005       DEC=ECMO-ECM
31006 C
31007 C-----------------------------
31008 C*** RANDOM LOOP
31009 C----------------------------
31010       IK=0
31011       WKK=0.0D0
31012       WICOR=0.0D0
31013    70 IK=IK+1
31014       IWK=IIWK+(IK-1)*IDWK+IE-IIEI
31015       WOK=WK(IWK)
31016       WDK=WOK-WK(IWK-1)
31017 C
31018 C-----------------------------
31019 C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
31020 C    GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
31021 C    CONTRIBUTE
31022 C----------------------------
31023       IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
31024       WICO=WOK*1.23459876D0+WDK*1.735218469D0
31025       IF (WICO.EQ.WICOR)                                        GO TO 70
31026       IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
31027       WICOR=WICO
31028 C
31029 C-----------------------------
31030 C*** INTERPOLATION IN CHANNEL WEIGHTS
31031 C----------------------------
31032       EKLIM=-THRESH(IIKI+IK)
31033       IELIM=IDT_IEFUND(EKLIM,IRE)
31034       DELIM=UMO(IELIM)+EKLIM
31035      *+1.D-16
31036       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
31037       IF (DELIM*DELIM-DETE*DETE) 90,90,80
31038    80 DECC=DELIM
31039                                                                GO TO 100
31040    90 DECC=DECM
31041   100 CONTINUE
31042       WKK=WOK-WDK*DEC/(DECC+1.D-9)
31043 C
31044 C-----------------------------
31045 C*** RANDOM CHOICE
31046 C----------------------------
31047 C
31048       IF (VV.GT.WKK)                                            GO TO 70
31049 C
31050 C***IK IS THE REACTION CHANNEL
31051 C----------------------------
31052       INRK=IKII(IRE)+IK
31053       ECM=HECM
31054       I1001 =0
31055 C
31056   110 CONTINUE
31057       IT1=NRK(1,INRK)
31058       AM1=DT_DAMG(IT1)
31059       IT2=NRK(2,INRK)
31060       AM2=DT_DAMG(IT2)
31061       AMS=AM1+AM2
31062       I1001=I1001+1
31063       IF (I1001.GT.50)                                          GO TO 60
31064 C
31065       IF (IT2*AMS.GT.IT2*ECM)                                  GO TO 110
31066       IT11=IT1
31067       IT22=IT2
31068       IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
31069       AM11=AM1
31070       AM22=AM2
31071       IF (IT2.GT.0)                                            GO TO 120
31072 **sr 19.2.97: supress direct channel for pp-collisions
31073       IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
31074          RR = DT_RNDM(AM11)
31075          IF (RR.LE.0.75D0) GOTO 60
31076       ENDIF
31077 **
31078 C
31079 C-----------------------------
31080 C  INCLUSION OF DIRECT RESONANCES
31081 C  RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE  IT1
31082 C------------------------
31083       KZ1=K1H(IT1)
31084       IST=IST+1
31085       IECO=0
31086       ECO=ECM
31087       GAM=(ELAB+AMT)/ECO
31088       BGAM=PLAB/ECO
31089       CXS(1)=CX
31090       CYS(1)=CY
31091       CZS(1)=CZ
31092                                                                GO TO 170
31093   120 CONTINUE
31094       WW=DT_RNDM(ECO)
31095       IF(WW.LT. 0.5D0)                                         GO TO 130
31096       IT1=IT22
31097       IT2=IT11
31098       AM1=AM22
31099       AM2=AM11
31100   130 CONTINUE
31101 C
31102 C-----------------------------
31103 C   THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
31104       IBN=IBARH(N)
31105       IB1=IBARH(IT1)
31106       IT11=IT1
31107       IT22=IT2
31108       AM11=AM1
31109       AM22=AM2
31110       IF(IB1.EQ.IBN)                                           GO TO 140
31111       IT1=IT22
31112       IT2=IT11
31113       AM1=AM22
31114       AM2=AM11
31115   140 CONTINUE
31116 C-----------------------------
31117 C***IT1,IT2 ARE THE CREATED PARTICLES
31118 C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
31119 C------------------------
31120       CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
31121      *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
31122       IST=IST+1
31123       ITS(IST)=IT1
31124       AMM(IST)=AM1
31125 C
31126 C-----------------------------
31127 C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
31128 C----------------------------
31129       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
31130      &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
31131       IST=IST+1
31132       ITS(IST)=IT2
31133       AMM(IST)=AM2
31134       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
31135      *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
31136   150 CONTINUE
31137 C
31138 C-----------------------------
31139 C***TEST   STABLE OR UNSTABLE
31140 C----------------------------
31141       IF(ITS(IST).GT.NSTAB)                                    GO TO 160
31142       IRH=IRH+1
31143 C
31144 C-----------------------------
31145 C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
31146 C----------------------------
31147 C*    IF (REDU.LT.0.D0) GO TO 1009
31148       ITRH(IRH)=ITS(IST)
31149       PLRH(IRH)=PLS(IST)
31150       CXRH(IRH)=CXS(IST)
31151       CYRH(IRH)=CYS(IST)
31152       CZRH(IRH)=CZS(IST)
31153       ELRH(IRH)=ELS(IST)
31154       IST=IST-1
31155       IF(IST.GE.1)                                             GO TO 150
31156                                                                GO TO 260
31157   160 CONTINUE
31158 C
31159 C  RANDOM CHOICE OF DECAY CHANNELS
31160 C----------------------------
31161 C
31162       IT=ITS(IST)
31163       ECO=AMM(IST)
31164       GAM=ELS(IST)/ECO
31165       BGAM=PLS(IST)/ECO
31166       IECO=0
31167       KZ1=K1H(IT)
31168   170 CONTINUE
31169       IECO=IECO+1
31170       VV=DT_RNDM(GAM)
31171       VV=VV-1.D-17
31172       IIK=KZ1-1
31173   180 IIK=IIK+1
31174       IF (VV.GT.WTI(IIK))                                      GO TO 180
31175 C
31176 C  IIK IS THE DECAY CHANNEL
31177 C----------------------------
31178       IT1=NZKI(IIK,1)
31179       I310=0
31180   190 CONTINUE
31181       I310=I310+1
31182       AM1=DT_DAMG(IT1)
31183       IT2=NZKI(IIK,2)
31184       AM2=DT_DAMG(IT2)
31185       IF (IT2-1.LT.0)                                          GO TO 240
31186       IT3=NZKI(IIK,3)
31187       AM3=DT_DAMG(IT3)
31188       AMS=AM1+AM2+AM3
31189 C
31190 C  IF  IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
31191 C----------------------------
31192       IF (IECO.LE.10)                                          GO TO 200
31193       IATMPT=IATMPT+1
31194       IF(IATMPT.GT.3) THEN
31195 C        WRITE(LOUT,*) ' jump 4'
31196          GO TO 280
31197       ENDIF
31198                                                                 GO TO 40
31199   200 CONTINUE
31200       IF (I310.GT.50)                                          GO TO 170
31201       IF (AMS.GT.ECO)                                          GO TO 190
31202 C
31203 C  FOR THE DECAY CHANNEL
31204 C  IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM  IT
31205 C----------------------------
31206       IF (REDU.LT.0.D0)                                        GO TO 30
31207       ITWTHC=0
31208       REDU=2.0D0
31209       IF(IT3.EQ.0)                                             GO TO 220
31210   210 CONTINUE
31211       ITWTH=1
31212       CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
31213      *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
31214                                                                GO TO 230
31215   220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
31216      &COD2,COF2,SIF2,AM1,AM2)
31217       ITWTH=-1
31218       IT3=0
31219   230 CONTINUE
31220       ITWTHC=ITWTHC+1
31221       IF (REDU.GT.0.D0)                                        GO TO 240
31222       REDU=2.0D0
31223       IF (ITWTHC.GT.100)                                        GO TO 30
31224       IF (ITWTH) 220,220,210
31225   240 CONTINUE
31226       ITS(IST  )=IT1
31227       IF (IT2-1.LT.0)                                          GO TO 250
31228       ITS(IST+1)  =IT2
31229       ITS(IST+2)=IT3
31230       RX=CXS(IST)
31231       RY=CYS(IST)
31232       RZ=CZS(IST)
31233       AMM(IST)=AM1
31234       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
31235      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
31236       IST=IST+1
31237       AMM(IST)=AM2
31238       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
31239      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
31240       IF (IT3.LE.0)                                            GO TO 250
31241       IST=IST+1
31242       AMM(IST)=AM3
31243       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
31244      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
31245   250 CONTINUE
31246                                                                GO TO 150
31247   260 CONTINUE
31248   270 CONTINUE
31249       RETURN
31250   280 CONTINUE
31251 C
31252 C----------------------------
31253 C
31254 C   ZERO CROSS SECTION CASE
31255 C----------------------------
31256 C
31257       IRH=1
31258       ITRH(1)=N
31259       CXRH(1)=CX
31260       CYRH(1)=CY
31261       CZRH(1)=CZ
31262       ELRH(1)=ELAB
31263       PLRH(1)=PLAB
31264       RETURN
31265       END
31266 *
31267 *===runtt==============================================================*
31268 *
31269 CDECK  ID>, DT_RUNTT
31270       BLOCK DATA DT_RUNTT
31271
31272       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31273       SAVE
31274
31275       COMMON /HNDRUN/ RUNTES,EFTES
31276
31277       DATA RUNTES,EFTES /100.D0,100.D0/
31278
31279       END
31280 *
31281 *===noname=============================================================*
31282 *
31283 CDECK  ID>, DT_NONAME
31284       BLOCK DATA DT_NONAME
31285
31286       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31287       SAVE
31288
31289 * slope parameters for HADRIN interactions
31290       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
31291       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
31292
31293 C     DATAS     DATAS    DATAS      DATAS     DATAS
31294 C******          *********
31295       DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
31296      &           207, 224, 241, 252, 268 /
31297       DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
31298      &           220, 241, 262, 279, 296 /
31299       DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
31300      &           3364, 3507, 4011, 4368, 4725, 4912, 5184/
31301
31302 C
31303 C     MASSES FOR THE SLOPE B(M) IN GEV
31304 C     SLOPE B(M) FOR AN MESONIC SYSTEM
31305 C     SLOPE B(M) FOR A BARYONIC SYSTEM
31306
31307 *
31308       DATA SM,BBM,BBB/  0.8D0, 0.85D0,  0.9D0, 0.95D0, 1.D0,
31309      &     1.05D0,  1.1D0, 1.15D0,  1.2D0, 1.25D0,
31310      &      1.3D0,  1.35D0, 1.4D0,  1.45D0,  1.5D0,
31311      &     1.55D0,  1.6D0,  1.65D0, 1.7D0,   1.75D0,
31312      &      1.8D0,  1.85D0, 1.9D0,  1.95D0,  2.D0,
31313      &     15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
31314      &    12.35D0, 11.7D0, 10.85D0, 10.D0,  9.15D0,
31315      &      8.3D0,  7.8D0,  7.3D0,  7.25D0,  7.2D0,
31316      &     6.95D0,  6.7D0,  6.6D0,  6.5D0,   6.3D0,
31317      &      6.1D0,  5.85D0, 5.6D0,  5.35D0,  5.1D0,
31318      &      15.D0,   15.D0, 15.D0,  15.D0,   15.D0, 15.D0, 15.D0,
31319      &     14.2D0,  13.4D0, 12.6D0,
31320      &     11.8D0, 11.2D0, 10.6D0,  9.8D0,    9.D0,
31321      &     8.25D0,  7.5D0, 6.25D0,  5.D0,    4.5D0, 5*4.D0 /
31322 *
31323       END
31324 *
31325 *===damg===============================================================*
31326 *
31327 CDECK  ID>, DT_DAMG
31328       DOUBLE PRECISION FUNCTION DT_DAMG(IT)
31329
31330       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31331       SAVE
31332
31333 * particle properties (BAMJET index convention),
31334 * (dublicate of DTPART for HADRIN)
31335       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31336      &                K1H(110),K2H(110)
31337
31338       DIMENSION GASUNI(14)
31339       DATA GASUNI/
31340      *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
31341      *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
31342       DATA GAUNO/2.352D0/
31343       DATA GAUNON/2.4D0/
31344       DATA IO/14/
31345       DATA NSTAB/23/
31346
31347       I=1
31348       IF (IT.LE.0)                                              GO TO 30
31349       IF (IT.LE.NSTAB)                                          GO TO 20
31350       DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
31351       VV=DT_RNDM(DGAUNI)
31352       VV=VV*2.0D0-1.0D0+1.D-16
31353    10 CONTINUE
31354       VO=GASUNI(I)
31355       I=I+1
31356       V1=GASUNI(I)
31357       IF (VV.GT.V1)                                             GO TO 10
31358       UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
31359      &      (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
31360       DAM=GAH(IT)*UNIGA/GAUNO
31361       AAM=AMH(IT)+DAM
31362       DT_DAMG=AAM
31363       RETURN
31364    20 CONTINUE
31365       DT_DAMG=AMH(IT)
31366       RETURN
31367    30 CONTINUE
31368       DT_DAMG=0.0D0
31369       RETURN
31370       END
31371 *
31372 *===dcalum=============================================================*
31373 *
31374 CDECK  ID>, DT_DCALUM
31375       SUBROUTINE DT_DCALUM(N,ITTA)
31376
31377       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31378       SAVE
31379
31380 C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
31381
31382 * particle properties (BAMJET index convention),
31383 * (dublicate of DTPART for HADRIN)
31384       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31385      &                K1H(110),K2H(110)
31386       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
31387       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
31388       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
31389      &                NRK(2,268),NURE(30,2)
31390
31391       IRE=NURE(N,ITTA/8+1)
31392       IEO=IEII(IRE)+1
31393       IEE=IEII(IRE +1)
31394       AM1=AMH(N   )
31395       AM12=AM1**2
31396       AM2=AMH(ITTA)
31397       AM22=AM2**2
31398       DO 10 IE=IEO,IEE
31399         PLAB2=PLABF(IE)**2
31400         ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
31401         UMO(IE)=ELAB
31402    10 CONTINUE
31403       IKO=IKII(IRE)+1
31404       IKE=IKII(IRE +1)
31405       UMOO=UMO(IEO)
31406       DO 30 IK=IKO,IKE
31407         IF(NRK(2,IK).GT.0)                                      GO TO 30
31408         IKI=NRK(1,IK)
31409         AMSS=5.0D0
31410         K11=K1H(IKI)
31411         K22=K2H(IKI)
31412         DO 20 IK1=K11,K22
31413           IN=NZKI(IK1,1)
31414           AMS=AMH(IN)
31415           IN=NZKI(IK1,2)
31416           IF(IN.GT.0)AMS=AMS+AMH(IN)
31417           IN=NZKI(IK1,3)
31418           IF(IN.GT.0) AMS=AMS+AMH(IN)
31419           IF (AMS.LT.AMSS) AMSS=AMS
31420    20   CONTINUE
31421         IF(UMOO.LT.AMSS) UMOO=AMSS
31422         THRESH(IK)=UMOO
31423    30 CONTINUE
31424       RETURN
31425       END
31426 *
31427 *===dchanh=============================================================*
31428 *
31429 CDECK  ID>, DT_DCHANH
31430       SUBROUTINE DT_DCHANH
31431
31432       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31433       SAVE
31434
31435       PARAMETER ( LINP = 5 ,
31436      &            LOUT = 6 ,
31437      &            LDAT = 9 )
31438
31439 * particle properties (BAMJET index convention),
31440 * (dublicate of DTPART for HADRIN)
31441       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31442      &                K1H(110),K2H(110)
31443       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
31444       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
31445       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
31446      &                NRK(2,268),NURE(30,2)
31447
31448       DIMENSION HWT(460),HWK(40),SI(5184)
31449       EQUIVALENCE (WK(1),SI(1))
31450 C--------------------
31451 C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
31452 C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
31453 C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
31454 C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
31455 C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
31456 C--------------------------
31457       IREG=16
31458       DO 90 IRE=1,IREG
31459         IWKO=IRII(IRE)
31460         IEE=IEII(IRE+1)-IEII(IRE)
31461         IKE=IKII(IRE+1)-IKII(IRE)
31462         IEO=IEII(IRE)+1
31463         IIKA=IKII(IRE)
31464 *   modifications to suppress elestic scattering  24/07/91
31465         DO 80 IE=1,IEE
31466           SIS=1.D-14
31467           SINORC=0.0D0
31468           DO 10 IK=1,IKE
31469             IWK=IWKO+IEE*(IK-1)+IE
31470             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
31471             SIS=SIS+SI(IWK)*SINORC
31472    10     CONTINUE
31473           SIIN(IEO+IE-1)=SIS
31474           SIO=0.D0
31475           IF (SIS.GE.1.D-12)                                    GO TO 20
31476           SIS=1.D0
31477           SIO=1.D0
31478    20     CONTINUE
31479           SINORC=0.0D0
31480           DO 30 IK=1,IKE
31481             IWK=IWKO+IEE*(IK-1)+IE
31482             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
31483             SIO=SIO+SI(IWK)*SINORC/SIS
31484             HWK(IK)=SIO
31485    30     CONTINUE
31486           DO 40 IK=1,IKE
31487             IWK=IWKO+IEE*(IK-1)+IE
31488    40     WK(IWK)=HWK(IK)
31489           IIKI=IKII(IRE)
31490           DO 70 IK=1,IKE
31491             AM111=0.D0
31492             INRK1=NRK(1,IIKI+IK)
31493             IF (INRK1.GT.0) AM111=AMH(INRK1)
31494             AM222=0.D0
31495             INRK2=NRK(2,IIKI+IK)
31496             IF (INRK2.GT.0) AM222=AMH(INRK2)
31497             THRESH(IIKI+IK)=AM111 +AM222
31498             IF (INRK2-1.GE.0)                                   GO TO 60
31499             INRKK=K1H(INRK1)
31500             AMSS=5.D0
31501             INRKO=K2H(INRK1)
31502             DO 50 INRK1=INRKK,INRKO
31503               INZK1=NZKI(INRK1,1)
31504               INZK2=NZKI(INRK1,2)
31505               INZK3=NZKI(INRK1,3)
31506               IF (INZK1.LE.0.OR.INZK1.GT.110)                   GO TO 50
31507               IF (INZK2.LE.0.OR.INZK2.GT.110)                   GO TO 50
31508               IF (INZK3.LE.0.OR.INZK3.GT.110)                   GO TO 50
31509 C     WRITE (6,310)INRK1,INZK1,INZK2,INZK3
31510  1000 FORMAT (4I10)
31511               AMS=AMH(INZK1)+AMH(INZK2)
31512               IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
31513               IF (AMSS.GT.AMS) AMSS=AMS
31514    50       CONTINUE
31515             AMS=AMSS
31516             IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
31517             THRESH(IIKI+IK)=AMS
31518    60       CONTINUE
31519    70     CONTINUE
31520    80   CONTINUE
31521    90 CONTINUE
31522       DO 100 J=1,460
31523   100 HWT(J)=0.D0
31524       DO 120 I=1,110
31525         IK1=K1H(I)
31526         IK2=K2H(I)
31527         HV=0.D0
31528         IF (IK2.GT.460)IK2=460
31529         IF (IK1.LE.0)IK1=1
31530         DO 110 J=IK1,IK2
31531           HV=HV+WTI(J)
31532           HWT(J)=HV
31533           JI=J
31534   110   CONTINUE
31535         IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
31536  1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
31537   120 CONTINUE
31538       DO 130 J=1,460
31539   130 WTI(J)=HWT(J)
31540       RETURN
31541       END
31542 *
31543 *===dhadde=============================================================*
31544 *
31545 CDECK  ID>, DT_DHADDE
31546       SUBROUTINE DT_DHADDE
31547
31548       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31549       SAVE
31550
31551 * particle properties (BAMJET index convention)
31552       CHARACTER*8  ANAME
31553       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31554      &                IICH(210),IIBAR(210),K1(210),K2(210)
31555 * HADRIN: decay channel information
31556       PARAMETER (IDMAX9=602)
31557       CHARACTER*8 ZKNAME
31558       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31559 * particle properties (BAMJET index convention),
31560 * (dublicate of DTPART for HADRIN)
31561       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31562      &                K1H(110),K2H(110)
31563       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
31564 * decay channel information for HADRIN
31565       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
31566      &                K1Z(16),K2Z(16),WTZ(153),II22,
31567      &                NZK1(153),NZK2(153),NZK3(153)
31568
31569       DATA IRETUR/0/
31570
31571       IRETUR=IRETUR+1
31572       AMH(31)=0.48D0
31573       IF (IRETUR.GT.1) RETURN
31574       DO 10 I=1,94
31575         AMH(I)   = AAM(I)
31576         GAH(I)   = GA(I)
31577         TAUH(I)  = TAU(I)
31578         ICHH(I)  = IICH(I)
31579         IBARH(I) = IIBAR(I)
31580         K1H(I)   = K1(I)
31581         K2H(I)   = K2(I)
31582    10 CONTINUE
31583 **sr
31584 C     AMH(1)=0.93828D0
31585       AMH(1)=0.9383D0
31586 **
31587       AMH(2)=AMH(1)
31588       DO 20 I=26,30
31589         K1H(I)=452
31590         K2H(I)=452
31591    20 CONTINUE
31592       DO 30 I=1,307
31593         WTI(I)    = WT(I)
31594         NZKI(I,1) = NZK(I,1)
31595         NZKI(I,2) = NZK(I,2)
31596         NZKI(I,3) = NZK(I,3)
31597    30 CONTINUE
31598       DO 40 I=1,16
31599         L=I+94
31600         AMH(L)=AMZ(I)
31601         GAH( L)=GAZ(I)
31602         TAUH( L)=TAUZ(I)
31603         ICHH( L)=ICHZ(I)
31604         IBARH( L)=IBARZ(I)
31605         K1H( L)=K1Z(I)
31606         K2H( L)=K2Z(I)
31607    40 CONTINUE
31608       DO 50 I=1,153
31609         L=I+307
31610         WTI(L)    = WTZ(I)
31611         NZKI(L,3) = NZK3(I)
31612         NZKI(L,2) = NZK2(I)
31613         NZKI(L,1) = NZK1(I)
31614    50 CONTINUE
31615       RETURN
31616       END
31617 *
31618 *===iefund=============================================================*
31619 *
31620 CDECK  ID>, IDT_IEFUND
31621       INTEGER FUNCTION IDT_IEFUND(PL,IRE)
31622
31623       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31624       SAVE
31625
31626 C*****IEFUN CALCULATES A MOMENTUM INDEX
31627
31628       PARAMETER ( LINP = 5 ,
31629      &            LOUT = 6 ,
31630      &            LDAT = 9 )
31631
31632       COMMON /HNDRUN/ RUNTES,EFTES
31633       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
31634       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
31635      &                NRK(2,268),NURE(30,2)
31636
31637       IPLA=IEII(IRE)+1
31638      *+1
31639       IPLE=IEII(IRE+1)
31640       IF (PL.LT.0.)                                             GO TO 30
31641       DO 10 I=IPLA,IPLE
31642         J=I-IPLA+1
31643         IF (PL.LE.PLABF(I))                                     GO TO 60
31644    10 CONTINUE
31645       I=IPLE
31646       IF ( EFTES.GT.40.D0)                                      GO TO 20
31647       EFTES=EFTES+1.0D0
31648       WRITE(LOUT,1000)PL,J
31649    20 CONTINUE
31650                                                                 GO TO 70
31651    30 CONTINUE
31652       DO 40 I=IPLA,IPLE
31653         J=I-IPLA+1
31654         IF (-PL.LE.UMO(I))                                      GO TO 60
31655    40 CONTINUE
31656       I=IPLE
31657       IF ( EFTES.GT.40.D0)                                      GO TO 50
31658       EFTES=EFTES+1.0D0
31659       WRITE(LOUT,1000)PL,I
31660    50 CONTINUE
31661    60 CONTINUE
31662    70 CONTINUE
31663       IDT_IEFUND=I
31664       RETURN
31665  1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
31666      +7H IEFUN=,I5)
31667       END
31668 *
31669 *===dsigin=============================================================*
31670 *
31671 CDECK  ID>, DT_DSIGIN
31672       SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
31673
31674       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31675       SAVE
31676
31677 * particle properties (BAMJET index convention),
31678 * (dublicate of DTPART for HADRIN)
31679       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31680      &                K1H(110),K2H(110)
31681       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
31682       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
31683      &                NRK(2,268),NURE(30,2)
31684
31685       IE=IDT_IEFUND(PLAB,IRE)
31686       IF (IE.LE.IEII(IRE)) IE=IE+1
31687       AMT=AMH(ITAR)
31688       AMN=AMH(N)
31689       AMN2=AMN*AMN
31690       AMT2=AMT*AMT
31691       ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
31692 C*** INTERPOLATION PREPARATION
31693       ECMO=UMO(IE)
31694       ECM1=UMO(IE-1)
31695       DECM=ECMO-ECM1
31696       DEC=ECMO-ECM
31697       IIKI=IKII(IRE)+1
31698       EKLIM=-THRESH(IIKI)
31699       WOK=SIIN(IE)
31700       WDK=WOK-SIIN(IE-1)
31701       IF (ECM.GT.ECMO) WDK=0.0D0
31702 C*** INTERPOLATION IN CHANNEL WEIGHTS
31703       IELIM=IDT_IEFUND(EKLIM,IRE)
31704       DELIM=UMO(IELIM)+EKLIM
31705      *+1.D-16
31706       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
31707       IF (DELIM*DELIM-DETE*DETE) 20,20,10
31708    10 DECC=DELIM
31709                                                                 GO TO 30
31710    20 DECC=DECM
31711    30 CONTINUE
31712       WKK=WOK-WDK*DEC/(DECC+1.D-9)
31713       IF (WKK.LT.0.0D0) WKK=0.0D0
31714       SI=WKK+1.D-12
31715       IF (-EKLIM.GT.ECM) SI=1.D-14
31716       RETURN
31717       END
31718 *
31719 *===dtchoi=============================================================*
31720 *
31721 CDECK  ID>, DT_DTCHOI
31722       SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
31723
31724       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31725       SAVE
31726
31727 C     ****************************
31728 C     TCHOIC CALCULATES A RANDOM VALUE
31729 C     FOR THE FOUR-MOMENTUM-TRANSFER T
31730 C     ****************************
31731
31732 * particle properties (BAMJET index convention),
31733 * (dublicate of DTPART for HADRIN)
31734       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31735      &                K1H(110),K2H(110)
31736 * slope parameters for HADRIN interactions
31737       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
31738
31739       AMA=AM1
31740       AMB=AM2
31741       IF (I.GT.30.AND.II.GT.30)                                 GO TO 20
31742       III=II
31743       AM3=AM2
31744       IF (I.LE.30)                                              GO TO 10
31745       III=I
31746       AM3=AM1
31747    10 CONTINUE
31748                                                                 GO TO 30
31749    20 CONTINUE
31750       III=II
31751       AM3=AM2
31752       IF (AMA.LE.AMB)                                           GO TO 30
31753       III=I
31754       AM3=AM1
31755    30 CONTINUE
31756       IB=IBARH(III)
31757       AMA=AM3
31758       K=INT((AMA-0.75D0)/0.05D0)
31759       IF (K-2.LT.0) K=1
31760       IF (K-26.GE.0) K=25
31761       IF (IB)50,40,50
31762    40 BM=BBM(K)
31763                                                                 GO TO 60
31764    50 BM=BBB(K)
31765    60 CONTINUE
31766 C     NORMALIZATION
31767       TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1  **2
31768       TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1  **2
31769       VB=DT_RNDM(TMIN)
31770 **sr test
31771 C     IF (VB.LT.0.2D0) BM=BM*0.1
31772 C    **0.5
31773       BM = BM*5.05D0
31774 **
31775       TMI=BM*TMIN
31776       TMA=BM*TMAX
31777       ETMA=0.D0
31778       IF (ABS(TMA).GT.120.D0)                                   GO TO 70
31779       ETMA=EXP(TMA)
31780    70 CONTINUE
31781       AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
31782 C*** RANDOM CHOICE OF THE T - VALUE
31783       R=DT_RNDM(TMI)
31784       T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
31785       RETURN
31786       END
31787 *
31788 *===dtwopa=============================================================*
31789 *
31790 CDECK  ID>, DT_DTWOPA
31791       SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
31792      &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
31793
31794       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31795       SAVE
31796
31797 C     ******************************************************
31798 C     QUASI TWO PARTICLE PRODUCTION
31799 C     TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
31800 C     FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
31801 C     IN THE CM - SYSTEM
31802 C     COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
31803 C     SPHERICAL COORDINATES
31804 C     ******************************************************
31805
31806 * particle properties (BAMJET index convention),
31807 * (dublicate of DTPART for HADRIN)
31808       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31809      &                K1H(110),K2H(110)
31810
31811       AMA=AM1
31812       AMB=AM2
31813       AMA2=AMA*AMA
31814       E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
31815       E2=UMOO - E1
31816       IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
31817       AMTE=(E1-AMA)*(E1+AMA)
31818       AMTE=AMTE+1.D-18
31819       P1=SQRT(AMTE)
31820       P2=P1
31821 C     / P2 / = / P1 /  BUT OPPOSITE DIRECTIONS
31822 C     DETERMINATION  OF  THE ANGLES
31823 C     COS(THETA1)=COD1      COS(THETA2)=COD2
31824 C     SIN(PHI1)=SIF1        SIN(PHI2)=SIF2
31825 C     COS(PHI1)=COF1        COS(PHI2)=COF2
31826 C     PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
31827       CALL DT_DSFECF(COF1,SIF1)
31828       COF2=-COF1
31829       SIF2=-SIF1
31830 C     CALCULATION OF THETA1
31831       CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
31832       COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
31833       IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
31834       COD2=-COD1
31835       RETURN
31836       END
31837 *
31838 *===zk=================================================================*
31839 *
31840 CDECK  ID>, DT_ZK
31841       BLOCK DATA DT_ZK
31842
31843       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31844       SAVE
31845
31846 * decay channel information for HADRIN
31847       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
31848      &                K1Z(16),K2Z(16),WTZ(153),II22,
31849      &                NZK1(153),NZK2(153),NZK3(153)
31850 * decay channel information for HADRIN
31851       CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
31852       COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
31853
31854 *     Particle masses in GeV                                           *
31855       DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
31856      &          2*1.7D0, 3*0.D0/
31857 *     Resonance width Gamma in GeV                                     *
31858       DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
31859 *     Mean life time in seconds                                        *
31860       DATA TAUZ / 16*0.D0 /
31861 *     Charge of particles and resonances                               *
31862       DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
31863 *     Baryonic charge                                                  *
31864       DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
31865 *     First number of decay channels used for resonances               *
31866 *     and decaying particles                                           *
31867       DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
31868      &          3*460/
31869 *     Last number of decay channels used for resonances                *
31870 *     and decaying particles                                           *
31871       DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
31872      &          3*460/
31873 *     Weight of decay channel                                          *
31874       DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
31875      & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
31876      & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
31877      & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
31878      & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
31879      & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
31880      & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
31881      & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
31882      & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
31883      & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
31884      & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
31885      & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
31886      & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
31887      & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
31888      & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
31889      & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
31890      & .05D0, .65D0, 9*1.D0 /
31891 *     Particle numbers in decay channel                                *
31892       DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
31893      & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
31894      & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
31895      & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
31896      & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
31897      & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
31898      & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
31899      & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
31900       DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
31901      & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
31902      & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
31903      & 4*33, 32, 3*35,  2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
31904      & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
31905      & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
31906      & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
31907      & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
31908      & 1, 8, 1, 8, 1, 9*0 /
31909       DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
31910      & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
31911      & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
31912      & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
31913      & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
31914      & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
31915 *     Particle  names                                                  *
31916       DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS  ',' PAP  ',' PAN  ',
31917      & 'APN', 'DEO   ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
31918      & 3*'BLANK' /
31919 *     Name of decay channel                                            *
31920       DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
31921      & 'ANNPI0','APPPI0','ANPPI-'/
31922       DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K-  ','K0AK0 ',
31923      & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET  ','&0R0  ','P-R+  ',
31924      & 'P+R-  ','POOM  ',' ETET ','ETSP0 ','R0ET  ',' R0R0 ','R+R-  ',
31925      & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
31926      & 'P+R-R0','R0OM  ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
31927      & 'P+R-OM','OMOM  ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
31928      & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
31929      & 'OMOMOM',
31930      & ' P+PO ','P+POPO','P+P+P-','P+ET  ','P0R+  ','P+R0  ','ETSP+ ',
31931      & 'R+ET  ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
31932      & 'P+R-R+','R+OM  ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
31933      & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
31934      & 'P-PO  ','P-POPO','P-P-P+','P-ET  ','POR-  ','P-R0  ','ETSP- ',
31935      & 'R-ET  ','R-R0  ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
31936       DATA ZKNAM6/'P+R-R-','R-OM  ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
31937      & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
31938      & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO  ','LPI+  ',
31939      & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
31940      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
31941      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
31942      & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
31943      & 9*'BLANK'/
31944 *=                                               end*block.zk      *
31945       END
31946 *
31947 *===blkd43=============================================================*
31948 *
31949 CDECK  ID>, DT_BLKD43
31950       BLOCK DATA DT_BLKD43
31951
31952       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31953       SAVE
31954
31955 *$ CREATE REAC.ADD
31956 *COPY REAC
31957 *
31958 *=== reac =============================================================*
31959 *
31960 *----------------------------------------------------------------------*
31961 *                                                                      *
31962 *     Created on 10 december 1991  by    Alfredo Ferrari & Paola Sala  *
31963 *                                                   Infn - Milan       *
31964 *                                                                      *
31965 *     Last change on 10-dec-91     by    Alfredo Ferrari               *
31966 *                                                                      *
31967 *     This is the original common reac of Hadrin                       *
31968 *                                                                      *
31969 *----------------------------------------------------------------------*
31970 *
31971       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
31972      &                NRK(2,268),NURE(30,2)
31973
31974       DIMENSION
31975      & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
31976      & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
31977      & SPIKP1(315), SPIKPU(278), SPIKPV(372),
31978      & SPIKPW(278), SPIKPX(372), SPIKP4(315),
31979      & SPIKP5(187), SPIKP6(289),
31980      & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
31981      & SPIKP9(143), SPIKP0(169), SPKPV(143),
31982      & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
31983      & SANPEL(84) , SPIKPF(273),
31984      & SPKP15(187), SPKP16(272),
31985      & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
31986      & NURELN(60)
31987 *
31988        DIMENSION NRKLIN(532)
31989        EQUIVALENCE (NRK(1,1), NRKLIN(1))
31990        EQUIVALENCE (   UMO(  1),  UMOPI(1)), (   UMO( 93),  UMOKC(1))
31991        EQUIVALENCE (   UMO(161),   UMOP(1)), (   UMO(200),   UMON(1))
31992        EQUIVALENCE (   UMO(263),  UMOK0(1))
31993        EQUIVALENCE ( PLABF(  1),  PLAPI(1)), ( PLABF( 93),  PLAKC(1))
31994        EQUIVALENCE ( PLABF(161),   PLAP(1)), ( PLABF(200),   PLAN(1))
31995        EQUIVALENCE ( PLABF(263),  PLAK0(1))
31996        EQUIVALENCE (   WK(   1), SPIKP1(1)), (   WK( 316), SPIKPU(1))
31997        EQUIVALENCE (   WK( 594), SPIKPV(1)), (   WK( 966), SPIKPW(1))
31998        EQUIVALENCE (   WK(1244), SPIKPX(1)), (   WK(1616), SPIKP4(1))
31999        EQUIVALENCE (   WK(1931), SPIKP5(1)), (   WK(2118), SPIKP6(1))
32000        EQUIVALENCE (   WK(2407), SKMPEL(1)), (   WK(2509), SPIKP7(1))
32001        EQUIVALENCE (   WK(2798), SKMNEL(1)), (   WK(2866), SPIKP8(1))
32002        EQUIVALENCE (   WK(3053), SPIKP9(1)), (   WK(3196), SPIKP0(1))
32003        EQUIVALENCE (   WK(3365),  SPKPV(1)), (   WK(3508), SAPPEL(1))
32004        EQUIVALENCE (   WK(3613), SPIKPE(1)), (   WK(4012), SAPNEL(1))
32005        EQUIVALENCE (   WK(4096), SPIKPZ(1)), (   WK(4369), SANPEL(1))
32006        EQUIVALENCE (   WK(4453), SPIKPF(1)), (   WK(4726), SPKP15(1))
32007        EQUIVALENCE (   WK(4913), SPKP16(1))
32008        EQUIVALENCE (NRK(1,1), NRKLIN(1))
32009        EQUIVALENCE (NRKLIN(   1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
32010        EQUIVALENCE (NRKLIN( 297),  NRKP(1)), (NRKLIN( 367),  NRKN(1))
32011        EQUIVALENCE (NRKLIN( 483), NRKK0(1))
32012        EQUIVALENCE (NURE(1,1), NURELN(1))
32013 *
32014 **** pi- p data                                                        *
32015 **** pi+ n data                                                        *
32016       DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
32017      & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
32018      & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
32019      & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
32020      & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
32021      & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
32022      & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
32023      & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
32024      & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
32025      & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
32026       DATA PLAKC /
32027      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
32028      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
32029      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
32030      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
32031      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
32032      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
32033      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
32034      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
32035      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
32036      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
32037      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
32038      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
32039       DATA PLAK0 /
32040      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
32041      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
32042      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
32043      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
32044      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
32045      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
32046 *                 pp   pn   np   nn                                    *
32047       DATA PLAP /
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      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
32053      & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
32054 *    app   apn   anp   ann                                             *
32055       DATA PLAN /
32056      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
32057      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
32058      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
32059      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
32060      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
32061      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
32062      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
32063      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
32064      & 3.43D0, 3.75D0, 4.07D0, 4.43D0  /
32065       DATA SIIN / 296*0.D0 /
32066       DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
32067      & 1.557D0,1.615D0,1.6435D0,
32068      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
32069      & 2.286D0,2.366D0,2.482D0,2.56D0,
32070      & 2.735D0,2.90D0,
32071      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
32072      & 1.496D0,1.527D0,1.557D0,
32073      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
32074      & 2.071D0,2.159D0,2.286D0,2.366D0,
32075      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
32076      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
32077      & 1.496D0,1.527D0,1.557D0,
32078      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
32079      & 2.071D0,2.159D0,2.286D0,2.366D0,
32080      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
32081      &                   1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
32082      & 1.557D0,1.615D0,1.6435D0,
32083      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
32084      & 2.286D0,2.366D0,2.482D0,2.56D0,
32085      &  2.735D0, 2.90D0/
32086       DATA UMOKC/ 1.44D0,
32087      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
32088      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
32089      & 3.1D0,1.44D0,
32090      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
32091      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
32092      & 3.1D0,1.44D0,
32093      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
32094      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
32095      & 3.1D0,1.44D0,
32096      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
32097      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
32098      &  3.1D0/
32099       DATA UMOK0/ 1.44D0,
32100      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
32101      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
32102      & 3.1D0,1.44D0,
32103      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
32104      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
32105      &  3.1D0/
32106 *                 pp   pn   np   nn                                    *
32107       DATA UMOP/
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      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
32113      & 3.D0,3.1D0,3.2D0/
32114 *    app   apn   anp   ann                                             *
32115       DATA UMON /
32116      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
32117      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
32118      & 3.D0,3.1D0,3.2D0,
32119      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
32120      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
32121      & 3.D0,3.1D0,3.2D0,
32122      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
32123      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
32124      &  3.D0,3.1D0,3.2D0/
32125 **** reaction channel state particles                                  *
32126       DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
32127      & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
32128      & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
32129      & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
32130      & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
32131      & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
32132      & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
32133      & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
32134      & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
32135      & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
32136       DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
32137      & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
32138      & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
32139      & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
32140      & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
32141      & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
32142      & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
32143      & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
32144 *                                                                      *
32145 *   k0 p   k0 n   ak0 p   ak/ n                                        *
32146 *                                                                      *
32147       DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
32148      & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13,   22, 13, 21, 23,
32149      & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
32150      & 53, 47, 1, 103, 0, 93, 0/
32151 *   pp  pn   np   nn                                                   *
32152       DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
32153      & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
32154      & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
32155      & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
32156 *     app   apn   anp   ann                                            *
32157       DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
32158      & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
32159      & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
32160      & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
32161      & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
32162      & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
32163      & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
32164 **** channel cross section                                             *
32165       DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
32166      & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
32167      & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
32168      & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
32169      & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
32170      &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
32171      & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
32172      & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
32173      &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
32174      & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
32175      & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
32176      & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
32177      & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
32178      & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
32179      & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
32180      & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
32181      & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
32182      & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
32183      & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
32184      & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
32185 **** pi+ n data                                                        *
32186       DATA SPIKPU/   0.D0, 25.D0, 13.D0,  11.D0, 10.5D0, 14.D0,  20.D0,
32187      & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
32188      & 10.D0, 10.D0, 9.5D0,  9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
32189      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0,   5.5D0,  4.8D0,
32190      & 4.2D0, 7.5D0, 3.4D0,  2.5D0, 2.5D0, 2.1D0, 1.4D0,   1.D0,   .8D0,
32191      &  .6D0, .46D0,  .3D0, .2D0, .15D0, .13D0, 11*0.D0,  .95D0,  .65D0,
32192      & .48D0, .35D0,  .2D0, .18D0, .17D0, .16D0,  .15D0,   .1D0,  .09D0,
32193      & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0,  .2D0,   .1D0,
32194      & .08D0, .06D0, .045D0,   .03D0, .02D0, .01D0,      .005D0, .003D0,
32195      & 12*0.D0, .3D0, .24D0,   .18D0, .15D0, .13D0,  .12D0, .11D0, .1D0,
32196      & .09D0,  .08D0, .05D0,   .04D0, .03D0,  0.D0, 0.16D0, .7D0, 1.3D0,
32197      & 3.1D0,  4.5D0,  2.D0, 18*0.D0, 3*.0D0,  0.D0, 0.D0, 4.0D0, 11.D0,
32198      & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0,  1.5D0, .9D0, .55D0,
32199      &  .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0,   2.25D0, 3.3D0,
32200      & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
32201      & .64D0,  1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0,  4.4D0,   3.D0, 1.8D0,
32202      &  .9D0, .53D0, .28D0,      10*0.D0, 2*0.D0,  .25D0,  .82D0,
32203      & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0,  5.7D0, 3.9D0, 2.35D0, 1.15D0,
32204      & .69D0, .37D0, 10*0.D0,     7*0.D0,   .0D0, .34D0,  1.5D0, 3.47D0,
32205      & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0,  .3D0,  .15D0, 6*0.D0/
32206 *
32207       DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
32208      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
32209      & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
32210      & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
32211      & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
32212      & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
32213      & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
32214      & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
32215      & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
32216      & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
32217      & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
32218      & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
32219      & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
32220      & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
32221      & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
32222      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
32223      & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
32224      & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
32225      & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
32226      & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
32227 **** pi- p data                                                        *
32228       DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
32229      & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
32230      & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
32231      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
32232      & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
32233      & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
32234      & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
32235      & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
32236      & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
32237      & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
32238      & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
32239      & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
32240      & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
32241      & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
32242      & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
32243      & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
32244      & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
32245      & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
32246      & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
32247 *
32248       DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
32249      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
32250      & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
32251      & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
32252      & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
32253      & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
32254      & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
32255      & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
32256      & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
32257      & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
32258      & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
32259      & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
32260      & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
32261      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
32262      & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
32263      & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
32264      & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
32265      & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
32266      & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
32267      & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
32268 **** pi- n data                                                        *
32269       DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
32270      & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
32271      & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
32272      & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
32273      & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
32274      & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
32275      & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
32276      & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
32277      & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
32278      & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
32279      & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
32280      & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
32281      & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
32282      & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
32283      & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
32284      & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
32285      & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
32286      & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
32287      & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
32288      & 3.3D0, 5.4D0, 7.D0 /
32289 **** k+  p data                                                        *
32290       DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
32291      & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
32292      & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
32293      & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
32294      & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
32295      & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
32296      & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
32297      & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
32298      & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
32299      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
32300      & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
32301      & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
32302      & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
32303 **** k+  n data                                                        *
32304       DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
32305      & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
32306      & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
32307      & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
32308      & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
32309      & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
32310      & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
32311      & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
32312      & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
32313      & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
32314      & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
32315      & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
32316      & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
32317      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
32318      & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
32319      & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
32320      & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
32321      & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
32322      & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
32323 **** k-  p data                                                        *
32324       DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
32325      &     7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
32326      &    0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
32327      &    .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
32328      &    0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
32329      &    .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
32330      &    0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
32331      &    .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
32332      &    0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
32333      &    .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
32334      &    0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
32335      &    .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
32336       DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
32337      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
32338      & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
32339      & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
32340      & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,  3*0.D0, 1.0D0, 3.03D0,
32341      & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
32342      & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
32343      & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
32344      & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
32345      & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
32346      & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
32347      & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
32348      & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
32349      & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
32350      & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
32351      & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
32352      & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
32353      & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
32354      & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
32355      & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
32356      & 10*0.D0/
32357 ***** k- n data                                                        *
32358       DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
32359      &        3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
32360      &        0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
32361      &        1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
32362      &        0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
32363      &        .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
32364      &        0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
32365      &       .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
32366       DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
32367      &  14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
32368      &  1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
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      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
32372      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
32373      &  7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
32374      &  .39D0, .22D0, .07D0, 0.D0,
32375      &  6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
32376      &  4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
32377      &  10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
32378      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
32379      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
32380      &  9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
32381      &  5.10D0, 5.44D0, 5.3D0,
32382      &  4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
32383 *****  p p data                                                        *
32384       DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
32385      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
32386      &              0.D0, 3.6D0, 1.7D0, 10*0.D0,
32387      &              .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
32388      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
32389      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
32390      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
32391      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
32392      &              16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
32393      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
32394      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
32395      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
32396      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
32397      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
32398      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
32399 *****  p n data                                                        *
32400       DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
32401      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
32402      &              0.D0, 1.8D0, .2D0,  12*0.D0,
32403      &              3.2D0, 6.05D0, 9.9D0, 5.1D0,
32404      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
32405      &              2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
32406      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
32407      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
32408      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
32409      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
32410      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
32411      &              10*0.D0, .7D0, 5.1D0, 8.D0,
32412      &              10*0.D0, .7D0, 5.1D0, 8.D0,
32413      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
32414      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
32415      &              7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
32416      &              7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
32417      &              5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
32418 *   nn - data                                                          *
32419 *                                                                      *
32420       DATA SPKPV/  0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
32421      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
32422      &              0.D0, 3.6D0, 1.7D0, 12*0.D0,
32423      &              8.7D0, 17.7D0, 18.8D0, 15.9D0,
32424      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
32425      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
32426      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
32427      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
32428      &              11.D0, 5.5D0, 3.5D0,
32429      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
32430      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
32431      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
32432      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
32433      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
32434      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
32435 ****************   ap - p - data                                       *
32436       DATA SAPPEL/ 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
32437      &  50.D0,  50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
32438      &  25.D0,  22.D0, 21.D0, 20.D0, 18.D0, 17.D0,  11*0.D0,
32439      &  .05D0,  .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
32440      &  0.D0,  1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
32441      &  .1D0,  .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
32442      &  0.D0,  55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
32443      &  10.D0,  7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
32444      &  1.55D0,  1.3D0, .95D0, .75D0,
32445      &  0.D0,  3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
32446      &  .25D0,  .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
32447      & .01D0,  .008D0, .006D0, .005D0/
32448       DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
32449      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
32450      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
32451      & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
32452      & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
32453      & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
32454      & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
32455      & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
32456      & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
32457      & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 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, 13*0.D0, 1.3D0,
32460      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
32461      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
32462      & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
32463      & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
32464      & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
32465      & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
32466      & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
32467      & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
32468 ****************   ap - n - data                                       *
32469       DATA SAPNEL/
32470      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0,  68.D0, 65.D0,
32471      & 50.D0, 50.D0,  43.D0,  42.D0,  40.5D0, 35.D0, 30.D0,  28.D0,
32472      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0,  17.D0, 11*0.D0,
32473      & .05D0, .15D0, .18D0,  .2D0,    .2D0,  .3D0,  .4D0,   .6D0,  .7D0,
32474      & .85D0,  0.D0,  1.D0,  .9D0,    .46D0, .3D0,  .23D0, .18D0, .16D0,
32475      & .14D0,  .1D0, .08D0, .05D0,    .02D0, .015D0, 4*.011D0, 3*.005D0,
32476      & 0.D0,  3.3D0,  3.D0, 1.5D0,     1.D0, .7D0,  .4D0,  .35D0, .4D0,
32477      & .25D0, .18D0, .08D0, .04D0,    .03D0, .023D0, .016D0, .014D0,
32478      & .01D0, .008D0, .006D0, .005D0 /
32479        DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
32480      &  84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
32481      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
32482      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
32483      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
32484      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
32485      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
32486      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
32487      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
32488      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
32489      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
32490      & 4.9D0, 8.5D0,  15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
32491      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
32492      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
32493 *                                                                      *
32494 *                                                                      *
32495 ****************   an - p - data                                       *
32496 *                                                                      *
32497       DATA SANPEL/
32498      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
32499      & 50.D0, 43.D0,  42.D0,  40.5D0, 35.D0, 30.D0, 28.D0,
32500      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0, 17.D0, 11*0.D0, .05D0,
32501      & .15D0, .18D0,   .2D0,   .2D0,   .3D0,  .4D0, .6D0,   .7D0, .85D0,
32502      & 0.D0,   1.D0,   .9D0,  .46D0,  .3D0,  .23D0, .18D0, .16D0, .14D0,
32503      & .1D0,  .08D0,  .05D0,  .02D0, .015D0, 4*.011D0, 3*.005D0,
32504      & 0.D0,  3.3D0,  3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
32505      & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
32506      & .01D0, .008D0, .006D0, .005D0 /
32507       DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
32508      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
32509      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
32510      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
32511      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
32512      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
32513      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
32514      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
32515      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
32516      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
32517      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
32518      & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
32519      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
32520      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
32521 ****  ko - n - data                                                    *
32522       DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
32523      &      6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
32524      &      0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
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      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
32528      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
32529      &    4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
32530      &     1.4D0, 1.2D0, 1.05D0, .9D0, .66D0,  .5D0,
32531      &    7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
32532      &   11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
32533      &    4.85D0, 4.9D0,
32534      &   10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
32535      &    6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
32536      &    2.85D0, 2.35D0, 2.01D0, 1.8D0,
32537      &   12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
32538      &   12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0  /
32539 **** ako - p - data                                                    *
32540       DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
32541      & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
32542      & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
32543      & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
32544      & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
32545      & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
32546      & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
32547      & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
32548      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
32549      & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
32550      & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
32551      & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
32552      & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
32553      & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
32554      & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
32555      & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
32556      & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
32557      & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
32558      & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
32559      & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
32560      & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
32561       DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
32562      & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
32563 *=                                               end*block.blkdt3      *
32564       END
32565 *
32566 *===qel_pol============================================================*
32567 *
32568 CDECK  ID>, DT_QEL_POL
32569       SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
32570
32571       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32572       SAVE
32573
32574       CALL DT_MASS_INI
32575       CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
32576
32577       RETURN
32578       END
32579
32580 C==================================================================
32581 C   Generation of  a Quasi-Elastic neutrino scattering
32582 C==================================================================
32583 *
32584 *===gen_qel============================================================*
32585 *
32586 CDECK  ID>, DT_GEN_QEL
32587       SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
32588
32589 C...Generate a quasi-elastic   neutrino/antineutrino
32590 C.  Interaction on a nuclear target
32591 C.  INPUT  : LTYP = neutrino type (1,...,6)
32592 C.           ENU (GeV) = neutrino energy
32593 C----------------------------------------------------
32594
32595       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32596       SAVE
32597
32598       PARAMETER ( LINP = 5 ,
32599      &            LOUT = 6 ,
32600      &            LDAT = 9 )
32601
32602       PARAMETER (MAXLND=4000)
32603       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
32604
32605 * nuclear potential
32606       LOGICAL LFERMI
32607       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
32608      &                EBINDP(2),EBINDN(2),EPOT(2,210),
32609      &                ETACOU(2),ICOUL,LFERMI
32610 * steering flags for qel neutrino scattering modules
32611       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
32612 **sr - removed (not needed)
32613 C     COMMON /CBAD/  LBAD, NBAD
32614 C     COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
32615 **
32616
32617       DIMENSION PI(3),PO(3)
32618 CJR+
32619       DATA ININU/0/
32620 CJR-
32621 C     REAL*8 DBETA(3)
32622 C     REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
32623       DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
32624       DATA AMN  /0.93827231D0, 0.93956563D0/
32625       DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
32626       DATA INIPRI/0/
32627
32628 C     DATA PFERMI/0.22D0/
32629 CGB+...Binding Energy
32630       DATA EBIND/0.008D0/
32631 CGB-...
32632
32633       ININU=ININU+1
32634       IF(ININU.EQ.1)NDSIG=0
32635       LBAD = 0
32636       enu0=enu
32637 c      write(*,*) enu0
32638 C...Lepton mass
32639       AML = AML0(LTYP)       !  massa leptoni
32640       AML2 = AML**2          !  massa leptoni **2
32641 C...Particle labels (LUND)
32642       N = 5
32643       K(1,1) = 21
32644       K(2,1) = 21
32645       K(3,1) = 21
32646       K(3,3) = 1
32647       K(4,1) = 1
32648       K(4,3) = 1
32649       K(5,1) = 1
32650       K(5,3) = 2
32651       K0 = (LTYP-1)/2          !  2
32652       K1 = LTYP/2              !  2
32653       KA = 12 + 2*K0           !  16
32654       IS = -1 + 2*LTYP - 4*K1  !  -1 +10 -8 = 1
32655       K(1,2) = IS*KA
32656       K(4,2) = IS*(KA-1)
32657       K(3,2) = IS*24
32658       LNU = 2 - LTYP + 2*K1    !  2 - 5 + 2 = - 1
32659       IF (LNU .EQ. 2)  THEN
32660         K(2,2) = 2212
32661         K(5,2) = 2112
32662         AMI = AMN(1)
32663         AMF = AMN(2)
32664 CJR+
32665         PFERMI=PFERMN(2)
32666 CJR-
32667       ELSE
32668         K(2,2) = 2112
32669         K(5,2) = 2212
32670         AMI = AMN(2)
32671         AMF = AMN(1)
32672 CJR+
32673         PFERMI=PFERMP(2)
32674 CJR-
32675       ENDIF
32676       AMI2 = AMI**2
32677       AMF2 = AMF**2
32678
32679       DO IGB=1,5
32680         P(3,IGB) = 0.
32681         P(4,IGB) = 0.
32682         P(5,IGB) = 0.
32683       END DO
32684
32685       NTRY = 0
32686 CGB+...
32687       EFMAX  = SQRT(PFERMI**2 + AMI2) -AMI             ! max. Fermi Energy
32688       ENWELL = EFMAX + EBIND ! depth of nuclear potential well
32689 CGB-...
32690
32691   100 CONTINUE
32692
32693 C...4-momentum initial lepton
32694       P(1,5) = 0.     ! massa
32695       P(1,4) = ENU0    ! energia
32696       P(1,1) = 0.     ! px
32697       P(1,2) = 0.     ! py
32698       P(1,3) = ENU0    ! pz
32699
32700 C     PF = PFERMI*PYR(0)**(1./3.)
32701 c       write(23,*) PYR(0)
32702 c      write(*,*) 'Pfermi=',PF
32703 c      PF = 0.
32704       NTRY=NTRY+1
32705 C     IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
32706       IF (NTRY .GT. 500)  THEN
32707         LBAD = 1
32708         WRITE (LOUT,1001)  NBAD, ENU
32709         RETURN
32710       ENDIF
32711 C     CT = -1. + 2.*PYR(0)
32712 c      CT = -1.
32713 C     ST =  SQRT(1.-CT*CT)
32714 C     F = 2.*3.1415926*PYR(0)
32715 c      F = 0.
32716
32717 C     P(2,4) = SQRT(PF*PF + MI2) - EBIND  ! energia
32718 C     P(2,1) = PF*ST*COS(F)               ! px
32719 C     P(2,2) = PF*ST*SIN(F)               ! py
32720 C     P(2,3) = PF*CT                      ! pz
32721 C     P(2,5) = SQRT(P(2,4)**2-PF*PF)      ! massa
32722        P(2,1) = P21
32723        P(2,2) = P22
32724        P(2,3) = P23
32725        P(2,4) = P24
32726        P(2,5) = P25
32727       beta1=-p(2,1)/p(2,4)
32728       beta2=-p(2,2)/p(2,4)
32729       beta3=-p(2,3)/p(2,4)
32730       N=2
32731 C      WRITE(6,*)' before transforming into target rest frame'
32732
32733       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
32734
32735 C      print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
32736       N=5
32737
32738       phi11=atan(p(1,2)/p(1,3))
32739       pi(1)=p(1,1)
32740       pi(2)=p(1,2)
32741       pi(3)=p(1,3)
32742
32743       CALL DT_TESTROT(PI,Po,PHI11,1)
32744       DO ll=1,3
32745         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
32746       END DO
32747 c        WRITE(*,*) po
32748       p(1,1)=po(1)
32749       p(1,2)=po(2)
32750       p(1,3)=po(3)
32751       phi12=atan(p(1,1)/p(1,3))
32752
32753       pi(1)=p(1,1)
32754       pi(2)=p(1,2)
32755       pi(3)=p(1,3)
32756       CALL DT_TESTROT(Pi,Po,PHI12,2)
32757       DO ll=1,3
32758         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
32759       END DO
32760 c        WRITE(*,*) po
32761       p(1,1)=po(1)
32762       p(1,2)=po(2)
32763       p(1,3)=po(3)
32764
32765       enu=p(1,4)
32766
32767 C...Kinematical limits in Q**2
32768 c      S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) !            ????
32769       S = P(2,5)**2 + 2.*ENU*P(2,5)
32770       SQS = SQRT(S)                          ! E centro massa
32771       IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
32772       ELF = (S-AMF2+AML2)/(2.*SQS)           ! energia leptone finale p
32773       PSTAR = (S-P(2,5)**2)/(2.*SQS)       ! p* neutrino nel c.m.
32774       PLF = SQRT(ELF**2-AML2)               ! 3-momento leptone finale
32775       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)    ! + o -
32776       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)    ! according con cos(theta)
32777       IF (Q2MIN .LT. 0.)   Q2MIN = 0.      ! ??? non fisico
32778
32779 C...Generate Q**2
32780       DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
32781   200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
32782       DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
32783       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
32784       CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
32785       NDSIG=NDSIG+1
32786 C     WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
32787 C    &Q2,Q2min,Q2MAX,DSIGEV
32788
32789 C...c.m. frame. Neutrino along z axis
32790       DETOT = (P(1,4)) + (P(2,4)) ! e totale
32791       DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
32792       DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
32793       DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
32794 c      WRITE(*,*)
32795 c      WRITE(*,*)
32796 C      WRITE(*,*) 'Input values laboratory frame'
32797       N=2
32798
32799       CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
32800
32801       N=5
32802 c      STHETA = ULANGL(P(1,3),P(1,1))
32803 c      write(*,*) 'stheta' ,stheta
32804 c      stheta=0.
32805 c      CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
32806 c      WRITE(*,*)
32807 c      WRITE(*,*)
32808 C      WRITE(*,*) 'Output values cm frame'
32809 C...Kinematic in c.m. frame
32810       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
32811       STSTAR = SQRT(1.-CTSTAR**2)
32812       PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
32813       P(4,5) = AML                  ! massa leptone
32814       P(4,4) = ELF                 ! e leptone
32815       P(4,3) = PLF*CTSTAR          ! px
32816       P(4,1) = PLF*STSTAR*COS(PHI) ! py
32817       P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
32818
32819       P(5,5) = AMF                  ! barione
32820       P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
32821       P(5,3) = -P(4,3)             ! px
32822       P(5,1) = -P(4,1)             ! py
32823       P(5,2) = -P(4,2)             ! pz
32824
32825       P(3,5) = -Q2
32826       P(3,1) = P(1,1)-P(4,1)
32827       P(3,2) = P(1,2)-P(4,2)
32828       P(3,3) = P(1,3)-P(4,3)
32829       P(3,4) = P(1,4)-P(4,4)
32830
32831 C...Transform back to laboratory  frame
32832 C      WRITE(*,*) 'before going back to nucl rest frame'
32833 c      CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
32834       N=5
32835
32836       CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
32837
32838 C      WRITE(*,*) 'Now back in nucl rest frame'
32839       IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
32840
32841 c********************************************
32842
32843       DO kw=1,5
32844         pi(1)=p(kw,1)
32845         pi(2)=p(kw,2)
32846         pi(3)=p(kw,3)
32847         CALL DT_TESTROT(Pi,Po,PHI12,3)
32848         DO ll=1,3
32849           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
32850         END DO
32851         p(kw,1)=po(1)
32852         p(kw,2)=po(2)
32853         p(kw,3)=po(3)
32854       END DO
32855 c********************************************
32856
32857       DO kw=1,5
32858         pi(1)=p(kw,1)
32859         pi(2)=p(kw,2)
32860         pi(3)=p(kw,3)
32861         CALL DT_TESTROT(Pi,Po,PHI11,4)
32862         DO ll=1,3
32863           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
32864         END DO
32865         p(kw,1)=po(1)
32866         p(kw,2)=po(2)
32867         p(kw,3)=po(3)
32868       END DO
32869
32870 c********************************************
32871
32872 C      WRITE(*,*) 'Now back in lab frame'
32873
32874       CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
32875
32876 CGB+...
32877 C...test (on final momentum of nucleon) if Fermi-blocking
32878 C...is operating
32879       ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
32880      &  - P(5,5)
32881       IF (ENUCL.LT. EFMAX) THEN
32882         IF(INIPRI.LT.10)THEN
32883           INIPRI=INIPRI+1
32884 C         WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
32885 C...the interaction is not possible due to Pauli-Blocking and
32886 C...it must be resampled
32887         ENDIF
32888         GOTO 100
32889       ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
32890         IF(INIPRI.LT.10)THEN
32891           INIPRI=INIPRI+1
32892 C     WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
32893         ENDIF
32894 C                      Reject (J:R) here all these events
32895 C                      are otherwise rejected in dpmjet
32896         GOTO 100
32897 C...the interaction is possible, but the nucleon remains inside
32898 C...the nucleus. The nucleus is therefore left excited.
32899 C...We treat this case as a nucleon with 0 kinetic energy.
32900 C       P(5,5) = AMF
32901 C       P(5,4) = AMF
32902 C       P(5,1) = 0.
32903 C       P(5,2) = 0.
32904 C       P(5,3) = 0.
32905       ELSE IF (ENUCL.GE.ENWELL) THEN
32906 C     WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
32907 C...the interaction is possible, the nucleon can exit the nucleus
32908 C...but the nuclear well depth must be subtracted. The nucleus could be
32909 C...left in an excited state.
32910         Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
32911 C       P(5,4) = ENUCL-ENWELL + AMF
32912         Pnucl = SQRT(P(5,4)**2-AMF**2)
32913 C...The 3-momentum is scaled assuming that the direction remains
32914 C...unaffected
32915         P(5,1) = P(5,1) * Pnucl/Pstart
32916         P(5,2) = P(5,2) * Pnucl/Pstart
32917         P(5,3) = P(5,3) * Pnucl/Pstart
32918 C     WRITE(6,*)' qel new P(5,4) ',P(5,4)
32919       ENDIF
32920 CGB-...
32921       DSIGSU=DSIGSU+DSIGEV
32922
32923          GA=P(4,4)/P(4,5)
32924          BGX=P(4,1)/P(4,5)
32925          BGY=P(4,2)/P(4,5)
32926          BGZ=P(4,3)/P(4,5)
32927 *
32928          DBETB(1)=BGX/GA
32929          DBETB(2)=BGY/GA
32930          DBETB(3)=BGZ/GA
32931          IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
32932
32933             CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
32934
32935          ENDIF
32936 c
32937 C      PRINT*,' FINE   EVENTO '
32938       enu=enu0
32939       RETURN
32940
32941  1001 FORMAT(2X, 'DT_GEN_QEL   : event rejected ', I5,  G10.3)
32942       END
32943
32944 C====================================================================
32945 C.  Masses
32946 C====================================================================
32947
32948 *
32949 *===mass_ini===========================================================*
32950 *
32951 CDECK  ID>, DT_MASS_INI
32952       SUBROUTINE DT_MASS_INI
32953 C...Initialize  the kinematics for the quasi-elastic cross section
32954
32955       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32956       SAVE
32957
32958 * particle masses used in qel neutrino scattering modules
32959       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
32960      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
32961      &                EMPROTSQ,EMNEUTSQ,EMNSQ
32962
32963       EML(1) = 0.51100D-03   ! e-
32964       EML(2) = EML(1)        ! e+
32965       EML(3) = 0.105659D0      ! mu-
32966       EML(4) = EML(3)        ! mu+
32967       EML(5) = 1.7777D0        ! tau-
32968       EML(6) = EML(5)        ! tau+
32969       EMPROT = 0.93827231D0    ! p
32970       EMNEUT = 0.93956563D0    ! n
32971       EMPROTSQ = EMPROT**2
32972       EMNEUTSQ = EMNEUT**2
32973       EMN = (EMPROT + EMNEUT)/2.
32974       EMNSQ = EMN**2
32975       DO J=1,3
32976         J0 = 2*(J-1)
32977         EMN1(J0+1) = EMNEUT
32978         EMN1(J0+2) = EMPROT
32979         EMN2(J0+1) = EMPROT
32980         EMN2(J0+2) = EMNEUT
32981       ENDDO
32982       DO J=1,6
32983         EMLSQ(J) = EML(J)**2
32984         ETQE(J)  = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
32985       ENDDO
32986       RETURN
32987       END
32988 *
32989 *===dsqel_q2===========================================================*
32990 *
32991 CDECK  ID>, DT_DSQEL_Q2
32992       DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
32993
32994 C...differential cross section for  Quasi-Elastic scattering
32995 C.       nu + N -> l + N'
32996 C.  From Llewellin Smith  Phys.Rep.  3C, 261, (1971).
32997 C.
32998 C.  INPUT :  JTYP = 1,...,6    nu_e, ...., nubar_tau
32999 C.           ENU (GeV) =  Neutrino energy
33000 C.           Q2  (GeV**2) =  (Transfer momentum)**2
33001 C.
33002 C.  OUTPUT : DSQEL_Q2  = differential  cross section :
33003 C.                       dsigma/dq**2  (10**-38 cm+2/GeV**2)
33004 C------------------------------------------------------------------
33005
33006       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33007       SAVE
33008
33009 * particle masses used in qel neutrino scattering modules
33010       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
33011      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
33012      &                EMPROTSQ,EMNEUTSQ,EMNSQ
33013 **sr - removed (not needed)
33014 C     COMMON /CAXIAL/ FA0, AXIAL2
33015 **
33016
33017       DIMENSION SS(6)
33018       DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
33019       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
33020       DATA AXIAL2 /1.03D0/  ! to be checked
33021
33022       FA0=-1.253D0
33023       CSI = 3.71D0                   !  ???
33024       GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2   ! G_e(q**2)
33025       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
33026       X = Q2/(EMN*EMN)     ! emn=massa barione
33027       XA = X/4.D0
33028       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
33029       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
33030       FA = FA0/(1.D0 + Q2/AXIAL2)**2
33031       FFA = FA*FA
33032       FFV1 = FV1*FV1
33033       FFV2 = FV2*FV2
33034       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
33035       A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
33036       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
33037       AA = (XA+0.25D0*RM)*(A1 + A2)
33038       BB = -X*FA*(FV1 + FV2)
33039       CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
33040       SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
33041       DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU)  !
33042       IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
33043
33044       RETURN
33045       END
33046 *
33047 *===prepola============================================================*
33048 *
33049 CDECK  ID>, DT_PREPOLA
33050       SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
33051
33052       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33053       SAVE
33054 c
33055 c By G. Battistoni and E. Scapparone (sept. 1997)
33056 c According to:
33057 c     Albright & Jarlskog, Nucl Phys B84 (1975) 467
33058 c
33059 c
33060
33061       PARAMETER (MAXLND=4000)
33062       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
33063
33064       COMMON /QNPOL/ POLARX(4),PMODUL
33065 * particle masses used in qel neutrino scattering modules
33066       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
33067      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
33068      &                EMPROTSQ,EMNEUTSQ,EMNSQ
33069 * steering flags for qel neutrino scattering modules
33070       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
33071 **sr - removed (not needed)
33072 C     COMMON /CAXIAL/ FA0, AXIAL2
33073 C     COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
33074 C    &        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
33075 **
33076       REAL*8 POL(4,4),BB2(3)
33077       DIMENSION SS(6)
33078 C     DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
33079       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
33080 **sr uncommented since common block CAXIAL is now commented
33081       DATA AXIAL2 /1.03D0/  ! to be checked
33082 **
33083
33084       RML=P(4,5)
33085       RMM=0.93960D+00
33086       FM2 = RMM**2
33087       MPI = 0.135D+00
33088       OLDQ2=Q2
33089       FA0=-1.253D+00
33090       CSI = 3.71D+00                      !
33091       GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2   ! G_e(q**2)
33092       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
33093       X = Q2/(EMN*EMN)     ! emn=massa barione
33094       XA = X/4.D0
33095       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
33096       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
33097       FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
33098       FFA = FA*FA
33099       FFV1 = FV1*FV1
33100       FFV2 = FV2*FV2
33101       FP=2.D0*FA*RMM/(MPI**2 + Q2)
33102       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
33103       A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
33104       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
33105       AA = (XA+0.25D+00*RM)*(A1 + A2)
33106       BB = -X*FA*(FV1 + FV2)
33107       CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
33108       SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
33109
33110       OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2   )  ! articolo di ll...-smith
33111       OMEGA2=4.D+00*CC
33112       OMEGA3=2.D+00*FA*(FV1+FV2)
33113       OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
33114      1     (Q2/FM2))*FP**2)
33115       OMEGA5=OMEGA2
33116       OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
33117       WW1=2.D+00*OMEGA1*EMN**2
33118       WW2=2.D+00*OMEGA2*EMN**2
33119       WW3=2.D+00*OMEGA3*EMN**2
33120       WW4=2.D+00*OMEGA4*EMN**2
33121       WW5=2.D+00*OMEGA5*EMN**2
33122
33123       DO I=1,3
33124         BB2(I)=-P(4,I)/P(4,4)
33125       END DO
33126 c      WRITE(*,*)
33127 c      WRITE(*,*)
33128 c      WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
33129       N=5
33130
33131       CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
33132
33133 * NOW PARTICLES ARE IN THE SCATTERED LEPTON  REST FRAME
33134 c      WRITE(*,*)
33135 c      WRITE(*,*)
33136 c      WRITE(*,*) 'Prepola: now in lepton rest frame'
33137       EE=ENU
33138       QM2=Q2+RML**2
33139       U=Q2/(2.*RMM)
33140       FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
33141      +     (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
33142      +     ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
33143
33144       FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
33145      +     - ((RML**2)/FM2)*WW4                        !<=FM2 inv di RMM!!
33146
33147       FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
33148
33149       DO I=1,3
33150         POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
33151         POLARX(I)=POL(4,I)
33152       END DO
33153
33154       PMODUL=0.D0
33155       DO I=1,3
33156         PMODUL=PMODUL+POL(4,I)**2
33157       END DO
33158
33159       IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
33160          IF(NEUDEC.EQ.1) THEN
33161             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
33162      +        ETL,PXL,PYL,PZL,
33163      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
33164 c
33165 c     Tau has decayed in muon
33166 c
33167          ENDIF
33168          IF(NEUDEC.EQ.2) THEN
33169             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
33170      +        ETL,PXL,PYL,PZL,
33171      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
33172 c
33173 c     Tau has decayed in electron
33174 c
33175          ENDIF
33176          K(4,1)=15
33177          K(4,4) = 6
33178          K(4,5) = 8
33179          N=N+3
33180 c
33181 c     fill common for muon(electron)
33182 c
33183          P(6,1)=PXL
33184          P(6,2)=PYL
33185          P(6,3)=PZL
33186          P(6,4)=ETL
33187          K(6,1)=1
33188          IF(JTYP.EQ.5) THEN
33189             IF(NEUDEC.EQ.1) THEN
33190                P(6,5)=EML(JTYP-2)
33191                K(6,2)=13
33192             ELSEIF(NEUDEC.EQ.2) THEN
33193                P(6,5)=EML(JTYP-4)
33194                K(6,2)=11
33195             ENDIF
33196          ELSEIF(JTYP.EQ.6) THEN
33197             IF(NEUDEC.EQ.1) THEN
33198                K(6,2)=-13
33199             ELSEIF(NEUDEC.EQ.2) THEN
33200                K(6,2)=-11
33201             ENDIF
33202          END IF
33203          K(6,3)=4
33204          K(6,4)=0
33205          K(6,5)=0
33206 c
33207 c     fill common for tau_(anti)neutrino
33208 c
33209          P(7,1)=PXB
33210          P(7,2)=PYB
33211          P(7,3)=PZB
33212          P(7,4)=ETB
33213          P(7,5)=0.
33214          K(7,1)=1
33215          IF(JTYP.EQ.5) THEN
33216             K(7,2)=16
33217          ELSEIF(JTYP.EQ.6) THEN
33218             K(7,2)=-16
33219          END IF
33220          K(7,3)=4
33221          K(7,4)=0
33222          K(7,5)=0
33223 c
33224 c     Fill common for muon(electron)_(anti)neutrino
33225 c
33226          P(8,1)=PXN
33227          P(8,2)=PYN
33228          P(8,3)=PZN
33229          P(8,4)=ETN
33230          P(8,5)=0.
33231          K(8,1)=1
33232          IF(JTYP.EQ.5) THEN
33233             IF(NEUDEC.EQ.1) THEN
33234                K(8,2)=-14
33235             ELSEIF(NEUDEC.EQ.2) THEN
33236                K(8,2)=-12
33237             ENDIF
33238          ELSEIF(JTYP.EQ.6) THEN
33239             IF(NEUDEC.EQ.1) THEN
33240                K(8,2)=14
33241             ELSEIF(NEUDEC.EQ.2) THEN
33242                K(8,2)=12
33243             ENDIF
33244          END IF
33245          K(8,3)=4
33246          K(8,4)=0
33247          K(8,5)=0
33248       ENDIF
33249 c      WRITE(*,*)
33250 c      WRITE(*,*)
33251
33252 c      IF(PMODUL.GE.1.D+00) THEN
33253 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
33254 c        write(*,*) pmodul
33255 c        DO I=1,3
33256 c          POL(4,I)=POL(4,I)/PMODUL
33257 c          POLARX(I)=POL(4,I)
33258 c        END DO
33259 c        PMODUL=0.
33260 c        DO I=1,3
33261 c          PMODUL=PMODUL+POL(4,I)**2
33262 c        END DO
33263 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
33264 c
33265 c      ENDIF
33266
33267 c      WRITE(*,*) 'PMODUL = ',PMODUL
33268
33269 c      WRITE(*,*)
33270 c      WRITE(*,*)
33271 c      WRITE(*,*) 'prepola: Now back to nucl rest frame'
33272
33273       CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
33274
33275       XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
33276       YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
33277       ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
33278       DO NDC =6,8
33279          V(NDC,1) = XDC
33280          V(NDC,2) = YDC
33281          V(NDC,3) = ZDC
33282       END DO
33283
33284       RETURN
33285       END
33286 *
33287 *===testrot============================================================*
33288 *
33289 CDECK  ID>, DT_TESTROT
33290       SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
33291
33292       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33293       SAVE
33294
33295       DIMENSION ROT(3,3),PI(3),PO(3)
33296
33297       IF (MODE.EQ.1) THEN
33298          ROT(1,1) = 1.D0
33299          ROT(1,2) = 0.D0
33300          ROT(1,3) = 0.D0
33301          ROT(2,1) = 0.D0
33302          ROT(2,2) = COS(PHI)
33303          ROT(2,3) = -SIN(PHI)
33304          ROT(3,1) = 0.D0
33305          ROT(3,2) = SIN(PHI)
33306          ROT(3,3) = COS(PHI)
33307       ELSEIF (MODE.EQ.2) THEN
33308          ROT(1,1) = 0.D0
33309          ROT(1,2) = 1.D0
33310          ROT(1,3) = 0.D0
33311          ROT(2,1) = COS(PHI)
33312          ROT(2,2) = 0.D0
33313          ROT(2,3) = -SIN(PHI)
33314          ROT(3,1) = SIN(PHI)
33315          ROT(3,2) = 0.D0
33316          ROT(3,3) = COS(PHI)
33317       ELSEIF (MODE.EQ.3) THEN
33318          ROT(1,1) = 0.D0
33319          ROT(2,1) = 1.D0
33320          ROT(3,1) = 0.D0
33321          ROT(1,2) = COS(PHI)
33322          ROT(2,2) = 0.D0
33323          ROT(3,2) = -SIN(PHI)
33324          ROT(1,3) = SIN(PHI)
33325          ROT(2,3) = 0.D0
33326          ROT(3,3) = COS(PHI)
33327       ELSEIF (MODE.EQ.4) THEN
33328          ROT(1,1) = 1.D0
33329          ROT(2,1) = 0.D0
33330          ROT(3,1) = 0.D0
33331          ROT(1,2) = 0.D0
33332          ROT(2,2) = COS(PHI)
33333          ROT(3,2) = -SIN(PHI)
33334          ROT(1,3) = 0.D0
33335          ROT(2,3) = SIN(PHI)
33336          ROT(3,3) = COS(PHI)
33337       ELSE
33338          STOP ' TESTROT: mode not supported!'
33339       ENDIF
33340       DO 1 J=1,3
33341         PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
33342     1 CONTINUE
33343
33344       RETURN
33345       END
33346 *
33347 *===lepdcyp============================================================*
33348 *
33349 CDECK  ID>, DT_LEPDCYP
33350       SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
33351      &                      ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
33352 C
33353 C-----------------------------------------------------------------
33354 C
33355 C   Author   :- G. Battistoni         10-NOV-1995
33356 C
33357 C=================================================================
33358 C
33359 C   Purpose   : performs decay of polarized lepton in
33360 C               its rest frame: a => b + l + anti-nu
33361 C               (Example: mu- => nu-mu + e- + anti-nu-e)
33362 C               Polarization is assumed along Z-axis
33363 C               WARNING:
33364 C               1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
33365 C                  OF NEGLIGIBLE MASS
33366 C               2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
33367 C                  IN THIS VERSION
33368 C
33369 C   Method    : modifies phase space distribution obtained
33370 C               by routine EXPLOD using a rejection against the
33371 C               matrix element for unpolarized lepton decay
33372 C
33373 C   Inputs    : Mass of a :  AMA
33374 C               Mass of l :  AML
33375 C               Polar. of a: POL
33376 C               (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
33377 C                                                 POL = -1)
33378 C
33379 C   Outputs   : kinematic variables in the rest frame of decaying lepton
33380 C               ETL,PXL,PYL,PZL 4-moment of l
33381 C               ETB,PXB,PYB,PZB 4-moment of b
33382 C               ETN,PXN,PYN,PZN 4-moment of anti-nu
33383 C
33384 C============================================================
33385 C +
33386 C Declarations.
33387 C -
33388       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33389       SAVE
33390
33391       PARAMETER ( LINP = 5 ,
33392      &            LOUT = 6 ,
33393      &            LDAT = 9 )
33394
33395       PARAMETER ( KALGNM = 2 )
33396       PARAMETER ( ANGLGB = 5.0D-16 )
33397       PARAMETER ( ANGLSQ = 2.5D-31 )
33398       PARAMETER ( AXCSSV = 0.2D+16 )
33399       PARAMETER ( ANDRFL = 1.0D-38 )
33400       PARAMETER ( AVRFLW = 1.0D+38 )
33401       PARAMETER ( AINFNT = 1.0D+30 )
33402       PARAMETER ( AZRZRZ = 1.0D-30 )
33403       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
33404       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
33405       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
33406       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
33407       PARAMETER ( CSNNRM = 2.0D-15 )
33408       PARAMETER ( DMXTRN = 1.0D+08 )
33409       PARAMETER ( ZERZER = 0.D+00 )
33410       PARAMETER ( ONEONE = 1.D+00 )
33411       PARAMETER ( TWOTWO = 2.D+00 )
33412       PARAMETER ( THRTHR = 3.D+00 )
33413       PARAMETER ( FOUFOU = 4.D+00 )
33414       PARAMETER ( FIVFIV = 5.D+00 )
33415       PARAMETER ( SIXSIX = 6.D+00 )
33416       PARAMETER ( SEVSEV = 7.D+00 )
33417       PARAMETER ( EIGEIG = 8.D+00 )
33418       PARAMETER ( ANINEN = 9.D+00 )
33419       PARAMETER ( TENTEN = 10.D+00 )
33420       PARAMETER ( HLFHLF = 0.5D+00 )
33421       PARAMETER ( ONETHI = ONEONE / THRTHR )
33422       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
33423       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
33424       PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
33425       PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
33426       PARAMETER ( CLIGHT = 2.99792458         D+10 )
33427       PARAMETER ( AVOGAD = 6.0221367          D+23 )
33428       PARAMETER ( AMELGR = 9.1093897          D-28 )
33429       PARAMETER ( PLCKBR = 1.05457266         D-27 )
33430       PARAMETER ( ELCCGS = 4.8032068          D-10 )
33431       PARAMETER ( ELCMKS = 1.60217733         D-19 )
33432       PARAMETER ( AMUGRM = 1.6605402          D-24 )
33433       PARAMETER ( AMMUMU = 0.113428913        D+00 )
33434       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
33435       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
33436       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
33437       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
33438       PARAMETER ( PLABRC = 0.197327053        D+00 )
33439       PARAMETER ( AMELCT = 0.51099906         D-03 )
33440       PARAMETER ( AMUGEV = 0.93149432         D+00 )
33441       PARAMETER ( AMMUON = 0.105658389        D+00 )
33442       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
33443       PARAMETER ( GEVMEV = 1.0                D+03 )
33444       PARAMETER ( EMVGEV = 1.0                D-03 )
33445       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
33446       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
33447       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
33448 C +
33449 C    variables for EXPLOD
33450 C -
33451       PARAMETER ( KPMX = 10 )
33452       DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
33453      &          PZEXPL (KPMX), ETEXPL (KPMX)
33454 C +
33455 C      test variables
33456 C -
33457 **sr - removed (not needed)
33458 C     COMMON /GBATNU/ ELERAT,NTRY
33459 **
33460 C +
33461 C     Initializes test variables
33462 C -
33463       NTRY = 0
33464       ELERAT = 0.D+00
33465 C +
33466 C     Maximum value for matrix element
33467 C -
33468       ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
33469      &  SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
33470 C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
33471 C     Inputs for EXPLOD
33472 C part. no. 1 is l       (e- in mu- decay)
33473 C part. no. 2 is b       (nu-mu in mu- decay)
33474 C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
33475 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
33476       NPEXPL = 3
33477       ETOTEX = AMA
33478       AMEXPL(1) = AML
33479       AMEXPL(2) = 0.D+00
33480       AMEXPL(3) = 0.D+00
33481 C +
33482 C     phase space distribution
33483 C -
33484   100 CONTINUE
33485       NTRY = NTRY + 1
33486
33487       CALL EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
33488      &              PYEXPL, PZEXPL )
33489
33490 C +
33491 C  Calculates matrix element:
33492 C  64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
33493 C  Here CTH is the cosine of the angle between anti-nu and Z axis
33494 C -
33495       CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
33496      &  PZEXPL(3)**2 )
33497       PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
33498       PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
33499      &     PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
33500       ELEMAT = 16.D+00 * PROD1 * PROD2
33501       IF(ELEMAT.GT.ELEMAX) THEN
33502         WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
33503         STOP
33504       ENDIF
33505 C +
33506 C     Here performs the rejection
33507 C -
33508       TEST = DT_RNDM(ETOTEX) * ELEMAX
33509       IF ( TEST .GT. ELEMAT ) GO TO 100
33510 C +
33511 C     final assignment of variables
33512 C -
33513       ELERAT = ELEMAT/ELEMAX
33514       ETL = ETEXPL(1)
33515       PXL = PXEXPL(1)
33516       PYL = PYEXPL(1)
33517       PZL = PZEXPL(1)
33518       ETB = ETEXPL(2)
33519       PXB = PXEXPL(2)
33520       PYB = PYEXPL(2)
33521       PZB = PZEXPL(2)
33522       ETN = ETEXPL(3)
33523       PXN = PXEXPL(3)
33524       PYN = PYEXPL(3)
33525       PZN = PZEXPL(3)
33526   999 RETURN
33527       END
33528
33529 C==================================================================
33530 C.  Generation of  Delta resonance events
33531 C==================================================================
33532 *
33533 *===gen_delta==========================================================*
33534 *
33535 CDECK  ID>, DT_GEN_DELTA
33536       SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
33537
33538       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33539       SAVE
33540
33541       PARAMETER ( LINP = 5 ,
33542      &            LOUT = 6 ,
33543      &            LDAT = 9 )
33544
33545 C...Generate a Delta-production neutrino/antineutrino
33546 C.  CC-interaction on a nucleon
33547 C
33548 C.  INPUT  ENU (GeV) = Neutrino Energy
33549 C.         LLEP = neutrino type
33550 C.         LTARG = nucleon target type 1=p, 2=n.
33551 C.         JINT = 1:CC, 2::NC
33552 C.
33553 C.  OUTPUT PPL(4)  4-monentum of final lepton
33554 C----------------------------------------------------
33555
33556       PARAMETER (MAXLND=4000)
33557       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
33558
33559 **sr - removed (not needed)
33560 C     COMMON /CBAD/  LBAD, NBAD
33561 **
33562
33563       DIMENSION PI(3),PO(3)
33564 C     REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
33565       DIMENSION AML0(6),AMN(2)
33566       DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
33567       DATA AMN  /0.93827231, 0.93956563/
33568       DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
33569
33570 c     WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
33571       LBAD = 0
33572 C...Final lepton mass
33573       IF (JINT.EQ.1) THEN
33574         AML = AML0(LLEP)
33575       ELSE
33576         AML = 0.
33577       ENDIF
33578       AML2 = AML**2
33579
33580 C...Particle labels (LUND)
33581       N = 5
33582       K(1,1) = 21
33583       K(2,1) = 21
33584       K(3,1) = 21
33585       K(4,1) = 1
33586       K(3,3) = 1
33587       K(4,3) = 1
33588       IF (LTARG .EQ. 1)  THEN
33589          K(2,2) = 2212
33590       ELSE
33591          K(2,2) = 2112
33592       ENDIF
33593       K0 = (LLEP-1)/2
33594       K1 = LLEP/2
33595       KA = 12 + 2*K0
33596       IS = -1 + 2*LLEP - 4*K1
33597       LNU = 2 - LLEP + 2*K1
33598       K(1,2) = IS*KA
33599       K(5,1) = 1
33600       K(5,3) = 2
33601       IF (JINT .EQ. 1)  THEN                    ! CC interactions
33602          K(3,2) = IS*24
33603          K(4,2) = IS*(KA-1)
33604         IF(LNU.EQ.1) THEN
33605           IF (LTARG .EQ. 1)  THEN
33606               K(5,2) = 2224
33607           ELSE
33608               K(5,2) = 2214
33609           ENDIF
33610         ELSE
33611           IF (LTARG .EQ. 1)  THEN
33612               K(5,2) = 2114
33613           ELSE
33614               K(5,2) = 1114
33615           ENDIF
33616         ENDIF
33617       ELSE
33618          K(3,2) = 23                           ! NC (Z0) interactions
33619          K(4,2) = K(1,2)
33620 **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
33621 *                                Delta0 for neutron (LTARG=2)
33622 C        IF (LTARG .EQ. 1)  THEN
33623 C           K(5,2) = 2114
33624 C        ELSE
33625 C           K(5,2) = 2214
33626 C        ENDIF
33627          IF (LTARG .EQ. 1)  THEN
33628             K(5,2) = 2214
33629          ELSE
33630             K(5,2) = 2114
33631          ENDIF
33632 **
33633       ENDIF
33634
33635 C...4-momentum initial lepton
33636       P(1,5) = 0.
33637       P(1,4) = ENU
33638       P(1,1) = 0.
33639       P(1,2) = 0.
33640       P(1,3) = ENU
33641 C...4-momentum initial nucleon
33642       P(2,5) = AMN(LTARG)
33643 C     P(2,4) = P(2,5)
33644 C     P(2,1) = 0.
33645 C     P(2,2) = 0.
33646 C     P(2,3) = 0.
33647        P(2,1) = P21
33648        P(2,2) = P22
33649        P(2,3) = P23
33650        P(2,4) = P24
33651        P(2,5) = P25
33652       N=2
33653       beta1=-p(2,1)/p(2,4)
33654       beta2=-p(2,2)/p(2,4)
33655       beta3=-p(2,3)/p(2,4)
33656       N=2
33657
33658       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
33659
33660 C     print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
33661
33662       phi11=atan(p(1,2)/p(1,3))
33663       pi(1)=p(1,1)
33664       pi(2)=p(1,2)
33665       pi(3)=p(1,3)
33666
33667       CALL DT_TESTROT(PI,Po,PHI11,1)
33668       DO ll=1,3
33669        IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
33670       END DO
33671       p(1,1)=po(1)
33672       p(1,2)=po(2)
33673       p(1,3)=po(3)
33674       phi12=atan(p(1,1)/p(1,3))
33675
33676       pi(1)=p(1,1)
33677       pi(2)=p(1,2)
33678       pi(3)=p(1,3)
33679       CALL DT_TESTROT(Pi,Po,PHI12,2)
33680       DO ll=1,3
33681         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
33682       END DO
33683       p(1,1)=po(1)
33684       p(1,2)=po(2)
33685       p(1,3)=po(3)
33686
33687       ENUU=P(1,4)
33688
33689 C...Generate the Mass of the Delta
33690       NTRY = 0
33691 100   R = PYR(0)
33692       AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
33693       NTRY = NTRY + 1
33694       IF (NTRY .GT. 1000)  THEN
33695          LBAD = 1
33696          WRITE (LOUT,1001)  NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
33697          RETURN
33698       ENDIF
33699       IF (AMD .LT. AMDMIN)  GOTO 100
33700       ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
33701       IF (ENUU .LT. ET) GOTO 100
33702
33703 C...Kinematical  limits in Q**2
33704       S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
33705       SQS = SQRT(S)
33706       PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
33707       ELF = (S - AMD**2 + AML2)/(2.*SQS)
33708       PLF = SQRT(ELF**2 - AML2)
33709       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
33710       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
33711       IF (Q2MIN .LT. 0.)   Q2MIN = 0.
33712
33713       DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
33714 200   Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
33715       DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
33716       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
33717
33718 C...Generate the kinematics of the final particles
33719       EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
33720       GAM = EISTAR/AMN(LTARG)
33721       BET = PSTAR/EISTAR
33722       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
33723       EL  = GAM*(ELF + BET*PLF*CTSTAR)
33724       PLZ = GAM*(PLF*CTSTAR + BET*ELF)
33725       PL  = SQRT(EL**2 - AML2)
33726       PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
33727       PHI = 6.28319*PYR(0)
33728       P(4,1) = PLT*COS(PHI)
33729       P(4,2) = PLT*SIN(PHI)
33730       P(4,3) = PLZ
33731       P(4,4) = EL
33732       P(4,5) = AML
33733
33734 C...4-momentum of Delta
33735       P(5,1) = -P(4,1)
33736       P(5,2) = -P(4,2)
33737       P(5,3) = ENUU-P(4,3)
33738       P(5,4) = ENUU+AMN(LTARG)-P(4,4)
33739       P(5,5) = AMD
33740
33741 C...4-momentum  of intermediate boson
33742       P(3,5) = -Q2
33743       P(3,4) = P(1,4)-P(4,4)
33744       P(3,1) = P(1,1)-P(4,1)
33745       P(3,2) = P(1,2)-P(4,2)
33746       P(3,3) = P(1,3)-P(4,3)
33747       N=5
33748
33749       DO kw=1,5
33750         pi(1)=p(kw,1)
33751         pi(2)=p(kw,2)
33752         pi(3)=p(kw,3)
33753         CALL DT_TESTROT(Pi,Po,PHI12,3)
33754         DO ll=1,3
33755           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
33756         END DO
33757         p(kw,1)=po(1)
33758         p(kw,2)=po(2)
33759         p(kw,3)=po(3)
33760       END DO
33761
33762 c********************************************
33763
33764         DO kw=1,5
33765           pi(1)=p(kw,1)
33766           pi(2)=p(kw,2)
33767           pi(3)=p(kw,3)
33768           CALL DT_TESTROT(Pi,Po,PHI11,4)
33769           DO ll=1,3
33770             IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
33771           END DO
33772           p(kw,1)=po(1)
33773           p(kw,2)=po(2)
33774           p(kw,3)=po(3)
33775        END DO
33776 c********************************************
33777 C         transform back into Lab.
33778
33779       CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
33780
33781 C     WRITE(6,*)' Lab fram ( fermi incl.) '
33782       N=5
33783       CALL PYEXEC
33784
33785       RETURN
33786 1001  FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5,  6G10.3)
33787       END
33788 *
33789 *===dsigma_delta=======================================================*
33790 *
33791 CDECK  ID>, DT_DSIGMA_DELTA
33792       DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
33793
33794       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33795       SAVE
33796
33797 C...Reaction nu + N -> lepton + Delta
33798 C.  returns the  cross section
33799 C.  dsigma/dt
33800 C.  INPUT  LNU = 1, 2  (neutrino-antineutrino)
33801 C.         QQ = t (always negative)  GeV**2
33802 C.         S  = (c.m energy)**2      GeV**2
33803 C.  OUTPUT =  10**-38 cm+2/GeV**2
33804 C-----------------------------------------------------
33805       REAL*8 MN, MN2, MN4, MD,MD2, MD4
33806       DATA MN /0.938/
33807       DATA PI /3.1415926/
33808
33809       GF = (1.1664 * 1.97)
33810       GF2 = GF*GF
33811       MN2 = MN*MN
33812       MN4 = MN2*MN2
33813       MD2 = MD*MD
33814       MD4 = MD2*MD2
33815       AML2 = AML*AML
33816       AML4 = AML2*AML2
33817       VQ  = (MN2 - MD2 - QQ)/2.
33818       VPI = (MN2 + MD2 - QQ)/2.
33819       VK  = (S + QQ - MN2 - AML2)/2.
33820       PIK = (S - MN2)/2.
33821       QK = (AML2 - QQ)/2.
33822       PIQ = (QQ + MN2 - MD2)/2.
33823       Q = SQRT(-QQ)
33824       C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
33825       C3 = SQRT(3.)*C3V/MN
33826       C4 = -C3/MD             ! attenzione al segno
33827       C5A = 1.18/(1.-QQ/0.4225)**2
33828       C32 = C3**2
33829       C42 = C4**2
33830       C5A2 = C5A**2
33831
33832       IF (LNU .EQ. 1)  THEN
33833       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
33834      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
33835      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
33836      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
33837       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
33838      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
33839      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
33840      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
33841      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
33842      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
33843      . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
33844      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
33845      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
33846      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
33847      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
33848      . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
33849      . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
33850      . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
33851      . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
33852      . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
33853      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
33854      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
33855      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
33856       ELSE
33857       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
33858      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
33859      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
33860      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
33861       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
33862      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
33863      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
33864      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
33865      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
33866      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
33867      . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
33868      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
33869      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
33870      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
33871      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
33872      . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
33873      . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
33874      . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
33875      . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
33876      . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
33877      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
33878      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
33879      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
33880       ENDIF
33881       ANS1=32.*ANS2
33882       ANS=ANS1/(3.*MD2)
33883       P1CM = (S-MN2)/(2.*SQRT(S))
33884       DT_DSIGMA_DELTA  = GF2/2. * ANS/(64.*PI*S*P1CM**2)
33885
33886       RETURN
33887       END
33888 *
33889 *===qgaus==============================================================*
33890 *
33891 CDECK  ID>, DT_QGAUS
33892       SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
33893
33894       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33895       SAVE
33896
33897       DIMENSION X(5),W(5)
33898       DATA X/.1488743389D0,.4333953941D0,
33899      & .6794095682D0,.8650633666D0,.9739065285D0
33900      */
33901       DATA W/.2955242247D0,.2692667193D0,
33902      & .2190863625D0,.1494513491D0,.0666713443D0
33903      */
33904       XM=0.5D0*(B+A)
33905       XR=0.5D0*(B-A)
33906       SS=0
33907       DO 11 J=1,5
33908         DX=XR*X(J)
33909         SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
33910      *  DT_DSQEL_Q2(LTYP,ENU,XM-DX))
33911 11    CONTINUE
33912       SS=XR*SS
33913
33914       RETURN
33915       END
33916 *
33917 *===diqbrk=============================================================*
33918 *
33919 CDECK  ID>, DT_DIQBRK
33920       SUBROUTINE DT_DIQBRK
33921
33922       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33923       SAVE
33924
33925 * event history
33926
33927       PARAMETER (NMXHKK=200000)
33928
33929       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
33930      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
33931      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
33932 * extended event history
33933       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
33934      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
33935      &                IHIST(2,NMXHKK)
33936 * event flag
33937       COMMON /DTEVNO/ NEVENT,ICASCA
33938
33939 C     IF(DT_RNDM(VV).LE.0.5D0)THEN
33940 C       CALL GSQBS1(NHKK)
33941 C       CALL GSQBS2(NHKK)
33942 C       CALL USQBS1(NHKK)
33943 C       CALL USQBS2(NHKK)
33944 C       CALL GSABS1(NHKK)
33945 C       CALL GSABS2(NHKK)
33946 C       CALL USABS1(NHKK)
33947 C       CALL USABS2(NHKK)
33948 C     ELSE
33949 C       CALL GSQBS2(NHKK)
33950 C       CALL GSQBS1(NHKK)
33951 C       CALL USQBS2(NHKK)
33952 C       CALL USQBS1(NHKK)
33953 C       CALL GSABS2(NHKK)
33954 C       CALL GSABS1(NHKK)
33955 C       CALL USABS2(NHKK)
33956 C       CALL USABS1(NHKK)
33957 C     ENDIF
33958
33959       IF(DT_RNDM(VV).LE.0.5D0) THEN
33960         CALL DT_DBREAK(1)
33961         CALL DT_DBREAK(2)
33962         CALL DT_DBREAK(3)
33963         CALL DT_DBREAK(4)
33964         CALL DT_DBREAK(5)
33965         CALL DT_DBREAK(6)
33966         CALL DT_DBREAK(7)
33967         CALL DT_DBREAK(8)
33968       ELSE
33969         CALL DT_DBREAK(2)
33970         CALL DT_DBREAK(1)
33971         CALL DT_DBREAK(4)
33972         CALL DT_DBREAK(3)
33973         CALL DT_DBREAK(6)
33974         CALL DT_DBREAK(5)
33975         CALL DT_DBREAK(8)
33976         CALL DT_DBREAK(7)
33977       ENDIF
33978
33979       RETURN
33980       END
33981 C
33982 C
33983 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
33984       SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
33985      *              IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
33986 C
33987 C                  USQBS-2 diagram (split target diquark)
33988 C
33989       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33990       SAVE
33991
33992       PARAMETER ( LINP = 5 ,
33993      &            LOUT = 6 ,
33994      &            LDAT = 9 )
33995
33996 * event history
33997
33998       PARAMETER (NMXHKK=200000)
33999
34000       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
34001      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
34002      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
34003 * extended event history
34004       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
34005      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
34006      &                IHIST(2,NMXHKK)
34007 * Lorentz-parameters of the current interaction
34008       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
34009      &                UMO,PPCM,EPROJ,PPROJ
34010 * diquark-breaking mechanism
34011       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
34012
34013 C
34014       PARAMETER (NTMHKK= 300)
34015       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
34016      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
34017      +(4,NTMHKK)
34018 *KEEP,XSEADI.
34019       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
34020      +SSMIMQ,VVMTHR
34021 *KEEP,DPRIN.
34022       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
34023       COMMON /EVFLAG/ NUMEV
34024 C
34025 C                  USQBS-2 diagram (split target diquark)
34026 C
34027 C
34028 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
34029 C     Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
34030 C
34031 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
34032 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
34033 C
34034 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
34035 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34036 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
34037 C
34038 C
34039 C       Put new chains into COMMON /HKKTMP/
34040 C
34041       IIGLU1=NC1T-NC1P-1
34042       IIGLU2=NC2T-NC2P-1
34043       IGCOUN=0
34044 C     WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
34045       CVQ=1.D0
34046       IREJ=0
34047       IF(IPIP.EQ.2)THEN
34048 C     IF(NUMEV.EQ.-324)THEN
34049 C     WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
34050 C    *             'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
34051 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
34052 C    *              IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
34053       ENDIF
34054 C
34055 C
34056 C
34057 C     determine x-values of NC1T diquark
34058       XDIQT=PHKK(4,NC1T)*2.D0/UMO
34059       XVQP=PHKK(4,NC1P)*2.D0/UMO
34060 C
34061 C     determine x-values of sea quark pair
34062 C
34063       IPCO=1
34064       ICOU=0
34065  2234 CONTINUE
34066       ICOU=ICOU+1
34067       IF(ICOU.GE.500)THEN
34068         IREJ=1
34069         IF(ISQ.EQ.3)IREJ=3
34070         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
34071         IPCO=0
34072         RETURN
34073       ENDIF
34074       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
34075      * UMO, XDIQT,XVQP
34076       XSQ=0.D0
34077       XSAQ=0.D0
34078 **NEW
34079 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
34080       IF (IPIP.EQ.1) THEN
34081          XQMAX  = XDIQT/2.0D0
34082          XAQMAX = 2.D0*XVQP/3.0D0
34083       ELSE
34084          XQMAX  = 2.D0*XVQP/3.0D0
34085          XAQMAX = XDIQT/2.0D0
34086       ENDIF
34087       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
34088       ISAQ = 6+ISQ
34089 C     write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
34090 **
34091         IF(IPCO.GE.3)
34092      &     WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
34093       IF(IREJ.GE.1)THEN
34094         IF(IPCO.GE.3)
34095      &     WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
34096         IPCO=0
34097         RETURN
34098       ENDIF
34099       IF(IPIP.EQ.1)THEN
34100         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
34101       ELSEIF(IPIP.EQ.2)THEN
34102         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
34103       ENDIF
34104       IF(IPCO.GE.3)THEN
34105         WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
34106      *  XDIQT,XVQP,XSQ,XSAQ
34107       ENDIF
34108 C
34109 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
34110 C
34111 C     XSQ=0.D0
34112       IF(IPIP.EQ.1)THEN
34113         XDIQT=XDIQT-XSQ
34114         XVQP =XVQP -XSAQ
34115       ELSEIF(IPIP.EQ.2)THEN
34116         XDIQT=XDIQT-XSAQ
34117         XVQP =XVQP -XSQ
34118       ENDIF
34119       IF(IPCO.GE.3)
34120      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
34121 C
34122 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
34123 C
34124       XVTHRO=CVQ/UMO
34125       IVTHR=0
34126  3466 CONTINUE
34127       IF(IVTHR.EQ.10)THEN
34128         IREJ=1
34129         IF(ISQ.EQ.3)IREJ=3
34130         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
34131       IPCO=0
34132         RETURN
34133       ENDIF
34134       IVTHR=IVTHR+1
34135       XVTHR=XVTHRO/(201-IVTHR)
34136       UNOPRV=UNON
34137  380  CONTINUE
34138       IF(XVTHR.GT.0.66D0*XDIQT)THEN
34139         IREJ=1
34140         IF(ISQ.EQ.3)IREJ=3
34141         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR  large ',
34142      *  XVTHR
34143       IPCO=0
34144         RETURN
34145       ENDIF
34146       IF(DT_RNDM(V).LT.0.5D0)THEN
34147         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
34148         XVTQII=XDIQT-XVTQI
34149       ELSE
34150         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
34151         XVTQI=XDIQT-XVTQII
34152       ENDIF
34153       IF(IPCO.GE.3)THEN
34154         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
34155       ENDIF
34156 C
34157 C     Prepare 4 momenta of new chains and chain ends
34158 C
34159 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
34160 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
34161 C    +(4,NTMHKK)
34162 C
34163 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
34164 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34165 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
34166 C
34167 C     SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
34168 C    *              IP1,IP21,IP22,IPP1,IPP2)
34169 C
34170       IF(IPIP.EQ.1)THEN
34171         XSQ1=XSQ
34172         XSAQ1=XSAQ
34173         ISQ1=ISQ
34174         ISAQ1=ISAQ
34175       ELSEIF(IPIP.EQ.2)THEN
34176         XSQ1=XSAQ
34177         XSAQ1=XSQ
34178         ISQ1=ISAQ
34179         ISAQ1=ISQ
34180       ENDIF
34181       IDHKT(1)   =IPP1
34182       ISTHKT(1)  =951
34183       JMOHKT(1,1)=NC2P
34184       JMOHKT(2,1)=0
34185       JDAHKT(1,1)=3+IIGLU1
34186       JDAHKT(2,1)=0
34187 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
34188       PHKT(1,1)  =PHKK(1,NC2P)
34189       PHKT(2,1)  =PHKK(2,NC2P)
34190       PHKT(3,1)  =PHKK(3,NC2P)
34191       PHKT(4,1)  =PHKK(4,NC2P)
34192 C     PHKT(5,1)  =PHKK(5,NC2P)
34193       XMIST  =(PHKT(4,1)**2-
34194      * PHKT(3,1)**2-PHKT(2,1)**2-
34195      *PHKT(1,1)**2)
34196       IF(XMIST.GT.0.D0)THEN
34197       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
34198      *PHKT(1,1)**2)
34199       ELSE
34200 C     WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
34201       PHKT(5,1)=0.D0
34202       ENDIF
34203       VHKT(1,1)  =VHKK(1,NC2P)
34204       VHKT(2,1)  =VHKK(2,NC2P)
34205       VHKT(3,1)  =VHKK(3,NC2P)
34206       VHKT(4,1)  =VHKK(4,NC2P)
34207       WHKT(1,1)  =WHKK(1,NC2P)
34208       WHKT(2,1)  =WHKK(2,NC2P)
34209       WHKT(3,1)  =WHKK(3,NC2P)
34210       WHKT(4,1)  =WHKK(4,NC2P)
34211 C     Add here IIGLU1 gluons to this chaina
34212       PG1=0.D0
34213       PG2=0.D0
34214       PG3=0.D0
34215       PG4=0.D0
34216       IF(IIGLU1.GE.1)THEN
34217       JJG=NC1P
34218       DO 61 IIG=2,2+IIGLU1-1
34219         KKG=JJG+IIG-1
34220         IDHKT(IIG)   =IDHKK(KKG)
34221         ISTHKT(IIG)  =921
34222         JMOHKT(1,IIG)=KKG
34223         JMOHKT(2,IIG)=0
34224         JDAHKT(1,IIG)=3+IIGLU1
34225         JDAHKT(2,IIG)=0
34226         PHKT(1,IIG)=PHKK(1,KKG)
34227         PG1=PG1+ PHKT(1,IIG)
34228         PHKT(2,IIG)=PHKK(2,KKG)
34229         PG2=PG2+ PHKT(2,IIG)
34230         PHKT(3,IIG)=PHKK(3,KKG)
34231         PG3=PG3+ PHKT(3,IIG)
34232         PHKT(4,IIG)=PHKK(4,KKG)
34233         PG4=PG4+ PHKT(4,IIG)
34234         PHKT(5,IIG)=PHKK(5,KKG)
34235         VHKT(1,IIG)  =VHKK(1,KKG)
34236         VHKT(2,IIG)  =VHKK(2,KKG)
34237         VHKT(3,IIG)  =VHKK(3,KKG)
34238         VHKT(4,IIG)  =VHKK(4,KKG)
34239         WHKT(1,IIG) =WHKK(1,KKG)
34240         WHKT(2,IIG) =WHKK(2,KKG)
34241         WHKT(3,IIG) =WHKK(3,KKG)
34242         WHKT(4,IIG) =WHKK(4,KKG)
34243    61 CONTINUE
34244       ENDIF
34245       IDHKT(2+IIGLU1)   =IP21
34246       ISTHKT(2+IIGLU1)  =952
34247       JMOHKT(1,2+IIGLU1)=NC1T
34248       JMOHKT(2,2+IIGLU1)=0
34249       JDAHKT(1,2+IIGLU1)=3+IIGLU1
34250       JDAHKT(2,2+IIGLU1)=0
34251       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
34252       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
34253       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
34254       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
34255 C     PHKT(5,2)  =PHKK(5,NC1T)
34256       XMIST  =(PHKT(4,2+IIGLU1)**2-
34257      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
34258      *PHKT(1,2+IIGLU1)**2)
34259       IF(XMIST.GT.0.D0)THEN
34260       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
34261      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
34262      *PHKT(1,2+IIGLU1)**2)
34263       ELSE
34264 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
34265         PHKT(5,5+IIGLU1)=0.D0
34266       ENDIF
34267       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
34268       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
34269       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
34270       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
34271       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
34272       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
34273       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
34274       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
34275       IDHKT(3+IIGLU1)   =88888
34276       ISTHKT(3+IIGLU1)  =95
34277       JMOHKT(1,3+IIGLU1)=1
34278       JMOHKT(2,3+IIGLU1)=2+IIGLU1
34279       JDAHKT(1,3+IIGLU1)=0
34280       JDAHKT(2,3+IIGLU1)=0
34281       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
34282       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
34283       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
34284       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
34285       XMIST
34286      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
34287      *            -PHKT(3,3+IIGLU1)**2)
34288       IF(XMIST.GT.0.D0)THEN
34289       PHKT(5,3+IIGLU1)
34290      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
34291      *            -PHKT(3,3+IIGLU1)**2)
34292       ELSE
34293 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
34294         PHKT(5,5+IIGLU1)=0.D0
34295       ENDIF
34296       IF(IPIP.GE.2)THEN
34297 C     IF(NUMEV.EQ.-324)THEN
34298 C     WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
34299 C    * JDAHKT(1,1),
34300 C    *JDAHKT(2,1),(PHKT(III,1),III=1,5)
34301       DO 71 IIG=2,2+IIGLU1-1
34302 C     WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
34303 C    &             JMOHKT(1,IIG),JMOHKT(2,IIG),
34304 C    * JDAHKT(1,IIG),
34305 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
34306    71 CONTINUE
34307 C     WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
34308 C    * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
34309 C    *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
34310 C     WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
34311 C    * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
34312 C    *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
34313       ENDIF
34314       CHAMAL=CHAM1
34315       IF(IPIP.EQ.1)THEN
34316         IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
34317       ELSEIF(IPIP.EQ.2)THEN
34318         IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
34319       ENDIF
34320       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
34321 C       IREJ=1
34322         IPCO=0
34323 C       RETURN
34324 C       WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
34325         GO TO 3466
34326       ENDIF
34327       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
34328       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
34329       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
34330       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
34331       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
34332       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
34333       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
34334       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
34335       IF(IPIP.EQ.1)THEN
34336         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
34337       ELSEIF(IPIP.EQ.2)THEN
34338         IDHKT(4+IIGLU1)   =ISAQ1
34339       ENDIF
34340       ISTHKT(4+IIGLU1)  =951
34341       JMOHKT(1,4+IIGLU1)=NC1P
34342       JMOHKT(2,4+IIGLU1)=0
34343       JDAHKT(1,4+IIGLU1)=6+IIGLU1
34344       JDAHKT(2,4+IIGLU1)=0
34345 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34346       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
34347       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
34348       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
34349       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
34350 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
34351       XMIST  =(PHKT(4,4+IIGLU1)**2-
34352      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
34353      *PHKT(1,4+IIGLU1)**2)
34354       IF(XMIST.GT.0.D0)THEN
34355       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
34356      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
34357      *PHKT(1,4+IIGLU1)**2)
34358       ELSE
34359 C     WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
34360       PHKT(5,4+IIGLU1)=0.D0
34361       ENDIF
34362       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
34363       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
34364       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
34365       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
34366       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
34367       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
34368       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
34369       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
34370       IDHKT(5+IIGLU1)   =IP22
34371       ISTHKT(5+IIGLU1)  =952
34372       JMOHKT(1,5+IIGLU1)=NC1T
34373       JMOHKT(2,5+IIGLU1)=0
34374       JDAHKT(1,5+IIGLU1)=6+IIGLU1
34375       JDAHKT(2,5+IIGLU1)=0
34376       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
34377       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
34378       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
34379       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
34380 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
34381       XMIST  =(PHKT(4,5+IIGLU1)**2-
34382      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
34383      *PHKT(1,5+IIGLU1)**2)
34384       IF(XMIST.GT.0.D0)THEN
34385       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
34386      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
34387      *PHKT(1,5+IIGLU1)**2)
34388       ELSE
34389 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
34390         PHKT(5,5+IIGLU1)=0.D0
34391       ENDIF
34392       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
34393       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
34394       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
34395       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
34396       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
34397       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
34398       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
34399       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
34400       IDHKT(6+IIGLU1)   =88888
34401       ISTHKT(6+IIGLU1)  =95
34402       JMOHKT(1,6+IIGLU1)=4+IIGLU1
34403       JMOHKT(2,6+IIGLU1)=5+IIGLU1
34404       JDAHKT(1,6+IIGLU1)=0
34405       JDAHKT(2,6+IIGLU1)=0
34406       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
34407       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
34408       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
34409       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
34410       XMIST
34411      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
34412      *            -PHKT(3,6+IIGLU1)**2)
34413       IF(XMIST.GT.0.D0)THEN
34414       PHKT(5,6+IIGLU1)
34415      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
34416      *            -PHKT(3,6+IIGLU1)**2)
34417       ELSE
34418 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
34419         PHKT(5,5+IIGLU1)=0.D0
34420       ENDIF
34421 C     IF(IPIP.GE.2)THEN
34422 C     IF(NUMEV.EQ.-324)THEN
34423 C     WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
34424 C    * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
34425 C    *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
34426 C     WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
34427 C    * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
34428 C    *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
34429 C     WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
34430 C    * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
34431 C    *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
34432 C     ENDIF
34433       CHAMAL=CHAM1
34434       IF(IPIP.EQ.1)THEN
34435         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
34436       ELSEIF(IPIP.EQ.2)THEN
34437         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
34438       ENDIF
34439       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
34440 C       IREJ=1
34441         IPCO=0
34442 C       RETURN
34443 C       WRITE(6,*)' MUSQBS1 jump back from chain 6',
34444 C    *  CHAMAL,PHKT(5,6+IIGLU1)
34445         GO TO 3466
34446       ENDIF
34447       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
34448       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
34449       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
34450       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
34451       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
34452       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
34453       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
34454       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
34455 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
34456       IDHKT(7+IIGLU1)   =IP1
34457       ISTHKT(7+IIGLU1)  =951
34458       JMOHKT(1,7+IIGLU1)=NC1P
34459       JMOHKT(2,7+IIGLU1)=0
34460 **NEW
34461 C     JDAHKT(1,7+IIGLU1)=9+IIGLU1
34462       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
34463 **
34464       JDAHKT(2,7+IIGLU1)=0
34465       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
34466       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
34467       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
34468       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
34469 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
34470       XMIST  =(PHKT(4,7+IIGLU1)**2-
34471      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
34472      *PHKT(1,7+IIGLU1)**2)
34473       IF(XMIST.GT.0.D0)THEN
34474       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
34475      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
34476      *PHKT(1,7+IIGLU1)**2)
34477       ELSE
34478 C     WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
34479       PHKT(5,7+IIGLU1)=0.D0
34480       ENDIF
34481       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
34482       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
34483       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
34484       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
34485       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
34486       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
34487       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
34488       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
34489 C     Insert here the IIGLU2 gluons
34490       PG1=0.D0
34491       PG2=0.D0
34492       PG3=0.D0
34493       PG4=0.D0
34494       IF(IIGLU2.GE.1)THEN
34495       JJG=NC2P
34496       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
34497         KKG=JJG+IIG-7-IIGLU1
34498         IDHKT(IIG)   =IDHKK(KKG)
34499         ISTHKT(IIG)  =921
34500         JMOHKT(1,IIG)=KKG
34501         JMOHKT(2,IIG)=0
34502         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
34503         JDAHKT(2,IIG)=0
34504         PHKT(1,IIG)=PHKK(1,KKG)
34505         PG1=PG1+ PHKT(1,IIG)
34506         PHKT(2,IIG)=PHKK(2,KKG)
34507         PG2=PG2+ PHKT(2,IIG)
34508         PHKT(3,IIG)=PHKK(3,KKG)
34509         PG3=PG3+ PHKT(3,IIG)
34510         PHKT(4,IIG)=PHKK(4,KKG)
34511         PG4=PG4+ PHKT(4,IIG)
34512         PHKT(5,IIG)=PHKK(5,KKG)
34513         VHKT(1,IIG)  =VHKK(1,KKG)
34514         VHKT(2,IIG)  =VHKK(2,KKG)
34515         VHKT(3,IIG)  =VHKK(3,KKG)
34516         VHKT(4,IIG)  =VHKK(4,KKG)
34517         WHKT(1,IIG)  =WHKK(1,KKG)
34518         WHKT(2,IIG) =WHKK(2,KKG)
34519         WHKT(3,IIG) =WHKK(3,KKG)
34520         WHKT(4,IIG) =WHKK(4,KKG)
34521    81 CONTINUE
34522       ENDIF
34523       IF(IPIP.EQ.1)THEN
34524         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
34525         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
34526         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
34527         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
34528       ELSEIF(IPIP.EQ.2)THEN
34529         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
34530         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
34531         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
34532         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
34533       ENDIF
34534       ISTHKT(8+IIGLU1+IIGLU2)  =952
34535       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
34536       JMOHKT(2,8+IIGLU1+IIGLU2)=0
34537       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
34538       JDAHKT(2,8+IIGLU1+IIGLU2)=0
34539       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC2T)+
34540      * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
34541       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC2T)+
34542      * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
34543       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC2T)+
34544      * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
34545       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC2T)+
34546      * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
34547 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
34548 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
34549       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
34550 C       IREJ=1
34551 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
34552 C    *  ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
34553         IPCO=0
34554 C       RETURN
34555         GO TO 3466
34556       ENDIF
34557 C     PHKT(5,8)  =PHKK(5,NC2T)
34558       XMIST  =(PHKT(4,8+IIGLU1+IIGLU2)**2-
34559      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
34560      *PHKT(1,8+IIGLU1+IIGLU2)**2)
34561       IF(XMIST.GT.0.D0)THEN
34562       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
34563      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
34564      *PHKT(1,8+IIGLU1+IIGLU2)**2)
34565       ELSE
34566 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
34567         PHKT(5,5+IIGLU1)=0.D0
34568       ENDIF
34569       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
34570       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
34571       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
34572       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
34573       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
34574       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
34575       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
34576       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
34577       IDHKT(9+IIGLU1+IIGLU2)   =88888
34578       ISTHKT(9+IIGLU1+IIGLU2)  =95
34579       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
34580       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
34581       JDAHKT(1,9+IIGLU1+IIGLU2)=0
34582       JDAHKT(2,9+IIGLU1+IIGLU2)=0
34583 **NEW
34584 C     PHKT(1,9+IIGLU1+IIGLU2)
34585 C    * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
34586 C     PHKT(2,9+IIGLU1+IIGLU2)
34587 C    * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
34588 C     PHKT(3,9+IIGLU1+IIGLU2)
34589 C    * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
34590 C     PHKT(4,9+IIGLU1+IIGLU2)
34591 C    * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
34592       PHKT(1,9+IIGLU1+IIGLU2)
34593      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
34594       PHKT(2,9+IIGLU1+IIGLU2)
34595      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
34596       PHKT(3,9+IIGLU1+IIGLU2)
34597      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
34598       PHKT(4,9+IIGLU1+IIGLU2)
34599      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
34600 **
34601       XMIST
34602      * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
34603      * -PHKT(2,9+IIGLU1+IIGLU2)**2
34604      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
34605       IF(XMIST.GT.0.D0)THEN
34606       PHKT(5,9+IIGLU1+IIGLU2)
34607      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
34608      * -PHKT(2,9+IIGLU1+IIGLU2)**2
34609      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
34610       ELSE
34611 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
34612         PHKT(5,5+IIGLU1)=0.D0
34613       ENDIF
34614       IF(IPIP.GE.2)THEN
34615 C     IF(NUMEV.EQ.-324)THEN
34616 C     WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
34617 C    * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
34618 C    *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
34619 C     DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
34620 C     WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
34621 C    * JDAHKT(1,IIG),
34622 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
34623 C  91 CONTINUE
34624 C     WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
34625 C    * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
34626 C    *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
34627 C    *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
34628 C     WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
34629 C    * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
34630 C    *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
34631 C    *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
34632       ENDIF
34633       CHAMAL=CHAB1
34634       IF(IPIP.EQ.1)THEN
34635         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
34636       ELSEIF(IPIP.EQ.2)THEN
34637         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
34638       ENDIF
34639       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
34640 C       IREJ=1
34641         IPCO=0
34642 C       RETURN
34643 C       WRITE(6,*)' MUSQBS1 jump back from chain 9',
34644 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
34645         GO TO 3466
34646       ENDIF
34647       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
34648       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
34649       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
34650       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
34651       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
34652       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
34653       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
34654       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
34655 C
34656       IPCO=0
34657       IGCOUN=9+IIGLU1+IIGLU2
34658        RETURN
34659        END
34660 C
34661 C
34662 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
34663       SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
34664      *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
34665 C
34666 C                  GSQBS-2 diagram (split target diquark)
34667 C
34668       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34669       SAVE
34670
34671       PARAMETER ( LINP = 5 ,
34672      &            LOUT = 6 ,
34673      &            LDAT = 9 )
34674
34675 * event history
34676
34677       PARAMETER (NMXHKK=200000)
34678
34679       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
34680      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
34681      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
34682 * extended event history
34683       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
34684      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
34685      &                IHIST(2,NMXHKK)
34686 * Lorentz-parameters of the current interaction
34687       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
34688      &                UMO,PPCM,EPROJ,PPROJ
34689 * diquark-breaking mechanism
34690       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
34691
34692 C
34693       PARAMETER (NTMHKK= 300)
34694       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
34695      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
34696      +(4,NTMHKK)
34697
34698 *KEEP,XSEADI.
34699       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
34700      +SSMIMQ,VVMTHR
34701 *KEEP,DPRIN.
34702       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
34703 C
34704 C                  GSQBS-2 diagram (split target diquark)
34705 C
34706 C
34707 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
34708 C     Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
34709 C
34710 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
34711 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
34712 C
34713 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
34714 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34715 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
34716 C
34717 C
34718 C
34719 C       Put new chains into COMMON /HKKTMP/
34720 C
34721       IIGLU1=NC1T-NC1P-1
34722       IIGLU2=NC2T-NC2P-1
34723       IGCOUN=0
34724 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
34725       CVQ=1.D0
34726       IREJ=0
34727 C     IF(IPIP.EQ.2)THEN
34728 C     WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
34729 C    *             'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
34730 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
34731 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
34732 C     ENDIF
34733 C
34734 C
34735 C
34736 C     determine x-values of NC1T diquark
34737       XDIQT=PHKK(4,NC1T)*2.D0/UMO
34738       XVQP=PHKK(4,NC1P)*2.D0/UMO
34739 C
34740 C     determine x-values of sea quark pair
34741 C
34742       IPCO=1
34743       ICOU=0
34744  2234 CONTINUE
34745       ICOU=ICOU+1
34746       IF(ICOU.GE.500)THEN
34747         IREJ=1
34748         IF(ISQ.EQ.3)IREJ=3
34749         IF(IPCO.GE.3)
34750      &     WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
34751         IPCO=0
34752         RETURN
34753       ENDIF
34754       IF(IPCO.GE.3)
34755      &     WRITE(LOUT,*)'MGSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
34756      * UMO, XDIQT,XVQP
34757       XSQ=0.D0
34758       XSAQ=0.D0
34759 **NEW
34760 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
34761       IF (IPIP.EQ.1) THEN
34762          XQMAX  = XDIQT/2.0D0
34763          XAQMAX = 2.D0*XVQP/3.0D0
34764       ELSE
34765          XQMAX  = 2.D0*XVQP/3.0D0
34766          XAQMAX = XDIQT/2.0D0
34767       ENDIF
34768       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
34769       ISAQ = 6+ISQ
34770 C     write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
34771 **
34772         IF(IPCO.GE.3)
34773      &     WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
34774       IF(IREJ.GE.1)THEN
34775         IF(IPCO.GE.3)
34776      &     WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
34777         IPCO=0
34778         RETURN
34779       ENDIF
34780       IF(IPIP.EQ.1)THEN
34781         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
34782       ELSEIF(IPIP.EQ.2)THEN
34783         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
34784       ENDIF
34785       IF(IPCO.GE.3)THEN
34786         WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
34787      *  XDIQT,XVQP,XSQ,XSAQ
34788       ENDIF
34789 C
34790 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
34791 C
34792 C     XSQ=0.D0
34793       IF(IPIP.EQ.1)THEN
34794         XDIQT=XDIQT-XSQ
34795         XVQP =XVQP -XSAQ
34796       ELSEIF(IPIP.EQ.2)THEN
34797         XDIQT=XDIQT-XSAQ
34798         XVQP =XVQP -XSQ
34799       ENDIF
34800       IF(IPCO.GE.3)
34801      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
34802 C
34803 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
34804 C
34805       XVTHRO=CVQ/UMO
34806       IVTHR=0
34807  3466 CONTINUE
34808       IF(IVTHR.EQ.10)THEN
34809         IREJ=1
34810         IF(ISQ.EQ.3)IREJ=3
34811         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
34812         IPCO=0
34813         RETURN
34814       ENDIF
34815       IVTHR=IVTHR+1
34816       XVTHR=XVTHRO/(201-IVTHR)
34817       UNOPRV=UNON
34818  380  CONTINUE
34819       IF(XVTHR.GT.0.66D0*XDIQT)THEN
34820         IREJ=1
34821         IF(ISQ.EQ.3)IREJ=3
34822         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR  large ',
34823      *  XVTHR
34824         IPCO=0
34825         RETURN
34826       ENDIF
34827       IF(DT_RNDM(V).LT.0.5D0)THEN
34828         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
34829         XVTQII=XDIQT-XVTQI
34830       ELSE
34831         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
34832         XVTQI=XDIQT-XVTQII
34833       ENDIF
34834       IF(IPCO.GE.3)THEN
34835         WRITE(LOUT,'(A,2E12.4)')'  MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
34836       ENDIF
34837 C
34838 C     Prepare 4 momenta of new chains and chain ends
34839 C
34840 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
34841 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
34842 C    +(4,NTMHKK)
34843 C
34844 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
34845 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34846 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
34847 C
34848 C     SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
34849 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
34850 C
34851       IF(IPIP.EQ.1)THEN
34852         XSQ1=XSQ
34853         XSAQ1=XSAQ
34854         ISQ1=ISQ
34855         ISAQ1=ISAQ
34856       ELSEIF(IPIP.EQ.2)THEN
34857         XSQ1=XSAQ
34858         XSAQ1=XSQ
34859         ISQ1=ISAQ
34860         ISAQ1=ISQ
34861       ENDIF
34862       KK11=IP21
34863 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
34864       KK21=IPP11
34865       KK22=IPP12
34866       XGIVE=0.D0
34867       IF(IPIP.EQ.1)THEN
34868         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
34869       ELSEIF(IPIP.EQ.2)THEN
34870         IDHKT(4+IIGLU1)   =ISAQ1
34871       ENDIF
34872       ISTHKT(4+IIGLU1)  =961
34873       JMOHKT(1,4+IIGLU1)=NC1P
34874       JMOHKT(2,4+IIGLU1)=0
34875       JDAHKT(1,4+IIGLU1)=6+IIGLU1
34876       JDAHKT(2,4+IIGLU1)=0
34877 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34878       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
34879       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
34880       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
34881       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
34882 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
34883       XXMIST=(PHKT(4,4+IIGLU1)**2-
34884      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
34885      *PHKT(1,4+IIGLU1)**2)
34886       IF(XXMIST.GT.0.D0)THEN
34887         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
34888       ELSE
34889         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
34890         XXMIST=ABS(XXMIST)
34891         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
34892       ENDIF
34893       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
34894       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
34895       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
34896       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
34897       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
34898       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
34899       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
34900       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
34901       IDHKT(5+IIGLU1)   =IP22
34902       ISTHKT(5+IIGLU1)  =962
34903       JMOHKT(1,5+IIGLU1)=NC1T
34904       JMOHKT(2,5+IIGLU1)=0
34905       JDAHKT(1,5+IIGLU1)=6+IIGLU1
34906       JDAHKT(2,5+IIGLU1)=0
34907       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
34908       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
34909       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
34910       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
34911 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
34912       XXMIST=(PHKT(4,5+IIGLU1)**2-
34913      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
34914      *PHKT(1,5+IIGLU1)**2)
34915       IF(XXMIST.GT.0.D0)THEN
34916         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
34917       ELSE
34918         WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
34919         XXMIST=ABS(XXMIST)
34920         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
34921       ENDIF
34922       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
34923       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
34924       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
34925       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
34926       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
34927       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
34928       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
34929       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
34930       IDHKT(6+IIGLU1)   =88888
34931       ISTHKT(6+IIGLU1)  =96
34932       JMOHKT(1,6+IIGLU1)=4+IIGLU1
34933       JMOHKT(2,6+IIGLU1)=5+IIGLU1
34934       JDAHKT(1,6+IIGLU1)=0
34935       JDAHKT(2,6+IIGLU1)=0
34936       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
34937       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
34938       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
34939       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
34940       PHKT(5,6+IIGLU1)
34941      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
34942      *            -PHKT(3,6+IIGLU1)**2)
34943       CHAMAL=CHAM1
34944       IF(IPIP.EQ.1)THEN
34945         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
34946       ELSEIF(IPIP.EQ.2)THEN
34947         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
34948       ENDIF
34949 C---------------------------------------------------
34950       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
34951         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
34952 C                    we drop chain 6 and give the energy to chain 3
34953           IDHKT(6+IIGLU1)=22888
34954           XGIVE=1.D0
34955 C         WRITE(6,*)' drop chain 6 xgive=1'
34956           GO TO 7788
34957         ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
34958 C                    we drop chain 6 and give the energy to chain 3
34959 C                    and change KK11 to IDHKT(5)
34960           IDHKT(6+IIGLU1)=22888
34961           XGIVE=1.D0
34962 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
34963           KK11=IDHKT(5+IIGLU1)
34964           GO TO 7788
34965         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
34966 C                    we drop chain 6 and give the energy to chain 3
34967 C                    and change KK21 to IDHKT(5+IIGLU1)
34968 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
34969           IDHKT(6+IIGLU1)=22888
34970           XGIVE=1.D0
34971 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
34972           KK21=IDHKT(5+IIGLU1)
34973           GO TO 7788
34974         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
34975 C                    we drop chain 6 and give the energy to chain 3
34976 C                    and change KK22 to IDHKT(5)
34977 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
34978           IDHKT(6+IIGLU1)=22888
34979           XGIVE=1.D0
34980 C         WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
34981           KK22=IDHKT(5+IIGLU1)
34982           GO TO 7788
34983         ENDIF
34984 C       IREJ=1
34985         IPCO=0
34986 C       RETURN
34987         GO TO 3466
34988       ENDIF
34989  7788 CONTINUE
34990 C---------------------------------------------------
34991       IF(IPIP.GE.3)THEN
34992       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
34993      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
34994      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
34995       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
34996      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
34997      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
34998       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
34999      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
35000      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
35001       ENDIF
35002       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
35003       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
35004       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
35005       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
35006       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
35007       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
35008       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
35009       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
35010 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
35011       IF(IPIP.EQ.1)THEN
35012         IDHKT(1)   =1000*KK21+100*KK22+3
35013         IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
35014         IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
35015         IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
35016       ELSEIF(IPIP.EQ.2)THEN
35017         IDHKT(1)   =1000*KK21+100*KK22-3
35018         IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
35019         IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
35020         IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
35021       ENDIF
35022       ISTHKT(1)  =961
35023       JMOHKT(1,1)=NC2P
35024       JMOHKT(2,1)=0
35025       JDAHKT(1,1)=3+IIGLU1
35026       JDAHKT(2,1)=0
35027 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
35028       PHKT(1,1)  =PHKK(1,NC2P)
35029      *+XGIVE*PHKT(1,4+IIGLU1)
35030       PHKT(2,1)  =PHKK(2,NC2P)
35031      *+XGIVE*PHKT(2,4+IIGLU1)
35032       PHKT(3,1)  =PHKK(3,NC2P)
35033      *+XGIVE*PHKT(3,4+IIGLU1)
35034       PHKT(4,1)  =PHKK(4,NC2P)
35035      *+XGIVE*PHKT(4,4+IIGLU1)
35036 C     PHKT(5,1)  =PHKK(5,NC2P)
35037       XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35038      *PHKT(1,1)**2
35039       IF(XXMIST.GT.0.D0)THEN
35040         PHKT(5,1)  =SQRT(XXMIST)
35041       ELSE
35042         WRITE(LOUT,*)'MGSQBS2',XXMIST
35043         XXMIST=ABS(XXMIST)
35044         PHKT(5,1)  =SQRT(XXMIST)
35045       ENDIF
35046       VHKT(1,1)  =VHKK(1,NC2P)
35047       VHKT(2,1)  =VHKK(2,NC2P)
35048       VHKT(3,1)  =VHKK(3,NC2P)
35049       VHKT(4,1)  =VHKK(4,NC2P)
35050       WHKT(1,1)  =WHKK(1,NC2P)
35051       WHKT(2,1)  =WHKK(2,NC2P)
35052       WHKT(3,1)  =WHKK(3,NC2P)
35053       WHKT(4,1)  =WHKK(4,NC2P)
35054 C     Add here IIGLU1 gluons to this chaina
35055       PG1=0.D0
35056       PG2=0.D0
35057       PG3=0.D0
35058       PG4=0.D0
35059       IF(IIGLU1.GE.1)THEN
35060       JJG=NC1P
35061       DO 61 IIG=2,2+IIGLU1-1
35062         KKG=JJG+IIG-1
35063         IDHKT(IIG)   =IDHKK(KKG)
35064         ISTHKT(IIG)  =921
35065         JMOHKT(1,IIG)=KKG
35066         JMOHKT(2,IIG)=0
35067         JDAHKT(1,IIG)=3+IIGLU1
35068         JDAHKT(2,IIG)=0
35069         PHKT(1,IIG)=PHKK(1,KKG)
35070         PG1=PG1+ PHKT(1,IIG)
35071         PHKT(2,IIG)=PHKK(2,KKG)
35072         PG2=PG2+ PHKT(2,IIG)
35073         PHKT(3,IIG)=PHKK(3,KKG)
35074         PG3=PG3+ PHKT(3,IIG)
35075         PHKT(4,IIG)=PHKK(4,KKG)
35076         PG4=PG4+ PHKT(4,IIG)
35077         PHKT(5,IIG)=PHKK(5,KKG)
35078         VHKT(1,IIG)  =VHKK(1,KKG)
35079         VHKT(2,IIG)  =VHKK(2,KKG)
35080         VHKT(3,IIG)  =VHKK(3,KKG)
35081         VHKT(4,IIG)  =VHKK(4,KKG)
35082         WHKT(1,IIG)  =WHKK(1,KKG)
35083         WHKT(2,IIG)  =WHKK(2,KKG)
35084         WHKT(3,IIG)  =WHKK(3,KKG)
35085         WHKT(4,IIG)  =WHKK(4,KKG)
35086    61 CONTINUE
35087       ENDIF
35088 C     IDHKT(2)   =IP21
35089       IDHKT(2+IIGLU1)   =KK11
35090       ISTHKT(2+IIGLU1)  =962
35091       JMOHKT(1,2+IIGLU1)=NC1T
35092       JMOHKT(2,2+IIGLU1)=0
35093       JDAHKT(1,2+IIGLU1)=3+IIGLU1
35094       JDAHKT(2,2+IIGLU1)=0
35095       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
35096 C    * +0.5D0*PHKK(1,NC2T)
35097      *+XGIVE*PHKT(1,5+IIGLU1)
35098       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
35099 C    *+0.5D0*PHKK(2,NC2T)
35100      *+XGIVE*PHKT(2,5+IIGLU1)
35101       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
35102 C    *+0.5D0*PHKK(3,NC2T)
35103      *+XGIVE*PHKT(3,5+IIGLU1)
35104       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
35105 C    *+0.5D0*PHKK(4,NC2T)
35106      *+XGIVE*PHKT(4,5+IIGLU1)
35107 C     PHKT(5,2)  =PHKK(5,NC1T)
35108       XXMIST=(PHKT(4,2+IIGLU1)**2-
35109      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35110      *PHKT(1,2+IIGLU1)**2)
35111       IF(XXMIST.GT.0.D0)THEN
35112         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
35113       ELSE
35114         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
35115         XXMIST=ABS(XXMIST)
35116         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
35117       ENDIF
35118       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
35119       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
35120       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
35121       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
35122       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
35123       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
35124       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
35125       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
35126       IDHKT(3+IIGLU1)   =88888
35127       ISTHKT(3+IIGLU1)  =96
35128       JMOHKT(1,3+IIGLU1)=1
35129       JMOHKT(2,3+IIGLU1)=2+IIGLU1
35130       JDAHKT(1,3+IIGLU1)=0
35131       JDAHKT(2,3+IIGLU1)=0
35132       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
35133       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
35134       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
35135       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
35136       PHKT(5,3+IIGLU1)
35137      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35138      *            -PHKT(3,3+IIGLU1)**2)
35139       IF(IPIP.EQ.3)THEN
35140       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
35141      * JDAHKT(1,1),
35142      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
35143       DO 71 IIG=2,2+IIGLU1-1
35144       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35145      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
35146      * JDAHKT(1,IIG),
35147      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35148    71 CONTINUE
35149       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
35150      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
35151      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
35152       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
35153      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
35154      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
35155       ENDIF
35156       CHAMAL=CHAB1
35157       IF(IPIP.EQ.1)THEN
35158         IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
35159       ELSEIF(IPIP.EQ.2)THEN
35160         IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
35161       ENDIF
35162       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
35163 C       IREJ=1
35164         IPCO=0
35165 C       RETURN
35166         GO TO 3466
35167       ENDIF
35168       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
35169       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
35170       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
35171       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
35172       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
35173       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
35174       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
35175       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
35176 C     IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+1
35177       IDHKT(7+IIGLU1)   =IP1
35178       ISTHKT(7+IIGLU1)  =961
35179       JMOHKT(1,7+IIGLU1)=NC1P
35180       JMOHKT(2,7+IIGLU1)=0
35181       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
35182       JDAHKT(2,7+IIGLU1)=0
35183       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
35184       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
35185       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
35186       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
35187 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
35188       XXMIST=(PHKT(4,7+IIGLU1)**2-
35189      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
35190      *PHKT(1,7+IIGLU1)**2)
35191       IF(XXMIST.GT.0.D0)THEN
35192         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
35193       ELSE
35194         WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
35195         XXMIST=ABS(XXMIST)
35196         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
35197       ENDIF
35198       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
35199       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
35200       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
35201       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
35202       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
35203       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
35204       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
35205       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
35206 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
35207 C     Insert here the IIGLU2 gluons
35208       PG1=0.D0
35209       PG2=0.D0
35210       PG3=0.D0
35211       PG4=0.D0
35212       IF(IIGLU2.GE.1)THEN
35213       JJG=NC2P
35214       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
35215         KKG=JJG+IIG-7-IIGLU1
35216         IDHKT(IIG)   =IDHKK(KKG)
35217         ISTHKT(IIG)  =921
35218         JMOHKT(1,IIG)=KKG
35219         JMOHKT(2,IIG)=0
35220         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
35221         JDAHKT(2,IIG)=0
35222         PHKT(1,IIG)=PHKK(1,KKG)
35223         PG1=PG1+ PHKT(1,IIG)
35224         PHKT(2,IIG)=PHKK(2,KKG)
35225         PG2=PG2+ PHKT(2,IIG)
35226         PHKT(3,IIG)=PHKK(3,KKG)
35227         PG3=PG3+ PHKT(3,IIG)
35228         PHKT(4,IIG)=PHKK(4,KKG)
35229         PG4=PG4+ PHKT(4,IIG)
35230         PHKT(5,IIG)=PHKK(5,KKG)
35231         VHKT(1,IIG)  =VHKK(1,KKG)
35232         VHKT(2,IIG)  =VHKK(2,KKG)
35233         VHKT(3,IIG)  =VHKK(3,KKG)
35234         VHKT(4,IIG)  =VHKK(4,KKG)
35235         WHKT(1,IIG)  =WHKK(1,KKG)
35236         WHKT(2,IIG)  =WHKK(2,KKG)
35237         WHKT(3,IIG)  =WHKK(3,KKG)
35238         WHKT(4,IIG)  =WHKK(4,KKG)
35239    81 CONTINUE
35240       ENDIF
35241       IF(IPIP.EQ.1)THEN
35242         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
35243         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
35244         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
35245         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
35246       ELSEIF(IPIP.EQ.2)THEN
35247 **NEW
35248 C       IDHKT(8)   =1000*IPP2+100*(-ISQ1+6)-3
35249         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
35250 **
35251         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
35252         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
35253         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
35254       ENDIF
35255       ISTHKT(8+IIGLU1+IIGLU2)  =962
35256       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
35257       JMOHKT(2,8+IIGLU1+IIGLU2)=0
35258       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
35259       JDAHKT(2,8+IIGLU1+IIGLU2)=0
35260 C     PHKT(1,8)  =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
35261 C     PHKT(2,8)  =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
35262 C     PHKT(3,8)  =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
35263 C     PHKT(4,8)  =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
35264       PHKT(1,8+IIGLU1+IIGLU2)  =
35265      * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
35266       PHKT(2,8+IIGLU1+IIGLU2)  =
35267      * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
35268       PHKT(3,8+IIGLU1+IIGLU2)  =
35269      * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
35270       PHKT(4,8+IIGLU1+IIGLU2)  =
35271      * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
35272 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
35273 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
35274       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
35275 C       IREJ=1
35276 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
35277         IPCO=0
35278 C       RETURN
35279         GO TO 3466
35280       ENDIF
35281 C     PHKT(5,8)  =PHKK(5,NC2T)
35282       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
35283      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
35284      *PHKT(1,8+IIGLU1+IIGLU2)**2)
35285       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
35286       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
35287       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
35288       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
35289       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
35290       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
35291       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
35292       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
35293       IDHKT(9+IIGLU1+IIGLU2)   =88888
35294       ISTHKT(9+IIGLU1+IIGLU2)  =96
35295       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
35296       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
35297       JDAHKT(1,9+IIGLU1+IIGLU2)=0
35298       JDAHKT(2,9+IIGLU1+IIGLU2)=0
35299       PHKT(1,9+IIGLU1+IIGLU2)
35300      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
35301       PHKT(2,9+IIGLU1+IIGLU2)
35302      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
35303       PHKT(3,9+IIGLU1+IIGLU2)
35304      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
35305       PHKT(4,9+IIGLU1+IIGLU2)
35306      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
35307       PHKT(5,9+IIGLU1+IIGLU2)
35308      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
35309      * PHKT(2,9+IIGLU1+IIGLU2)**2
35310      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
35311       IF(IPIP.GE.3)THEN
35312       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
35313      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
35314      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
35315       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
35316       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35317      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
35318      * JDAHKT(1,IIG),
35319      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35320    91 CONTINUE
35321       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
35322      * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
35323      *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
35324      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
35325       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
35326      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
35327      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
35328      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
35329       ENDIF
35330       CHAMAL=CHAB1
35331       IF(IPIP.EQ.1)THEN
35332         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
35333       ELSEIF(IPIP.EQ.2)THEN
35334         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
35335       ENDIF
35336       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
35337 C       IREJ=1
35338         IPCO=0
35339 C       RETURN
35340         GO TO 3466
35341       ENDIF
35342       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
35343       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
35344       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
35345       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
35346       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
35347       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
35348       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
35349       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
35350 C
35351       IPCO=0
35352       IGCOUN=9+IIGLU1+IIGLU2
35353        RETURN
35354        END
35355 C
35356 C
35357 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
35358       SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35359      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
35360 C
35361 C                  USQBS-1 diagram (split projectile diquark)
35362 C
35363       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35364       SAVE
35365
35366       PARAMETER ( LINP = 5 ,
35367      &            LOUT = 6 ,
35368      &            LDAT = 9 )
35369
35370 * event history
35371
35372       PARAMETER (NMXHKK=200000)
35373
35374       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35375      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35376      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35377 * extended event history
35378       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35379      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35380      &                IHIST(2,NMXHKK)
35381 * Lorentz-parameters of the current interaction
35382       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
35383      &                UMO,PPCM,EPROJ,PPROJ
35384 * diquark-breaking mechanism
35385       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
35386
35387 C
35388       PARAMETER (NTMHKK= 300)
35389       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35390      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35391      +(4,NTMHKK)
35392 *KEEP,XSEADI.
35393       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
35394      +SSMIMQ,VVMTHR
35395 *KEEP,DPRIN.
35396       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
35397       COMMON /EVFLAG/ NUMEV
35398 C
35399 C                  USQBS-1 diagram (split projectile diquark)
35400 C
35401 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
35402 C     Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
35403 C
35404 C     Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
35405 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
35406 C
35407 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
35408 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
35409 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
35410 C
35411 C       Put new chains into COMMON /HKKTMP/
35412 C
35413       IIGLU1=NC1T-NC1P-1
35414       IIGLU2=NC2T-NC2P-1
35415       IGCOUN=0
35416 C     WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
35417       CVQ=1.D0
35418       IREJ=0
35419       IF(IPIP.EQ.3)THEN
35420 C     IF(NUMEV.EQ.-324)THEN
35421       WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
35422      *             ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
35423      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35424      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
35425       ENDIF
35426 C
35427 C
35428 C
35429 C     determine x-values of NC1P diquark
35430       XDIQP=PHKK(4,NC1P)*2.D0/UMO
35431       XVQT=PHKK(4,NC1T)*2.D0/UMO
35432 C
35433 C     determine x-values of sea quark pair
35434 C
35435       IPCO=1
35436       ICOU=0
35437  2234 CONTINUE
35438       ICOU=ICOU+1
35439       IF(ICOU.GE.500)THEN
35440         IREJ=1
35441         IF(ISQ.EQ.3)IREJ=3
35442         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
35443         IPCO=0
35444         RETURN
35445       ENDIF
35446       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
35447      * UMO, XDIQP,XVQT
35448       XSQ=0.D0
35449       XSAQ=0.D0
35450 **NEW
35451 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
35452       IF (IPIP.EQ.1) THEN
35453          XQMAX  = XDIQP/2.0D0
35454          XAQMAX = 2.D0*XVQT/3.0D0
35455       ELSE
35456          XQMAX  = 2.D0*XVQT/3.0D0
35457          XAQMAX = XDIQP/2.0D0
35458       ENDIF
35459       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
35460       ISAQ = 6+ISQ
35461 C     write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
35462 **
35463       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35464       IF(IREJ.GE.1)THEN
35465         IF(IPCO.GE.3)
35466      &     WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35467         IPCO=0
35468         RETURN
35469       ENDIF
35470       IF(IPIP.EQ.1)THEN
35471         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
35472       ELSEIF(IPIP.EQ.2)THEN
35473         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
35474       ENDIF
35475       IF(IPCO.GE.3)THEN
35476         WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
35477      *  XDIQP,XVQT,XSQ,XSAQ
35478       ENDIF
35479 C
35480 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
35481 C
35482 C     XSQ=0.D0
35483       IF(IPIP.EQ.1)THEN
35484         XDIQP=XDIQP-XSQ
35485         XVQT =XVQT -XSAQ
35486       ELSEIF(IPIP.EQ.2)THEN
35487         XDIQP=XDIQP-XSAQ
35488         XVQT =XVQT -XSQ
35489       ENDIF
35490       IF(IPCO.GE.3)
35491      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
35492 C
35493 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
35494 C
35495       XVTHRO=CVQ/UMO
35496       IVTHR=0
35497  3466 CONTINUE
35498       IF(IVTHR.EQ.10)THEN
35499         IREJ=1
35500         IF(ISQ.EQ.3)IREJ=3
35501         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
35502         IPCO=0
35503         RETURN
35504       ENDIF
35505       IVTHR=IVTHR+1
35506       XVTHR=XVTHRO/(201-IVTHR)
35507       UNOPRV=UNON
35508  380  CONTINUE
35509       IF(XVTHR.GT.0.66D0*XDIQP)THEN
35510         IREJ=1
35511         IF(ISQ.EQ.3)IREJ=3
35512         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR  large ',
35513      *  XVTHR
35514         IPCO=0
35515         RETURN
35516       ENDIF
35517       IF(DT_RNDM(V).LT.0.5D0)THEN
35518         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
35519         XVPQII=XDIQP-XVPQI
35520       ELSE
35521         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
35522         XVPQI=XDIQP-XVPQII
35523       ENDIF
35524       IF(IPCO.GE.3)THEN
35525         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
35526       ENDIF
35527 C
35528 C     Prepare 4 momenta of new chains and chain ends
35529 C
35530 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35531 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35532 C    +(4,NTMHKK)
35533 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
35534 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
35535 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
35536       IF(IPIP.EQ.1)THEN
35537         XSQ1=XSQ
35538         XSAQ1=XSAQ
35539         ISQ1=ISQ
35540         ISAQ1=ISAQ
35541       ELSEIF(IPIP.EQ.2)THEN
35542         XSQ1=XSAQ
35543         XSAQ1=XSQ
35544         ISQ1=ISAQ
35545         ISAQ1=ISQ
35546       ENDIF
35547       IDHKT(1)   =IP11
35548       ISTHKT(1)  =931
35549       JMOHKT(1,1)=NC1P
35550       JMOHKT(2,1)=0
35551       JDAHKT(1,1)=3+IIGLU1
35552       JDAHKT(2,1)=0
35553 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
35554       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
35555       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
35556       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
35557       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
35558 C     PHKT(5,1)  =PHKK(5,NC1P)
35559       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35560      *PHKT(1,1)**2)
35561       IF(XMIST.GE.0.D0)THEN
35562       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35563      *PHKT(1,1)**2)
35564       ELSE
35565 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
35566        PHKT(5,1)=0.D0
35567       ENDIF
35568       VHKT(1,1)  =VHKK(1,NC1P)
35569       VHKT(2,1)  =VHKK(2,NC1P)
35570       VHKT(3,1)  =VHKK(3,NC1P)
35571       VHKT(4,1)  =VHKK(4,NC1P)
35572       WHKT(1,1)  =WHKK(1,NC1P)
35573       WHKT(2,1)  =WHKK(2,NC1P)
35574       WHKT(3,1)  =WHKK(3,NC1P)
35575       WHKT(4,1)  =WHKK(4,NC1P)
35576 C     Add here IIGLU1 gluons to this chaina
35577       PG1=0.D0
35578       PG2=0.D0
35579       PG3=0.D0
35580       PG4=0.D0
35581       IF(IIGLU1.GE.1)THEN
35582       JJG=NC1P
35583       DO 61 IIG=2,2+IIGLU1-1
35584         KKG=JJG+IIG-1
35585         IDHKT(IIG)   =IDHKK(KKG)
35586         ISTHKT(IIG)  =921
35587         JMOHKT(1,IIG)=KKG
35588         JMOHKT(2,IIG)=0
35589         JDAHKT(1,IIG)=3+IIGLU1
35590         JDAHKT(2,IIG)=0
35591         PHKT(1,IIG)=PHKK(1,KKG)
35592         PG1=PG1+ PHKT(1,IIG)
35593         PHKT(2,IIG)=PHKK(2,KKG)
35594         PG2=PG2+ PHKT(2,IIG)
35595         PHKT(3,IIG)=PHKK(3,KKG)
35596         PG3=PG3+ PHKT(3,IIG)
35597         PHKT(4,IIG)=PHKK(4,KKG)
35598         PG4=PG4+ PHKT(4,IIG)
35599         PHKT(5,IIG)=PHKK(5,KKG)
35600         VHKT(1,IIG)  =VHKK(1,KKG)
35601         VHKT(2,IIG)  =VHKK(2,KKG)
35602         VHKT(3,IIG)  =VHKK(3,KKG)
35603         VHKT(4,IIG)  =VHKK(4,KKG)
35604         WHKT(1,IIG) =WHKK(1,KKG)
35605         WHKT(2,IIG) =WHKK(2,KKG)
35606         WHKT(3,IIG) =WHKK(3,KKG)
35607         WHKT(4,IIG) =WHKK(4,KKG)
35608    61 CONTINUE
35609       ENDIF
35610       IDHKT(2+IIGLU1)   =IPP2
35611       ISTHKT(2+IIGLU1)  =932
35612       JMOHKT(1,2+IIGLU1)=NC2T
35613       JMOHKT(2,2+IIGLU1)=0
35614       JDAHKT(1,2+IIGLU1)=3+IIGLU1
35615       JDAHKT(2,2+IIGLU1)=0
35616       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
35617       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
35618       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
35619       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
35620 C     PHKT(5,2+IIGLU1)  =PHKK(5,NC2T)
35621       XMIST=(PHKT(4,2+IIGLU1)**2-
35622      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35623      *PHKT(1,2+IIGLU1)**2)
35624       IF(XMIST.GT.0.D0)THEN
35625       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
35626      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35627      *PHKT(1,2+IIGLU1)**2)
35628       ELSE
35629 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
35630         PHKT(5,2+IIGLU1)=0.D0
35631       ENDIF
35632       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
35633       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
35634       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
35635       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
35636       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
35637       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
35638       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
35639       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
35640       IDHKT(3+IIGLU1)   =88888
35641       ISTHKT(3+IIGLU1)  =94
35642       JMOHKT(1,3+IIGLU1)=1
35643       JMOHKT(2,3+IIGLU1)=2+IIGLU1
35644       JDAHKT(1,3+IIGLU1)=0
35645       JDAHKT(2,3+IIGLU1)=0
35646       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
35647       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
35648       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
35649       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
35650       XMIST
35651      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35652      *            -PHKT(3,3+IIGLU1)**2)
35653       IF(XMIST.GE.0.D0)THEN
35654       PHKT(5,3+IIGLU1)
35655      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35656      *            -PHKT(3,3+IIGLU1)**2)
35657       ELSE
35658 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
35659        PHKT(5,1)=0.D0
35660       ENDIF
35661       IF(IPIP.GE.3)THEN
35662 C     IF(NUMEV.EQ.-324)THEN
35663       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
35664      * JMOHKT(2,1),JDAHKT(1,1),
35665      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
35666       DO 71 IIG=2,2+IIGLU1-1
35667       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35668      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
35669      * JDAHKT(1,IIG),
35670      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35671    71 CONTINUE
35672       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
35673      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
35674      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
35675       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
35676      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
35677      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
35678       ENDIF
35679       CHAMAL=CHAM1
35680       IF(IPIP.EQ.1)THEN
35681         IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
35682       ELSEIF(IPIP.EQ.2)THEN
35683         IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
35684       ENDIF
35685       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
35686 C       IREJ=1
35687         IPCO=0
35688 C       RETURN
35689 C       WRITE(6,*)' MUSQBS1 jump back from chain 3'
35690         GO TO 3466
35691       ENDIF
35692       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
35693       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
35694       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
35695       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
35696       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
35697       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
35698       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
35699       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
35700       IDHKT(4+IIGLU1)   =IP12
35701       ISTHKT(4+IIGLU1)  =931
35702       JMOHKT(1,4+IIGLU1)=NC1P
35703       JMOHKT(2,4+IIGLU1)=0
35704       JDAHKT(1,4+IIGLU1)=6+IIGLU1
35705       JDAHKT(2,4+IIGLU1)=0
35706 C   create  chain   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
35707       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
35708       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
35709       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
35710       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
35711 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
35712       XMIST  =(PHKT(4,4+IIGLU1)**2-
35713      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
35714      *PHKT(1,4+IIGLU1)**2)
35715       IF(XMIST.GT.0.D0)THEN
35716       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
35717      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
35718      *PHKT(1,4+IIGLU1)**2)
35719       ELSE
35720 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
35721         PHKT(5,4+IIGLU1)=0.D0
35722       ENDIF
35723       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
35724       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
35725       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
35726       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
35727       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
35728       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
35729       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
35730       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
35731       IF(IPIP.EQ.1)THEN
35732         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
35733       ELSEIF(IPIP.EQ.2)THEN
35734         IDHKT(5+IIGLU1)   =ISAQ1
35735       ENDIF
35736       ISTHKT(5+IIGLU1)  =932
35737       JMOHKT(1,5+IIGLU1)=NC1T
35738       JMOHKT(2,5+IIGLU1)=0
35739       JDAHKT(1,5+IIGLU1)=6+IIGLU1
35740       JDAHKT(2,5+IIGLU1)=0
35741       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
35742       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
35743       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
35744       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
35745 C     IF( PHKT(4,5).EQ.0.D0)THEN
35746 C       IREJ=1
35747 CIPCO=0
35748 CRETURN
35749 C     ENDIF
35750 C     PHKT(5,5)  =PHKK(5,NC1T)
35751       XMIST=(PHKT(4,5+IIGLU1)**2-
35752      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
35753      *PHKT(1,5+IIGLU1)**2)
35754       IF(XMIST.GT.0.D0)THEN
35755       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
35756      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
35757      *PHKT(1,5+IIGLU1)**2)
35758       ELSE
35759 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
35760         PHKT(5,5+IIGLU1)=0.D0
35761       ENDIF
35762       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
35763       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
35764       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
35765       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
35766       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
35767       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
35768       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
35769       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
35770       IDHKT(6+IIGLU1)   =88888
35771       ISTHKT(6+IIGLU1)  =94
35772       JMOHKT(1,6+IIGLU1)=4+IIGLU1
35773       JMOHKT(2,6+IIGLU1)=5+IIGLU1
35774       JDAHKT(1,6+IIGLU1)=0
35775       JDAHKT(2,6+IIGLU1)=0
35776       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
35777       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
35778       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
35779       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
35780       XMIST
35781      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
35782      *            -PHKT(3,6+IIGLU1)**2)
35783       IF(XMIST.GE.0.D0)THEN
35784       PHKT(5,6+IIGLU1)
35785      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
35786      *            -PHKT(3,6+IIGLU1)**2)
35787       ELSE
35788 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
35789        PHKT(5,1)=0.D0
35790       ENDIF
35791 C     IF(IPIP.EQ.3)THEN
35792       CHAMAL=CHAM1
35793       IF(IPIP.EQ.1)THEN
35794         IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
35795       ELSEIF(IPIP.EQ.2)THEN
35796         IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
35797       ENDIF
35798       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
35799 C       IREJ=1
35800         IPCO=0
35801 C       RETURN
35802 C       WRITE(6,*)' MGSQBS1 jump back from chain 6',
35803 C    *  CHAMAL,PHKT(5,6+IIGLU1)
35804         GO TO 3466
35805       ENDIF
35806       IF(IPIP.GE.3)THEN
35807 C     IF(NUMEV.EQ.-324)THEN
35808       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
35809      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
35810      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
35811       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
35812      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
35813      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
35814       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
35815      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
35816      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
35817       ENDIF
35818       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
35819       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
35820       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
35821       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
35822       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
35823       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
35824       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
35825       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
35826       IF(IPIP.EQ.1)THEN
35827         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+3
35828         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
35829         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
35830         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
35831       ELSEIF(IPIP.EQ.2)THEN
35832         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
35833         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
35834         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
35835         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
35836 C       WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
35837       ENDIF
35838       ISTHKT(7+IIGLU1)  =931
35839       JMOHKT(1,7+IIGLU1)=NC2P
35840       JMOHKT(2,7+IIGLU1)=0
35841       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
35842       JDAHKT(2,7+IIGLU1)=0
35843 C    create chain     9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
35844       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
35845       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
35846       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
35847       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
35848 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
35849 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
35850       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
35851 C       IREJ=1
35852 C       WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
35853         IPCO=0
35854 C       RETURN
35855         GO TO 3466
35856       ENDIF
35857 C     PHKT(5,7)  =PHKK(5,NC2P)
35858       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
35859      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
35860      *PHKT(1,7+IIGLU1)**2)
35861       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
35862       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
35863       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
35864       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
35865       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
35866       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
35867       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
35868       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
35869 C     Insert here the IIGLU2 gluons
35870       PG1=0.D0
35871       PG2=0.D0
35872       PG3=0.D0
35873       PG4=0.D0
35874       IF(IIGLU2.GE.1)THEN
35875       JJG=NC2P
35876       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
35877         KKG=JJG+IIG-7-IIGLU1
35878         IDHKT(IIG)   =IDHKK(KKG)
35879         ISTHKT(IIG)  =921
35880         JMOHKT(1,IIG)=KKG
35881         JMOHKT(2,IIG)=0
35882         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
35883         JDAHKT(2,IIG)=0
35884         PHKT(1,IIG)=PHKK(1,KKG)
35885         PG1=PG1+ PHKT(1,IIG)
35886         PHKT(2,IIG)=PHKK(2,KKG)
35887         PG2=PG2+ PHKT(2,IIG)
35888         PHKT(3,IIG)=PHKK(3,KKG)
35889         PG3=PG3+ PHKT(3,IIG)
35890         PHKT(4,IIG)=PHKK(4,KKG)
35891         PG4=PG4+ PHKT(4,IIG)
35892         PHKT(5,IIG)=PHKK(5,KKG)
35893         VHKT(1,IIG)  =VHKK(1,KKG)
35894         VHKT(2,IIG)  =VHKK(2,KKG)
35895         VHKT(3,IIG)  =VHKK(3,KKG)
35896         VHKT(4,IIG)  =VHKK(4,KKG)
35897         WHKT(1,IIG)  =WHKK(1,KKG)
35898         WHKT(2,IIG) =WHKK(2,KKG)
35899         WHKT(3,IIG) =WHKK(3,KKG)
35900         WHKT(4,IIG) =WHKK(4,KKG)
35901    81 CONTINUE
35902       ENDIF
35903       IDHKT(8+IIGLU1+IIGLU2)   =IP2
35904       ISTHKT(8+IIGLU1+IIGLU2)  =932
35905       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
35906       JMOHKT(2,8+IIGLU1+IIGLU2)=0
35907       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
35908       JDAHKT(2,8+IIGLU1+IIGLU2)=0
35909       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
35910       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
35911       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
35912       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
35913 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
35914       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
35915      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
35916      *PHKT(1,8+IIGLU1+IIGLU2)**2)
35917       IF(XMIST.GT.0.D0)THEN
35918       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
35919      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
35920      *PHKT(1,8+IIGLU1+IIGLU2)**2)
35921       ELSE
35922 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
35923         PHKT(5,8+IIGLU1+IIGLU2)=0.D0
35924       ENDIF
35925       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
35926       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
35927       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
35928       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
35929       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
35930       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
35931       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
35932       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
35933       IDHKT(9+IIGLU1+IIGLU2)   =88888
35934       ISTHKT(9+IIGLU1+IIGLU2)  =94
35935       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
35936       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
35937       JDAHKT(1,9+IIGLU1+IIGLU2)=0
35938       JDAHKT(2,9+IIGLU1+IIGLU2)=0
35939       PHKT(1,9+IIGLU1+IIGLU2)
35940      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
35941       PHKT(2,9+IIGLU1+IIGLU2)
35942      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
35943       PHKT(3,9+IIGLU1+IIGLU2)
35944      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
35945       PHKT(4,9+IIGLU1+IIGLU2)
35946      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
35947       XMIST
35948      *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
35949      * -PHKT(2,9+IIGLU1+IIGLU2)**2
35950      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
35951       IF(XMIST.GE.0.D0)THEN
35952       PHKT(5,9+IIGLU1+IIGLU2)
35953      *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
35954      * -PHKT(2,9+IIGLU1+IIGLU2)**2
35955      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
35956       ELSE
35957 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
35958        PHKT(5,1)=0.D0
35959       ENDIF
35960       IF(IPIP.GE.3)THEN
35961 C     IF(NUMEV.EQ.-324)THEN
35962       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
35963      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
35964      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
35965       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
35966       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35967      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
35968      * JDAHKT(1,IIG),
35969      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35970    91 CONTINUE
35971       WRITE(LOUT,*)8+IIGLU1+IIGLU2,
35972      * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
35973      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
35974      *JDAHKT(1,8+IIGLU1+IIGLU2),
35975      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
35976       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
35977      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
35978      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
35979      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
35980       ENDIF
35981       CHAMAL=CHAB1
35982       IF(IPIP.EQ.1)THEN
35983         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
35984       ELSEIF(IPIP.EQ.2)THEN
35985         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
35986       ENDIF
35987       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
35988 C       IREJ=1
35989         IPCO=0
35990 C       RETURN
35991 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
35992 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
35993         GO TO 3466
35994       ENDIF
35995       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
35996       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
35997       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
35998       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
35999       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
36000       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
36001       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
36002       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
36003 C
36004       IPCO=0
36005       IGCOUN=9+IIGLU1+IIGLU2
36006        RETURN
36007        END
36008 C
36009 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36010       SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36011      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
36012 C
36013 C                  GSQBS-1 diagram (split projectile diquark)
36014 C
36015       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36016       SAVE
36017
36018       PARAMETER ( LINP = 5 ,
36019      &            LOUT = 6 ,
36020      &            LDAT = 9 )
36021
36022 * event history
36023
36024       PARAMETER (NMXHKK=200000)
36025
36026       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36027      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36028      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36029 * extended event history
36030       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36031      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36032      &                IHIST(2,NMXHKK)
36033 * Lorentz-parameters of the current interaction
36034       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
36035      &                UMO,PPCM,EPROJ,PPROJ
36036 * diquark-breaking mechanism
36037       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36038
36039 C
36040       PARAMETER (NTMHKK= 300)
36041       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36042      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36043      +(4,NTMHKK)
36044 *KEEP,XSEADI.
36045       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
36046      +SSMIMQ,VVMTHR
36047 *KEEP,DPRIN.
36048       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
36049 C
36050 C                  GSQBS-1 diagram (split projectile diquark)
36051 C
36052 C
36053 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
36054 C     Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
36055 C
36056 C     Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
36057 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
36058 C
36059 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
36060 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
36061 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
36062 C
36063 C       Put new chains into COMMON /HKKTMP/
36064 C
36065       IIGLU1=NC1T-NC1P-1
36066       IIGLU2=NC2T-NC2P-1
36067       IGCOUN=0
36068 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
36069       CVQ=1.D0
36070       NNNC1=IDHKK(NC1)/1000
36071       MMMC1=IDHKK(NC1)-NNNC1*1000
36072       KKKC1=ISTHKK(NC1)
36073       NNNC2=IDHKK(NC2)/1000
36074       MMMC2=IDHKK(NC2)-NNNC2*1000
36075       KKKC2=ISTHKK(NC2)
36076       IREJ=0
36077       IF(IPIP.EQ.3)THEN
36078       WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
36079      *             ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
36080      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36081      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
36082       ENDIF
36083 C
36084 C
36085 C
36086 C     determine x-values of NC1P diquark
36087       XDIQP=PHKK(4,NC1P)*2.D0/UMO
36088       XVQT=PHKK(4,NC1T)*2.D0/UMO
36089 C
36090 C     determine x-values of sea quark pair
36091 C
36092       IPCO=1
36093       ICOU=0
36094  2234 CONTINUE
36095       ICOU=ICOU+1
36096       IF(ICOU.GE.500)THEN
36097         IREJ=1
36098         IF(ISQ.EQ.3)IREJ=3
36099         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
36100       IPCO=0
36101         RETURN
36102       ENDIF
36103       IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
36104      * UMO, XDIQP,XVQT
36105       XSQ=0.D0
36106       XSAQ=0.D0
36107 **NEW
36108 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
36109       IF (IPIP.EQ.1) THEN
36110          XQMAX  = XDIQP/2.0D0
36111          XAQMAX = 2.D0*XVQT/3.0D0
36112       ELSE
36113          XQMAX  = 2.D0*XVQT/3.0D0
36114          XAQMAX = XDIQP/2.0D0
36115       ENDIF
36116       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
36117       ISAQ = 6+ISQ
36118 C     write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
36119 **
36120         IF(IPCO.GE.3)
36121      &     WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36122       IF(IREJ.GE.1)THEN
36123         IF(IPCO.GE.3)
36124      &     WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36125       IPCO=0
36126         RETURN
36127       ENDIF
36128       IF(IPIP.EQ.1)THEN
36129         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
36130       ELSEIF(IPIP.EQ.2)THEN
36131         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
36132       ENDIF
36133       IF(IPCO.GE.3)THEN
36134         WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
36135      *  XDIQP,XVQT,XSQ,XSAQ
36136       ENDIF
36137 C
36138 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
36139 C
36140 C     XSQ=0.D0
36141       IF(IPIP.EQ.1)THEN
36142         XDIQP=XDIQP-XSQ
36143 **NEW
36144 C       IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
36145 **
36146         XVQT =XVQT -XSAQ
36147       ELSEIF(IPIP.EQ.2)THEN
36148         XDIQP=XDIQP-XSAQ
36149         XVQT =XVQT -XSQ
36150       ENDIF
36151       IF(IPCO.GE.3)
36152      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
36153 C
36154 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
36155 C
36156       XVTHRO=CVQ/UMO
36157       IVTHR=0
36158  3466 CONTINUE
36159       IF(IVTHR.EQ.10)THEN
36160         IREJ=1
36161         IF(ISQ.EQ.3)IREJ=3
36162         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
36163       IPCO=0
36164         RETURN
36165       ENDIF
36166       IVTHR=IVTHR+1
36167       XVTHR=XVTHRO/(201-IVTHR)
36168       UNOPRV=UNON
36169  380  CONTINUE
36170       IF(XVTHR.GT.0.66D0*XDIQP)THEN
36171         IREJ=1
36172         IF(ISQ.EQ.3)IREJ=3
36173         IF(IPCO.GE.3)
36174      &     WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR  large ',
36175      *  XVTHR
36176       IPCO=0
36177         RETURN
36178       ENDIF
36179       IF(DT_RNDM(V).LT.0.5D0)THEN
36180         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
36181         XVPQII=XDIQP-XVPQI
36182       ELSE
36183         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
36184         XVPQI=XDIQP-XVPQII
36185       ENDIF
36186       IF(IPCO.GE.3)THEN
36187         WRITE(LOUT,'(A,4E12.4)')'  MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
36188      *  XVTHR,XDIQP,XVPQI,XVPQII
36189       ENDIF
36190 C
36191 C     Prepare 4 momenta of new chains and chain ends
36192 C
36193 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36194 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36195 C    +(4,NTMHKK)
36196 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
36197 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
36198 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
36199       IF(IPIP.EQ.1)THEN
36200         XSQ1=XSQ
36201         XSAQ1=XSAQ
36202         ISQ1=ISQ
36203         ISAQ1=ISAQ
36204       ELSEIF(IPIP.EQ.2)THEN
36205         XSQ1=XSAQ
36206         XSAQ1=XSQ
36207         ISQ1=ISAQ
36208         ISAQ1=ISQ
36209       ENDIF
36210       KK11=IP11
36211 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
36212       KK21= IPP21
36213       KK22= IPP22
36214       XGIVE=0.D0
36215       IDHKT(4+IIGLU1)   =IP12
36216       ISTHKT(4+IIGLU1)  =921
36217       JMOHKT(1,4+IIGLU1)=NC1P
36218       JMOHKT(2,4+IIGLU1)=0
36219       JDAHKT(1,4+IIGLU1)=6+IIGLU1
36220       JDAHKT(2,4+IIGLU1)=0
36221 **NEW
36222       IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
36223      &    (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
36224 **
36225       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
36226       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
36227       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
36228       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
36229 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
36230       XXMIST=(PHKT(4,4+IIGLU1)**2-
36231      *              PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36232      *              PHKT(1,4+IIGLU1)**2)
36233       IF(XXMIST.GT.0.D0)THEN
36234         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
36235       ELSE
36236         WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
36237         XXMIST=ABS(XXMIST)
36238         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
36239       ENDIF
36240       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
36241       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
36242       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
36243       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
36244       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
36245       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
36246       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
36247       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
36248       IF(IPIP.EQ.1)THEN
36249         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
36250       ELSEIF(IPIP.EQ.2)THEN
36251         IDHKT(5+IIGLU1)   =ISAQ1
36252       ENDIF
36253       ISTHKT(5+IIGLU1)  =922
36254       JMOHKT(1,5+IIGLU1)=NC1T
36255       JMOHKT(2,5+IIGLU1)=0
36256       JDAHKT(1,5+IIGLU1)=6+IIGLU1
36257       JDAHKT(2,5+IIGLU1)=0
36258 **NEW
36259       IF ((XSAQ1.LT.0.0D0).OR.(XVQT  .LT.0.0D0))
36260      &    WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
36261 **
36262       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
36263       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
36264       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
36265       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
36266 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
36267       XMIST=(PHKT(4,5+IIGLU1)**2-
36268      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36269      *PHKT(1,5+IIGLU1)**2)
36270       IF(XMIST.GT.0.D0)THEN
36271       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
36272      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36273      *PHKT(1,5+IIGLU1)**2)
36274       ELSE
36275 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36276         PHKT(5,5+IIGLU1)=0.D0
36277       ENDIF
36278       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
36279       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
36280       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
36281       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
36282       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
36283       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
36284       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
36285       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
36286       IDHKT(6+IIGLU1)   =88888
36287 C     IDHKT(6)   =1000*NNNC1+MMMC1
36288       ISTHKT(6+IIGLU1)  =93
36289 C     ISTHKT(6)  =KKKC1
36290       JMOHKT(1,6+IIGLU1)=4+IIGLU1
36291       JMOHKT(2,6+IIGLU1)=5+IIGLU1
36292       JDAHKT(1,6+IIGLU1)=0
36293       JDAHKT(2,6+IIGLU1)=0
36294       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36295       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36296       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36297       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36298       PHKT(5,6+IIGLU1)
36299      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36300      *            -PHKT(3,6+IIGLU1)**2)
36301       CHAMAL=CHAM1
36302       IF(IPIP.EQ.1)THEN
36303         IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
36304       ELSEIF(IPIP.EQ.2)THEN
36305         IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
36306       ENDIF
36307       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36308         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
36309 C                    we drop chain 6 and give the energy to chain 3
36310           IDHKT(6+IIGLU1)=33888
36311           XGIVE=1.D0
36312 C         WRITE(6,*)' drop chain 6 xgive=1'
36313           GO TO 7788
36314         ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
36315 C                    we drop chain 6 and give the energy to chain 3
36316 C                    and change KK11 to IDHKT(4)
36317           IDHKT(6+IIGLU1)=33888
36318           XGIVE=1.D0
36319 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
36320           KK11=IDHKT(4+IIGLU1)
36321           GO TO 7788
36322         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
36323 C                    we drop chain 6 and give the energy to chain 3
36324 C                    and change KK21 to IDHKT(4)
36325 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
36326           IDHKT(6+IIGLU1)=33888
36327           XGIVE=1.D0
36328 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
36329           KK21=IDHKT(4+IIGLU1)
36330           GO TO 7788
36331         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
36332 C                    we drop chain 6 and give the energy to chain 3
36333 C                    and change KK22 to IDHKT(4)
36334 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
36335           IDHKT(6+IIGLU1)=33888
36336           XGIVE=1.D0
36337 C         WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
36338           KK22=IDHKT(4+IIGLU1)
36339           GO TO 7788
36340         ENDIF
36341 C       IREJ=1
36342         IPCO=0
36343 C       RETURN
36344 C       WRITE(6,*)' MGSQBS1 jump back from chain 6'
36345         GO TO 3466
36346       ENDIF
36347  7788 CONTINUE
36348       IF(IPIP.GE.3)THEN
36349       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36350      * JMOHKT(1,4+IIGLU1),
36351      * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36352      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36353       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36354      * JMOHKT(1,5+IIGLU1),
36355      * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36356      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36357       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36358      * JMOHKT(1,6+IIGLU1),
36359      * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36360      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36361       ENDIF
36362       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
36363       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
36364       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
36365       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
36366       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
36367       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
36368       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
36369       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
36370 C     IDHKT(1)   =IP11
36371       IDHKT(1)   =KK11
36372       ISTHKT(1)  =921
36373       JMOHKT(1,1)=NC1P
36374       JMOHKT(2,1)=0
36375       JDAHKT(1,1)=3+IIGLU1
36376       JDAHKT(2,1)=0
36377       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
36378 C    * +0.5D0*PHKK(1,NC2P)
36379      *+XGIVE*PHKT(1,4+IIGLU1)
36380       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
36381 C    * +0.5D0*PHKK(2,NC2P)
36382      *+XGIVE*PHKT(2,4+IIGLU1)
36383       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
36384 C    * +0.5D0*PHKK(3,NC2P)
36385      *+XGIVE*PHKT(3,4+IIGLU1)
36386       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
36387 C    * +0.5D0*PHKK(4,NC2P)
36388      *+XGIVE*PHKT(4,4+IIGLU1)
36389 C     PHKT(5,1)  =PHKK(5,NC1P)
36390       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
36391      *PHKT(1,1)**2)
36392       IF(XMIST.GE.0.D0)THEN
36393       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
36394      *PHKT(1,1)**2)
36395       ELSE
36396 C      WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
36397        PHKT(5,1)=0.D0
36398       ENDIF
36399       VHKT(1,1)  =VHKK(1,NC1P)
36400       VHKT(2,1)  =VHKK(2,NC1P)
36401       VHKT(3,1)  =VHKK(3,NC1P)
36402       VHKT(4,1)  =VHKK(4,NC1P)
36403       WHKT(1,1)  =WHKK(1,NC1P)
36404       WHKT(2,1)  =WHKK(2,NC1P)
36405       WHKT(3,1)  =WHKK(3,NC1P)
36406       WHKT(4,1)  =WHKK(4,NC1P)
36407 C     Add here IIGLU1 gluons to this chaina
36408       PG1=0.D0
36409       PG2=0.D0
36410       PG3=0.D0
36411       PG4=0.D0
36412       IF(IIGLU1.GE.1)THEN
36413       JJG=NC1P
36414       DO 61 IIG=2,2+IIGLU1-1
36415         KKG=JJG+IIG-1
36416         IDHKT(IIG)   =IDHKK(KKG)
36417         ISTHKT(IIG)  =921
36418         JMOHKT(1,IIG)=KKG
36419         JMOHKT(2,IIG)=0
36420         JDAHKT(1,IIG)=3+IIGLU1
36421         JDAHKT(2,IIG)=0
36422         PHKT(1,IIG)=PHKK(1,KKG)
36423         PG1=PG1+ PHKT(1,IIG)
36424         PHKT(2,IIG)=PHKK(2,KKG)
36425         PG2=PG2+ PHKT(2,IIG)
36426         PHKT(3,IIG)=PHKK(3,KKG)
36427         PG3=PG3+ PHKT(3,IIG)
36428         PHKT(4,IIG)=PHKK(4,KKG)
36429         PG4=PG4+ PHKT(4,IIG)
36430         PHKT(5,IIG)=PHKK(5,KKG)
36431         VHKT(1,IIG)  =VHKK(1,KKG)
36432         VHKT(2,IIG)  =VHKK(2,KKG)
36433         VHKT(3,IIG)  =VHKK(3,KKG)
36434         VHKT(4,IIG)  =VHKK(4,KKG)
36435         WHKT(1,IIG)  =WHKK(1,KKG)
36436         WHKT(2,IIG)  =WHKK(2,KKG)
36437         WHKT(3,IIG)  =WHKK(3,KKG)
36438         WHKT(4,IIG)  =WHKK(4,KKG)
36439    61 CONTINUE
36440       ENDIF
36441 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
36442       IF(IPIP.EQ.1)THEN
36443         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22+3
36444         IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
36445         IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
36446         IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
36447       ELSEIF(IPIP.EQ.2)THEN
36448         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22-3
36449         IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
36450         IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
36451         IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
36452       ENDIF
36453       ISTHKT(2+IIGLU1)  =922
36454       JMOHKT(1,2+IIGLU1)=NC2T
36455       JMOHKT(2,2+IIGLU1)=0
36456       JDAHKT(1,2+IIGLU1)=3+IIGLU1
36457       JDAHKT(2,2+IIGLU1)=0
36458       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
36459      *+XGIVE*PHKT(1,5+IIGLU1)
36460       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
36461      *+XGIVE*PHKT(2,5+IIGLU1)
36462       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
36463      *+XGIVE*PHKT(3,5+IIGLU1)
36464       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
36465      *+XGIVE*PHKT(4,5+IIGLU1)
36466 C     PHKT(5,2)  =PHKK(5,NC2T)
36467       XMIST=(PHKT(4,2+IIGLU1)**2-
36468      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
36469      *PHKT(1,2+IIGLU1)**2)
36470       IF(XMIST.GT.0.D0)THEN
36471       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
36472      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
36473      *PHKT(1,2+IIGLU1)**2)
36474       ELSE
36475 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
36476       PHKT(5,2+IIGLU1)=0.D0
36477       ENDIF
36478       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
36479       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
36480       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
36481       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
36482       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
36483       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
36484       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
36485       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
36486       IDHKT(3+IIGLU1)   =88888
36487 C     IDHKT(3)   =1000*NNNC1+MMMC1+10
36488       ISTHKT(3+IIGLU1)  =93
36489 C     ISTHKT(3)  =KKKC1
36490       JMOHKT(1,3+IIGLU1)=1
36491       JMOHKT(2,3+IIGLU1)=2+IIGLU1
36492       JDAHKT(1,3+IIGLU1)=0
36493       JDAHKT(2,3+IIGLU1)=0
36494       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
36495       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
36496       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
36497       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
36498       PHKT(5,3+IIGLU1)
36499      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
36500      *            -PHKT(3,3+IIGLU1)**2)
36501       IF(IPIP.GE.3)THEN
36502       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
36503      * JDAHKT(1,1),
36504      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
36505       DO 71 IIG=2,2+IIGLU1-1
36506       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36507      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
36508      * JDAHKT(1,IIG),
36509      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36510    71 CONTINUE
36511       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
36512      &             IDHKT(2),JMOHKT(1,2+IIGLU1),
36513      * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
36514      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
36515       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
36516      * JMOHKT(1,3+IIGLU1),
36517      * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
36518      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
36519       ENDIF
36520       CHAMAL=CHAB1
36521 **NEW
36522 C     IF(IPIP.EQ.1)THEN
36523 C       IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
36524 C     ELSEIF(IPIP.EQ.2)THEN
36525 C       IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
36526 C     ENDIF
36527       IF(IPIP.EQ.1)THEN
36528         IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
36529       ELSEIF(IPIP.EQ.2)THEN
36530         IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
36531       ENDIF
36532 **
36533       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
36534 C       IREJ=1
36535         IPCO=0
36536 C       RETURN
36537 C       WRITE(6,*)' MGSQBS1 jump back from chain 3'
36538         GO TO 3466
36539       ENDIF
36540       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
36541       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
36542       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
36543       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
36544       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
36545       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
36546       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
36547       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
36548       IF(IPIP.EQ.1)THEN
36549         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ1+3
36550         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
36551         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
36552         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
36553       ELSEIF(IPIP.EQ.2)THEN
36554         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
36555         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
36556         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
36557         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
36558 C       WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
36559       ENDIF
36560       ISTHKT(7+IIGLU1)  =921
36561       JMOHKT(1,7+IIGLU1)=NC2P
36562       JMOHKT(2,7+IIGLU1)=0
36563       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36564       JDAHKT(2,7+IIGLU1)=0
36565 C     PHKT(1,7)  =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
36566 C     PHKT(2,7)  =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
36567 C     PHKT(3,7)  =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
36568 C     PHKT(4,7+IIGLU1)  =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
36569 **NEW
36570       IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
36571      &    WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
36572 **
36573       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
36574       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
36575       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
36576       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
36577 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
36578 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
36579       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
36580 C       IREJ=1
36581 C       WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
36582         IPCO=0
36583 C       RETURN
36584         GO TO 3466
36585       ENDIF
36586 C     PHKT(5,7)  =PHKK(5,NC2P)
36587       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
36588      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36589      *PHKT(1,7+IIGLU1)**2)
36590       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
36591       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
36592       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
36593       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
36594       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
36595       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
36596       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
36597       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
36598 C     Insert here the IIGLU2 gluons
36599       PG1=0.D0
36600       PG2=0.D0
36601       PG3=0.D0
36602       PG4=0.D0
36603       IF(IIGLU2.GE.1)THEN
36604       JJG=NC2P
36605       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36606         KKG=JJG+IIG-7-IIGLU1
36607         IDHKT(IIG)   =IDHKK(KKG)
36608         ISTHKT(IIG)  =921
36609         JMOHKT(1,IIG)=KKG
36610         JMOHKT(2,IIG)=0
36611         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36612         JDAHKT(2,IIG)=0
36613         PHKT(1,IIG)=PHKK(1,KKG)
36614         PG1=PG1+ PHKT(1,IIG)
36615         PHKT(2,IIG)=PHKK(2,KKG)
36616         PG2=PG2+ PHKT(2,IIG)
36617         PHKT(3,IIG)=PHKK(3,KKG)
36618         PG3=PG3+ PHKT(3,IIG)
36619         PHKT(4,IIG)=PHKK(4,KKG)
36620         PG4=PG4+ PHKT(4,IIG)
36621         PHKT(5,IIG)=PHKK(5,KKG)
36622         VHKT(1,IIG)  =VHKK(1,KKG)
36623         VHKT(2,IIG)  =VHKK(2,KKG)
36624         VHKT(3,IIG)  =VHKK(3,KKG)
36625         VHKT(4,IIG)  =VHKK(4,KKG)
36626         WHKT(1,IIG)  =WHKK(1,KKG)
36627         WHKT(2,IIG)  =WHKK(2,KKG)
36628         WHKT(3,IIG)  =WHKK(3,KKG)
36629         WHKT(4,IIG)  =WHKK(4,KKG)
36630    81 CONTINUE
36631       ENDIF
36632       IDHKT(8+IIGLU1+IIGLU2)   =IP2
36633       ISTHKT(8+IIGLU1+IIGLU2)  =922
36634       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
36635       JMOHKT(2,8+IIGLU1+IIGLU2)=0
36636       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36637       JDAHKT(2,8+IIGLU1+IIGLU2)=0
36638 **NEW
36639       IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
36640      &    WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
36641 **
36642       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
36643       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
36644       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
36645       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
36646 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
36647       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
36648      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36649      *PHKT(1,8+IIGLU1+IIGLU2)**2)
36650       IF(XMIST.GT.0.D0)THEN
36651       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36652      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36653      *PHKT(1,8+IIGLU1+IIGLU2)**2)
36654       ELSE
36655 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
36656       PHKT(5,8+IIGLU1+IIGLU2)=0.D0
36657       ENDIF
36658       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
36659       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
36660       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
36661       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
36662       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
36663       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
36664       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
36665       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
36666       IDHKT(9+IIGLU1+IIGLU2)   =88888
36667 C     IDHKT(9)   =1000*NNNC2+MMMC2+10
36668       ISTHKT(9+IIGLU1+IIGLU2)  =93
36669 C     ISTHKT(9)  =KKKC2
36670       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36671       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36672       JDAHKT(1,9+IIGLU1+IIGLU2)=0
36673       JDAHKT(2,9+IIGLU1+IIGLU2)=0
36674       PHKT(1,9+IIGLU1+IIGLU2)  =PHKT(1,7+IIGLU1)
36675      * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
36676       PHKT(2,9+IIGLU1+IIGLU2)  =PHKT(2,7+IIGLU1)
36677      * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
36678       PHKT(3,9+IIGLU1+IIGLU2)  =PHKT(3,7+IIGLU1)
36679      * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
36680       PHKT(4,9+IIGLU1+IIGLU2)  =PHKT(4,7+IIGLU1)
36681      * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
36682       PHKT(5,9+IIGLU1+IIGLU2)
36683      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
36684      * PHKT(2,9+IIGLU1+IIGLU2)**2
36685      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
36686       IF(IPIP.GE.3)THEN
36687       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36688      * JMOHKT(1,7+IIGLU1),
36689      * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36690      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36691       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36692       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36693      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
36694      * JDAHKT(1,IIG),
36695      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36696    91 CONTINUE
36697       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36698      * IDHKT(8+IIGLU1+IIGLU2),
36699      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
36700      * JDAHKT(1,8+IIGLU1+IIGLU2),
36701      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36702       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36703      * IDHKT(9+IIGLU1+IIGLU2),
36704      * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
36705      * JDAHKT(1,9+IIGLU1+IIGLU2),
36706      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36707       ENDIF
36708       CHAMAL=CHAB1
36709       IF(IPIP.EQ.1)THEN
36710         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
36711       ELSEIF(IPIP.EQ.2)THEN
36712         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
36713       ENDIF
36714       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
36715 C       IREJ=1
36716         IPCO=0
36717 C       RETURN
36718 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
36719 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
36720         GO TO 3466
36721       ENDIF
36722       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
36723       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
36724       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
36725       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
36726       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
36727       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
36728       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
36729       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
36730 C
36731       IGCOUN=9+IIGLU1+IIGLU2
36732       IPCO=0
36733        RETURN
36734        END
36735 C
36736 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36737 C
36738       SUBROUTINE HKKHKT(I,J)
36739       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36740       SAVE
36741
36742 * event history
36743
36744       PARAMETER (NMXHKK=200000)
36745
36746       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36747      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36748      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36749 * extended event history
36750       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36751      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36752      &                IHIST(2,NMXHKK)
36753
36754       PARAMETER (NTMHKK= 300)
36755       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36756      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36757      +(4,NTMHKK)
36758 C
36759       ISTHKK(I)  =ISTHKT(J)
36760       IDHKK(I)   =IDHKT(J)
36761 C     IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
36762       IF(IDHKK(I).EQ.88888)THEN
36763 C       JMOHKK(1,I)=I-2
36764 C       JMOHKK(2,I)=I-1
36765         JMOHKK(1,I)=I-(J-JMOHKT(1,J))
36766         JMOHKK(2,I)=I-(J-JMOHKT(2,J))
36767       ELSE
36768         JMOHKK(1,I)=JMOHKT(1,J)
36769         JMOHKK(2,I)=JMOHKT(2,J)
36770       ENDIF
36771       JDAHKK(1,I)=JDAHKT(1,J)
36772       JDAHKK(2,I)=JDAHKT(2,J)
36773 C       IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
36774 C       JDAHKK(1,I)=I+2
36775 C     ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
36776 C       JDAHKK(1,I)=I+1
36777 C     ENDIF
36778       IF(JDAHKT(1,J).GT.0)THEN
36779         JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
36780       ENDIF
36781       PHKK(1,I)  =PHKT(1,J)
36782       PHKK(2,I)  =PHKT(2,J)
36783       PHKK(3,I)  =PHKT(3,J)
36784       PHKK(4,I)  =PHKT(4,J)
36785       PHKK(5,I)  =PHKT(5,J)
36786       VHKK(1,I)  =VHKT(1,J)
36787       VHKK(2,I)  =VHKT(2,J)
36788       VHKK(3,I)  =VHKT(3,J)
36789       VHKK(4,I)  =VHKT(4,J)
36790       WHKK(1,I)  =WHKT(1,J)
36791       WHKK(2,I)  =WHKT(2,J)
36792       WHKK(3,I)  =WHKT(3,J)
36793       WHKK(4,I)  =WHKT(4,J)
36794       RETURN
36795       END
36796 *
36797 *===dbreak=============================================================*
36798 *
36799 CDECK  ID>, DT_DBREAK
36800       SUBROUTINE DT_DBREAK(MODE)
36801
36802 ************************************************************************
36803 * This is the steering subroutine for the different diquark breaking   *
36804 * mechanisms.                                                          *
36805 *                                                                      *
36806 * MODE = 1  breaking of projectile diquark in qq-q chain using         *
36807 *           a sea quark (q-qq chain) of the same projectile            *
36808 *      = 2  breaking of target     diquark in q-qq chain using         *
36809 *           a sea quark (qq-q chain) of the same target                *
36810 *      = 3  breaking of projectile diquark in qq-q chain using         *
36811 *           a sea quark (q-aq chain) of the same projectile            *
36812 *      = 4  breaking of target     diquark in q-qq chain using         *
36813 *           a sea quark (aq-q chain) of the same target                *
36814 *      = 5  breaking of projectile anti-diquark in aqaq-aq chain using *
36815 *           a sea anti-quark (aq-aqaq chain) of the same projectile    *
36816 *      = 6  breaking of target     anti-diquark in aq-aqaq chain using *
36817 *           a sea anti-quark (aqaq-aq chain) of the same target        *
36818 *      = 7  breaking of projectile anti-diquark in aqaq-aq chain using *
36819 *           a sea anti-quark (aq-q chain) of the same projectile       *
36820 *      = 8  breaking of target     anti-diquark in aq-aqaq chain using *
36821 *           a sea anti-quark (q-aq chain) of the same target           *
36822 *                                                                      *
36823 * Original version by J. Ranft.                                        *
36824 * This version dated 17.5.00  is written by S. Roesler.                *
36825 ************************************************************************
36826
36827       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36828       SAVE
36829
36830       PARAMETER ( LINP = 5 ,
36831      &            LOUT = 6 ,
36832      &            LDAT = 9 )
36833
36834 * event history
36835
36836       PARAMETER (NMXHKK=200000)
36837
36838       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36839      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36840      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36841 * extended event history
36842       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36843      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36844      &                IHIST(2,NMXHKK)
36845 * flags for input different options
36846       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
36847       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
36848      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
36849 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
36850       PARAMETER (MAXCHN=10000)
36851       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
36852 * diquark-breaking mechanism
36853       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36854 * flags for particle decays
36855       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
36856      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
36857      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
36858
36859 *
36860 * chain identifiers
36861 * ( 1 = q-aq,   2 = aq-q,   3 = q-qq,   4 = qq-q,
36862 *   5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
36863       DIMENSION IDCHN1(8),IDCHN2(8)
36864       DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
36865       DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
36866 *
36867 * parton identifiers
36868 * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
36869 *   +-51/52 = unitarity-sea, +-61/62 = gluons )
36870       DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
36871       DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
36872      &             31, 31, 31, 31, 31, 31, 31, 31,
36873      &             41, 41, 41, 41, 51, 51, 51, 51/
36874       DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
36875      &             32, 32, 32, 32, 32, 32, 32, 32,
36876      &             42, 42, 42, 42, 52, 52, 52, 52/
36877       DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
36878      &             51, 31, 41, 41, 31, 31, 31, 31,
36879      &              0, 41, 51, 51, 51, 51, 51, 51/
36880       DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
36881      &             32, 52, 42, 42, 32, 32, 32, 32,
36882      &             42,  0, 52, 52, 52, 52, 52, 52/
36883
36884       IF (NCHAIN.LE.0) RETURN
36885       DO 1 I=1,NCHAIN
36886          IDX1 = IDXCHN(1,I)
36887          IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
36888          IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
36889          IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
36890      &       .AND.
36891      &        ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
36892      &                                    (IS1P.EQ.ISP1P(MODE,3)))
36893      &       .AND.
36894      &        ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
36895      &                                    (IS1T.EQ.ISP1T(MODE,3)))
36896      &      ) THEN
36897             DO 2 J=1,NCHAIN
36898                IDX2 = IDXCHN(1,J)
36899                IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
36900                IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
36901                IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
36902      &             .AND.
36903      &              ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
36904      &                                      .OR.(IS2P.EQ.ISP2P(MODE,3)))
36905      &             .AND.
36906      &              ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
36907      &                                      .OR.(IS2T.EQ.ISP2T(MODE,3)))
36908      &            ) THEN
36909 *   find mother nucleons of the diquark to be splitted and of the
36910 *   sea-quark and reject this combination if it is not the same
36911                   IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
36912      &                (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
36913                      IANCES = 1
36914                   ELSE
36915                      IANCES = 2
36916                   ENDIF
36917                   IDXMO1 = JMOHKK(IANCES,IDX1)
36918     4             CONTINUE
36919                   IF ((JMOHKK(1,IDXMO1).NE.0).AND.
36920      &                (JMOHKK(2,IDXMO1).NE.0)) THEN
36921                      IANC = IANCES
36922                   ELSE
36923                      IANC = 1
36924                   ENDIF
36925                   IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
36926                      IDXMO1 = JMOHKK(IANC,IDXMO1)
36927                      GOTO 4
36928                   ENDIF
36929                   IDXMO2 = JMOHKK(IANCES,IDX2)
36930     5             CONTINUE
36931                   IF ((JMOHKK(1,IDXMO2).NE.0).AND.
36932      &                (JMOHKK(2,IDXMO2).NE.0)) THEN
36933                      IANC = IANCES
36934                   ELSE
36935                      IANC = 1
36936                   ENDIF
36937                   IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
36938                      IDXMO2 = JMOHKK(IANC,IDXMO2)
36939                      GOTO 5
36940                   ENDIF
36941                   IF (IDXMO1.NE.IDXMO2) GOTO 2
36942 *   quark content of projectile parton
36943                   IP1   = IDHKK(JMOHKK(1,IDX1))
36944                   IP11  = IP1/1000
36945                   IP12  = (IP1-1000*IP11)/100
36946                   IP2   = IDHKK(JMOHKK(2,IDX1))
36947                   IP21  = IP2/1000
36948                   IP22  = (IP2-1000*IP21)/100
36949 *   quark content of target parton
36950                   IT1  = IDHKK(JMOHKK(1,IDX2))
36951                   IT11 = IT1/1000
36952                   IT12 = (IT1-1000*IT11)/100
36953                   IT2  = IDHKK(JMOHKK(2,IDX2))
36954                   IT21 = IT2/1000
36955                   IT22 = (IT2-1000*IT21)/100
36956 *   split diquark and form new chains
36957                   IF (MODE.EQ.1) THEN
36958                      IF (IT1.EQ.4) GOTO 2
36959                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36960      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36961      &                         IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
36962                   ELSEIF (MODE.EQ.2) THEN
36963                      IF (IT2.EQ.4) GOTO 2
36964                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36965      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36966      &                         IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
36967                   ELSEIF (MODE.EQ.3) THEN
36968                      IF (IT1.EQ.4) GOTO 2
36969                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36970      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36971      &                         IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
36972                   ELSEIF (MODE.EQ.4) THEN
36973                      IF (IT2.EQ.4) GOTO 2
36974                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36975      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36976      &                         IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
36977                   ELSEIF (MODE.EQ.5) THEN
36978                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36979      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36980      &                         IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
36981                   ELSEIF (MODE.EQ.6) THEN
36982                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36983      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36984      &                         IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
36985                   ELSEIF (MODE.EQ.7) THEN
36986                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36987      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36988      &                         IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
36989                   ELSEIF (MODE.EQ.8) THEN
36990                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36991      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36992      &                         IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
36993                   ENDIF
36994                   IF (IREJ.GE.1) THEN
36995                      if ((ipq.lt.0).or.(ipq.ge.4))
36996      &                  write(LOUT,*) 'ipq !!!',ipq,mode
36997                      DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
36998 *   accept or reject new chains corresponding to PDBSEA
36999                   ELSE
37000                      IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
37001                         ACC   = DBRKA(1,MODE)+DBRKA(2,MODE)
37002                         REJ   = DBRKR(1,MODE)+DBRKR(2,MODE)
37003                      ELSEIF (IPQ.EQ.3) THEN
37004                         ACC   = DBRKA(3,MODE)
37005                         REJ   = DBRKR(3,MODE)
37006                      ELSE
37007                         WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
37008                         STOP
37009                      ENDIF
37010                      IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
37011                         DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
37012                         IACC = 1
37013                      ELSE
37014                         DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
37015                         IACC = 0
37016                      ENDIF
37017 *   new chains have been accepted and are now copied into HKKEVT
37018                      IF (IACC.EQ.1) THEN
37019                         IF (LEMCCK) THEN
37020                            CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
37021      &                                    PHKK(3,IDX1),PHKK(4,IDX1),
37022      &                                    1,IDUM1,IDUM2)
37023                            CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
37024      &                                    PHKK(3,IDX2),PHKK(4,IDX2),
37025      &                                    2,IDUM1,IDUM2)
37026                         ENDIF
37027                         IDHKK(IDX1) = 99888
37028                         IDHKK(IDX2) = 99888
37029                         IDXCHN(2,I) = -1
37030                         IDXCHN(2,J) = -1
37031                         DO 3 K=1,IGCOUN
37032                            NHKK = NHKK+1
37033                            CALL HKKHKT(NHKK,K)
37034                            IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
37035                               PX = -PHKK(1,NHKK)
37036                               PY = -PHKK(2,NHKK)
37037                               PZ = -PHKK(3,NHKK)
37038                               PE = -PHKK(4,NHKK)
37039                               CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
37040                            ENDIF
37041     3                   CONTINUE
37042                         IF (LEMCCK) THEN
37043                            CHKLEV = 0.1D0
37044                            CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
37045      &                                                             IREJ)
37046                            IF (IREJ.NE.0) CALL DT_EVTOUT(4)
37047                         ENDIF
37048                         GOTO 1
37049                      ENDIF
37050                   ENDIF
37051                ENDIF
37052     2       CONTINUE
37053          ENDIF
37054     1 CONTINUE
37055       RETURN
37056       END
37057 *
37058 *===cqpair=============================================================*
37059 *
37060 CDECK  ID>, DT_CQPAIR
37061       SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
37062
37063 ************************************************************************
37064 * This subroutine Creates a Quark-antiquark PAIR from the sea.         *
37065 *                                                                      *
37066 *   XQMAX   maxium energy fraction of quark (input)                    *
37067 *   XAQMAX  maxium energy fraction of antiquark (input)                *
37068 *   XQ      energy fraction of quark (output)                          *
37069 *   XAQ     energy fraction of antiquark (output)                      *
37070 *   IFLV    quark flavour (- antiquark flavor) (output)                *
37071 *                                                                      *
37072 * This version dated 14.5.00  is written by S. Roesler.                *
37073 ************************************************************************
37074
37075       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37076       SAVE
37077
37078       PARAMETER ( LINP = 5 ,
37079      &            LOUT = 6 ,
37080      &            LDAT = 9 )
37081
37082 * Lorentz-parameters of the current interaction
37083       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37084      &                UMO,PPCM,EPROJ,PPROJ
37085
37086 *
37087       IREJ = 0
37088       XQ   = 0.0D0
37089       XAQ  = 0.0D0
37090 *
37091 * sample quark flavour
37092 *
37093 *  set seasq here (the one from DTCHAI should be used in the future)
37094       SEASQ = 0.5D0
37095       IFLV  = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
37096 *
37097 * sample energy fractions of sea pair
37098 * we first sample the energy fraction of a gluon and then split the gluon
37099 *
37100 *  maximum energy fraction of the gluon forced via input
37101       XGMAXI = XQMAX+XAQMAX
37102 *  minimum energy fraction of the gluon
37103       XTHR1 = 4.0D0 /UMO**2
37104       XTHR2 = 0.54D0/UMO**1.5D0
37105       XGMIN = MAX(XTHR1,XTHR2)
37106 *  maximum energy fraction of the gluon
37107       XGMAX = 0.3D0
37108       XGMAX = MIN(XGMAXI,XGMAX)
37109       IF (XGMIN.GE.XGMAX) THEN
37110          IREJ = 1
37111          RETURN
37112       ENDIF
37113 *
37114 *  sample energy fraction of the gluon
37115       NLOOP = 0
37116     1 CONTINUE
37117       NLOOP = NLOOP+1
37118       IF (NLOOP.GE.50) THEN
37119          IREJ = 1
37120          RETURN
37121       ENDIF
37122       XGLUON = DT_SAMSQX(XGMIN,XGMAX)
37123       EGLUON = XGLUON*UMO/2.0D0
37124 *
37125 *  split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
37126       ZMIN = MIN(0.1D0,0.5D0/EGLUON)
37127       ZMAX = 1.0D0-ZMIN
37128       RZ   = DT_RNDM(ZMAX)
37129       XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
37130       RQ   = DT_RNDM(ZMAX)
37131       IF (RQ.LT.0.5D0) THEN
37132          XQ  = XGLUON*XHLP
37133          XAQ = XGLUON-XQ
37134       ELSE
37135          XAQ = XGLUON*XHLP
37136          XQ  = XGLUON-XAQ
37137       ENDIF
37138       IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1
37139
37140       RETURN
37141       END