DPMJET/dpmjet3.0-5.f

   1 *$ CREATE DT_INIT.FOR
   2 *COPY DT_INIT
   3 *
   4 *    +-------------------------------------------------------------+
   5 *    |                                                             |
   6 *    |                                                             |
   7 *    |                        DPMJET 3.0                           |
   8 *    |                                                             |
   9 *    |                                                             |
  10 *    |         S. Roesler+), R. Engel#), J. Ranft*)                |
  11 *    |                                                             |
  12 *    |         +) CERN, SC-RP                                      |
  13 *    |            CH-1211 Geneva 23, Switzerland                   |
  14 *    |            Email: Stefan.Roesler@cern.ch                    |
  15 *    |                                                             |
  16 *    |         #) Institut fuer Kernphysik                         |
  17 *    |            Forschungszentrum Karlsruhe                      |
  18 *    |            D-76021 Karlsruhe, Germany                       |
  19 *    |                                                             |
  20 *    |         *) University of Siegen, Dept. of Physics           |
  21 *    |            D-57068 Siegen, Germany                          |
  22 *    |                                                             |
  23 *    |                                                             |
  24 *    |       http://home.cern.ch/sroesler/dpmjet3.html             |
  25 *    |                                                             |
  26 *    |                                                             |
  27 *    |       Monte Carlo models used for event generation:         |
  28 *    |          PHOJET 1.12, JETSET 7.4 and LEPTO 6.5.1            |
  29 *    |                                                             |
  30 *    +-------------------------------------------------------------+
  31 *
  32 *
  33 *===init===============================================================*
  34 *
  35       SUBROUTINE DT_INIT(NCASES,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
  36      &                                             IDP,IGLAU)
  37
  38 ************************************************************************
  39 * Initialization of event generation                                   *
  40 * This version dated  7.4.98  is written by S. Roesler.                *
  41 *                                                                      *
  42 * Last change 27.12.2006 by S. Roesler.                                *
  43 ************************************************************************
  44
  45       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  46       SAVE
  47
  48       PARAMETER ( LINP = 10 ,
  49      &            LOUT = 6 ,
  50      &            LDAT = 9 )
  51       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
  52
  53 * particle properties (BAMJET index convention)
  54       CHARACTER*8  ANAME
  55       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
  56      &                IICH(210),IIBAR(210),K1(210),K2(210)
  57 * names of hadrons used in input-cards
  58       CHARACTER*8 BTYPE
  59       COMMON /DTPAIN/ BTYPE(30)
  60 * (original name: PAREVT)
  61       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
  62      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
  63       PARAMETER ( NALLWP = 39   )
  64       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
  65      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
  66      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
  67      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
  68 * (original name: INPFLG)
  69       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
  70 * (original name: FRBKCM)
  71       PARAMETER ( MXFFBK =     6 )
  72       PARAMETER ( MXZFBK =     9 )
  73       PARAMETER ( MXNFBK =    10 )
  74       PARAMETER ( MXAFBK =    16 )
  75       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
  76       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
  77       PARAMETER ( NXAFBK = MXAFBK + 1 )
  78       PARAMETER ( MXPSST =   300 )
  79       PARAMETER ( MXPSFB = 41000 )
  80       LOGICAL LFRMBK, LNCMSS
  81       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
  82      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
  83      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
  84      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
  85      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
  86      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
  87      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
  88      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
  89      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
  90       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
  91 * emulsion treatment
  92       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
  93      &                NCOMPO,IEMUL
  94 * Glauber formalism: parameters
  95       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
  96      &                BMAX(NCOMPX),BSTEP(NCOMPX),
  97      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
  98      &                NSITEB,NSTATB
  99 * Glauber formalism: cross sections
 100       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
 101      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
 102      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
 103      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
 104      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
 105      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
 106      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
 107      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
 108      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
 109      &                BSLOPE,NEBINI,NQBINI
 110 * interface HADRIN-DPM
 111       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
 112 * central particle production, impact parameter biasing
 113       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
 114 * parameter for intranuclear cascade
 115       LOGICAL LPAULI
 116       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
 117 * various options for treatment of partons (DTUNUC 1.x)
 118 * (chain recombination, Cronin,..)
 119       LOGICAL LCO2CR,LINTPT
 120       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
 121      &                LCO2CR,LINTPT
 122 * threshold values for x-sampling (DTUNUC 1.x)
 123       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
 124      &                SSMIMQ,VVMTHR
 125 * flags for input different options
 126       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
 127       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
 128      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
 129 * nuclear potential
 130       LOGICAL LFERMI
 131       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
 132      &                EBINDP(2),EBINDN(2),EPOT(2,210),
 133      &                ETACOU(2),ICOUL,LFERMI
 134 * n-n cross section fluctuations
 135       PARAMETER (NBINS = 1000)
 136       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
 137 * flags for particle decays
 138       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
 139      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
 140      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
 141 * diquark-breaking mechanism
 142       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
 143 * nucleon-nucleon event-generator
 144       CHARACTER*8 CMODEL
 145       LOGICAL LPHOIN
 146       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
 147 * properties of interacting particles
 148       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
 149 * properties of photon/lepton projectiles
 150       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
 151 * flags for diffractive interactions (DTUNUC 1.x)
 152       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
 153 * parameters for hA-diffraction
 154       COMMON /DTDIHA/ DIBETA,DIALPH
 155 * Lorentz-parameters of the current interaction
 156       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
 157      &                UMO,PPCM,EPROJ,PPROJ
 158 * kinematical cuts for lepton-nucleus interactions
 159       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
 160      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
 161 * VDM parameter for photon-nucleus interactions
 162       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
 163 * Glauber formalism: flags and parameters for statistics
 164       LOGICAL LPROD
 165       CHARACTER*8 CGLB
 166       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
 167 * cuts for variable energy runs
 168       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
 169 * flags for activated histograms
 170       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
 171       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
 172       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
 173 * LEPTO
 174 **LUND single / double precision
 175       REAL CUT,PARL,TMPX,TMPY,TMPW2,TMPQ2,TMPU
 176       COMMON /LEPTOU/ CUT(14),LST(40),PARL(30),
 177      &                TMPX,TMPY,TMPW2,TMPQ2,TMPU
 178 * LEPTO
 179       REAL RPPN
 180       COMMON /LEPTOI/ RPPN,LEPIN,INTER
 181 * steering flags for qel neutrino scattering modules
 182       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
 183 * event flag
 184       COMMON /DTEVNO/ NEVENT,ICASCA
 185
 186       INTEGER PYCOMP
 187
 188 C     DIMENSION XPARA(5)
 189       DIMENSION XDUMB(40),IPRANG(5)
 190
 191       PARAMETER (MXCARD=58)
 192       CHARACTER*78 CLINE,CTITLE
 193       CHARACTER*60 CWHAT
 194       CHARACTER*8  BLANK,SDUM
 195       CHARACTER*10 CODE,CODEWD
 196       CHARACTER*72 HEADER
 197       LOGICAL LSTART,LEINP,LXSTAB
 198       DIMENSION WHAT(6),CODE(MXCARD)
 199       DATA CODE/
 200      &   'TITLE     ','PROJPAR   ','TARPAR    ','ENERGY    ',
 201      &   'MOMENTUM  ','CMENERGY  ','EMULSION  ','FERMI     ',
 202      &   'TAUFOR    ','PAULI     ','COULOMB   ','HADRIN    ',
 203      &   'EVAP      ','EMCCHECK  ','MODEL     ','PHOINPUT  ',
 204      &   'GLAUBERI  ','FLUCTUAT  ','CENTRAL   ','RECOMBIN  ',
 205      &   'COMBIJET  ','XCUTS     ','INTPT     ','CRONINPT  ',
 206      &   'SEADISTR  ','SEASU3    ','DIQUARKS  ','RESONANC  ',
 207      &   'DIFFRACT  ','SINGLECH  ','NOFRAGME  ','HADRONIZE ',
 208      &   'POPCORN   ','PARDECAY  ','BEAM      ','LUND-MSTU ',
 209      &   'LUND-MSTJ ','LUND-MDCY ','LUND-PARJ ','LUND-PARU ',
 210      &   'OUTLEVEL  ','FRAME     ','L-TAG     ','L-ETAG    ',
 211      &   'ECMS-CUT  ','VDM-PAR1  ','HISTOGRAM ','XS-TABLE  ',
 212      &   'GLAUB-PAR ','GLAUB-INI ','VDM-PAR2  ','XS-QELPRO ',
 213      &   'RNDMINIT  ','LEPTO-CUT ','LEPTO-LST ','LEPTO-PARL',
 214      &   'START     ','STOP      '/
 215       DATA BLANK /'        '/
 216
 217       DATA LSTART,LXSTAB,IFIRST /.TRUE.,.FALSE.,1/
 218       DATA CMEOLD /0.0D0/
 219
 220 *---------------------------------------------------------------------
 221 * at the first call of INIT: initialize event generation
 222       EPNSAV = EPN
 223       IF (LSTART) THEN
 224          CALL DT_TITLE
 225 *   initialization and test of the random number generator
 226          IF (ITRSPT.NE.1) THEN
 227             CALL DT_RNDMST(22,54,76,92)
 228             CALL DT_RNDMTE(1)
 229          ENDIF
 230 *   initialization of BAMJET, DECAY and HADRIN
 231          CALL DT_DDATAR
 232          CALL DT_DHADDE
 233          CALL DT_DCHANT
 234          CALL DT_DCHANH
 235 *   set default values for input variables
 236          CALL DT_DEFAUL(EPN,PPN)
 237          IGLAU  = 0
 238          IXSQEL = 0
 239 *   flag for collision energy input
 240          LEINP  = .FALSE.
 241          LSTART = .FALSE.
 242       ENDIF
 243
 244 *---------------------------------------------------------------------
 245    10 CONTINUE
 246
 247 * bypass reading input cards (e.g. for use with Fluka)
 248 *  in this case Epn is expected to carry the beam momentum
 249       IF (NCASES.EQ.-1) THEN
 250          IP      = NPMASS
 251          IPZ     = NPCHAR
 252          PPN     = EPNSAV
 253          EPN     = ZERO
 254          CMENER  = ZERO
 255          LEINP   = .TRUE.
 256          MKCRON  = 0
 257          WHAT(1) = 1
 258          WHAT(2) = 0
 259          CODEWD  = 'START     '
 260          GOTO 900
 261       ENDIF
 262
 263 * read control card from input-unit LINP
 264       READ(LINP,'(A78)',END=9999) CLINE
 265       IF (CLINE(1:1).EQ.'*') THEN
 266 * comment-line
 267          WRITE(LOUT,'(A78)') CLINE
 268          GOTO 10
 269       ENDIF
 270 C     READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM
 271 C1000 FORMAT(A10,6E10.0,A8)
 272       DO 1008 I=1,6
 273          WHAT(I) = ZERO
 274  1008 CONTINUE
 275       READ(CLINE,1006,END=9999) CODEWD,CWHAT,SDUM
 276  1006 FORMAT(A10,A60,A8)
 277       READ(CWHAT,*,END=1007) (WHAT(I),I=1,6)
 278  1007 CONTINUE
 279       WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM
 280  1001 FORMAT(A10,6G10.3,A8)
 281
 282   900 CONTINUE
 283
 284 * check for valid control card and get card index
 285       ICW = 0
 286       DO 11 I=1,MXCARD
 287          IF (CODEWD.EQ.CODE(I)) ICW = I
 288    11 CONTINUE
 289       IF (ICW.EQ.0) THEN
 290          WRITE(LOUT,1002) CODEWD
 291  1002    FORMAT(/,1X,'---> ',A10,': invalid control-card !',/)
 292          GOTO 10
 293       ENDIF
 294
 295       GOTO(
 296 *------------------------------------------------------------
 297 *       TITLE   ,  PROJPAR ,  TARPAR  ,  ENERGY  ,  MOMENTUM,
 298      &  100     ,  110     ,  120     ,  130     ,  140     ,
 299 *
 300 *------------------------------------------------------------
 301 *       CMENERGY,  EMULSION,  FERMI   ,  TAUFOR  ,  PAULI   ,
 302      &  150     ,  160     ,  170     ,  180     ,  190     ,
 303 *
 304 *------------------------------------------------------------
 305 *       COULOMB ,  HADRIN  ,  EVAP    ,  EMCCHECK,  MODEL   ,
 306      &  200     ,  210     ,  220     ,  230     ,  240     ,
 307 *
 308 *------------------------------------------------------------
 309 *       PHOINPUT,  GLAUBERI,  FLUCTUAT,  CENTRAL ,  RECOMBIN,
 310      &  250     ,  260     ,  270     ,  280     ,  290     ,
 311 *
 312 *------------------------------------------------------------
 313 *       COMBIJET,  XCUTS   ,  INTPT   ,  CRONINPT,  SEADISTR,
 314      &  300     ,  310     ,  320     ,  330     ,  340     ,
 315 *
 316 *------------------------------------------------------------
 317 *       SEASU3  ,  DIQUARKS,  RESONANC,  DIFFRACT,  SINGLECH,
 318      &  350     ,  360     ,  370     ,  380     ,  390     ,
 319 *
 320 *------------------------------------------------------------
 321 *       NOFRAGME, HADRONIZE,  POPCORN ,  PARDECAY,  BEAM    ,
 322      &  400     ,  410     ,  420     ,  430     ,  440     ,
 323 *
 324 *------------------------------------------------------------
 325 *      LUND-MSTU, LUND-MSTJ, LUND-MDCY, LUND-PARJ, LUND-PARU,
 326      &  450     ,  451     ,  452     ,  460     ,  470     ,
 327 *
 328 *------------------------------------------------------------
 329 *       OUTLEVEL,  FRAME   , L-TAG    ,  L-ETAG  ,  ECMS-CUT,
 330      &  480     ,  490     ,  500     ,  510     ,  520     ,
 331 *
 332 *------------------------------------------------------------
 333 *       VDM-PAR1, HISTOGRAM, XS-TABLE , GLAUB-PAR, GLAUB-INI,
 334      &  530     ,  540     ,  550     ,  560     ,  565     ,
 335 *
 336 *------------------------------------------------------------
 337 *               ,          ,  VDM-PAR2, XS-QELPRO, RNDMINIT ,
 338      &                        570     ,  580     ,  590     ,
 339 *
 340 *------------------------------------------------------------
 341 *      LEPTO-CUT, LEPTO-LST,LEPTO-PARL,  START   ,  STOP    )
 342      &  600     ,  610     ,  620     ,  630     ,  640     ) , ICW
 343 *
 344 *------------------------------------------------------------
 345
 346       GOTO 10
 347
 348 *********************************************************************
 349 *                                                                   *
 350 *               control card:  codewd = TITLE                       *
 351 *                                                                   *
 352 *       what (1..6), sdum   no meaning                              *
 353 *                                                                   *
 354 *       Note:  The control-card following this must consist of      *
 355 *              a string of characters usually giving the title of   *
 356 *              the run.                                             *
 357 *                                                                   *
 358 *********************************************************************
 359
 360   100 CONTINUE
 361       READ(LINP,'(A78)') CTITLE
 362       WRITE(LOUT,'(//,5X,A78,//)') CTITLE
 363       GOTO 10
 364
 365 *********************************************************************
 366 *                                                                   *
 367 *               control card:  codewd = PROJPAR                     *
 368 *                                                                   *
 369 *       what (1) =  mass number of projectile nucleus  default: 1   *
 370 *       what (2) =  charge of projectile nucleus       default: 1   *
 371 *       what (3..6)   no meaning                                    *
 372 *       sdum        projectile particle code word                   *
 373 *                                                                   *
 374 *       Note: If sdum is defined what (1..2) have no meaning.       *
 375 *                                                                   *
 376 *********************************************************************
 377
 378   110 CONTINUE
 379       IF (SDUM.EQ.BLANK) THEN
 380          IP     = INT(WHAT(1))
 381          IPZ    = INT(WHAT(2))
 382          IJPROJ = 1
 383          IBPROJ = 1
 384       ELSE
 385          IJPROJ = 0
 386          DO 111 II=1,30
 387             IF (SDUM.EQ.BTYPE(II)) THEN
 388                IP     = 1
 389                IPZ    = 1
 390                IF (II.EQ.26) THEN
 391                   IJPROJ = 135
 392                ELSEIF (II.EQ.27) THEN
 393                   IJPROJ = 136
 394                ELSEIF (II.EQ.28) THEN
 395                   IJPROJ = 133
 396                ELSEIF (II.EQ.29) THEN
 397                   IJPROJ = 134
 398                ELSE
 399                   IJPROJ = II
 400                ENDIF
 401                IBPROJ = IIBAR(IJPROJ)
 402 * photon
 403                IF ((IJPROJ.EQ.7).AND.(WHAT(1).GT.ZERO)) VIRT = WHAT(1)
 404 * lepton
 405                IF (((IJPROJ.EQ. 3).OR.(IJPROJ.EQ. 4).OR.
 406      &              (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11)).AND.
 407      &                              (WHAT(1).GT.ZERO)) Q2HI = WHAT(1)
 408             ENDIF
 409   111    CONTINUE
 410          IF (IJPROJ.EQ.0) THEN
 411             WRITE(LOUT,1110)
 412  1110       FORMAT(/,1X,'invalid PROJPAR card !',/)
 413             GOTO 9999
 414          ENDIF
 415       ENDIF
 416       GOTO 10
 417
 418 *********************************************************************
 419 *                                                                   *
 420 *               control card:  codewd = TARPAR                      *
 421 *                                                                   *
 422 *       what (1) =  mass number of target nucleus      default: 1   *
 423 *       what (2) =  charge of target nucleus           default: 1   *
 424 *       what (3..6)   no meaning                                    *
 425 *       sdum        target particle code word                       *
 426 *                                                                   *
 427 *       Note: If sdum is defined what (1..2) have no meaning.       *
 428 *                                                                   *
 429 *********************************************************************
 430
 431   120 CONTINUE
 432       IF (SDUM.EQ.BLANK) THEN
 433          IT     = INT(WHAT(1))
 434          ITZ    = INT(WHAT(2))
 435          IJTARG = 1
 436          IBTARG = 1
 437       ELSE
 438          IJTARG = 0
 439          DO 121 II=1,30
 440             IF (SDUM.EQ.BTYPE(II)) THEN
 441                IT     = 1
 442                ITZ    = 1
 443                IJTARG = II
 444                IBTARG = IIBAR(IJTARG)
 445             ENDIF
 446   121    CONTINUE
 447          IF (IJTARG.EQ.0) THEN
 448             WRITE(LOUT,1120)
 449  1120       FORMAT(/,1X,'invalid TARPAR card !',/)
 450             GOTO 9999
 451          ENDIF
 452       ENDIF
 453       GOTO 10
 454
 455 *********************************************************************
 456 *                                                                   *
 457 *               control card:  codewd = ENERGY                      *
 458 *                                                                   *
 459 *       what (1) =  energy (GeV) of projectile in Lab.              *
 460 *                   if what(1) < 0:  |what(1)| = kinetic energy     *
 461 *                                                default: 200 GeV   *
 462 *                   if |what(2)| > 0: min. energy for variable      *
 463 *                                     energy runs                   *
 464 *       what (2) =  max. energy for variable energy runs            *
 465 *                   if what(2) < 0:  |what(2)| = kinetic energy     *
 466 *                                                                   *
 467 *********************************************************************
 468
 469   130 CONTINUE
 470       EPN    = WHAT(1)
 471       PPN    = ZERO
 472       CMENER = ZERO
 473       IF ((ABS(WHAT(2)).GT.ZERO).AND.
 474      &    (ABS(WHAT(2)).GT.ABS(WHAT(1)))) THEN
 475          VARELO = WHAT(1)
 476          VAREHI = WHAT(2)
 477          EPN    = VAREHI
 478       ENDIF
 479       LEINP  = .TRUE.
 480       GOTO 10
 481
 482 *********************************************************************
 483 *                                                                   *
 484 *               control card:  codewd = MOMENTUM                    *
 485 *                                                                   *
 486 *       what (1) =  momentum (GeV/c) of projectile in Lab.          *
 487 *                                                default: 200 GeV/c *
 488 *       what (2..6), sdum   no meaning                              *
 489 *                                                                   *
 490 *********************************************************************
 491
 492   140 CONTINUE
 493       EPN    = ZERO
 494       PPN    = WHAT(1)
 495       CMENER = ZERO
 496       LEINP  = .TRUE.
 497       GOTO 10
 498
 499 *********************************************************************
 500 *                                                                   *
 501 *               control card:  codewd = CMENERGY                    *
 502 *                                                                   *
 503 *       what (1) =  energy in nucleon-nucleon cms.                  *
 504 *                                                default: none      *
 505 *       what (2..6), sdum   no meaning                              *
 506 *                                                                   *
 507 *********************************************************************
 508
 509   150 CONTINUE
 510       EPN    = ZERO
 511       PPN    = ZERO
 512       CMENER = WHAT(1)
 513       LEINP  = .TRUE.
 514       GOTO 10
 515
 516 *********************************************************************
 517 *                                                                   *
 518 *               control card:  codewd = EMULSION                    *
 519 *                                                                   *
 520 *               definition of nuclear emulsions                     *
 521 *                                                                   *
 522 *     what(1)      mass number of emulsion component                *
 523 *     what(2)      charge of emulsion component                     *
 524 *     what(3)      fraction of events in which a scattering on a    *
 525 *                  nucleus of this properties is performed          *
 526 *     what(4,5,6)  as what(1,2,3) but for another component         *
 527 *                                             default: no emulsion  *
 528 *     sdum         no meaning                                       *
 529 *                                                                   *
 530 *     Note: If this input-card is once used with valid parameters   *
 531 *           TARPAR is obsolete.                                     *
 532 *           Not the absolute values of the fractions are important  *
 533 *           but only the ratios of fractions of different comp.     *
 534 *           This control card can be repeatedly used to define      *
 535 *           emulsions consisting of up to 10 elements.              *
 536 *                                                                   *
 537 *********************************************************************
 538
 539   160 CONTINUE
 540       IF ((WHAT(1).GT.ZERO).AND.(WHAT(2).GT.ZERO)
 541      &                     .AND.(ABS(WHAT(3)).GT.ZERO)) THEN
 542          NCOMPO = NCOMPO+1
 543          IF (NCOMPO.GT.NCOMPX) THEN
 544             WRITE(LOUT,1600)
 545             STOP
 546          ENDIF
 547          IEMUMA(NCOMPO) = INT(WHAT(1))
 548          IEMUCH(NCOMPO) = INT(WHAT(2))
 549          EMUFRA(NCOMPO) = WHAT(3)
 550          IEMUL = 1
 551 C        CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
 552       ENDIF
 553       IF ((WHAT(4).GT.ZERO).AND.(WHAT(5).GT.ZERO)
 554      &                     .AND.(ABS(WHAT(6)).GT.ZERO)) THEN
 555          NCOMPO = NCOMPO+1
 556          IF (NCOMPO.GT.NCOMPX) THEN
 557             WRITE(LOUT,1001)
 558             STOP
 559          ENDIF
 560          IEMUMA(NCOMPO) = INT(WHAT(4))
 561          IEMUCH(NCOMPO) = INT(WHAT(5))
 562          EMUFRA(NCOMPO) = WHAT(6)
 563 C        CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
 564       ENDIF
 565  1600 FORMAT(1X,'too many emulsion components - program stopped')
 566       GOTO 10
 567
 568 *********************************************************************
 569 *                                                                   *
 570 *               control card:  codewd = FERMI                       *
 571 *                                                                   *
 572 *       what (1) = -1 Fermi-motion of nucleons not treated          *
 573 *                                                 default: 1        *
 574 *       what (2) =    scale factor for Fermi-momentum               *
 575 *                                                 default: 0.75     *
 576 *       what (3..6), sdum   no meaning                              *
 577 *                                                                   *
 578 *********************************************************************
 579
 580   170 CONTINUE
 581       IF (WHAT(1).EQ.-1.0D0) THEN
 582          LFERMI = .FALSE.
 583       ELSE
 584          LFERMI = .TRUE.
 585       ENDIF
 586       XMOD = WHAT(2)
 587       IF (XMOD.GE.ZERO) FERMOD = XMOD
 588       GOTO 10
 589
 590 *********************************************************************
 591 *                                                                   *
 592 *               control card:  codewd = TAUFOR                      *
 593 *                                                                   *
 594 *          formation time supressed intranuclear cascade            *
 595 *                                                                   *
 596 *    what (1)      formation time (in fm/c)                         *
 597 *                  note: what(1)=10. corresponds roughly to an      *
 598 *                        average formation time of 1 fm/c           *
 599 *                                                 default: 5. fm/c  *
 600 *    what (2)      number of generations followed                   *
 601 *                                                 default: 25       *
 602 *    what (3) = 1. p_t-dependent formation zone                     *
 603 *             = 2. constant formation zone                          *
 604 *                                                 default: 1        *
 605 *    what (4)      modus of selection of nucleus where the          *
 606 *                  cascade if followed first                        *
 607 *             = 1.  proj./target-nucleus with probab. 1/2           *
 608 *             = 2.  nucleus with highest mass                       *
 609 *             = 3.  proj. nucleus if particle is moving in pos. z   *
 610 *                   targ. nucleus if particle is moving in neg. z   *
 611 *                                                 default: 1        *
 612 *    what (5..6), sdum   no meaning                                 *
 613 *                                                                   *
 614 *********************************************************************
 615
 616   180 CONTINUE
 617       TAUFOR = WHAT(1)
 618       KTAUGE = INT(WHAT(2))
 619       INCMOD = 1
 620       IF ((WHAT(3).GE.1.0D0).AND.(WHAT(3).LE.2.0D0))
 621      &                                    ITAUVE = INT(WHAT(3))
 622       IF ((WHAT(4).GE.1.0D0).AND.(WHAT(4).LE.3.0D0))
 623      &                                    INCMOD = INT(WHAT(4))
 624       GOTO 10
 625
 626 *********************************************************************
 627 *                                                                   *
 628 *               control card:  codewd = PAULI                       *
 629 *                                                                   *
 630 *       what (1) =  -1  Pauli's principle for secondary             *
 631 *                       interactions not treated                    *
 632 *                                                    default: 1     *
 633 *       what (2..6), sdum   no meaning                              *
 634 *                                                                   *
 635 *********************************************************************
 636
 637   190 CONTINUE
 638       IF (WHAT(1).EQ.-1.0D0) THEN
 639          LPAULI = .FALSE.
 640       ELSE
 641          LPAULI = .TRUE.
 642       ENDIF
 643       GOTO 10
 644
 645 *********************************************************************
 646 *                                                                   *
 647 *               control card:  codewd = COULOMB                     *
 648 *                                                                   *
 649 *       what (1) = -1. Coulomb-energy treatment switched off        *
 650 *                                                    default: 1     *
 651 *       what (2..6), sdum   no meaning                              *
 652 *                                                                   *
 653 *********************************************************************
 654
 655   200 CONTINUE
 656       ICOUL = 1
 657       IF (WHAT(1).EQ.-1.0D0) THEN
 658          ICOUL = 0
 659       ELSE
 660          ICOUL = 1
 661       ENDIF
 662       GOTO 10
 663
 664 *********************************************************************
 665 *                                                                   *
 666 *               control card:  codewd = HADRIN                      *
 667 *                                                                   *
 668 *                       HADRIN module                               *
 669 *                                                                   *
 670 *    what (1) = 0. elastic/inelastic interactions with probab.      *
 671 *                  as defined by cross-sections                     *
 672 *             = 1. inelastic interactions forced                    *
 673 *             = 2. elastic interactions forced                      *
 674 *                                                 default: 1        *
 675 *    what (2)      upper threshold in total energy (GeV) below      *
 676 *                  which interactions are sampled by HADRIN         *
 677 *                                                 default: 5. GeV   *
 678 *    what (3..6), sdum   no meaning                                 *
 679 *                                                                   *
 680 *********************************************************************
 681
 682   210 CONTINUE
 683       IWHAT = INT(WHAT(1))
 684       IF ((IWHAT.GE.0).AND.(IWHAT.LE.2)) INTHAD = IWHAT
 685       IF ((WHAT(2).GT.ZERO).AND.(WHAT(2).LT.15.0D0)) EHADTH = WHAT(2)
 686       GOTO 10
 687
 688 *********************************************************************
 689 *                                                                   *
 690 *               control card:  codewd = EVAP                        *
 691 *                                                                   *
 692 *                    evaporation module                             *
 693 *                                                                   *
 694 *  what (1) =< -1 ==> evaporation is switched off                   *
 695 *           >=  1 ==> evaporation is performed                      *
 696 *                                                                   *
 697 *         what (1) = i1 + i2*10 + i3*100 + i4*10000                 *
 698 *                    (i1, i2, i3, i4 >= 0 )                         *
 699 *                                                                   *
 700 *   i1 is the flag for selecting the T=0 level density option used  *
 701 *      =  1: standard EVAP level densities with Cook pairing        *
 702 *            energies                                               *
 703 *      =  2: Z,N-dependent Gilbert & Cameron level densities        *
 704 *                                                        (default)  *
 705 *      =  3: Julich A-dependent level densities                     *
 706 *      =  4: Z,N-dependent Brancazio & Cameron level densities      *
 707 *                                                                   *
 708 *   i2 >= 1: high energy fission activated                          *
 709 *            (default high energy fission activated)                *
 710 *                                                                   *
 711 *   i3 =  0: No energy dependence for level densities               *
 712 *      =  1: Standard Ignyatuk (1975, 1st) energy dependence        *
 713 *            for level densities (default)                          *
 714 *      =  2: Standard Ignyatuk (1975, 1st) energy dependence        *
 715 *            for level densities with NOT used set of parameters    *
 716 *      =  3: Standard Ignyatuk (1975, 1st) energy dependence        *
 717 *            for level densities with NOT used set of parameters    *
 718 *      =  4: Second   Ignyatuk (1975, 2nd) energy dependence        *
 719 *            for level densities                                    *
 720 *      =  5: Second   Ignyatuk (1975, 2nd) energy dependence        *
 721 *            for level densities with fit 1 Iljinov & Mebel set of  *
 722 *            parameters                                             *
 723 *      =  6: Second   Ignyatuk (1975, 2nd) energy dependence        *
 724 *            for level densities with fit 2 Iljinov & Mebel set of  *
 725 *            parameters                                             *
 726 *      =  7: Second   Ignyatuk (1975, 2nd) energy dependence        *
 727 *            for level densities with fit 3 Iljinov & Mebel set of  *
 728 *            parameters                                             *
 729 *      =  8: Second   Ignyatuk (1975, 2nd) energy dependence        *
 730 *            for level densities with fit 4 Iljinov & Mebel set of  *
 731 *            parameters                                             *
 732 *                                                                   *
 733 *   i4 >= 1: Original Gilbert and Cameron pairing energies used     *
 734 *            (default Cook's modified pairing energies)             *
 735 *                                                                   *
 736 *  what (2) = ig + 10 * if   (ig and if must have the same sign)    *
 737 *                                                                   *
 738 *   ig =< -1 ==> deexcitation gammas are not produced               *
 739 *                (if the evaporation step is not performed          *
 740 *                 they are never produced)                          *
 741 *   if =< -1 ==> Fermi Break Up is not invoked                      *
 742 *                (if the evaporation step is not performed          *
 743 *                 it is never invoked)                              *
 744 *   The default is: deexcitation gamma produced and Fermi break up  *
 745 *                   activated for the new  preequilibrium, not      *
 746 *                   activated otherwise.                            *
 747 *  what (3..6), sdum   no meaning                                   *
 748 *                                                                   *
 749 *********************************************************************
 750
 751  220  CONTINUE
 752       WRITE(LOUT,1009)
 753  1009 FORMAT(1X,/,'Warning!  Evaporation request rejected since',
 754      &       ' evaporation modules not available with this version.')
 755       LEVPRT = .FALSE.
 756       LDEEXG = .FALSE.
 757       LHEAVY = .FALSE.
 758       LFRMBK = .FALSE.
 759       IFISS  = 0
 760       IEVFSS = 0
 761
 762       GOTO 10
 763
 764 *********************************************************************
 765 *                                                                   *
 766 *               control card:  codewd = EMCCHECK                    *
 767 *                                                                   *
 768 *    extended energy-momentum / quantum-number conservation check   *
 769 *                                                                   *
 770 *       what (1) = -1   extended check not performed                *
 771 *                                                    default: 1.    *
 772 *       what (2..6), sdum   no meaning                              *
 773 *                                                                   *
 774 *********************************************************************
 775
 776   230 CONTINUE
 777       IF (WHAT(1).EQ.-1) THEN
 778          LEMCCK = .FALSE.
 779       ELSE
 780          LEMCCK = .TRUE.
 781       ENDIF
 782       GOTO 10
 783
 784 *********************************************************************
 785 *                                                                   *
 786 *               control card:  codewd = MODEL                       *
 787 *                                                                   *
 788 *     Model to be used to treat nucleon-nucleon interactions        *
 789 *                                                                   *
 790 *       sdum = DTUNUC    two-chain model                            *
 791 *            = PHOJET    multiple chains including minijets         *
 792 *            = LEPTO     DIS                                        *
 793 *            = QNEUTRIN  quasi-elastic neutrino scattering          *
 794 *                                                  default: PHOJET  *
 795 *                                                                   *
 796 *       if sdum = LEPTO:                                            *
 797 *       what (1)         (variable INTER)                           *
 798 *                        = 1  gamma exchange                        *
 799 *                        = 2  W+-   exchange                        *
 800 *                        = 3  Z0    exchange                        *
 801 *                        = 4  gamma/Z0 exchange                     *
 802 *                                                                   *
 803 *       if sdum = QNEUTRIN:                                         *
 804 *       what (1)         = 0  elastic scattering on nucleon and     *
 805 *                             tau does not decay (default)          *
 806 *                        = 1  decay of tau into mu..                *
 807 *                        = 2  decay of tau into e..                 *
 808 *                        = 10 CC events on p and n                  *
 809 *                        = 11 NC events on p and n                  *
 810 *                                                                   *
 811 *       what (2..6)      no meaning                                 *
 812 *                                                                   *
 813 *********************************************************************
 814
 815   240 CONTINUE
 816       IF (SDUM.EQ.CMODEL(1)) THEN
 817          MCGENE = 1
 818       ELSEIF (SDUM.EQ.CMODEL(2)) THEN
 819          MCGENE = 2
 820       ELSEIF (SDUM.EQ.CMODEL(3)) THEN
 821          MCGENE = 3
 822          IF ((WHAT(1).GE.1.0D0).AND.(WHAT(1).LE.4.0D0))
 823      &      INTER = INT(WHAT(1))
 824       ELSEIF (SDUM.EQ.CMODEL(4)) THEN
 825          MCGENE = 4
 826          IWHAT  = INT(WHAT(1))
 827          IF ((IWHAT.EQ.1 ).OR.(IWHAT.EQ.2 ).OR.
 828      &       (IWHAT.EQ.10).OR.(IWHAT.EQ.11))
 829      &      NEUDEC = IWHAT
 830       ELSE
 831          STOP ' Unknown model !'
 832       ENDIF
 833       GOTO 10
 834
 835 *********************************************************************
 836 *                                                                   *
 837 *               control card:  codewd = PHOINPUT                    *
 838 *                                                                   *
 839 *       Start of input-section for PHOJET-specific input-cards      *
 840 *       Note:  This section will not be finished before giving      *
 841 *              ENDINPUT-card                                        *
 842 *       what (1..6), sdum   no meaning                              *
 843 *                                                                   *
 844 *********************************************************************
 845
 846   250 CONTINUE
 847       IF (LPHOIN) THEN
 848          CALL PHO_INIT(LINP,LOUT,IREJ1)
 849          IF (IREJ1.NE.0) THEN
 850             WRITE(LOUT,'(1X,A)')'INIT:   reading PHOJET-input failed'
 851             STOP
 852          ENDIF
 853          LPHOIN = .FALSE.
 854       ENDIF
 855       GOTO 10
 856
 857 *********************************************************************
 858 *                                                                   *
 859 *               control card:  codewd = GLAUBERI                    *
 860 *                                                                   *
 861 *        Pre-initialization of impact parameter selection           *
 862 *                                                                   *
 863 *        what (1..6), sdum   no meaning                             *
 864 *                                                                   *
 865 *********************************************************************
 866
 867   260 CONTINUE
 868       IF (IFIRST.NE.99) THEN
 869          CALL DT_RNDMST(12,34,56,78)
 870          CALL DT_RNDMTE(1)
 871          OPEN(40,FILE='outdata0/shm.out',STATUS='UNKNOWN')
 872 C        OPEN(11,FILE='outdata0/shm.dbg',STATUS='UNKNOWN')
 873          IFIRST = 99
 874       ENDIF
 875
 876       IPPN = 8
 877       PLOW = 10.0D0
 878 C     IPPN = 1
 879 C     PLOW = 100.0D0
 880       PHI  = 1.0D5
 881       APLOW = LOG10(PLOW)
 882       APHI  = LOG10(PHI)
 883       ADP   = (APHI-APLOW)/DBLE(IPPN)
 884
 885       IPLOW = 1
 886       IDIP  = 1
 887       IIP   = 5
 888 C     IPLOW = 1
 889 C     IDIP  = 1
 890 C     IIP   = 1
 891       IPRANG(1) = 1
 892       IPRANG(2) = 2
 893       IPRANG(3) = 5
 894       IPRANG(4) = 10
 895       IPRANG(5) = 20
 896
 897       ITLOW = 30
 898       IDIT  = 3
 899       IIT   = 60
 900 C     IDIT  = 10
 901 C     IIT   = 21
 902
 903       DO 473 NCIT=1,IIT
 904          IT   = ITLOW+(NCIT-1)*IDIT
 905 C        IPHI = IT
 906 C        IDIP = 10
 907 C        IIP  = (IPHI-IPLOW)/IDIP
 908 C        IF (IIP.EQ.0) IIP = 1
 909 C        IF (IT.EQ.IPLOW) IIP = 0
 910
 911          DO 472 NCIP=1,IIP
 912             IP = IPRANG(NCIP)
 913 CC           IF (NCIP.LE.IIP) THEN
 914 C               IP = IPLOW+(NCIP-1)*IDIP
 915 CC           ELSE
 916 CC              IP = IT
 917 CC           ENDIF
 918             IF (IP.GT.IT) GOTO 472
 919
 920             DO 471 NCP=1,IPPN+1
 921                APPN = APLOW+DBLE(NCP-1)*ADP
 922                PPN  = 10**APPN
 923
 924                OPEN(12,FILE='outdata0/shm.sta',STATUS='UNKNOWN')
 925                WRITE(12,'(1X,2I5,E15.3)') IP,IT,PPN
 926                CLOSE(12)
 927
 928                XLIM1 = 0.0D0
 929                XLIM2 = 50.0D0
 930                XLIM3 = ZERO
 931                IBIN  = 50
 932                CALL DT_NEWHGR(XDUM,XDUM,XDUM,XDUMB,-1,IHDUM)
 933                CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHSHMA)
 934
 935                NEVFIT = 5
 936 C              IF ((IP.GT.10).OR.(IT.GT.10)) THEN
 937 C                 NEVFIT = 5
 938 C              ELSE
 939 C                 NEVFIT = 10
 940 C              ENDIF
 941                SIGAV  = 0.0D0
 942
 943                DO 478 I=1,NEVFIT
 944                   CALL DT_SHMAKI(IP,IDUM1,IT,IDUM1,IJPROJ,PPN,99)
 945                   SIGAV = SIGAV+XSPRO(1,1,1)
 946                   DO 479 J=1,50
 947                      XC = DBLE(J)
 948                      CALL DT_FILHGR(XC,BSITE(1,1,1,J),IHSHMA,I)
 949   479             CONTINUE
 950   478          CONTINUE
 951
 952                CALL DT_EVTHIS(IDUM)
 953                HEADER = ' BSITE'
 954 C              CALL OUTGEN(IHSHMA,0,0,0,0,0,HEADER,0,NEVFIT,ONE,0,1,-1)
 955
 956 C              CALL GENFIT(XPARA)
 957 C              WRITE(40,'(2I4,E11.3,F6.0,5E11.3)')
 958 C    &              IP,IT,PPN,SIGAV/DBLE(NEVFIT),XPARA
 959
 960   471       CONTINUE
 961
 962   472    CONTINUE
 963
 964   473 CONTINUE
 965
 966       STOP
 967
 968 *********************************************************************
 969 *                                                                   *
 970 *               control card:  codewd = FLUCTUAT                    *
 971 *                                                                   *
 972 *           Treatment of cross section fluctuations                 *
 973 *                                                                   *
 974 *       what (1) = 1  treat cross section fluctuations              *
 975 *                                                    default: 0.    *
 976 *       what (1..6), sdum   no meaning                              *
 977 *                                                                   *
 978 *********************************************************************
 979
 980  270  CONTINUE
 981       IFLUCT = 0
 982       IF (WHAT(1).EQ.ONE) THEN
 983          IFLUCT = 1
 984          CALL DT_FLUINI
 985       ENDIF
 986       GOTO 10
 987
 988 *********************************************************************
 989 *                                                                   *
 990 *               control card:  codewd = CENTRAL                     *
 991 *                                                                   *
 992 *       what (1) = 1.  central production forced     default: 0     *
 993 *  if what (1) < 0 and > -100                                       *
 994 *       what (2) = min. impact parameter             default: 0     *
 995 *       what (3) = max. impact parameter             default: b_max *
 996 *  if what (1) < -99                                                *
 997 *       what (2) = fraction of cross section         default: 1     *
 998 *  if what (1) = -1 : evaporation/fzc suppressed                    *
 999 *  if what (1) < -1 : evaporation/fzc allowed                       *
1000 *                                                                   *
1001 *       what (4..6), sdum   no meaning                              *
1002 *                                                                   *
1003 *********************************************************************
1004
1005   280 CONTINUE
1006       ICENTR = INT(WHAT(1))
1007       IF (ICENTR.LT.0) THEN
1008          IF (ICENTR.GT.-100) THEN
1009             BIMIN = WHAT(2)
1010             BIMAX = WHAT(3)
1011          ELSE
1012             XSFRAC = WHAT(2)
1013          ENDIF
1014       ENDIF
1015       GOTO 10
1016
1017 *********************************************************************
1018 *                                                                   *
1019 *               control card:  codewd = RECOMBIN                    *
1020 *                                                                   *
1021 *                     Chain recombination                           *
1022 *        (recombine S-S and V-V chains to V-S chains)               *
1023 *                                                                   *
1024 *       what (1) = -1. recombination switched off    default: 1     *
1025 *       what (2..6), sdum   no meaning                              *
1026 *                                                                   *
1027 *********************************************************************
1028
1029   290 CONTINUE
1030       IRECOM = 1
1031       IF (WHAT(1).EQ.-1.0D0) IRECOM = 0
1032       GOTO 10
1033
1034 *********************************************************************
1035 *                                                                   *
1036 *               control card:  codewd = COMBIJET                    *
1037 *                                                                   *
1038 *               chain fusion (2 q-aq --> qq-aqaq)                   *
1039 *                                                                   *
1040 *       what (1) = 1   fusion treated                               *
1041 *                                                    default: 0.    *
1042 *       what (2)       minimum number of uncombined chains from     *
1043 *                      single projectile or target nucleons         *
1044 *                                                    default: 0.    *
1045 *       what (3..6), sdum   no meaning                              *
1046 *                                                                   *
1047 *********************************************************************
1048
1049   300 CONTINUE
1050       LCO2CR = .FALSE.
1051       IF (INT(WHAT(1)).EQ.1) LCO2CR = .TRUE.
1052       IF (WHAT(2).GE.ZERO) CUTOF = WHAT(2)
1053       GOTO 10
1054
1055 *********************************************************************
1056 *                                                                   *
1057 *               control card:  codewd = XCUTS                       *
1058 *                                                                   *
1059 *                 thresholds for x-sampling                         *
1060 *                                                                   *
1061 *    what (1)    defines lower threshold for val.-q x-value (CVQ)   *
1062 *                                                 default: 1.       *
1063 *    what (2)    defines lower threshold for val.-qq x-value (CDQ)  *
1064 *                                                 default: 2.       *
1065 *    what (3)    defines lower threshold for sea-q x-value (CSEA)   *
1066 *                                                 default: 0.2      *
1067 *    what (4)    sea-q x-values in S-S chains (SSMIMA)              *
1068 *                                                 default: 0.14     *
1069 *    what (5)    not used                                           *
1070 *                                                 default: 2.       *
1071 *    what (6), sdum   no meaning                                    *
1072 *                                                                   *
1073 *    Note: Lower thresholds (what(1..3)) are def. as x_thr=CXXX/ECM *
1074 *                                                                   *
1075 *********************************************************************
1076
1077   310 CONTINUE
1078       IF (WHAT(1).GE.0.5D0) CVQ    = WHAT(1)
1079       IF (WHAT(2).GE.ONE)   CDQ    = WHAT(2)
1080       IF (WHAT(3).GE.0.1D0) CSEA   = WHAT(3)
1081       IF (WHAT(4).GE.ZERO) THEN
1082          SSMIMA = WHAT(4)
1083          SSMIMQ = SSMIMA**2
1084       ENDIF
1085       IF (WHAT(5).GT.2.0D0) VVMTHR = WHAT(5)
1086       GOTO 10
1087
1088 *********************************************************************
1089 *                                                                   *
1090 *               control card:  codewd = INTPT                       *
1091 *                                                                   *
1092 *     what (1) = -1   intrinsic transverse momenta of partons       *
1093 *                     not treated                default: 1         *
1094 *     what (2..6), sdum   no meaning                                *
1095 *                                                                   *
1096 *********************************************************************
1097
1098   320 CONTINUE
1099       IF (WHAT(1).EQ.-1.0D0) THEN
1100          LINTPT = .FALSE.
1101       ELSE
1102          LINTPT = .TRUE.
1103       ENDIF
1104       GOTO 10
1105
1106 *********************************************************************
1107 *                                                                   *
1108 *               control card:  codewd = CRONINPT                    *
1109 *                                                                   *
1110 *    Cronin effect (multiple scattering of partons at chain ends)   *
1111 *                                                                   *
1112 *       what (1) = -1  Cronin effect not treated     default: 1     *
1113 *       what (2) = 0   scattering parameter          default: 0.64  *
1114 *       what (3..6), sdum   no meaning                              *
1115 *                                                                   *
1116 *********************************************************************
1117
1118   330 CONTINUE
1119       IF (WHAT(1).EQ.-1.0D0) THEN
1120          MKCRON = 0
1121       ELSE
1122          MKCRON = 1
1123       ENDIF
1124       CRONCO = WHAT(2)
1125       GOTO 10
1126
1127 *********************************************************************
1128 *                                                                   *
1129 *               control card:  codewd = SEADISTR                    *
1130 *                                                                   *
1131 *     what (1)  (XSEACO)  sea(x) prop. 1/x**what (1)   default: 1.  *
1132 *     what (2)  (UNON)                                 default: 2.  *
1133 *     what (3)  (UNOM)                                 default: 1.5 *
1134 *     what (4)  (UNOSEA)                               default: 5.  *
1135 *                        qdis(x) prop. (1-x)**what (1)  etc.        *
1136 *     what (5..6), sdum   no meaning                                *
1137 *                                                                   *
1138 *********************************************************************
1139
1140   340 CONTINUE
1141       XSEACO = WHAT(1)
1142       XSEACU = 1.05D0-XSEACO
1143       UNON   = WHAT(2)
1144       IF (UNON.LT.0.1D0) UNON = 2.0D0
1145       UNOM   = WHAT(3)
1146       IF (UNOM.LT.0.1D0) UNOM = 1.5D0
1147       UNOSEA = WHAT(4)
1148       IF (UNOSEA.LT.0.1D0) UNOSEA = 5.0D0
1149       GOTO 10
1150
1151 *********************************************************************
1152 *                                                                   *
1153 *               control card:  codewd = SEASU3                      *
1154 *                                                                   *
1155 *          Treatment of strange-quarks at chain ends                *
1156 *                                                                   *
1157 *       what (1)   (SEASQ)  strange-quark supression factor         *
1158 *                  iflav = 1.+rndm*(2.+SEASQ)                       *
1159 *                                                    default: 1.    *
1160 *       what (2..6), sdum   no meaning                              *
1161 *                                                                   *
1162 *********************************************************************
1163
1164   350 CONTINUE
1165       SEASQ = WHAT(1)
1166       GOTO 10
1167
1168 *********************************************************************
1169 *                                                                   *
1170 *               control card:  codewd = DIQUARKS                    *
1171 *                                                                   *
1172 *     what (1) = -1.  sea-diquark/antidiquark-pairs not treated     *
1173 *                                                    default: 1.    *
1174 *     what (2..6), sdum   no meaning                                *
1175 *                                                                   *
1176 *********************************************************************
1177
1178  360  CONTINUE
1179       IF (WHAT(1).EQ.-1.0D0) THEN
1180          LSEADI = .FALSE.
1181       ELSE
1182          LSEADI = .TRUE.
1183       ENDIF
1184       GOTO 10
1185
1186 *********************************************************************
1187 *                                                                   *
1188 *               control card:  codewd = RESONANC                    *
1189 *                                                                   *
1190 *                 treatment of low mass chains                      *
1191 *                                                                   *
1192 *    what (1) = -1 low chain masses are not corrected for resonance *
1193 *                  masses (obsolete for BAMJET-fragmentation)       *
1194 *                                       default: 1.                 *
1195 *    what (2) = -1 massless partons     default: 1. (massive)       *
1196 *                                       default: 1. (massive)       *
1197 *    what (3) = -1 chain-system containing chain of too small       *
1198 *                  mass is rejected (note: this does not fully      *
1199 *                  apply to S-S chains) default: 0.                 *
1200 *    what (4..6), sdum   no meaning                                 *
1201 *                                                                   *
1202 *********************************************************************
1203
1204   370 CONTINUE
1205       IRESCO = 1
1206       IMSHL  = 1
1207       IRESRJ = 0
1208       IF (WHAT(1).EQ.-ONE) IRESCO = 0
1209       IF (WHAT(2).EQ.-ONE) IMSHL  = 0
1210       IF (WHAT(3).EQ.-ONE) IRESRJ = 1
1211       GOTO 10
1212
1213 *********************************************************************
1214 *                                                                   *
1215 *               control card:  codewd = DIFFRACT                    *
1216 *                                                                   *
1217 *                Treatment of diffractive events                    *
1218 *                                                                   *
1219 *     what (1) = (ISINGD) 0  no single diffraction                  *
1220 *                         1  single diffraction included            *
1221 *                       +-2  single diffractive events only         *
1222 *                       +-3  projectile single diffraction only     *
1223 *                       +-4  target single diffraction only         *
1224 *                        -5  double pomeron exchange only           *
1225 *                      (neg. sign applies to PHOJET events)         *
1226 *                                                     default: 0.   *
1227 *                                                                   *
1228 *     what (2) = (IDOUBD) 0  no double diffraction                  *
1229 *                         1  double diffraction included            *
1230 *                         2  double diffractive events only         *
1231 *                                                     default: 0.   *
1232 *     what (3) = 1 projectile diffraction treated (2-channel form.) *
1233 *                                                     default: 0.   *
1234 *     what (4) = alpha-parameter in projectile diffraction          *
1235 *                                                     default: 0.   *
1236 *     what (5..6), sdum   no meaning                                *
1237 *                                                                   *
1238 *********************************************************************
1239
1240   380 CONTINUE
1241       IF (ABS(WHAT(1)).GT.ZERO) ISINGD = INT(WHAT(1))
1242       IF (ABS(WHAT(2)).GT.ZERO) IDOUBD = INT(WHAT(2))
1243       IF ((ISINGD.GT.1).AND.(IDOUBD.GT.1)) THEN
1244          WRITE(LOUT,1380)
1245  1380    FORMAT(1X,'INIT:   inconsistent DIFFRACT - input !',/,
1246      &          11X,'IDOUBD is reset to zero')
1247          IDOUBD = 0
1248       ENDIF
1249       IF (WHAT(3).GT.ZERO) DIBETA = WHAT(3)
1250       IF (WHAT(4).GT.ZERO) DIALPH = WHAT(4)
1251       GOTO 10
1252
1253 *********************************************************************
1254 *                                                                   *
1255 *               control card:  codewd = SINGLECH                    *
1256 *                                                                   *
1257 *       what (1) = 1.  Regge contribution (one chain) included      *
1258 *                                                   default: 0.     *
1259 *       what (2..6), sdum   no meaning                              *
1260 *                                                                   *
1261 *********************************************************************
1262
1263  390  CONTINUE
1264       ISICHA = 0
1265       IF (WHAT(1).EQ.ONE) ISICHA = 1
1266       GOTO 10
1267
1268 *********************************************************************
1269 *                                                                   *
1270 *               control card:  codewd = NOFRAGME                    *
1271 *                                                                   *
1272 *                 biased chain hadronization                        *
1273 *                                                                   *
1274 *       what (1..6) = -1  no of hadronizsation of S-S chains        *
1275 *                   = -2  no of hadronizsation of D-S chains        *
1276 *                   = -3  no of hadronizsation of S-D chains        *
1277 *                   = -4  no of hadronizsation of S-V chains        *
1278 *                   = -5  no of hadronizsation of D-V chains        *
1279 *                   = -6  no of hadronizsation of V-S chains        *
1280 *                   = -7  no of hadronizsation of V-D chains        *
1281 *                   = -8  no of hadronizsation of V-V chains        *
1282 *                   = -9  no of hadronizsation of comb. chains      *
1283 *                                  default:  complete hadronization *
1284 *       sdum   no meaning                                           *
1285 *                                                                   *
1286 *********************************************************************
1287
1288   400 CONTINUE
1289       DO 401 I=1,6
1290          ICHAIN = INT(WHAT(I))
1291          IF ((ICHAIN.LE.-1).AND.(ICHAIN.GE.-9))
1292      &      LHADRO(ABS(ICHAIN)) = .FALSE.
1293   401 CONTINUE
1294       GOTO 10
1295
1296 *********************************************************************
1297 *                                                                   *
1298 *               control card:  codewd = HADRONIZE                   *
1299 *                                                                   *
1300 *           hadronization model and parameter switch                *
1301 *                                                                   *
1302 *       what (1) = 1    hadronization via BAMJET                    *
1303 *                = 2    hadronization via JETSET                    *
1304 *                                                    default: 2     *
1305 *       what (2) = 1..3 parameter set to be used                    *
1306 *                       JETSET: 3 sets available                    *
1307 *                               ( = 3 default JETSET-parameters)    *
1308 *                       BAMJET: 1 set available                     *
1309 *                                                    default: 1     *
1310 *       what (3..6), sdum   no meaning                              *
1311 *                                                                   *
1312 *********************************************************************
1313
1314   410 CONTINUE
1315       IWHAT1 = INT(WHAT(1))
1316       IWHAT2 = INT(WHAT(2))
1317       IF ((IWHAT1.EQ.1).OR.(IWHAT1.EQ.2)) IFRAG(1) = IWHAT1
1318       IF ((IWHAT1.EQ.2).AND.(IWHAT2.GE.1).AND.(IWHAT2.LE.3))
1319      &                                    IFRAG(2) = IWHAT2
1320       GOTO 10
1321
1322 *********************************************************************
1323 *                                                                   *
1324 *               control card:  codewd = POPCORN                     *
1325 *                                                                   *
1326 *  "Popcorn-effect" in fragmentation and diquark breaking diagrams  *
1327 *                                                                   *
1328 *   what (1) = (PDB) frac. of diquark fragmenting directly into     *
1329 *                    baryons (PYTHIA/JETSET fragmentation)          *
1330 *                    (JETSET: = 0. Popcorn mechanism switched off)  *
1331 *                                                    default: 0.5   *
1332 *   what (2) = probability for accepting a diquark breaking         *
1333 *              diagram involving the generation of a u/d quark-     *
1334 *              antiquark pair                        default: 0.0   *
1335 *   what (3) = same a what (2), here for s quark-antiquark pair     *
1336 *                                                    default: 0.0   *
1337 *   what (4..6), sdum   no meaning                                  *
1338 *                                                                   *
1339 *********************************************************************
1340
1341   420 CONTINUE
1342       IF (WHAT(1).GE.0.0D0) PDB = WHAT(1)
1343       IF (WHAT(2).GE.0.0D0) THEN
1344          PDBSEA(1) = WHAT(2)
1345          PDBSEA(2) = WHAT(2)
1346       ENDIF
1347       IF (WHAT(3).GE.0.0D0) PDBSEA(3) = WHAT(3)
1348       DO 421 I=1,8
1349          DBRKA(1,I) = DBRKR(1,I)*PDBSEA(1)/(1.D0-PDBSEA(1))
1350          DBRKA(2,I) = DBRKR(2,I)*PDBSEA(2)/(1.D0-PDBSEA(2))
1351          DBRKA(3,I) = DBRKR(3,I)*PDBSEA(3)/(1.D0-PDBSEA(3))
1352   421 CONTINUE
1353       GOTO 10
1354
1355 *********************************************************************
1356 *                                                                   *
1357 *               control card:  codewd = PARDECAY                    *
1358 *                                                                   *
1359 *      what (1) = 1.  Sigma0/Asigma0 are decaying within JETSET     *
1360 *               = 2.  pion^0 decay after intranucl. cascade         *
1361 *                                                default: no decay  *
1362 *      what (2..6), sdum   no meaning                               *
1363 *                                                                   *
1364 *********************************************************************
1365
1366  430  CONTINUE
1367       IF (WHAT(1).EQ.ONE)  ISIG0 = 1
1368       IF (WHAT(1).EQ.2.0D0) IPI0 = 1
1369       GOTO 10
1370
1371 *********************************************************************
1372 *                                                                   *
1373 *               control card:  codewd = BEAM                        *
1374 *                                                                   *
1375 *              definition of beam parameters                        *
1376 *                                                                   *
1377 *      what (1/2)  > 0 : energy of beam 1/2 (GeV)                   *
1378 *                  < 0 : abs(what(1/2)) energy per charge of        *
1379 *                        beam 1/2 (GeV)                             *
1380 *                  (beam 1 is directed into positive z-direction)   *
1381 *      what (3)    beam crossing angle, defined as 2x angle between *
1382 *                  one beam and the z-axis (micro rad)              *
1383 *      what (4)    angle with x-axis defining the collision plane   *
1384 *      what (5..6), sdum   no meaning                               *
1385 *                                                                   *
1386 *      Note: this card requires previously defined projectile and   *
1387 *            target identities (PROJPAR, TARPAR)                    *
1388 *                                                                   *
1389 *********************************************************************
1390
1391   440 CONTINUE
1392       CALL DT_BEAMPR(WHAT,PPN,1)
1393       EPN    = ZERO
1394       CMENER = ZERO
1395       LEINP  = .TRUE.
1396       GOTO 10
1397
1398 *********************************************************************
1399 *                                                                   *
1400 *               control card:  codewd = LUND-MSTU                   *
1401 *                                                                   *
1402 *          set parameter MSTU in JETSET-common /LUDAT1/             *
1403 *                                                                   *
1404 *       what (1) =  index according to LUND-common block            *
1405 *       what (2) =  new value of MSTU( int(what(1)) )               *
1406 *       what (3), what(4) and what (5), what(6) further             *
1407 *                   parameter in the same way as what (1) and       *
1408 *                   what (2)                                        *
1409 *                        default: default-Lund or corresponding to  *
1410 *                                 the set given in HADRONIZE        *
1411 *                                                                   *
1412 *********************************************************************
1413
1414   450 CONTINUE
1415       IF (WHAT(1).GT.ZERO) THEN
1416          NMSTU = NMSTU+1
1417          IMSTU(NMSTU) = INT(WHAT(1))
1418          MSTUX(NMSTU) = INT(WHAT(2))
1419       ENDIF
1420       IF (WHAT(3).GT.ZERO) THEN
1421          NMSTU = NMSTU+1
1422          IMSTU(NMSTU) = INT(WHAT(3))
1423          MSTUX(NMSTU) = INT(WHAT(4))
1424       ENDIF
1425       IF (WHAT(5).GT.ZERO) THEN
1426          NMSTU = NMSTU+1
1427          IMSTU(NMSTU) = INT(WHAT(5))
1428          MSTUX(NMSTU) = INT(WHAT(6))
1429       ENDIF
1430       GOTO 10
1431
1432 *********************************************************************
1433 *                                                                   *
1434 *               control card:  codewd = LUND-MSTJ                   *
1435 *                                                                   *
1436 *          set parameter MSTJ in JETSET-common /LUDAT1/             *
1437 *                                                                   *
1438 *       what (1) =  index according to LUND-common block            *
1439 *       what (2) =  new value of MSTJ( int(what(1)) )               *
1440 *       what (3), what(4) and what (5), what(6) further             *
1441 *                   parameter in the same way as what (1) and       *
1442 *                   what (2)                                        *
1443 *                        default: default-Lund or corresponding to  *
1444 *                                 the set given in HADRONIZE        *
1445 *                                                                   *
1446 *********************************************************************
1447
1448   451 CONTINUE
1449       IF (WHAT(1).GT.ZERO) THEN
1450          NMSTJ = NMSTJ+1
1451          IMSTJ(NMSTJ) = INT(WHAT(1))
1452          MSTJX(NMSTJ) = INT(WHAT(2))
1453       ENDIF
1454       IF (WHAT(3).GT.ZERO) THEN
1455          NMSTJ = NMSTJ+1
1456          IMSTJ(NMSTJ) = INT(WHAT(3))
1457          MSTJX(NMSTJ) = INT(WHAT(4))
1458       ENDIF
1459       IF (WHAT(5).GT.ZERO) THEN
1460          NMSTJ = NMSTJ+1
1461          IMSTJ(NMSTJ) = INT(WHAT(5))
1462          MSTJX(NMSTJ) = INT(WHAT(6))
1463       ENDIF
1464       GOTO 10
1465
1466 *********************************************************************
1467 *                                                                   *
1468 *               control card:  codewd = LUND-MDCY                   *
1469 *                                                                   *
1470 *  set parameter MDCY(I,1) for particle decays in JETSET-common     *
1471 *                                                      /LUDAT3/     *
1472 *                                                                   *
1473 *       what (1-6) = PDG particle index of particle which should    *
1474 *                    not decay                                      *
1475 *                        default: default-Lund or forced in         *
1476 *                                 DT_INITJS                         *
1477 *                                                                   *
1478 *********************************************************************
1479
1480   452 CONTINUE
1481       DO 4521 I=1,6
1482          IF (WHAT(I).NE.ZERO) THEN
1483             KC = PYCOMP(INT(WHAT(I)))
1484             MDCY(KC,1) = 0
1485          ENDIF
1486  4521 CONTINUE
1487       GOTO 10
1488
1489 *********************************************************************
1490 *                                                                   *
1491 *               control card:  codewd = LUND-PARJ                   *
1492 *                                                                   *
1493 *          set parameter PARJ in JETSET-common /LUDAT1/             *
1494 *                                                                   *
1495 *       what (1) =  index according to LUND-common block            *
1496 *       what (2) =  new value of PARJ( int(what(1)) )               *
1497 *       what (3), what(4) and what (5), what(6) further             *
1498 *                   parameter in the same way as what (1) and       *
1499 *                   what (2)                                        *
1500 *                        default: default-Lund or corresponding to  *
1501 *                                 the set given in HADRONIZE        *
1502 *                                                                   *
1503 *********************************************************************
1504
1505   460 CONTINUE
1506       IF (WHAT(1).NE.ZERO) THEN
1507          NPARJ = NPARJ+1
1508          IPARJ(NPARJ) = INT(WHAT(1))
1509          PARJX(NPARJ) = WHAT(2)
1510       ENDIF
1511       IF (WHAT(3).NE.ZERO) THEN
1512          NPARJ = NPARJ+1
1513          IPARJ(NPARJ) = INT(WHAT(3))
1514          PARJX(NPARJ) = WHAT(4)
1515       ENDIF
1516       IF (WHAT(5).NE.ZERO) THEN
1517          NPARJ = NPARJ+1
1518          IPARJ(NPARJ) = INT(WHAT(5))
1519          PARJX(NPARJ) = WHAT(6)
1520       ENDIF
1521       GOTO 10
1522
1523 *********************************************************************
1524 *                                                                   *
1525 *               control card:  codewd = LUND-PARU                   *
1526 *                                                                   *
1527 *          set parameter PARJ in JETSET-common /LUDAT1/             *
1528 *                                                                   *
1529 *       what (1) =  index according to LUND-common block            *
1530 *       what (2) =  new value of PARU( int(what(1)) )               *
1531 *       what (3), what(4) and what (5), what(6) further             *
1532 *                   parameter in the same way as what (1) and       *
1533 *                   what (2)                                        *
1534 *                        default: default-Lund or corresponding to  *
1535 *                                 the set given in HADRONIZE        *
1536 *                                                                   *
1537 *********************************************************************
1538
1539   470 CONTINUE
1540       IF (WHAT(1).GT.ZERO) THEN
1541          NPARU = NPARU+1
1542          IPARU(NPARU) = INT(WHAT(1))
1543          PARUX(NPARU) = WHAT(2)
1544       ENDIF
1545       IF (WHAT(3).GT.ZERO) THEN
1546          NPARU = NPARU+1
1547          IPARU(NPARU) = INT(WHAT(3))
1548          PARUX(NPARU) = WHAT(4)
1549       ENDIF
1550       IF (WHAT(5).GT.ZERO) THEN
1551          NPARU = NPARU+1
1552          IPARU(NPARU) = INT(WHAT(5))
1553          PARUX(NPARU) = WHAT(6)
1554       ENDIF
1555       GOTO 10
1556
1557 *********************************************************************
1558 *                                                                   *
1559 *               control card:  codewd = OUTLEVEL                    *
1560 *                                                                   *
1561 *                    output control switches                        *
1562 *                                                                   *
1563 *       what (1) =  internal rejection informations  default: 0     *
1564 *       what (2) =  energy-momentum conservation check output       *
1565 *                                                    default: 0     *
1566 *       what (3) =  internal warning messages        default: 0     *
1567 *       what (4..6), sdum    not yet used                           *
1568 *                                                                   *
1569 *********************************************************************
1570
1571   480 CONTINUE
1572       DO 481 K=1,6
1573          IOULEV(K) = INT(WHAT(K))
1574   481 CONTINUE
1575       GOTO 10
1576
1577 *********************************************************************
1578 *                                                                   *
1579 *               control card:  codewd = FRAME                       *
1580 *                                                                   *
1581 *          frame in which final state is given in DTEVT1            *
1582 *                                                                   *
1583 *       what (1) = 1  target rest frame (laboratory)                *
1584 *                = 2  nucleon-nucleon cms                           *
1585 *                                                    default: 1     *
1586 *                                                                   *
1587 *********************************************************************
1588
1589   490 CONTINUE
1590       KFRAME = INT(WHAT(1))
1591       IF ((KFRAME.GE.1).AND.(KFRAME.LE.2)) IFRAME = KFRAME
1592       GOTO 10
1593
1594 *********************************************************************
1595 *                                                                   *
1596 *               control card:  codewd = L-TAG                       *
1597 *                                                                   *
1598 *                        lepton tagger:                             *
1599 *   definition of kinematical cuts for radiated photon and          *
1600 *   outgoing lepton detection in lepton-nucleus interactions        *
1601 *                                                                   *
1602 *       what (1) = y_min                                            *
1603 *       what (2) = y_max                                            *
1604 *       what (3) = Q^2_min                                          *
1605 *       what (4) = Q^2_max                                          *
1606 *       what (5) = theta_min  (Lab)                                 *
1607 *       what (6) = theta_max  (Lab)                                 *
1608 *                                       default: no cuts            *
1609 *       sdum    no meaning                                          *
1610 *                                                                   *
1611 *********************************************************************
1612
1613   500 CONTINUE
1614       YMIN  = WHAT(1)
1615       YMAX  = WHAT(2)
1616       Q2MIN = WHAT(3)
1617       Q2MAX = WHAT(4)
1618       THMIN = WHAT(5)
1619       THMAX = WHAT(6)
1620       GOTO 10
1621
1622 *********************************************************************
1623 *                                                                   *
1624 *               control card:  codewd = L-ETAG                      *
1625 *                                                                   *
1626 *                        lepton tagger:                             *
1627 *       what (1) = min. outgoing lepton energy  (in Lab)            *
1628 *       what (2) = min. photon energy           (in Lab)            *
1629 *       what (3) = max. photon energy           (in Lab)            *
1630 *                                       default: no cuts            *
1631 *       what (2..6), sdum    no meaning                             *
1632 *                                                                   *
1633 *********************************************************************
1634
1635   510 CONTINUE
1636       ELMIN = MAX(WHAT(1),ZERO)
1637       EGMIN = MAX(WHAT(2),ZERO)
1638       EGMAX = MAX(WHAT(3),ZERO)
1639       GOTO 10
1640
1641 *********************************************************************
1642 *                                                                   *
1643 *               control card:  codewd = ECMS-CUT                    *
1644 *                                                                   *
1645 *     what (1) = min. c.m. energy to be sampled                     *
1646 *     what (2) = max. c.m. energy to be sampled                     *
1647 *     what (3) = min x_Bj         to be sampled                     *
1648 *                                       default: no cuts            *
1649 *     what (3..6), sdum    no meaning                               *
1650 *                                                                   *
1651 *********************************************************************
1652
1653   520 CONTINUE
1654       ECMIN  = WHAT(1)
1655       ECMAX  = WHAT(2)
1656       IF (ECMIN.GT.ECMAX) ECMIN = ECMAX
1657       XBJMIN = MAX(WHAT(3),ZERO)
1658       GOTO 10
1659
1660 *********************************************************************
1661 *                                                                   *
1662 *               control card:  codewd = VDM-PAR1                    *
1663 *                                                                   *
1664 *      parameters in gamma-nucleus cross section calculation        *
1665 *                                                                   *
1666 *       what (1) =  Lambda^2                       default: 2.      *
1667 *       what (2)    lower limit in M^2 integration                  *
1668 *                =  1  (3m_pi)^2                                    *
1669 *                =  2  (m_rho0)^2                                   *
1670 *                =  3  (m_phi)^2                   default: 1       *
1671 *       what (3)    upper limit in M^2 integration                  *
1672 *                =  1   s/2                                         *
1673 *                =  2   s/4                                         *
1674 *                =  3   s                          default: 3       *
1675 *       what (4)    CKMT F_2 structure function                     *
1676 *                =  2212  proton                                    *
1677 *                =  100   deuteron                 default: 2212    *
1678 *       what (5)    calculation of gamma-nucleon xsections          *
1679 *                =  1  according to CKMT-parametrization of F_2     *
1680 *                =  2  integrating SIGVP over M^2                   *
1681 *                =  3  using SIGGA                                  *
1682 *                =  4  PHOJET cross sections       default:  4      *
1683 *                                                                   *
1684 *       what (6), sdum    no meaning                                *
1685 *                                                                   *
1686 *********************************************************************
1687
1688   530 CONTINUE
1689       IF (WHAT(1).GE.ZERO) RL2 = WHAT(1)
1690       IF ((WHAT(2).GE.1).AND.(WHAT(2).LE.3)) INTRGE(1) = INT(WHAT(2))
1691       IF ((WHAT(3).GE.1).AND.(WHAT(3).LE.3)) INTRGE(2) = INT(WHAT(3))
1692       IF ((WHAT(4).EQ.2212).OR.(WHAT(4).EQ.100)) IDPDF = INT(WHAT(4))
1693       IF ((WHAT(5).GE.1).AND.(WHAT(5).LE.4)) MODEGA = INT(WHAT(5))
1694       GOTO 10
1695
1696 *********************************************************************
1697 *                                                                   *
1698 *               control card:  codewd = HISTOGRAM                   *
1699 *                                                                   *
1700 *           activate different classes of histograms                *
1701 *                                                                   *
1702 *                                default: no histograms             *
1703 *                                                                   *
1704 *********************************************************************
1705
1706   540 CONTINUE
1707       DO 541 J=1,6
1708          IF ((WHAT(J).GE.100).AND.(WHAT(J).LE.150)) THEN
1709             IHISPP(INT(WHAT(J))-100) = 1
1710          ELSEIF ((ABS(WHAT(J)).GE.200).AND.(ABS(WHAT(J)).LE.250)) THEN
1711             IHISXS(INT(ABS(WHAT(J)))-200) = 1
1712             IF (WHAT(J).LT.ZERO) IXSTBL = 1
1713          ENDIF
1714   541 CONTINUE
1715       GOTO 10
1716
1717 *********************************************************************
1718 *                                                                   *
1719 *               control card:  codewd = XS-TABLE                    *
1720 *                                                                   *
1721 *    output of cross section table for requested interaction        *
1722 *              - particle production deactivated ! -                *
1723 *                                                                   *
1724 *       what (1)      lower energy limit for tabulation             *
1725 *                > 0  Lab. frame                                    *
1726 *                < 0  nucleon-nucleon cms                           *
1727 *       what (2)      upper energy limit for tabulation             *
1728 *                > 0  Lab. frame                                    *
1729 *                < 0  nucleon-nucleon cms                           *
1730 *       what (3) > 0  # of equidistant lin. bins in E               *
1731 *                < 0  # of equidistant log. bins in E               *
1732 *       what (4)      lower limit of particle virtuality (photons)  *
1733 *       what (5)      upper limit of particle virtuality (photons)  *
1734 *       what (6) > 0  # of equidistant lin. bins in Q^2             *
1735 *                < 0  # of equidistant log. bins in Q^2             *
1736 *                                                                   *
1737 *********************************************************************
1738
1739   550 CONTINUE
1740       IF (WHAT(1).EQ.99999.0D0) THEN
1741          IRATIO = INT(WHAT(2))
1742          GOTO 10
1743       ENDIF
1744       CMENER = ABS(WHAT(2))
1745       IF (.NOT.LXSTAB) THEN
1746          CALL DT_BERTTP
1747          CALL DT_INCINI
1748       ENDIF
1749       IF ((.NOT.LXSTAB).OR.(CMENER.NE.CMEOLD)) THEN
1750          CMEOLD = CMENER
1751          IF (WHAT(2).GT.ZERO)
1752      &      CMENER = SQRT(2.0D0*AAM(1)**2+2.0D0*WHAT(2)*AAM(1))
1753          EPN = ZERO
1754          PPN = ZERO
1755 C        WRITE(LOUT,*) 'CMENER = ',CMENER
1756          CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,CMENER,1)
1757          CALL DT_PHOINI
1758       ENDIF
1759       CALL DT_XSTABL(WHAT,IXSQEL,IRATIO)
1760       IXSQEL = 0
1761       LXSTAB = .TRUE.
1762       GOTO 10
1763
1764 *********************************************************************
1765 *                                                                   *
1766 *               control card:  codewd = GLAUB-PAR                   *
1767 *                                                                   *
1768 *                parameters in Glauber-formalism                    *
1769 *                                                                   *
1770 *    what (1)  # of nucleon configurations sampled in integration   *
1771 *              over nuclear desity                default: 1000     *
1772 *    what (2)  # of bins for integration over impact-parameter and  *
1773 *              for profile-function calculation   default: 49       *
1774 *    what (3)  = 1 calculation of tot., el. and qel. cross sections *
1775 *                                                 default: 0        *
1776 *    what (4)  = 1   read pre-calculated impact-parameter distrib.  *
1777 *                    from "sdum".glb                                *
1778 *              =-1   dump pre-calculated impact-parameter distrib.  *
1779 *                    into "sdum".glb                                *
1780 *              = 100 read pre-calculated impact-parameter distrib.  *
1781 *                    for variable projectile/target/energy runs     *
1782 *                    from "sdum".glb                                *
1783 *                                                 default: 0        *
1784 *    what (5..6)   no meaning                                       *
1785 *    sdum      if |what (4)| = 1 name of in/output-file (sdum.glb)  *
1786 *                                                                   *
1787 *********************************************************************
1788
1789   560 CONTINUE
1790       IF (WHAT(1).GT.ZERO) JSTATB = INT(WHAT(1))
1791       IF (WHAT(2).GT.ZERO) JBINSB = INT(WHAT(2))
1792       IF (WHAT(3).EQ.ONE) LPROD = .FALSE.
1793       IF ((ABS(WHAT(4)).EQ.ONE).OR.(WHAT(4).EQ.100)) THEN
1794          IOGLB = INT(WHAT(4))
1795          CGLB  = SDUM
1796       ENDIF
1797       GOTO 10
1798
1799 *********************************************************************
1800 *                                                                   *
1801 *               control card:  codewd = GLAUB-INI                   *
1802 *                                                                   *
1803 *             pre-initialization of profile function                *
1804 *                                                                   *
1805 *       what (1)      lower energy limit for initialization         *
1806 *                > 0  Lab. frame                                    *
1807 *                < 0  nucleon-nucleon cms                           *
1808 *       what (2)      upper energy limit for initialization         *
1809 *                > 0  Lab. frame                                    *
1810 *                < 0  nucleon-nucleon cms                           *
1811 *       what (3) > 0  # of equidistant lin. bins in E               *
1812 *                < 0  # of equidistant log. bins in E               *
1813 *       what (4)      maximum projectile mass number for which the  *
1814 *                     Glauber data are initialized for each         *
1815 *                     projectile mass number                        *
1816 *                     (if <= mass given with the PROJPAR-card)      *
1817 *                                              default: 18          *
1818 *       what (5)      steps in mass number starting from what (4)   *
1819 *                     up to mass number defined with PROJPAR-card   *
1820 *                     for which Glauber data are initialized        *
1821 *                                              default: 5           *
1822 *       what (6)      no meaning                                    *
1823 *       sdum          no meaning                                    *
1824 *                                                                   *
1825 *********************************************************************
1826
1827   565 CONTINUE
1828       IOGLB = -100
1829       CALL DT_GLBINI(WHAT)
1830       GOTO 10
1831
1832 *********************************************************************
1833 *                                                                   *
1834 *               control card:  codewd = VDM-PAR2                    *
1835 *                                                                   *
1836 *      parameters in gamma-nucleus cross section calculation        *
1837 *                                                                   *
1838 *      what (1) = 0 no suppression of shadowing by direct photon    *
1839 *                   processes                                       *
1840 *               = 1 suppression ..                   default: 1     *
1841 *      what (2) = 0 no suppression of shadowing by anomalous        *
1842 *                   component if photon-F_2                         *
1843 *               = 1 suppression ..                   default: 1     *
1844 *      what (3) = 0 no suppression of shadowing by coherence        *
1845 *                   length of the photon                            *
1846 *               = 1 suppression ..                   default: 1     *
1847 *      what (4) = 1 longitudinal polarized photons are taken into   *
1848 *                   account                                         *
1849 *                   eps*R*Q^2/M^2 = what(4)*Q^2/M^2  default: 0     *
1850 *      what (5..6), sdum    no meaning                              *
1851 *                                                                   *
1852 *********************************************************************
1853
1854   570 CONTINUE
1855       IF ((WHAT(1).EQ.ZERO).OR.(WHAT(1).EQ.ONE)) ISHAD(1) = INT(WHAT(1))
1856       IF ((WHAT(2).EQ.ZERO).OR.(WHAT(2).EQ.ONE)) ISHAD(2) = INT(WHAT(2))
1857       IF ((WHAT(3).EQ.ZERO).OR.(WHAT(3).EQ.ONE)) ISHAD(3) = INT(WHAT(3))
1858       EPSPOL  = WHAT(4)
1859       GOTO 10
1860
1861 *********************************************************************
1862 *                                                                   *
1863 *               control card:  XS-QELPRO                            *
1864 *                                                                   *
1865 *     what (1..6), sdum    no meaning                               *
1866 *                                                                   *
1867 *********************************************************************
1868
1869   580 CONTINUE
1870       IXSQEL = ABS(WHAT(1))
1871       GOTO 10
1872
1873 *********************************************************************
1874 *                                                                   *
1875 *               control card:  RNDMINIT                             *
1876 *                                                                   *
1877 *           initialization of random number generator               *
1878 *                                                                   *
1879 *     what (1..4)    values for initialization (= 1..168)           *
1880 *     what (5..6), sdum    no meaning                               *
1881 *                                                                   *
1882 *********************************************************************
1883
1884   590 CONTINUE
1885       IF ((WHAT(1).LT.1.0D0).OR.(WHAT(1).GT.168.0D0)) THEN
1886          NA1 = 22
1887       ELSE
1888          NA1 = WHAT(1)
1889       ENDIF
1890       IF ((WHAT(2).LT.1.0D0).OR.(WHAT(2).GT.168.0D0)) THEN
1891          NA2 = 54
1892       ELSE
1893          NA2 = WHAT(2)
1894       ENDIF
1895       IF ((WHAT(3).LT.1.0D0).OR.(WHAT(3).GT.168.0D0)) THEN
1896          NA3 = 76
1897       ELSE
1898          NA3 = WHAT(3)
1899       ENDIF
1900       IF ((WHAT(4).LT.1.0D0).OR.(WHAT(4).GT.168.0D0)) THEN
1901          NA4 = 92
1902       ELSE
1903          NA4 = WHAT(4)
1904       ENDIF
1905       CALL DT_RNDMST(NA1,NA2,NA3,NA4)
1906       GOTO 10
1907
1908 *********************************************************************
1909 *                                                                   *
1910 *               control card:  codewd = LEPTO-CUT                   *
1911 *                                                                   *
1912 *          set parameter CUT in LEPTO-common /LEPTOU/               *
1913 *                                                                   *
1914 *       what (1) =  index in CUT-array                              *
1915 *       what (2) =  new value of CUT( int(what(1)) )                *
1916 *       what (3), what(4) and what (5), what(6) further             *
1917 *                   parameter in the same way as what (1) and       *
1918 *                   what (2)                                        *
1919 *                        default: default-LEPTO parameters          *
1920 *                                                                   *
1921 *********************************************************************
1922
1923   600 CONTINUE
1924       IF (WHAT(1).GT.ZERO) CUT(INT(WHAT(1))) = WHAT(2)
1925       IF (WHAT(3).GT.ZERO) CUT(INT(WHAT(3))) = WHAT(4)
1926       IF (WHAT(5).GT.ZERO) CUT(INT(WHAT(5))) = WHAT(6)
1927       GOTO 10
1928
1929 *********************************************************************
1930 *                                                                   *
1931 *               control card:  codewd = LEPTO-LST                   *
1932 *                                                                   *
1933 *          set parameter LST in LEPTO-common /LEPTOU/               *
1934 *                                                                   *
1935 *       what (1) =  index in LST-array                              *
1936 *       what (2) =  new value of LST( int(what(1)) )                *
1937 *       what (3), what(4) and what (5), what(6) further             *
1938 *                   parameter in the same way as what (1) and       *
1939 *                   what (2)                                        *
1940 *                        default: default-LEPTO parameters          *
1941 *                                                                   *
1942 *********************************************************************
1943
1944   610 CONTINUE
1945       IF (WHAT(1).GT.ZERO) LST(INT(WHAT(1))) = INT(WHAT(2))
1946       IF (WHAT(3).GT.ZERO) LST(INT(WHAT(3))) = INT(WHAT(4))
1947       IF (WHAT(5).GT.ZERO) LST(INT(WHAT(5))) = INT(WHAT(6))
1948       GOTO 10
1949
1950 *********************************************************************
1951 *                                                                   *
1952 *               control card:  codewd = LEPTO-PARL                  *
1953 *                                                                   *
1954 *          set parameter PARL in LEPTO-common /LEPTOU/              *
1955 *                                                                   *
1956 *       what (1) =  index in PARL-array                             *
1957 *       what (2) =  new value of PARL( int(what(1)) )               *
1958 *       what (3), what(4) and what (5), what(6) further             *
1959 *                   parameter in the same way as what (1) and       *
1960 *                   what (2)                                        *
1961 *                        default: default-LEPTO parameters          *
1962 *                                                                   *
1963 *********************************************************************
1964
1965   620 CONTINUE
1966       IF (WHAT(1).GT.ZERO) PARL(INT(WHAT(1))) = WHAT(2)
1967       IF (WHAT(3).GT.ZERO) PARL(INT(WHAT(3))) = WHAT(4)
1968       IF (WHAT(5).GT.ZERO) PARL(INT(WHAT(5))) = WHAT(6)
1969       GOTO 10
1970
1971 *********************************************************************
1972 *                                                                   *
1973 *               control card:  codewd = START                       *
1974 *                                                                   *
1975 *       what (1) =   number of events                default: 100.  *
1976 *       what (2) = 0 Glauber initialization follows                 *
1977 *                = 1 Glauber initialization supressed, fitted       *
1978 *                    results are used instead                       *
1979 *                    (this does not apply if emulsion-treatment     *
1980 *                     is requested)                                 *
1981 *                = 2 Glauber initialization is written to           *
1982 *                    output-file shmakov.out                        *
1983 *                = 3 Glauber initialization is read from input-file *
1984 *                    shmakov.out                     default: 0     *
1985 *       what (3..6)  no meaning                                     *
1986 *       what (3..6)  no meaning                                     *
1987 *                                                                   *
1988 *********************************************************************
1989
1990   630 CONTINUE
1991
1992 * check for cross-section table output only
1993       IF (LXSTAB) STOP
1994
1995       NCASES = INT(WHAT(1))
1996       IF (NCASES.LE.0) NCASES = 100
1997       IGLAU = INT(WHAT(2))
1998       IF ((IGLAU.NE.1).AND.(IGLAU.NE.2).AND.(IGLAU.NE.3))
1999      &                                            IGLAU = 0
2000
2001       NPMASS = IP
2002       NPCHAR = IPZ
2003       NTMASS = IT
2004       NTCHAR = ITZ
2005       IDP    = IJPROJ
2006       IDT    = IJTARG
2007       IF (IDP.LE.0) IDP = 1
2008 * muon neutrinos: temporary (missing index)
2009 * (new patch in projpar: therefore the following this is probably not
2010 *  necessary anymore..)
2011 C     IF (IDP.EQ.26) IDP = 5
2012 C     IF (IDP.EQ.27) IDP = 6
2013
2014 * redefine collision energy
2015       IF (LEINP) THEN
2016          IF (ABS(VAREHI).GT.ZERO) THEN
2017             PDUM = ZERO
2018             IF (VARELO.LT.EHADLO) VARELO = EHADLO
2019             CALL DT_LTINI(IDP,IDT,VARELO,PDUM,VARCLO,1)
2020             PDUM = ZERO
2021             CALL DT_LTINI(IDP,IDT,VAREHI,PDUM,VARCHI,1)
2022          ENDIF
2023          CALL DT_LTINI(IDP,IDT,EPN,PPN,CMENER,1)
2024       ELSE
2025          WRITE(LOUT,1003)
2026  1003    FORMAT(1X,'INIT:   collision energy not defined!',/,
2027      &          1X,'              -program stopped-      ')
2028          STOP
2029       ENDIF
2030
2031 * switch off evaporation (even if requested) if central coll. requ.
2032       IF ((ICENTR.EQ.-1).OR.(ICENTR.GT.0).OR.(XSFRAC.LT.0.5D0)) THEN
2033          IF (LEVPRT) THEN
2034             WRITE(LOUT,1004)
2035  1004       FORMAT(1X,/,'Warning!  Evaporation request rejected since',
2036      &             ' central collisions forced.')
2037             LEVPRT = .FALSE.
2038             LDEEXG = .FALSE.
2039             LHEAVY = .FALSE.
2040          ENDIF
2041       ENDIF
2042
2043 * initialization of evaporation-module
2044
2045       WRITE(LOUT,1010)
2046  1010 FORMAT(1X,/,'Warning!  No evaporation performed since',
2047      &       ' evaporation modules not available with this version.')
2048       LEVPRT = .FALSE.
2049       LDEEXG = .FALSE.
2050       LHEAVY = .FALSE.
2051       LFRMBK = .FALSE.
2052       IFISS  = 0
2053       IEVFSS = 0
2054       CALL DT_BERTTP
2055       CALL DT_INCINI
2056
2057 * save the default JETSET-parameter
2058       CALL DT_JSPARA(0)
2059
2060 * force use of phojet for g-A
2061       IF ((IDP.EQ.7).AND.(MCGENE.NE.3)) MCGENE = 2
2062 * initialization of nucleon-nucleon event generator
2063       IF (MCGENE.EQ.2) CALL DT_PHOINI
2064 * initialization of LEPTO event generator
2065       IF (MCGENE.EQ.3) THEN
2066
2067          STOP ' This version does not contain LEPTO !'
2068
2069       ENDIF
2070
2071 * initialization of quasi-elastic neutrino scattering
2072       IF (MCGENE.EQ.4) THEN
2073          IF (IJPROJ.EQ.5) THEN
2074             NEUTYP = 1
2075          ELSEIF (IJPROJ.EQ.6) THEN
2076             NEUTYP = 2
2077          ELSEIF (IJPROJ.EQ.135) THEN
2078             NEUTYP = 3
2079          ELSEIF (IJPROJ.EQ.136) THEN
2080             NEUTYP = 4
2081          ELSEIF (IJPROJ.EQ.133) THEN
2082             NEUTYP = 5
2083          ELSEIF (IJPROJ.EQ.134) THEN
2084             NEUTYP = 6
2085          ENDIF
2086       ENDIF
2087
2088 * normalize fractions of emulsion components
2089       IF (NCOMPO.GT.0) THEN
2090          SUMFRA = ZERO
2091          DO 491 I=1,NCOMPO
2092             SUMFRA = SUMFRA+EMUFRA(I)
2093   491    CONTINUE
2094          IF (SUMFRA.GT.ZERO) THEN
2095             DO 492 I=1,NCOMPO
2096                EMUFRA(I) = EMUFRA(I)/SUMFRA
2097   492       CONTINUE
2098          ENDIF
2099       ENDIF
2100
2101 * disallow Cronin's multiple scattering for nucleus-nucleus interactions
2102       IF ((IP.GT.1).AND.(MKCRON.GT.0)) THEN
2103          WRITE(LOUT,1005)
2104  1005    FORMAT(/,1X,'INIT:  multiple scattering disallowed',/)
2105          MKCRON = 0
2106       ENDIF
2107
2108 * initialization of Glauber-formalism (moved to xAEVT, sr 26.3.96)
2109 C     IF (NCOMPO.LE.0) THEN
2110 C        CALL DT_SHMAKI(IP,IPZ,IT,ITZ,IDP,PPN,IGLAU)
2111 C     ELSE
2112 C        DO 493 I=1,NCOMPO
2113 C           CALL DT_SHMAKI(IP,IPZ,IEMUMA(I),IEMUCH(I),IDP,PPN,0)
2114 C 493    CONTINUE
2115 C     ENDIF
2116
2117 * pre-tabulation of elastic cross-sections
2118       CALL DT_SIGTBL(JDUM,JDUM,DUM,DUM,-1)
2119
2120       CALL DT_XTIME
2121
2122       RETURN
2123
2124 *********************************************************************
2125 *                                                                   *
2126 *               control card:  codewd = STOP                        *
2127 *                                                                   *
2128 *               stop of the event generation                        *
2129 *                                                                   *
2130 *       what (1..6)  no meaning                                     *
2131 *                                                                   *
2132 *********************************************************************
2133
2134  9999 CONTINUE
2135       WRITE(LOUT,9000)
2136  9000 FORMAT(1X,'---> unexpected end of input !')
2137
2138   640 CONTINUE
2139       STOP
2140
2141       END
2142
2143 *$ CREATE DT_KKINC.FOR
2144 *COPY DT_KKINC
2145 *
2146 *===kkinc==============================================================*
2147 *
2148       SUBROUTINE DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,
2149      &                                                         IREJ)
2150
2151 ************************************************************************
2152 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering   *
2153 * This subroutine is an update of the previous version written         *
2154 * by J. Ranft/ H.-J. Moehring.                                         *
2155 * This version dated 19.11.95 is written by S. Roesler                 *
2156 ************************************************************************
2157
2158       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2159       SAVE
2160       PARAMETER ( LINP = 10 ,
2161      &            LOUT = 6 ,
2162      &            LDAT = 9 )
2163       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY5=1.0D-5,
2164      &           TINY2=1.0D-2,TINY3=1.0D-3)
2165
2166       LOGICAL LFZC
2167
2168 * event history
2169       PARAMETER (NMXHKK=200000)
2170       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2171      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2172      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2173 * extended event history
2174       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2175      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2176      &                IHIST(2,NMXHKK)
2177 * particle properties (BAMJET index convention)
2178       CHARACTER*8  ANAME
2179       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2180      &                IICH(210),IIBAR(210),K1(210),K2(210)
2181 * properties of interacting particles
2182       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2183 * Lorentz-parameters of the current interaction
2184       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
2185      &                UMO,PPCM,EPROJ,PPROJ
2186 * flags for input different options
2187       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2188       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2189      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2190 * flags for particle decays
2191       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2192      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2193      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2194 * cuts for variable energy runs
2195       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2196 * Glauber formalism: flags and parameters for statistics
2197       LOGICAL LPROD
2198       CHARACTER*8 CGLB
2199       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2200
2201       DIMENSION WHAT(6)
2202
2203       IREJ  = 0
2204       ILOOP = 0
2205   100 CONTINUE
2206       IF (ILOOP.EQ.4) THEN
2207          WRITE(LOUT,1000) NEVHKK
2208  1000    FORMAT(1X,'KKINC: event ',I8,' rejected!')
2209          GOTO 9999
2210       ENDIF
2211       ILOOP = ILOOP+1
2212
2213 * variable energy-runs, recalculate parameters for LT's
2214       IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN
2215          PDUM = ZERO
2216          CDUM = ZERO
2217          CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1)
2218       ENDIF
2219       IF (EPN.GT.EPROJ) THEN
2220          WRITE(LOUT,'(A,E9.3,2A,E9.3,A)')
2221      &      ' Requested energy (',EPN,'GeV) exceeds',
2222      &      ' initialization energy (',EPROJ,'GeV) !'
2223          STOP
2224       ENDIF
2225
2226 * re-initialize /DTPRTA/
2227       IP  = NPMASS
2228       IPZ = NPCHAR
2229       IT  = NTMASS
2230       ITZ = NTCHAR
2231       IJPROJ = IDP
2232       IBPROJ = IIBAR(IJPROJ)
2233
2234 * calculate nuclear potentials (common /DTNPOT/)
2235       CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
2236
2237 * initialize treatment for residual nuclei
2238       CALL DT_RESNCL(EPN,NLOOP,1)
2239
2240 * sample hadron/nucleus-nucleus interaction
2241       CALL DT_KKEVNT(KKMAT,IREJ1)
2242       IF (IREJ1.GT.0) THEN
2243          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC'
2244          GOTO 9999
2245       ENDIF
2246
2247       IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN
2248
2249 * intranuclear cascade of final state particles for KTAUGE generations
2250 * of secondaries
2251          CALL DT_FOZOCA(LFZC,IREJ1)
2252          IF (IREJ1.GT.0) THEN
2253             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC'
2254             GOTO 9999
2255          ENDIF
2256
2257 * baryons unable to escape the nuclear potential are treated as
2258 * excited nucleons (ISTHKK=15,16)
2259          CALL DT_SCN4BA
2260
2261 * decay of resonances produced in intranuclear cascade processes
2262 **sr 15-11-95 should be obsolete
2263 C        IF (LFZC) CALL DT_DECAY1
2264
2265   101    CONTINUE
2266 * treatment of residual nuclei
2267          CALL DT_RESNCL(EPN,NLOOP,2)
2268
2269 * evaporation / fission / fragmentation
2270 * (if intranuclear cascade was sampled only)
2271          IF (LFZC) THEN
2272             CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1)
2273             IF (IREJ1.GT.1) GOTO 101
2274             IF (IREJ1.EQ.1) GOTO 100
2275          ENDIF
2276
2277       ENDIF
2278
2279 * rejection of unphysical configurations
2280       CALL DT_REJUCO(1,IREJ1)
2281       IF (IREJ1.GT.0) THEN
2282          IF (IOULEV(1).GT.0)
2283      &      WRITE(LOUT,*) 'rejected 3 in KKINC: too large x'
2284          GOTO 100
2285       ENDIF
2286
2287 * transform finale state into Lab.
2288       IFLAG = 2
2289       CALL DT_BEAMPR(WHAT,DUM,IFLAG)
2290       IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB
2291
2292       IF (IPI0.EQ.1) CALL DT_DECPI0
2293
2294 C     IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4)
2295
2296       RETURN
2297  9999 CONTINUE
2298       IREJ = 1
2299       RETURN
2300       END
2301
2302 *$ CREATE DT_DEFAUL.FOR
2303 *COPY DT_DEFAUL
2304 *
2305 *===defaul=============================================================*
2306 *
2307       SUBROUTINE DT_DEFAUL(EPN,PPN)
2308
2309 ************************************************************************
2310 * Variables are set to default values.                                 *
2311 * This version dated 8.5.95 is written by S. Roesler.                  *
2312 ************************************************************************
2313
2314       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2315       SAVE
2316       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
2317       PARAMETER (TWOPI  = 6.283185307179586454D+00)
2318
2319 * particle properties (BAMJET index convention)
2320       CHARACTER*8  ANAME
2321       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2322      &                IICH(210),IIBAR(210),K1(210),K2(210)
2323 * nuclear potential
2324       LOGICAL LFERMI
2325       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
2326      &                EBINDP(2),EBINDN(2),EPOT(2,210),
2327      &                ETACOU(2),ICOUL,LFERMI
2328 * interface HADRIN-DPM
2329       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
2330 * central particle production, impact parameter biasing
2331       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
2332 * properties of interacting particles
2333       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2334 * properties of photon/lepton projectiles
2335       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2336       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2337 * emulsion treatment
2338       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2339      &                NCOMPO,IEMUL
2340 * parameter for intranuclear cascade
2341       LOGICAL LPAULI
2342       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
2343 * various options for treatment of partons (DTUNUC 1.x)
2344 * (chain recombination, Cronin,..)
2345       LOGICAL LCO2CR,LINTPT
2346       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
2347      &                LCO2CR,LINTPT
2348 * threshold values for x-sampling (DTUNUC 1.x)
2349       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
2350      &                SSMIMQ,VVMTHR
2351 * flags for input different options
2352       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2353       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2354      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2355 * n-n cross section fluctuations
2356       PARAMETER (NBINS = 1000)
2357       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
2358 * flags for particle decays
2359       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2360      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2361      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2362 * diquark-breaking mechanism
2363       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
2364 * nucleon-nucleon event-generator
2365       CHARACTER*8 CMODEL
2366       LOGICAL LPHOIN
2367       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2368 * flags for diffractive interactions (DTUNUC 1.x)
2369       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
2370 * VDM parameter for photon-nucleus interactions
2371       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
2372 * Glauber formalism: flags and parameters for statistics
2373       LOGICAL LPROD
2374       CHARACTER*8 CGLB
2375       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2376 * kinematical cuts for lepton-nucleus interactions
2377       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2378      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2379 * flags for activated histograms
2380       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2381 * cuts for variable energy runs
2382       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2383 * parameters for hA-diffraction
2384       COMMON /DTDIHA/ DIBETA,DIALPH
2385 * LEPTO
2386       REAL RPPN
2387       COMMON /LEPTOI/ RPPN,LEPIN,INTER
2388 * steering flags for qel neutrino scattering modules
2389       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
2390 * event flag
2391       COMMON /DTEVNO/ NEVENT,ICASCA
2392
2393       DATA POTMES /0.002D0/
2394
2395 * common /DTNPOT/
2396       DO 10 I=1,2
2397          PFERMP(I) = ZERO
2398          PFERMN(I) = ZERO
2399          EBINDP(I) = ZERO
2400          EBINDN(I) = ZERO
2401          DO 11 J=1,210
2402             EPOT(I,J) = ZERO
2403    11    CONTINUE
2404 * nucleus independent meson potential
2405          EPOT(I,13) = POTMES
2406          EPOT(I,14) = POTMES
2407          EPOT(I,15) = POTMES
2408          EPOT(I,16) = POTMES
2409          EPOT(I,23) = POTMES
2410          EPOT(I,24) = POTMES
2411          EPOT(I,25) = POTMES
2412    10 CONTINUE
2413       FERMOD    = 0.55D0
2414       ETACOU(1) = ZERO
2415       ETACOU(2) = ZERO
2416       ICOUL     = 1
2417       LFERMI    = .TRUE.
2418
2419 * common /HNTHRE/
2420       EHADTH = -99.0D0
2421       EHADLO = 4.06D0
2422       EHADHI = 6.0D0
2423       INTHAD = 1
2424       IDXTA  = 2
2425
2426 * common /DTIMPA/
2427       ICENTR = 0
2428       BIMIN  = ZERO
2429       BIMAX  = 1.0D10
2430       XSFRAC = 1.0D0
2431
2432 * common /DTPRTA/
2433       IP  = 1
2434       IPZ = 1
2435       IT  = 1
2436       ITZ = 1
2437       IJPROJ = 1
2438       IBPROJ = 1
2439       IJTARG = 1
2440       IBTARG = 1
2441 * common /DTGPRO/
2442       VIRT = ZERO
2443       DO 14 I=1,4
2444          PGAMM(I)  = ZERO
2445          PLEPT0(I) = ZERO
2446          PLEPT1(I) = ZERO
2447          PNUCL(I)  = ZERO
2448    14 CONTINUE
2449       IDIREC   = 0
2450
2451 * common /DTFOTI/
2452 **sr 7.4.98: changed after corrected B-sampling
2453 C     TAUFOR = 4.4D0
2454       TAUFOR = 3.5D0
2455       KTAUGE = 25
2456       ITAUVE = 1
2457       INCMOD = 1
2458       LPAULI = .TRUE.
2459
2460 * common /DTCHAI/
2461       SEASQ  = ONE
2462       MKCRON = 1
2463       CRONCO = 0.64D0
2464       ISICHA = 0
2465       CUTOF  = 100.0D0
2466       LCO2CR = .FALSE.
2467       IRECOM = 1
2468       LINTPT = .TRUE.
2469
2470 * common /DTXCUT/
2471 *  definition of soft quark distributions
2472       XSEACU = 0.05D0
2473       UNON   = 2.0D0
2474       UNOM   = 1.5D0
2475       UNOSEA = 5.0D0
2476 *  cutoff parameters for x-sampling
2477       CVQ    = 1.0D0
2478       CDQ    = 2.0D0
2479 C     CSEA   = 0.3D0
2480       CSEA   = 0.1D0
2481       SSMIMA = 1.2D0
2482       SSMIMQ = SSMIMA**2
2483       VVMTHR = 2.0D0
2484
2485 * common /DTXSFL/
2486       IFLUCT = 0
2487
2488 * common /DTFRPA/
2489       PDB = 0.15D0
2490       PDBSEA(1) = 0.0D0
2491       PDBSEA(2) = 0.0D0
2492       PDBSEA(3) = 0.0D0
2493       ISIG0 = 0
2494       IPI0  = 0
2495       NMSTU = 0
2496       NPARU = 0
2497       NMSTJ = 0
2498       NPARJ = 0
2499
2500 * common /DTDIQB/
2501       DO 15 I=1,8
2502          DBRKR(1,I) = 5.0D0
2503          DBRKR(2,I) = 5.0D0
2504          DBRKR(3,I) = 10.0D0
2505          DBRKA(1,I) = ZERO
2506          DBRKA(2,I) = ZERO
2507          DBRKA(3,I) = ZERO
2508    15 CONTINUE
2509       CHAM1 = 0.2D0
2510       CHAM3 = 0.5D0
2511       CHAB1 = 0.7D0
2512       CHAB3 = 1.0D0
2513
2514 * common /DTFLG3/
2515       ISINGD = 0
2516       IDOUBD = 0
2517       IFLAGD = 0
2518       IDIFF  = 0
2519
2520 * common /DTMODL/
2521       MCGENE    = 2
2522       CMODEL(1) = 'DTUNUC  '
2523       CMODEL(2) = 'PHOJET  '
2524       CMODEL(3) = 'LEPTO   '
2525       CMODEL(4) = 'QNEUTRIN'
2526       LPHOIN    = .TRUE.
2527       ELOJET    = 5.0D0
2528
2529 * common /DTLCUT/
2530       ECMIN  = 3.5D0
2531       ECMAX  = 1.0D10
2532       XBJMIN = ZERO
2533       ELMIN = ZERO
2534       EGMIN = ZERO
2535       EGMAX = 1.0D10
2536       YMIN  = TINY10
2537       YMAX  = 0.999D0
2538       Q2MIN = TINY10
2539       Q2MAX = 10.0D0
2540       THMIN = ZERO
2541       THMAX = TWOPI
2542       Q2LI  = ZERO
2543       Q2HI  = 1.0D10
2544       ECMLI = ZERO
2545       ECMHI = 1.0D10
2546
2547 * common /DTVDMP/
2548       RL2       = 2.0D0
2549       INTRGE(1) = 1
2550       INTRGE(2) = 3
2551       IDPDF     = 2212
2552       MODEGA    = 4
2553       ISHAD(1)  = 1
2554       ISHAD(2)  = 1
2555       ISHAD(3)  = 1
2556       EPSPOL    = ZERO
2557
2558 * common /DTGLGP/
2559       JSTATB = 1000
2560       JBINSB = 49
2561       CGLB   = '        '
2562       IF (ITRSPT.EQ.1) THEN
2563          IOGLB  = 100
2564       ELSE
2565          IOGLB  = 0
2566       ENDIF
2567       LPROD  = .TRUE.
2568
2569 * common /DTHIS3/
2570       DO 16 I=1,50
2571          IHISPP(I) = 0
2572          IHISXS(I) = 0
2573    16 CONTINUE
2574       IXSTBL = 0
2575
2576 * common /DTVARE/
2577       VARELO = ZERO
2578       VAREHI = ZERO
2579       VARCLO = ZERO
2580       VARCHI = ZERO
2581
2582 * common /DTDIHA/
2583       DIBETA = -1.0D0
2584       DIALPH = ZERO
2585
2586 * common /LEPTOI/
2587       RPPN  = 0.0
2588       LEPIN = 0
2589       INTER = 0
2590
2591 * common /QNEUTO/
2592       NEUTYP = 1
2593       NEUDEC = 0
2594
2595 * common /DTEVNO/
2596       NEVENT = 1
2597       IF (ITRSPT.EQ.1) THEN
2598          ICASCA = 1
2599       ELSE
2600          ICASCA = 0
2601       ENDIF
2602
2603 * default Lab.-energy
2604       EPN = 200.0D0
2605       PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ)))
2606
2607       RETURN
2608       END
2609
2610 *$ CREATE DT_AAEVT.FOR
2611 *COPY DT_AAEVT
2612 *
2613 *===aaevt==============================================================*
2614 *
2615       SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2616      &                                             IDP,IGLAU)
2617
2618 ************************************************************************
2619 * This version dated 22.03.96 is written by S. Roesler.                *
2620 ************************************************************************
2621
2622       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2623       SAVE
2624       PARAMETER ( LINP = 10 ,
2625      &            LOUT = 6 ,
2626      &            LDAT = 9 )
2627
2628       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2629 * emulsion treatment
2630       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2631      &                NCOMPO,IEMUL
2632 * event flag
2633       COMMON /DTEVNO/ NEVENT,ICASCA
2634
2635       CHARACTER*8 DATE,HHMMSS
2636       DIMENSION IDMNYR(3)
2637
2638       KKMAT  = 1
2639       NMSG   = MAX(NEVTS/100,1)
2640
2641 * initialization of run-statistics and histograms
2642       CALL DT_STATIS(1)
2643       CALL PHO_PHIST(1000,DUM)
2644
2645 * initialization of Glauber-formalism
2646       IF (NCOMPO.LE.0) THEN
2647          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2648       ELSE
2649          DO 1 I=1,NCOMPO
2650             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2651     1    CONTINUE
2652       ENDIF
2653       CALL DT_SIGEMU
2654
2655       CALL IDATE(IDMNYR)
2656       WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2657      &   IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2658       CALL ITIME(IDMNYR)
2659       WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2660      &   IDMNYR(1),IDMNYR(2),IDMNYR(3)
2661       WRITE(LOUT,1001) DATE,HHMMSS
2662  1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8,
2663      &       '   Time: ',A8,' )')
2664
2665 * generate NEVTS events
2666       DO 2 IEVT=1,NEVTS
2667
2668 *  print run-status message
2669          IF (MOD(IEVT,NMSG).EQ.0) THEN
2670             CALL IDATE(IDMNYR)
2671             WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2672      &         IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2673             CALL ITIME(IDMNYR)
2674             WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2675      &         IDMNYR(1),IDMNYR(2),IDMNYR(3)
2676             WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS
2677  1000       FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A,
2678      &             '   Time: ',A,' )',/)
2679 C           WRITE(LOUT,1000) IEVT-1
2680 C1000       FORMAT(1X,I8,' events sampled')
2681          ENDIF
2682          NEVENT = IEVT
2683 *  treat nuclear emulsions
2684          IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
2685 *  composite targets only
2686          KKMAT = -KKMAT
2687 *  sample this event
2688          CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ)
2689
2690          CALL PHO_PHIST(2000,DUM)
2691
2692     2 CONTINUE
2693
2694 * print run-statistics and histograms to output-unit 6
2695       CALL PHO_PHIST(3000,DUM)
2696       CALL DT_STATIS(2)
2697
2698       RETURN
2699       END
2700
2701 *$ CREATE DT_LAEVT.FOR
2702 *COPY DT_LAEVT
2703 *
2704 *===laevt==============================================================*
2705 *
2706       SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2707      &                                             IDP,IGLAU)
2708
2709 ************************************************************************
2710 * Interface to run DPMJET for lepton-nucleus interactions.             *
2711 * Kinematics is sampled using the equivalent photon approximation      *
2712 * Based on GPHERA-routine by R. Engel.                                 *
2713 * This version dated 23.03.96 is written by S. Roesler.                *
2714 ************************************************************************
2715
2716       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2717       SAVE
2718       PARAMETER ( LINP = 10 ,
2719      &            LOUT = 6 ,
2720      &            LDAT = 9 )
2721       PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,
2722      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
2723       PARAMETER (TWOPI  = 6.283185307179586454D+00,
2724      &           PI     = TWOPI/TWO,
2725      &           ALPHEM = ONE/137.0D0)
2726
2727 C     CHARACTER*72 HEADER
2728
2729 * particle properties (BAMJET index convention)
2730       CHARACTER*8  ANAME
2731       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2732      &                IICH(210),IIBAR(210),K1(210),K2(210)
2733 * event history
2734       PARAMETER (NMXHKK=200000)
2735       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2736      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2737      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2738 * extended event history
2739       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2740      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2741      &                IHIST(2,NMXHKK)
2742 * kinematical cuts for lepton-nucleus interactions
2743       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2744      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2745 * properties of interacting particles
2746       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2747 * properties of photon/lepton projectiles
2748       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2749 * kinematics at lepton-gamma vertex
2750       COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4)
2751 * flags for activated histograms
2752       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2753       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2754 * emulsion treatment
2755       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2756      &                NCOMPO,IEMUL
2757 * Glauber formalism: cross sections
2758       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
2759      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
2760      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
2761      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
2762      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
2763      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
2764      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
2765      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
2766      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
2767      &                BSLOPE,NEBINI,NQBINI
2768 * nucleon-nucleon event-generator
2769       CHARACTER*8 CMODEL
2770       LOGICAL LPHOIN
2771       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2772 * flags for input different options
2773       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2774       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2775      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2776 * event flag
2777       COMMON /DTEVNO/ NEVENT,ICASCA
2778
2779       DIMENSION XDUMB(40),BGTA(4)
2780
2781 * LEPTO
2782       IF (MCGENE.EQ.3) THEN
2783          STOP ' This version does not contain LEPTO !'
2784       ENDIF
2785
2786       KKMAT  = 1
2787       NMSG   = MAX(NEVTS/10,1)
2788
2789 * mass of incident lepton
2790       AMLPT  = AAM(IDP)
2791       AMLPT2 = AMLPT**2
2792       IDPPDG = IDT_IPDGHA(IDP)
2793
2794 * consistency of kinematical limits
2795       Q2MIN  = MAX(Q2MIN,TINY10)
2796       Q2MAX  = MAX(Q2MAX,TINY10)
2797       YMIN   = MIN(MAX(YMIN,TINY10),0.999D0)
2798       YMAX   = MIN(MAX(YMAX,TINY10),0.999D0)
2799
2800 * total energy of the lepton-nucleon system
2801       PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2
2802      &                                      +(PLEPT0(3)+PNUCL(3))**2 )
2803       ETOTLN = PLEPT0(4)+PNUCL(4)
2804       ECMLN  = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN))
2805       ECMAX  = MIN(ECMAX,ECMLN)
2806       WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN,
2807      &                 THMIN,THMAX,ELMIN
2808  1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X,
2809      &       '------------------',/,9X,'W (min)   =',
2810      &       F7.1,' GeV    (max) =',F7.1,' GeV',/,9X,'y (min)   =',
2811      &       F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1,
2812      &       ' GeV^2  (max) =',F7.1,' GeV^2',/,' (Lab)   E_g (min) ='
2813      &       ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =',
2814      &       F7.4,'   for E_lpt >',F7.1,' GeV',/)
2815
2816 * Lorentz-parameter for transf. into Lab
2817       BGTA(1) = PNUCL(1)/AAM(1)
2818       BGTA(2) = PNUCL(2)/AAM(1)
2819       BGTA(3) = PNUCL(3)/AAM(1)
2820       BGTA(4) = PNUCL(4)/AAM(1)
2821 * LT of incident lepton into Lab and dump it in DTEVT1
2822       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2823      &            PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4),
2824      &            PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4))
2825       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2826      &            PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4),
2827      &            PLTOT,PPA(1),PPA(2),PPA(3),PPA(4))
2828 * maximum energy of photon nucleon system
2829       PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2
2830      &                                      +(YMAX*PPL0(3)+PPA(3))**2)
2831       ETOTGN = YMAX*PPL0(4)+PPA(4)
2832       EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2833       EGNMAX = MIN(EGNMAX,ECMAX)
2834 * minimum energy of photon nucleon system
2835       PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2
2836      &                                      +(YMIN*PPL0(3)+PPA(3))**2)
2837       ETOTGN = YMIN*PPL0(4)+PPA(4)
2838       EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2839       EGNMIN = MAX(EGNMIN,ECMIN)
2840
2841 * limits for Glauber-initialization
2842       Q2LI  = Q2MIN
2843       Q2HI  = MAX(Q2LI,MIN(Q2HI,Q2MAX))
2844       ECMLI = MAX(EGNMIN,THREE)
2845       ECMHI = EGNMAX
2846       WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI
2847  1004 FORMAT(1X,'resulting limits:',/,9X,'W (min)   =',F7.1,
2848      &       ' GeV    (max) =',F7.1,' GeV',/,/,' limits for ',
2849      &       'Glauber-initialization:',/,9X,'W (min)   =',F7.1,
2850      &       ' GeV    (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1,
2851      &       ' GeV^2  (max) =',F7.1,' GeV^2',/)
2852 * initialization of Glauber-formalism
2853       IF (NCOMPO.LE.0) THEN
2854          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2855       ELSE
2856          DO 9 I=1,NCOMPO
2857             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2858     9    CONTINUE
2859       ENDIF
2860       CALL DT_SIGEMU
2861
2862 * initialization of run-statistics and histograms
2863       CALL DT_STATIS(1)
2864       CALL PHO_PHIST(1000,DUM)
2865
2866 * maximum photon-nucleus cross section
2867       I1  = 1
2868       I2  = 1
2869       RAT = ONE
2870       IF (EGNMAX.GE.ECMNN(NEBINI)) THEN
2871          I1  = NEBINI
2872          I2  = NEBINI
2873          RAT = ONE
2874       ELSEIF (EGNMAX.GT.ECMNN(1)) THEN
2875          DO 5 I=2,NEBINI
2876             IF (EGNMAX.LT.ECMNN(I)) THEN
2877                I1  = I-1
2878                I2  = I
2879                RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2880                GOTO 6
2881             ENDIF
2882     5    CONTINUE
2883     6    CONTINUE
2884       ENDIF
2885       SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2886       EGNXX  = EGNMAX
2887       I1  = 1
2888       I2  = 1
2889       RAT = ONE
2890       IF (EGNMIN.GE.ECMNN(NEBINI)) THEN
2891          I1  = NEBINI
2892          I2  = NEBINI
2893          RAT = ONE
2894       ELSEIF (EGNMIN.GT.ECMNN(1)) THEN
2895          DO 7 I=2,NEBINI
2896             IF (EGNMIN.LT.ECMNN(I)) THEN
2897                I1  = I-1
2898                I2  = I
2899                RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2900                GOTO 8
2901             ENDIF
2902     7    CONTINUE
2903     8    CONTINUE
2904       ENDIF
2905       SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2906       IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN
2907       SIGMAX = MAX(SIGMAX,SIGXX)
2908       WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb'
2909
2910 * plot photon flux table
2911       AYMIN = LOG(YMIN)
2912       AYMAX = LOG(YMAX)
2913       AYRGE = AYMAX-AYMIN
2914       MAXTAB = 50
2915       ADY    = LOG(YMAX/YMIN)/DBLE(MAXTAB-1)
2916 C     WRITE(LOUT,'(/,1X,A)') 'LAEVT:   photon flux '
2917       DO 1 I=1,MAXTAB
2918          Y     = EXP(AYMIN+ADY*DBLE(I-1))
2919          Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y))
2920          FF1   = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2921      &                           -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX))
2922          FF2   = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2923      &                           -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX))
2924 C        WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2
2925     1 CONTINUE
2926
2927 * maximum residual weight for flux sampling (dy/y)
2928       YY     = YMIN
2929       Q2LOW  = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2930       WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW)
2931      &         -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2932
2933       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0)
2934       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1)
2935       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2)
2936       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0)
2937       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1)
2938       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2)
2939       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0)
2940       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1)
2941       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2)
2942       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0)
2943       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1)
2944       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2)
2945       XBLOW = 0.001D0
2946       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0)
2947       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1)
2948       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2)
2949
2950       ITRY = 0
2951       ITRW = 0
2952       NC0  = 0
2953       NC1  = 0
2954
2955 * generate events
2956       DO 2 IEVT=1,NEVTS
2957          IF (MOD(IEVT,NMSG).EQ.0) THEN
2958 C           OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out',
2959 C    &                                         STATUS='UNKNOWN')
2960             WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled'
2961 C           CLOSE(LDAT)
2962          ENDIF
2963          NEVENT = IEVT
2964
2965   100    CONTINUE
2966          ITRY = ITRY+1
2967
2968 *  sample y
2969   101    CONTINUE
2970          ITRW  = ITRW+1
2971          YY    = EXP(AYRGE*DT_RNDM(RAT)+AYMIN)
2972          Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2973          Q2LOG = LOG(Q2MAX/Q2LOW)
2974          WGH   = (ONE+(ONE-YY)**2)*Q2LOG
2975      &           -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2976          IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH
2977  1000    FORMAT(1X,'LAEVT:   weight error!',3E12.5)
2978          IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101
2979
2980 *  sample Q2
2981          YEFF = ONE+(ONE-YY)**2
2982   102    CONTINUE
2983          Q2  = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
2984          WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF
2985          IF (WGH.LT.DT_RNDM(Q2)) GOTO 102
2986
2987 c        NC0 = NC0+1
2988 c        CALL DT_FILHGR(YY,ONE,IHFLY0,NC0)
2989 c        CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0)
2990
2991 *  kinematics at lepton-photon vertex
2992 *   scattered electron
2993          YQ2 = SQRT((ONE-YY)*Q2)
2994          Q2E = Q2/(4.0D0*PLEPT0(4))
2995          E1Y = (ONE-YY)*PLEPT0(4)
2996          CALL DT_DSFECF(SIF,COF)
2997          PLEPT1(1) = YQ2*COF
2998          PLEPT1(2) = YQ2*SIF
2999          PLEPT1(3) = E1Y-Q2E
3000          PLEPT1(4) = E1Y+Q2E
3001 C        THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) )
3002 *   radiated photon
3003          PGAMM(1) = -PLEPT1(1)
3004          PGAMM(2) = -PLEPT1(2)
3005          PGAMM(3) = PLEPT0(3)-PLEPT1(3)
3006          PGAMM(4) = PLEPT0(4)-PLEPT1(4)
3007 *   E_cm cut
3008          PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2
3009      &                                        +(PGAMM(3)+PNUCL(3))**2 )
3010          ETOTGN = PGAMM(4)+PNUCL(4)
3011          ECMGN  = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)
3012          IF (ECMGN.LT.0.1D0) GOTO 101
3013          ECMGN  = SQRT(ECMGN)
3014          IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101
3015
3016 *  Lorentz-transformation into nucleon-rest system
3017          CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3018      &               PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4),
3019      &               PGTOT,PPG(1),PPG(2),PPG(3),PPG(4))
3020          CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3021      &               PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4),
3022      &               PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4))
3023 *  temporary checks..
3024          Q2TMP = ABS(PPG(4)**2-PGTOT**2)
3025          IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP
3026  1001    FORMAT(1X,'LAEVT:    inconsistent kinematics (Q2,Q2TMP) ',
3027      &          2F10.4)
3028          ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT))
3029          IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP
3030  1002    FORMAT(1X,'LAEVT:    inconsistent kinematics (ECMGN,ECMTMP) ',
3031      &          2F10.2)
3032          YYTMP = PPG(4)/PPL0(4)
3033          IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP
3034  1005    FORMAT(1X,'LAEVT:    inconsistent kinematics (YY,YYTMP) ',
3035      &          2F10.4)
3036
3037 *  lepton tagger (Lab)
3038          THETA = ACOS( PPL1(3)/PLTOT )
3039          IF (PPL1(4).GT.ELMIN) THEN
3040             IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101
3041          ENDIF
3042 *  photon energy-cut (Lab)
3043          IF (PPG(4).LT.EGMIN) GOTO 101
3044          IF (PPG(4).GT.EGMAX) GOTO 101
3045 *   x_Bj cut
3046          XBJ = ABS(Q2/(1.876D0*PPG(4)))
3047          IF (XBJ.LT.XBJMIN) GOTO 101
3048
3049          NC0 = NC0+1
3050          CALL DT_FILHGR(    Q2,ONE,IHFLQ0,NC0)
3051          CALL DT_FILHGR(    YY,ONE,IHFLY0,NC0)
3052          CALL DT_FILHGR(   XBJ,ONE,IHFLX0,NC0)
3053          CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0)
3054          CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0)
3055
3056 *  rotation angles against z-axis
3057          COD = PPG(3)/PGTOT
3058 C        SID = SQRT((ONE-COD)*(ONE+COD))
3059          PPT = SQRT(PPG(1)**2+PPG(2)**2)
3060          SID = PPT/PGTOT
3061          COF = ONE
3062          SIF = ZERO
3063          IF (PGTOT*SID.GT.TINY10) THEN
3064             COF   = PPG(1)/(SID*PGTOT)
3065             SIF   = PPG(2)/(SID*PGTOT)
3066             ANORF = SQRT(COF*COF+SIF*SIF)
3067             COF   = COF/ANORF
3068             SIF   = SIF/ANORF
3069          ENDIF
3070
3071          IF (IXSTBL.EQ.0) THEN
3072 *  change to photon projectile
3073             IJPROJ = 7
3074 *  set virtuality
3075             VIRT = Q2
3076 *  re-initialize LTs with new kinematics
3077 *  !!PGAMM ist set in cms (ECMGN) along z
3078             EPN = ZERO
3079             PPN = ZERO
3080             CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0)
3081 *  force Lab-system
3082             IFRAME = 1
3083 *  get emulsion component if requested
3084             IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
3085 *  convolute with cross section
3086             CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT)
3087             CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT)
3088             IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)')
3089      &         'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX,
3090      &                                        Q2,ECMGN,STOT
3091             IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100
3092             NC1 = NC1+1
3093             CALL DT_FILHGR(    Q2,ONE,IHFLQ1,NC1)
3094             CALL DT_FILHGR(    YY,ONE,IHFLY1,NC1)
3095             CALL DT_FILHGR(   XBJ,ONE,IHFLX1,NC1)
3096             CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1)
3097             CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1)
3098 *  composite targets only
3099             KKMAT = -KKMAT
3100 *  sample this event
3101             CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT,
3102      &                                                            IREJ)
3103 *  rotate momenta of final state particles back in photon-nucleon syst.
3104             DO 4 I=NPOINT(4),NHKK
3105                IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3106      &                                      (ISTHKK(I).EQ.1001)) THEN
3107                   PX = PHKK(1,I)
3108                   PY = PHKK(2,I)
3109                   PZ = PHKK(3,I)
3110                   CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF,
3111      &                        PHKK(1,I),PHKK(2,I),PHKK(3,I))
3112                ENDIF
3113     4       CONTINUE
3114          ENDIF
3115
3116          CALL DT_FILHGR(    Q2,ONE,IHFLQ2,NC1)
3117          CALL DT_FILHGR(    YY,ONE,IHFLY2,NC1)
3118          CALL DT_FILHGR(   XBJ,ONE,IHFLX2,NC1)
3119          CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1)
3120          CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1)
3121
3122 *  dump this event to histograms
3123          CALL PHO_PHIST(2000,DUM)
3124
3125     2 CONTINUE
3126
3127       WGY    = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW)
3128       WGY    = WGY*LOG(YMAX/YMIN)
3129       WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY)
3130
3131 C     HEADER = ' LAEVT:  Q^2 distribution 0'
3132 C     CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3133 C     HEADER = ' LAEVT:  Q^2 distribution 1'
3134 C     CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3135 C     HEADER = ' LAEVT:  Q^2 distribution 2'
3136 C     CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3137 C     HEADER = ' LAEVT:  y   distribution 0'
3138 C     CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3139 C     HEADER = ' LAEVT:  y   distribution 1'
3140 C     CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3141 C     HEADER = ' LAEVT:  y   distribution 2'
3142 C     CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3143 C     HEADER = ' LAEVT:  x   distribution 0'
3144 C     CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3145 C     HEADER = ' LAEVT:  x   distribution 1'
3146 C     CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3147 C     HEADER = ' LAEVT:  x   distribution 2'
3148 C     CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3149 C     HEADER = ' LAEVT:  E_g distribution 0'
3150 C     CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3151 C     HEADER = ' LAEVT:  E_g distribution 1'
3152 C     CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3153 C     HEADER = ' LAEVT:  E_g distribution 2'
3154 C     CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3155 C     HEADER = ' LAEVT:  E_c distribution 0'
3156 C     CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3157 C     HEADER = ' LAEVT:  E_c distribution 1'
3158 C     CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3159 C     HEADER = ' LAEVT:  E_c distribution 2'
3160 C     CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3161
3162 * print run-statistics and histograms to output-unit 6
3163       CALL PHO_PHIST(3000,DUM)
3164       IF (IXSTBL.EQ.0) CALL DT_STATIS(2)
3165
3166       RETURN
3167       END
3168
3169 *$ CREATE DT_DTUINI.FOR
3170 *COPY DT_DTUINI
3171 *
3172 *===dtuini=============================================================*
3173 *
3174       SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
3175      &                                               IDP,IEMU)
3176
3177       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3178       SAVE
3179
3180       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
3181 * emulsion treatment
3182       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
3183      &                NCOMPO,IEMUL
3184 * Glauber formalism: flags and parameters for statistics
3185       LOGICAL LPROD
3186       CHARACTER*8 CGLB
3187       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
3188
3189       CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU)
3190       CALL DT_STATIS(1)
3191       CALL PHO_PHIST(1000,DUM)
3192       IF (NCOMPO.LE.0) THEN
3193          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
3194       ELSE
3195          DO 1 I=1,NCOMPO
3196             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
3197     1    CONTINUE
3198       ENDIF
3199       IF (IOGLB.NE.100) CALL DT_SIGEMU
3200       IEMU = IEMUL
3201
3202       RETURN
3203       END
3204
3205 *$ CREATE DT_DTUOUT.FOR
3206 *COPY DT_DTUOUT
3207 *
3208 *===dtuout=============================================================*
3209 *
3210       SUBROUTINE DT_DTUOUT
3211
3212       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3213       SAVE
3214
3215       CALL PHO_PHIST(3000,DUM)
3216       CALL DT_STATIS(2)
3217
3218       RETURN
3219       END
3220
3221 *$ CREATE DT_BEAMPR.FOR
3222 *COPY DT_BEAMPR
3223 *
3224 *===beampr=============================================================*
3225 *
3226       SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE)
3227
3228 ************************************************************************
3229 * Initialization of event generation                                   *
3230 * This version dated  7.4.98  is written by S. Roesler.                *
3231 ************************************************************************
3232
3233       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3234       SAVE
3235
3236       PARAMETER ( LINP = 10 ,
3237      &            LOUT = 6 ,
3238      &            LDAT = 9 )
3239       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3240       PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3241
3242       LOGICAL LBEAM
3243
3244 * event history
3245       PARAMETER (NMXHKK=200000)
3246       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3247      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3248      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3249 * extended event history
3250       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3251      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3252      &                IHIST(2,NMXHKK)
3253 * properties of interacting particles
3254       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3255 * particle properties (BAMJET index convention)
3256       CHARACTER*8  ANAME
3257       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3258      &                IICH(210),IIBAR(210),K1(210),K2(210)
3259 * beam momenta
3260       COMMON /DTBEAM/ P1(4),P2(4)
3261
3262 C     DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4)
3263       DIMENSION WHAT(6),P1CMS(4),P2CMS(4)
3264
3265       DATA LBEAM /.FALSE./
3266
3267       GOTO (1,2) MODE
3268
3269     1 CONTINUE
3270
3271       E1  = WHAT(1)
3272       IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1))
3273       E2  = WHAT(2)
3274       IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2))
3275       PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) )
3276       PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) )
3277       TH  = 1.D-6*WHAT(3)/2.D0
3278       PH  = WHAT(4)*BOG
3279       P1(1) = PP1*SIN(TH)*COS(PH)
3280       P1(2) = PP1*SIN(TH)*SIN(PH)
3281       P1(3) = PP1*COS(TH)
3282       P1(4) = E1
3283       P2(1) = PP2*SIN(TH)*COS(PH)
3284       P2(2) = PP2*SIN(TH)*SIN(PH)
3285       P2(3) = -PP2*COS(TH)
3286       P2(4) = E2
3287       ECM  = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
3288      &                                              -(P1(3)+P2(3))**2 )
3289       ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG))
3290       PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) )
3291       BGX  = (P1(1)+P2(1))/ECM
3292       BGY  = (P1(2)+P2(2))/ECM
3293       BGZ  = (P1(3)+P2(3))/ECM
3294       BGE  = (P1(4)+P2(4))/ECM
3295       CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4),
3296      &            P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4))
3297       CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4),
3298      &            P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4))
3299       COD = P1CMS(3)/P1TOT
3300 C     SID = SQRT((ONE-COD)*(ONE+COD))
3301       PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2)
3302       SID = PPT/P1TOT
3303       COF = ONE
3304       SIF = ZERO
3305       IF (P1TOT*SID.GT.TINY10) THEN
3306          COF   = P1CMS(1)/(SID*P1TOT)
3307          SIF   = P1CMS(2)/(SID*P1TOT)
3308          ANORF = SQRT(COF*COF+SIF*SIF)
3309          COF   = COF/ANORF
3310          SIF   = SIF/ANORF
3311       ENDIF
3312 **check
3313 C     WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3314 C     WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3315 C     WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT
3316 C     WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT
3317 C     PAX = ZERO
3318 C     PAY = ZERO
3319 C     PAZ = P1TOT
3320 C     PAE = SQRT(AAM(IJPROJ)**2+PAZ**2)
3321 C     PBX = ZERO
3322 C     PBY = ZERO
3323 C     PBZ = -P2TOT
3324 C     PBE = SQRT(AAM(IJTARG)**2+PBZ**2)
3325 C     WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE
3326 C     WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE
3327 C     CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF,
3328 C    &            P1CMS(1),P1CMS(2),P1CMS(3))
3329 C     CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF,
3330 C    &            P2CMS(1),P2CMS(2),P2CMS(3))
3331 C     WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)
3332 C     WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)
3333 C     CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),
3334 C    &            P1TOT,P1(1),P1(2),P1(3),P1(4))
3335 C     CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),
3336 C    &            P2TOT,P2(1),P2(2),P2(3),P2(4))
3337 C     WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3338 C     WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3339 C     STOP
3340 **
3341
3342       LBEAM = .TRUE.
3343
3344       RETURN
3345
3346     2 CONTINUE
3347
3348       IF (LBEAM) THEN
3349          IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3350          DO 20 I=NPOINT(4),NHKK
3351             IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3352      &                                   (ISTHKK(I).EQ.1001)) THEN
3353                CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
3354      &                     COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
3355                PECMS = PHKK(4,I)
3356                CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
3357      &                     PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
3358             ENDIF
3359    20    CONTINUE
3360       ELSE
3361          MODE = -1
3362       ENDIF
3363
3364       RETURN
3365       END
3366
3367 *$ CREATE DT_REJUCO.FOR
3368 *COPY DT_REJUCO
3369 *
3370 *===rejuco=============================================================*
3371 *
3372       SUBROUTINE DT_REJUCO(MODE,IREJ)
3373
3374 ************************************************************************
3375 * REJection of Unphysical COnfigurations                               *
3376 *     MODE = 1  rejection of particles with unphysically large energy  *
3377 *                                                                      *
3378 * This version dated 27.12.2006 is written by S. Roesler.              *
3379 ************************************************************************
3380
3381       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3382       SAVE
3383
3384       PARAMETER ( LINP = 10 ,
3385      &            LOUT = 6 ,
3386      &            LDAT = 9 )
3387       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3388       PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3389
3390 * maximum x_cms of final state particle
3391       PARAMETER (XCMSMX = 1.4D0)
3392
3393 * event history
3394       PARAMETER (NMXHKK=200000)
3395       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3396      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3397      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3398 * extended event history
3399       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3400      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3401      &                IHIST(2,NMXHKK)
3402 * Lorentz-parameters of the current interaction
3403       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
3404      &                UMO,PPCM,EPROJ,PPROJ
3405
3406       IREJ = 0
3407
3408       IF (MODE.EQ.1) THEN
3409          IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3410          ECMHLF = UMO/2.0D0
3411          DO 10 I=NPOINT(4),NHKK
3412             IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN
3413                XCMS = ABS(PHKK(4,I))/ECMHLF
3414                IF (XCMS.GT.XCMSMX) GOTO 9999
3415             ENDIF
3416    10    CONTINUE
3417       ENDIF
3418
3419       RETURN
3420  9999 CONTINUE
3421       IREJ = 1
3422       RETURN
3423       END
3424
3425 *$ CREATE DT_EVENTB.FOR
3426 *COPY DT_EVENTB
3427 *
3428 *===eventb=============================================================*
3429 *
3430       SUBROUTINE DT_EVENTB(NCSY,IREJ)
3431
3432 ************************************************************************
3433 * Treatment of nucleon-nucleon interactions with full two-component    *
3434 * Dual Parton Model.                                                   *
3435 *          NCSY     number of nucleon-nucleon interactions             *
3436 *          IREJ     rejection flag                                     *
3437 * This version dated 14.01.2000 is written by S. Roesler               *
3438 ************************************************************************
3439
3440       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3441       SAVE
3442       PARAMETER ( LINP = 10 ,
3443      &            LOUT = 6 ,
3444      &            LDAT = 9 )
3445       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
3446
3447 * event history
3448       PARAMETER (NMXHKK=200000)
3449       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3450      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3451      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3452 * extended event history
3453       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3454      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3455      &                IHIST(2,NMXHKK)
3456 *! uncomment this line for internal phojet-fragmentation
3457 C #include "dtu_dtevtp.inc"
3458 * particle properties (BAMJET index convention)
3459       CHARACTER*8  ANAME
3460       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3461      &                IICH(210),IIBAR(210),K1(210),K2(210)
3462 * flags for input different options
3463       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
3464       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3465      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3466 * rejection counter
3467       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
3468      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
3469      &                IREXCI(3),IRDIFF(2),IRINC
3470 * properties of interacting particles
3471       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3472 * properties of photon/lepton projectiles
3473       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
3474 * various options for treatment of partons (DTUNUC 1.x)
3475 * (chain recombination, Cronin,..)
3476       LOGICAL LCO2CR,LINTPT
3477       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
3478      &                LCO2CR,LINTPT
3479 * statistics
3480       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
3481      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
3482      &                ICEVTG(8,0:30)
3483 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
3484       COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
3485 * Glauber formalism: collision properties
3486       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
3487      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
3488 * flags for diffractive interactions (DTUNUC 1.x)
3489       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
3490 * statistics: double-Pomeron exchange
3491       COMMON /DTFLG2/ INTFLG,IPOPO
3492 * flags for particle decays
3493       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
3494      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
3495      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
3496 * nucleon-nucleon event-generator
3497       CHARACTER*8 CMODEL
3498       LOGICAL LPHOIN
3499       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
3500 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
3501       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3502       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3503       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3504      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3505 C  model switches and parameters
3506       CHARACTER*8 MDLNA
3507       INTEGER ISWMDL,IPAMDL
3508       DOUBLE PRECISION PARMDL
3509       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3510 C  initial state parton radiation (internal part)
3511       INTEGER MXISR3,MXISR4
3512       PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
3513       INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
3514       DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
3515       COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
3516      &                ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
3517      &                IFL1(2,MXISR3),IFL2(2,MXISR3),
3518      &                IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
3519 C  event debugging information
3520       INTEGER NMAXD
3521       PARAMETER (NMAXD=100)
3522       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3523      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3524       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3525      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3526 C  general process information
3527       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3528       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3529
3530       DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
3531      &          PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
3532      &          PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
3533      &          KPRON(15),ISINGL(2000)
3534
3535 * initial values for max. number of phojet scatterings and dtunuc chains
3536 * to be fragmented with one pyexec call
3537       DATA MXPHFR,MXDTFR /10,100/
3538
3539       IREJ      = 0
3540 * pointer to first parton of the first chain in dtevt common
3541       NPOINT(3) = NHKK+1
3542 * special flag for double-Pomeron statistics
3543       IPOPO = 1
3544 * counter for low-mass (DTUNUC) interactions
3545       NDTUSC = 0
3546 * counter for interactions treated by PHOJET
3547       NPHOSC = 0
3548
3549 * scan interactions for single nucleon-nucleon interactions
3550 * (this has to be checked here because Cronin modifies parton momenta)
3551       NC = NPOINT(2)
3552       IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
3553       DO 8 I=1,NCSY
3554          ISINGL(I) = 0
3555          MOP = JMOHKK(1,NC)
3556          MOT = JMOHKK(1,NC+1)
3557          DIFF1 = ABS(PHKK(4,MOP)-PHKK(4,  NC)-PHKK(4,NC+2))
3558          DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
3559          IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
3560          NC = NC+4
3561     8 CONTINUE
3562
3563 * multiple scattering of chain ends
3564       IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
3565       IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
3566
3567 * switch to PHOJET-settings for JETSET parameter
3568       CALL DT_INITJS(1)
3569
3570 * loop over nucleon-nucleon interaction
3571       NC = NPOINT(2)
3572       DO 2 I=1,NCSY
3573 *
3574 *   pick up one nucleon-nucleon interaction from DTEVT1
3575 *     ppnn  / ptnn   - momenta of the interacting nucleons (cms)
3576 *     ptotnn         - total momentum of the interacting nucleons (cms)
3577 *     pp1,2 / pt1,2  - momenta of the four partons
3578 *     pp    / pt     - total momenta of the proj / targ partons
3579 *     ptot           - total momentum of the four partons
3580          MOP = JMOHKK(1,NC)
3581          MOT = JMOHKK(1,NC+1)
3582          DO 3 K=1,4
3583             PPNN(K)   = PHKK(K,MOP)
3584             PTNN(K)   = PHKK(K,MOT)
3585             PTOTNN(K) = PPNN(K)+PTNN(K)
3586             PP1(K)    = PHKK(K,NC)
3587             PT1(K)    = PHKK(K,NC+1)
3588             PP2(K)    = PHKK(K,NC+2)
3589             PT2(K)    = PHKK(K,NC+3)
3590             PP(K)     = PP1(K)+PP2(K)
3591             PT(K)     = PT1(K)+PT2(K)
3592             PTOT(K)   = PP(K)+PT(K)
3593     3    CONTINUE
3594 *
3595 *-----------------------------------------------------------------------
3596 *   this is a complete nucleon-nucleon interaction
3597 *
3598          IF (ISINGL(I).EQ.1) THEN
3599 *
3600 *     initialize PHOJET-variables for remnant/valence-partons
3601             IHFLD(1,1) = 0
3602             IHFLD(1,2) = 0
3603             IHFLD(2,1) = 0
3604             IHFLD(2,2) = 0
3605             IHFLS(1) = 1
3606             IHFLS(2) = 1
3607 *     save current settings of PHOJET process and min. bias flags
3608             DO 9 K=1,11
3609                KPRON(K) = IPRON(K,1)
3610     9       CONTINUE
3611             ISWSAV   = ISWMDL(2)
3612 *
3613 *     check if forced sampling of diffractive interaction requested
3614             IF (ISINGD.LT.-1) THEN
3615                DO 90 K=1,11
3616                   IPRON(K,1) = 0
3617    90          CONTINUE
3618                IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
3619                IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
3620                IF (ISINGD.EQ.-5) IPRON(4,1) = 1
3621             ENDIF
3622 *
3623 *     for photons: a direct/anomalous interaction is not sampled
3624 *     in PHOJET but already in Glauber-formalism. Here we check if such
3625 *     an interaction is requested
3626             IF (IJPROJ.EQ.7) THEN
3627 *       first switch off direct interactions
3628                IPRON(8,1) = 0
3629 *       this is a direct interactions
3630                IF (IDIREC.EQ.1) THEN
3631                   DO 12 K=1,11
3632                      IPRON(K,1) = 0
3633    12             CONTINUE
3634                   IPRON(8,1) = 1
3635 *       this is an anomalous interactions
3636 *         (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
3637                ELSEIF (IDIREC.EQ.2) THEN
3638                   ISWMDL(2) = 0
3639                ENDIF
3640             ELSE
3641                IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
3642             ENDIF
3643 *
3644 *     make sure that total momenta of partons, pp and pt, are on mass
3645 *     shell (Cronin may have srewed this up..)
3646             CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
3647             IF (IR1.NE.0) THEN
3648                IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
3649      &              'EVENTB:  mass shell correction rejected'
3650                GOTO 9999
3651             ENDIF
3652 *
3653 *     initialize the incoming particles in PHOJET
3654             IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3655                CALL PHO_SETPAR(1,22,0,VIRT)
3656             ELSE
3657                CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
3658             ENDIF
3659             CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
3660 *
3661 *     initialize rejection loop counter for anomalous processes
3662             IRJANO = 0
3663   800       CONTINUE
3664             IRJANO = IRJANO+1
3665 *
3666 *     temporary fix for ifano problem
3667             IFANO(1) = 0
3668             IFANO(2) = 0
3669 *
3670 *     generate complete hadron/nucleon/photon-nucleon event with PHOJET
3671             CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
3672 *
3673 *     for photons: special consistency check for anomalous interactions
3674             IF (IJPROJ.EQ.7) THEN
3675                IF (IRJANO.LT.30) THEN
3676                   IF (IFANO(1).NE.0) THEN
3677 *       here, an anomalous interaction was generated. Check if it
3678 *       was also requested. Otherwise reject this event.
3679                      IF (IDIREC.EQ.0) GOTO 800
3680                   ELSE
3681 *       here, an anomalous interaction was not generated. Check if it
3682 *       was requested in which case we need to reject this event.
3683                      IF (IDIREC.EQ.2) GOTO 800
3684                   ENDIF
3685                ELSE
3686                   WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
3687      &                          IRJANO,IDIREC,NEVHKK
3688                ENDIF
3689             ENDIF
3690 *
3691 *     copy back original settings of PHOJET process and min. bias flags
3692             DO 10 K=1,11
3693                IPRON(K,1) = KPRON(K)
3694    10       CONTINUE
3695             ISWMDL(2) = ISWSAV
3696 *
3697 *     check if PHOJET has rejected this event
3698             IF (IREJ1.NE.0) THEN
3699 C              IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3700                WRITE(LOUT,'(1X,A,I4)')
3701      &            'EVENTB:  chain system rejected',IDIREC
3702                CALL PHO_PREVNT(0)
3703                GOTO 9999
3704             ENDIF
3705 *
3706 *     copy partons and strings from PHOJET common back into DTEVT for
3707 *     external fragmentation
3708             MO1 = NC
3709             MO2 = NC+3
3710 *!      uncomment this line for internal phojet-fragmentation
3711 C           CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
3712             NPHOSC = NPHOSC+1
3713             CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
3714             IF (IREJ1.NE.0) THEN
3715                IF (IOULEV(1).GT.0)
3716      &         WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
3717                GOTO 9999
3718             ENDIF
3719 *
3720 *     update statistics counter
3721             ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
3722 *
3723 *-----------------------------------------------------------------------
3724 *   this interaction involves "remnants"
3725 *
3726          ELSE
3727 *
3728 *     total mass of this system
3729             PPTOT  = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
3730             AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
3731             IF (AMTOT2.LT.ZERO) THEN
3732                AMTOT = ZERO
3733             ELSE
3734                AMTOT = SQRT(AMTOT2)
3735             ENDIF
3736 *
3737 *     systems with masses larger than elojet are treated with PHOJET
3738             IF (AMTOT.GT.ELOJET) THEN
3739 *
3740 *     initialize PHOJET-variables for remnant/valence-partons
3741 *       projectile parton flavors and valence flag
3742                IHFLD(1,1) = IDHKK(NC)
3743                IHFLD(1,2) = IDHKK(NC+2)
3744                IHFLS(1)   = 0
3745                IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
3746      &                            .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
3747 *       target parton flavors and valence flag
3748                IHFLD(2,1) = IDHKK(NC+1)
3749                IHFLD(2,2) = IDHKK(NC+3)
3750                IHFLS(2)   = 0
3751                IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
3752      &                            .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
3753 *       flag signalizing PHOJET how to treat the remnant:
3754 *         iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
3755 *         iremn > -1 valence remnant: PHOJET assumes flavors according
3756 *                    to mother particle
3757                IREMN1 = IHFLS(1)-1
3758                IREMN2 = IHFLS(2)-1
3759 *
3760 *     initialize the incoming particles in PHOJET
3761                IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3762                   CALL PHO_SETPAR(1,22,IREMN1,VIRT)
3763                ELSE
3764                   CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
3765                ENDIF
3766                CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
3767 *
3768 *     calculate Lorentz parameter of the nucleon-nucleon cm-system
3769                PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
3770                AMNN   = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
3771                BGX    = PTOTNN(1)/AMNN
3772                BGY    = PTOTNN(2)/AMNN
3773                BGZ    = PTOTNN(3)/AMNN
3774                GAM    = PTOTNN(4)/AMNN
3775 *     transform interacting nucleons into nucleon-nucleon cm-system
3776                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3777      &                     PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
3778      &                     PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
3779                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3780      &                     PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
3781      &                     PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
3782 *     transform (total) momenta of the proj and targ partons into
3783 *     nucleon-nucleon cm-system
3784                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3785      &                     PP(1),PP(2),PP(3),PP(4),
3786      &                     PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
3787                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3788      &                     PT(1),PT(2),PT(3),PT(4),
3789      &                     PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
3790 *     energy fractions of the proj and targ partons
3791                XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
3792                XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
3793 ***
3794 * testprint
3795 c              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3796 c    &                        (PPTCMS(2)+PTTCMS(2))**2 +
3797 c    &                        (PPTCMS(3)+PTTCMS(3))**2 )
3798 c              EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3799 c    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3800 c              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3801 c    &                        (PPSUB(2)+PTSUB(2))**2 +
3802 c    &                        (PPSUB(3)+PTSUB(3))**2 )
3803 c              EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3804 c    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
3805 ***
3806 *
3807 *     save current settings of PHOJET process and min. bias flags
3808                DO 7 K=1,11
3809                   KPRON(K) = IPRON(K,1)
3810     7          CONTINUE
3811 *     disallow direct photon int. (does not make sense here anyway)
3812                IPRON(8,1) = 0
3813 *     disallow double pomeron processes (due to technical problems
3814 *     in PHOJET, needs to be solved sometime)
3815                IPRON(4,1) = 0
3816 *     disallow diffraction for sea-diquarks
3817                IF ((IABS(IHFLD(1,1)).GT.1100).AND.
3818      &             (IABS(IHFLD(1,2)).GT.1100)) THEN
3819                   IPRON(3,1) = 0
3820                   IPRON(6,1) = 0
3821                ENDIF
3822                IF ((IABS(IHFLD(2,1)).GT.1100).AND.
3823      &             (IABS(IHFLD(2,2)).GT.1100)) THEN
3824                   IPRON(3,1) = 0
3825                   IPRON(5,1) = 0
3826                ENDIF
3827 *
3828 *     we need massless partons: transform them on mass shell
3829                XMP = ZERO
3830                XMT = ZERO
3831                DO 6 K=1,4
3832                   PPTMP(K) = PPSUB(K)
3833                   PTTMP(K) = PTSUB(K)
3834     6          CONTINUE
3835                CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
3836                PPSUTO  = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
3837                PTSUTO  = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
3838                PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
3839      &                  (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
3840 *     total energy of the subsysten after mass transformation
3841 *      (should be the same as before..)
3842                SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
3843      &                      (PPSUB(4)+PTSUB(4)+PSUTOT) )
3844 *
3845 *     after mass shell transformation the x_sub - relation has to be
3846 *     corrected. We therefore create "pseudo-momenta" of mother-nucleons.
3847 *
3848 *     The old version was to scale based on the original x_sub and the
3849 *     4-momenta of the subsystem. At very high energy this could lead to
3850 *     "pseudo-cm energies" of the parent system considerably exceeding
3851 *     the true cm energy. Now we keep the true cm energy and calculate
3852 *     new x_sub instead.
3853 C old version  PPTCMS(4) = PPSUB(4)/XPSUB
3854                PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
3855                XPSUB = PPSUB(4)/PPTCMS(4)
3856                IF (IJPROJ.EQ.7) THEN
3857                   AMP2  = PHKK(5,MOT)**2
3858                   PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
3859                ELSE
3860 *???????
3861                   PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
3862      &                        *(PPTCMS(4)+PHKK(5,MOP)))
3863 C                 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
3864 C    &                        *(PPTCMS(4)+PHKK(5,MOT)))
3865                ENDIF
3866 C old version  PTTCMS(4) = PTSUB(4)/XTSUB
3867                PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
3868                XTSUB = PTSUB(4)/PTTCMS(4)
3869                PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
3870      &                     *(PTTCMS(4)+PHKK(5,MOT)))
3871                DO 4 K=1,3
3872                   PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
3873                   PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
3874     4          CONTINUE
3875 ***
3876 * testprint
3877 *
3878 *     ppnn  / ptnn   - momenta of the int. nucleons (cms, negl. Fermi)
3879 *     ptotnn         - total momentum of the int. nucleons (cms, negl. Fermi)
3880 *     pptcms/ pttcms - momenta of the interacting nucleons (cms)
3881 *     pp1,2 / pt1,2  - momenta of the four partons
3882 *
3883 *     pp    / pt     - total momenta of the pr/ta partons (cms, negl. Fermi)
3884 *     ptot           - total momentum of the four partons (cms, negl. Fermi)
3885 *     ppsub / ptsub  - total momenta of the proj / targ partons (cms)
3886 *
3887 c              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3888 c    &                        (PPTCMS(2)+PTTCMS(2))**2 +
3889 c    &                        (PPTCMS(3)+PTTCMS(3))**2 )
3890 c              ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3891 c    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3892 c              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3893 c    &                        (PPSUB(2)+PTSUB(2))**2 +
3894 c    &                        (PPSUB(3)+PTSUB(3))**2 )
3895 c              ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3896 c    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
3897 c              IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
3898 c                 WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
3899 c                 WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
3900 c                 WRITE(*,*) ' XPSUB,  XTSUB  : ',XPSUB,XTSUB
3901 c              ENDIF
3902 c              BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
3903 c              BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
3904 c              BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
3905 c              BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
3906 *     transform interacting nucleons into nucleon-nucleon cm-system
3907 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3908 c    &                    PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
3909 c    &                     PPNEW1,PPNEW2,PPNEW3,PPNEW4)
3910 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3911 c    &                    PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
3912 c    &                     PTNEW1,PTNEW2,PTNEW3,PTNEW4)
3913 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3914 c    &                     PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
3915 c    &                     PPSUB1,PPSUB2,PPSUB3,PPSUB4)
3916 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3917 c    &                     PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
3918 c    &                     PTSUB1,PTSUB2,PTSUB3,PTSUB4)
3919 c              PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
3920 c    &                        (PPNEW2+PTNEW2)**2 +
3921 c    &                        (PPNEW3+PTNEW3)**2 )
3922 c              ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
3923 c    &                        (PPNEW4+PTNEW4+PTSTCM) )
3924 c              PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
3925 c    &                        (PPSUB2+PTSUB2)**2 +
3926 c    &                        (PPSUB3+PTSUB3)**2 )
3927 c              ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
3928 c    &                        (PPSUB4+PTSUB4+PTSTSU) )
3929 C              WRITE(*,*) ' mother cmE :'
3930 C              WRITE(*,*) ETSTCM,ENEWCM
3931 C              WRITE(*,*) ' subsystem cmE :'
3932 C              WRITE(*,*) ETSTSU,ENEWSU
3933 C              WRITE(*,*) ' projectile mother :'
3934 C              WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
3935 C              WRITE(*,*) ' target mother :'
3936 C              WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
3937 C              WRITE(*,*) ' projectile subsystem:'
3938 C              WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
3939 C              WRITE(*,*) ' target subsystem:'
3940 C              WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
3941 C              WRITE(*,*) ' projectile subsystem should be:'
3942 C              WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
3943 C    &                    XPSUB*ETSTCM/2.0D0
3944 C              WRITE(*,*) ' target subsystem should be:'
3945 C              WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
3946 C    &                    XTSUB*ETSTCM/2.0D0
3947 C              WRITE(*,*) ' subsystem cmE should be: '
3948 C              WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
3949 ***
3950 *
3951 *     generate complete remnant - nucleon/remnant event with PHOJET
3952                CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
3953 *
3954 *     copy back original settings of PHOJET process flags
3955                DO 11 K=1,11
3956                   IPRON(K,1) = KPRON(K)
3957    11          CONTINUE
3958 *
3959 *     check if PHOJET has rejected this event
3960                IF (IREJ1.NE.0) THEN
3961                   IF (IOULEV(1).GT.0)
3962      &            WRITE(LOUT,'(1X,A)') 'EVENTB:  chain system rejected'
3963                   WRITE(LOUT,*)
3964      &                 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
3965                   CALL PHO_PREVNT(0)
3966                   GOTO 9999
3967                ENDIF
3968 *
3969 *     copy partons and strings from PHOJET common back into DTEVT for
3970 *     external fragmentation
3971                MO1 = NC
3972                MO2 = NC+3
3973 *!      uncomment this line for internal phojet-fragmentation
3974 C              CALL DT_GETFSP(MO1,MO2,PP,PT,1)
3975                NPHOSC = NPHOSC+1
3976                CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
3977                IF (IREJ1.NE.0) THEN
3978                   IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3979      &               'EVENTB: chain system rejected 2'
3980                   GOTO 9999
3981                ENDIF
3982 *
3983 *     update statistics counter
3984                ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
3985 *
3986 *-----------------------------------------------------------------------
3987 * two-chain approx. for smaller systems
3988 *
3989             ELSE
3990 *
3991                NDTUSC = NDTUSC+1
3992 *   special flag for double-Pomeron statistics
3993                IPOPO = 0
3994 *
3995 *   pick up flavors at the ends of the two chains
3996                IFP1 = IDHKK(NC)
3997                IFT1 = IDHKK(NC+1)
3998                IFP2 = IDHKK(NC+2)
3999                IFT2 = IDHKK(NC+3)
4000 *   ..and the indices of the mothers
4001                MOP1 = NC
4002                MOT1 = NC+1
4003                MOP2 = NC+2
4004                MOT2 = NC+3
4005                CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
4006      &                     IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
4007 *
4008 *   check if this chain system was rejected
4009                IF (IREJ1.GT.0) THEN
4010                   IF (IOULEV(1).GT.0) THEN
4011                      WRITE(LOUT,*) 'rejected 1 in EVENTB'
4012                      WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
4013      &                  IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
4014                   ENDIF
4015                   IRHHA = IRHHA+1
4016                   GOTO 9999
4017                ENDIF
4018 *   the following lines are for sea-sea chains rejected in GETCSY
4019                IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
4020                ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
4021             ENDIF
4022 *
4023          ENDIF
4024 *
4025 *     update statistics counter
4026          ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
4027 *
4028          NC = NC+4
4029 *
4030     2 CONTINUE
4031 *
4032 *-----------------------------------------------------------------------
4033 * treatment of low-mass chains (if there are any)
4034 *
4035       IF (NDTUSC.GT.0) THEN
4036 *
4037 *   correct chains of very low masses for possible resonances
4038          IF (IRESCO.EQ.1) THEN
4039             CALL DT_EVTRES(IREJ1)
4040             IF (IREJ1.GT.0) THEN
4041                IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
4042                IRRES(1) = IRRES(1)+1
4043                GOTO 9999
4044             ENDIF
4045          ENDIF
4046 *   fragmentation of low-mass chains
4047 *!  uncomment this line for internal phojet-fragmentation
4048 *   (of course it will still be fragmented by DPMJET-routines but it
4049 *    has to be done here instead of further below)
4050 C        CALL DT_EVTFRA(IREJ1)
4051 C        IF (IREJ1.GT.0) THEN
4052 C           IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
4053 C           IRFRAG = IRFRAG+1
4054 C           GOTO 9999
4055 C        ENDIF
4056       ELSE
4057 *! uncomment this line for internal phojet-fragmentation
4058 C        NPOINT(4) = NHKK+1
4059          IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
4060       ENDIF
4061 *
4062 *-----------------------------------------------------------------------
4063 * new di-quark breaking mechanisms
4064 *
4065       MXLEFT = 2
4066       CALL DT_CHASTA(0)
4067       IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
4068      &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
4069          CALL DT_DIQBRK
4070          MXLEFT = 4
4071       ENDIF
4072 *
4073 *-----------------------------------------------------------------------
4074 * hadronize this event
4075 *
4076 *   hadronize PHOJET chain systems
4077       NPYMAX = 0
4078       NPJE   = NPHOSC/MXPHFR
4079       IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
4080       IF (NPJE.GT.1) THEN
4081          NLEFT = NPHOSC-NPJE*MXPHFR
4082          DO 20 JFRG=1,NPJE
4083             NFRG = JFRG*MXPHFR
4084             IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
4085                CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4086                IF (IREJ1.GT.0) GOTO 22
4087                NLEFT = 0
4088             ELSE
4089                CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
4090                IF (IREJ1.GT.0) GOTO 22
4091             ENDIF
4092             IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4093    20    CONTINUE
4094          IF (NLEFT.GT.0) THEN
4095             CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4096             IF (IREJ1.GT.0) GOTO 22
4097             IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4098          ENDIF
4099       ELSE
4100          CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4101          IF (IREJ1.GT.0) GOTO 22
4102          IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4103       ENDIF
4104 *
4105 *   check max. filling level of jetset common and
4106 *   reduce mxphfr if necessary
4107       IF (NPYMAX.GT.3000) THEN
4108          IF (NPYMAX.GT.3500) THEN
4109             MXPHFR = MAX(1,MXPHFR-2)
4110          ELSE
4111             MXPHFR = MAX(1,MXPHFR-1)
4112          ENDIF
4113 C        WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
4114       ENDIF
4115 *
4116 *   hadronize DTUNUC chain systems
4117    23 CONTINUE
4118       IBACK = MXDTFR
4119       CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
4120       IF (IREJ2.GT.0) GOTO 22
4121 *
4122 *   check max. filling level of jetset common and
4123 *   reduce mxdtfr if necessary
4124       IF (NPYMEM.GT.3000) THEN
4125          IF (NPYMEM.GT.3500) THEN
4126             MXDTFR = MAX(1,MXDTFR-20)
4127          ELSE
4128             MXDTFR = MAX(1,MXDTFR-10)
4129          ENDIF
4130 C        WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
4131       ENDIF
4132 *
4133       IF (IBACK.EQ.-1) GOTO 23
4134 *
4135    22 CONTINUE
4136 C     CALL DT_EVTFRG(1,IREJ1)
4137 C     CALL DT_EVTFRG(2,IREJ2)
4138       IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
4139          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
4140          IRFRAG = IRFRAG+1
4141          GOTO 9999
4142       ENDIF
4143 *
4144 * get final state particles from /DTEVTP/
4145 *! uncomment this line for internal phojet-fragmentation
4146 C     CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
4147
4148       IF (IJPROJ.NE.7)
4149      &   CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
4150 C     IF (IREJ3.NE.0) GOTO 9999
4151
4152       RETURN
4153
4154  9999 CONTINUE
4155       IREVT = IREVT+1
4156       IREJ  = 1
4157       RETURN
4158       END
4159
4160 *$ CREATE DT_GETPJE.FOR
4161 *COPY DT_GETPJE
4162 *
4163 *===getpje=============================================================*
4164 *
4165       SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
4166
4167 ************************************************************************
4168 * This subroutine copies PHOJET partons and strings from POEVT1 into   *
4169 * DTEVT1.                                                              *
4170 *      MO1,MO2   indices of first and last mother-parton in DTEVT1     *
4171 *      PP,PT     4-momenta of projectile/target being handled by       *
4172 *                PHOJET                                                *
4173 * This version dated 11.12.99 is written by S. Roesler                 *
4174 ************************************************************************
4175
4176       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4177       SAVE
4178       PARAMETER ( LINP = 10 ,
4179      &            LOUT = 6 ,
4180      &            LDAT = 9 )
4181       PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
4182      &           ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
4183
4184       LOGICAL LFLIP
4185
4186 * event history
4187       PARAMETER (NMXHKK=200000)
4188       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4189      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4190      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4191 * extended event history
4192       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4193      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4194      &                IHIST(2,NMXHKK)
4195 * Lorentz-parameters of the current interaction
4196       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4197      &                UMO,PPCM,EPROJ,PPROJ
4198 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
4199       COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
4200 * flags for input different options
4201       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4202       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4203      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4204 * statistics: double-Pomeron exchange
4205       COMMON /DTFLG2/ INTFLG,IPOPO
4206 * statistics
4207       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
4208      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
4209      &                ICEVTG(8,0:30)
4210 * rejection counter
4211       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
4212      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
4213      &                IREXCI(3),IRDIFF(2),IRINC
4214 C  standard particle data interface
4215       INTEGER NMXHEP
4216       PARAMETER (NMXHEP=4000)
4217       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
4218       DOUBLE PRECISION PHEP,VHEP
4219       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
4220      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
4221      &                VHEP(4,NMXHEP)
4222 C  extension to standard particle data interface (PHOJET specific)
4223       INTEGER IMPART,IPHIST,ICOLOR
4224       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
4225 C  color string configurations including collapsed strings and hadrons
4226       INTEGER MSTR
4227       PARAMETER (MSTR=500)
4228       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
4229       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
4230      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
4231      &                NNCH(MSTR),IBHAD(MSTR),ISTR
4232 C  general process information
4233       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4234       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4235 C  model switches and parameters
4236       CHARACTER*8 MDLNA
4237       INTEGER ISWMDL,IPAMDL
4238       DOUBLE PRECISION PARMDL
4239       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4240 C  event debugging information
4241       INTEGER NMAXD
4242       PARAMETER (NMAXD=100)
4243       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4244      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4245       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4246      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4247
4248       DIMENSION PP(4),PT(4)
4249       DATA MAXLOP /10000/
4250
4251       INHKK = NHKK
4252       LFLIP = .TRUE.
4253     1 CONTINUE
4254       NPVAL = 0
4255       NTVAL = 0
4256       IREJ  = 0
4257
4258 *   store initial momenta for energy-momentum conservation check
4259       IF (LEMCCK) THEN
4260          CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
4261          CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
4262       ENDIF
4263 * copy partons and strings from POEVT1 into DTEVT1
4264       DO 11 I=1,ISTR
4265 C        IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
4266          IF (NCODE(I).EQ.-99) THEN
4267             IDXSTG = NPOS(1,I)
4268             IDSTG  = IDHEP(IDXSTG)
4269             PX = PHEP(1,IDXSTG)
4270             PY = PHEP(2,IDXSTG)
4271             PZ = PHEP(3,IDXSTG)
4272             PE = PHEP(4,IDXSTG)
4273             IF (MODE.LT.0) THEN
4274                ISTAT = 70000+IPJE
4275                CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
4276      &                        11,IDSTG,0)
4277                IF (LEMCCK) THEN
4278                   PX = -PX
4279                   PY = -PY
4280                   PZ = -PZ
4281                   PE = -PE
4282                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4283                ENDIF
4284             ELSE
4285                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4286      &                        PPX,PPY,PPZ,PPE)
4287                ISTAT = 70000+IPJE
4288                CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
4289      &                        11,IDSTG,0)
4290                IF (LEMCCK) THEN
4291                   PX = -PPX
4292                   PY = -PPY
4293                   PZ = -PPZ
4294                   PE = -PPE
4295                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4296                ENDIF
4297             ENDIF
4298             NOBAM(NHKK)   = 0
4299             IHIST(1,NHKK) = IPHIST(1,IDXSTG)
4300             IHIST(2,NHKK) = 0
4301          ELSEIF (NCODE(I).GE.0) THEN
4302 *   indices of partons and string in POEVT1
4303             IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
4304             IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
4305             IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
4306                WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
4307      &         ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
4308                STOP ' GETPJE 1'
4309             ENDIF
4310             IDXSTG = NPOS(1,I)
4311 *   find "mother" string of the string
4312             IDXMS1 = ABS(JMOHEP(1,IDX1))
4313             IDXMS2 = ABS(JMOHEP(1,IDX2))
4314             IF (IDXMS1.NE.IDXMS2) THEN
4315                IDXMS1 = IDXSTG
4316                IDXMS2 = IDXSTG
4317 C              STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
4318             ENDIF
4319 *   search POEVT1 for the original hadron of the parton
4320             ILOOP = 0
4321             IPOM1 = 0
4322    14       CONTINUE
4323             ILOOP = ILOOP+1
4324             IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
4325             IDXMS1 = ABS(JMOHEP(1,IDXMS1))
4326             IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
4327      &          (ILOOP.LT.MAXLOP)) GOTO 14
4328             IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
4329             IPOM2 = 0
4330             ILOOP = 0
4331    15       CONTINUE
4332             ILOOP = ILOOP+1
4333             IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
4334             IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
4335                IDXMS2 = ABS(JMOHEP(2,IDXMS2))
4336             ELSE
4337                IDXMS2 = ABS(JMOHEP(1,IDXMS2))
4338             ENDIF
4339             IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
4340      &          (ILOOP.LT.MAXLOP)) GOTO 15
4341             IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
4342 *   parton 1
4343             IF (IDXMS1.EQ.1) THEN
4344                ISPTN1 = ISTHKK(MO1)
4345                M1PTN1 = MO1
4346                M2PTN1 = MO1+2
4347             ELSE
4348                ISPTN1 = ISTHKK(MO2)
4349                M1PTN1 = MO2-2
4350                M2PTN1 = MO2
4351             ENDIF
4352 *   parton 2
4353             IF (IDXMS2.EQ.1) THEN
4354                ISPTN2 = ISTHKK(MO1)
4355                M1PTN2 = MO1
4356                M2PTN2 = MO1+2
4357             ELSE
4358                ISPTN2 = ISTHKK(MO2)
4359                M1PTN2 = MO2-2
4360                M2PTN2 = MO2
4361             ENDIF
4362 *   check for mis-identified mothers and switch mother indices if necessary
4363             IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
4364      &          .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
4365      &          (LFLIP)) THEN
4366                IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
4367                   ISPTN1 = ISTHKK(MO1)
4368                   M1PTN1 = MO1
4369                   M2PTN1 = MO1+2
4370                   ISPTN2 = ISTHKK(MO2)
4371                   M1PTN2 = MO2-2
4372                   M2PTN2 = MO2
4373                ELSE
4374                   ISPTN1 = ISTHKK(MO2)
4375                   M1PTN1 = MO2-2
4376                   M2PTN1 = MO2
4377                   ISPTN2 = ISTHKK(MO1)
4378                   M1PTN2 = MO1
4379                   M2PTN2 = MO1+2
4380                ENDIF
4381             ENDIF
4382 *   register partons in temporary common
4383 *     parton at chain end
4384             PX = PHEP(1,IDX1)
4385             PY = PHEP(2,IDX1)
4386             PZ = PHEP(3,IDX1)
4387             PE = PHEP(4,IDX1)
4388 * flag only partons coming from Pomeron with 41/42
4389 C           IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4390             IF (IPOM1.NE.0) THEN
4391                ISTX = ABS(ISPTN1)/10
4392                IMO  = ABS(ISPTN1)-10*ISTX
4393                ISPTN1 = -(40+IMO)
4394             ELSE
4395                IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
4396                   ISTX = ABS(ISPTN1)/10
4397                   IMO  = ABS(ISPTN1)-10*ISTX
4398                   IF ((IDHEP(IDX1).EQ.21).OR.
4399      &                (ABS(IPHIST(1,IDX1)).GE.100)) THEN
4400                      ISPTN1 = -(60+IMO)
4401                   ELSE
4402                      ISPTN1 = -(50+IMO)
4403                   ENDIF
4404                ENDIF
4405             ENDIF
4406             IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
4407             IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
4408             IF (MODE.LT.0) THEN
4409                CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
4410      &                        PZ,PE,0,0,0)
4411             ELSE
4412                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4413      &                        PPX,PPY,PPZ,PPE)
4414                CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
4415      &                        PPZ,PPE,0,0,0)
4416             ENDIF
4417             IHIST(1,NHKK) = IPHIST(1,IDX1)
4418             IHIST(2,NHKK) = 0
4419             DO 19 KK=1,4
4420                VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
4421                WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
4422    19       CONTINUE
4423             VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
4424             WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
4425             M1STRG = NHKK
4426 *     gluon kinks
4427             NGLUON = IDX2-IDX1-1
4428             IF (NGLUON.GT.0) THEN
4429                DO 17 IGLUON=1,NGLUON
4430                   IDX   = IDX1+IGLUON
4431                   IDXMS = ABS(JMOHEP(1,IDX))
4432                   IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
4433                      ILOOP = 0
4434    16                CONTINUE
4435                      ILOOP = ILOOP+1
4436                      IDXMS = ABS(JMOHEP(1,IDXMS))
4437                      IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
4438      &                   (ILOOP.LT.MAXLOP)) GOTO 16
4439                      IF (ILOOP.EQ.MAXLOP)
4440      &                  WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
4441                   ENDIF
4442                   IF (IDXMS.EQ.1) THEN
4443                      ISPTN = ISTHKK(MO1)
4444                      M1PTN = MO1
4445                      M2PTN = MO1+2
4446                   ELSE
4447                      ISPTN = ISTHKK(MO2)
4448                      M1PTN = MO2-2
4449                      M2PTN = MO2
4450                   ENDIF
4451                   PX = PHEP(1,IDX)
4452                   PY = PHEP(2,IDX)
4453                   PZ = PHEP(3,IDX)
4454                   PE = PHEP(4,IDX)
4455                   IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
4456                      ISTX = ABS(ISPTN)/10
4457                      IMO  = ABS(ISPTN)-10*ISTX
4458                      IF ((IDHEP(IDX).EQ.21).OR.
4459      &                   (ABS(IPHIST(1,IDX)).GE.100)) THEN
4460                         ISPTN = -(60+IMO)
4461                      ELSE
4462                         ISPTN = -(50+IMO)
4463                      ENDIF
4464                   ENDIF
4465                   IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
4466                   IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
4467                   IF (MODE.LT.0) THEN
4468                      CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4469      &                              PX,PY,PZ,PE,0,0,0)
4470                   ELSE
4471                      CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4472      &                              PPX,PPY,PPZ,PPE)
4473                      CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4474      &                              PPX,PPY,PPZ,PPE,0,0,0)
4475                   ENDIF
4476                   IHIST(1,NHKK) = IPHIST(1,IDX)
4477                   IHIST(2,NHKK) = 0
4478                   DO 20 KK=1,4
4479                      VHKK(KK,NHKK) = VHKK(KK,M2PTN)
4480                      WHKK(KK,NHKK) = WHKK(KK,M1PTN)
4481    20             CONTINUE
4482                   VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
4483                   WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
4484    17          CONTINUE
4485             ENDIF
4486 *     parton at chain end
4487             PX = PHEP(1,IDX2)
4488             PY = PHEP(2,IDX2)
4489             PZ = PHEP(3,IDX2)
4490             PE = PHEP(4,IDX2)
4491 * flag only partons coming from Pomeron with 41/42
4492 C           IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4493             IF (IPOM2.NE.0) THEN
4494                ISTX = ABS(ISPTN2)/10
4495                IMO  = ABS(ISPTN2)-10*ISTX
4496                ISPTN2 = -(40+IMO)
4497             ELSE
4498                IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
4499                   ISTX = ABS(ISPTN2)/10
4500                   IMO  = ABS(ISPTN2)-10*ISTX
4501                   IF ((IDHEP(IDX2).EQ.21).OR.
4502      &                (ABS(IPHIST(1,IDX2)).GE.100)) THEN
4503                      ISPTN2 = -(60+IMO)
4504                   ELSE
4505                      ISPTN2 = -(50+IMO)
4506                   ENDIF
4507                ENDIF
4508             ENDIF
4509             IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
4510             IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
4511             IF (MODE.LT.0) THEN
4512                CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4513      &                        PX,PY,PZ,PE,0,0,0)
4514             ELSE
4515                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4516      &                        PPX,PPY,PPZ,PPE)
4517                CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4518      &                        PPX,PPY,PPZ,PPE,0,0,0)
4519             ENDIF
4520             IHIST(1,NHKK) = IPHIST(1,IDX2)
4521             IHIST(2,NHKK) = 0
4522             DO 21 KK=1,4
4523                VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
4524                WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
4525    21       CONTINUE
4526             VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
4527             WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
4528             M2STRG = NHKK
4529 *   register string
4530             JSTRG = 100*IPROCE+NCODE(I)
4531             PX = PHEP(1,IDXSTG)
4532             PY = PHEP(2,IDXSTG)
4533             PZ = PHEP(3,IDXSTG)
4534             PE = PHEP(4,IDXSTG)
4535             IF (MODE.LT.0) THEN
4536                ISTAT = 70000+IPJE
4537                CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4538      &                        PX,PY,PZ,PE,0,0,0)
4539                IF (LEMCCK) THEN
4540                   PX = -PX
4541                   PY = -PY
4542                   PZ = -PZ
4543                   PE = -PE
4544                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4545                ENDIF
4546             ELSE
4547                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4548      &                        PPX,PPY,PPZ,PPE)
4549                ISTAT = 70000+IPJE
4550                CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4551      &                        PPX,PPY,PPZ,PPE,0,0,0)
4552                IF (LEMCCK) THEN
4553                   PX = -PPX
4554                   PY = -PPY
4555                   PZ = -PPZ
4556                   PE = -PPE
4557                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4558                ENDIF
4559             ENDIF
4560             NOBAM(NHKK)   = 0
4561             IHIST(1,NHKK) = 0
4562             IHIST(2,NHKK) = 0
4563             DO 18 KK=1,4
4564                VHKK(KK,NHKK) = VHKK(KK,MO2)
4565                WHKK(KK,NHKK) = WHKK(KK,MO1)
4566    18       CONTINUE
4567             VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
4568             WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
4569          ENDIF
4570    11 CONTINUE
4571
4572       IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
4573          NHKK  = INHKK
4574          LFLIP = .FALSE.
4575          GOTO 1
4576       ENDIF
4577
4578       IF (LEMCCK) THEN
4579          IF (UMO.GT.1.0D5) THEN
4580             CHKLEV = 1.0D0
4581          ELSE
4582             CHKLEV = TINY1
4583          ENDIF
4584          CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
4585          IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
4586       ENDIF
4587
4588 * internal statistics
4589 *   dble-Po statistics.
4590       IF (IPROCE.NE.4) IPOPO = 0
4591
4592       INTFLG = IPROCE
4593       IDCHSY = IDCH(MO1)
4594       IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
4595          ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
4596       ELSE
4597          WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
4598  1000    FORMAT(1X,'GETFSP:   warning! incons. process id. (',I2,
4599      &          ') at evt(chain) ',I6,'(',I2,')')
4600       ENDIF
4601       IF (IPROCE.EQ.5) THEN
4602          IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
4603             ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
4604          ELSE
4605 C           WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4606  1001       FORMAT(1X,'GETFSP:   warning! incons. diffrac. id. ',
4607      &             '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
4608          ENDIF
4609       ELSEIF (IPROCE.EQ.6) THEN
4610          IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4611             ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
4612          ELSE
4613 C           WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4614          ENDIF
4615       ELSEIF (IPROCE.EQ.7) THEN
4616          IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
4617      &       (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4618             IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
4619      &         ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
4620             IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
4621      &         ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
4622             IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
4623      &         ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
4624             IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
4625      &         ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
4626          ELSE
4627             WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4628          ENDIF
4629       ENDIF
4630       IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
4631      &                                                       THEN
4632          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4633          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4634          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4635       ENDIF
4636       ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
4637       ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
4638       ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
4639       ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
4640       ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
4641
4642       RETURN
4643
4644  9999 CONTINUE
4645       IREJ = 1
4646       RETURN
4647       END
4648
4649 *$ CREATE DT_PHOINI.FOR
4650 *COPY DT_PHOINI
4651 *
4652 *===phoini=============================================================*
4653 *
4654       SUBROUTINE DT_PHOINI
4655
4656 ************************************************************************
4657 * Initialization PHOJET-event generator for nucleon-nucleon interact.  *
4658 * This version dated 16.11.95 is written by S. Roesler                 *
4659 *                                                                      *
4660 * Last change 27.12.2006 by S. Roesler.                                *
4661 ************************************************************************
4662
4663       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4664       SAVE
4665       PARAMETER ( LINP = 10 ,
4666      &            LOUT = 6 ,
4667      &            LDAT = 9 )
4668       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
4669
4670 * nucleon-nucleon event-generator
4671       CHARACTER*8 CMODEL
4672       LOGICAL LPHOIN
4673       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
4674 * particle properties (BAMJET index convention)
4675       CHARACTER*8  ANAME
4676       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
4677      &                IICH(210),IIBAR(210),K1(210),K2(210)
4678 * Lorentz-parameters of the current interaction
4679       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4680      &                UMO,PPCM,EPROJ,PPROJ
4681 * properties of interacting particles
4682       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4683 * properties of photon/lepton projectiles
4684       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
4685       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
4686 * emulsion treatment
4687       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
4688      &                NCOMPO,IEMUL
4689 * VDM parameter for photon-nucleus interactions
4690       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
4691 * nuclear potential
4692       LOGICAL LFERMI
4693       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4694      &                EBINDP(2),EBINDN(2),EPOT(2,210),
4695      &                ETACOU(2),ICOUL,LFERMI
4696 * Glauber formalism: flags and parameters for statistics
4697       LOGICAL LPROD
4698       CHARACTER*8 CGLB
4699       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
4700 *
4701 * parameters for cascade calculations:
4702 * maximum mumber of PDF's which can be defined in phojet (limited
4703 * by the dimension of ipdfs in pho_setpdf)
4704       PARAMETER (MAXPDF = 20)
4705 * PDF parametrization and number of set for the first 30 hadrons in
4706 * the bamjet-code list
4707 *   negative numbers mean that the PDF is set in phojet,
4708 *   zero stands for "not a hadron"
4709       DIMENSION IPARPD(30),ISETPD(30)
4710 * PDF parametrization
4711       DATA IPARPD /
4712      &  -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
4713      &   5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
4714 * number of set
4715       DATA ISETPD /
4716      &  -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
4717      &   6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
4718
4719 **PHOJET105a
4720 C     COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4721 C     PARAMETER ( MAXPRO = 16 )
4722 C     PARAMETER ( MAXTAB = 20 )
4723 C     COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
4724 C    &                MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
4725 C     CHARACTER*8 MDLNA
4726 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
4727 C     COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
4728 **PHOJET110
4729 C  global event kinematics and particle IDs
4730       INTEGER IFPAP,IFPAB
4731       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
4732       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4733 C  hard cross sections and MC selection weights
4734       INTEGER Max_pro_2
4735       PARAMETER ( Max_pro_2 = 16 )
4736       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
4737      &  MH_acc_1,MH_acc_2
4738       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
4739       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
4740      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
4741      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
4742      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
4743      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
4744 C  model switches and parameters
4745       CHARACTER*8 MDLNA
4746       INTEGER ISWMDL,IPAMDL
4747       DOUBLE PRECISION PARMDL
4748       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4749 C  general process information
4750       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4751       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4752 **
4753       DIMENSION PP(4),PT(4)
4754
4755       LOGICAL LSTART
4756       DATA LSTART /.TRUE./
4757
4758       IJP = IJPROJ
4759       IJT = IJTARG
4760       Q2  = VIRT
4761 * lepton-projectiles: initialize real photon instead
4762       IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
4763          IJP = 7
4764          Q2  = ZERO
4765       ENDIF
4766       IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM)
4767 * switch Reggeon off
4768 C     IPAMDL(3)= 0
4769       IF (IP.EQ.1) THEN
4770          IFPAP(1) = IDT_IPDGHA(IJP)
4771          IFPAB(1) = IJP
4772       ELSE
4773          IFPAP(1) = 2212
4774          IFPAB(1) = IDT_ICIHAD(IFPAP(1))
4775       ENDIF
4776       PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
4777       PVIRT(1) = PMASS(1)**2
4778       IF (IT.EQ.1) THEN
4779          IFPAP(2) = IDT_IPDGHA(IJT)
4780          IFPAB(2) = IJT
4781       ELSE
4782          IFPAP(2) = 2212
4783          IFPAB(2) = IDT_ICIHAD(IFPAP(2))
4784       ENDIF
4785       PMASS(2) = AAM(IFPAB(2))
4786       PVIRT(2) = ZERO
4787       DO 1 K=1,4
4788          PP(K) = ZERO
4789          PT(K) = ZERO
4790     1 CONTINUE
4791 * get max. possible momenta of incoming particles to be used for PHOJET ini.
4792       PPF = ZERO
4793       PTF = ZERO
4794       SCPF= 1.5D0
4795       IF (UMO.GE.1.E5) THEN
4796          SCPF= 5.0D0
4797       ENDIF
4798       IF (NCOMPO.GT.0) THEN
4799          DO 2 I=1,NCOMPO
4800             IF (IT.GT.1) THEN
4801                CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
4802             ELSE
4803                CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
4804             ENDIF
4805             PPFTMP = MAX(PFERMP(1),PFERMN(1))
4806             PTFTMP = MAX(PFERMP(2),PFERMN(2))
4807             IF (PPFTMP.GT.PPF) PPF = PPFTMP
4808             IF (PTFTMP.GT.PTF) PTF = PTFTMP
4809     2    CONTINUE
4810       ELSE
4811          CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
4812          PPF = MAX(PFERMP(1),PFERMN(1))
4813          PTF = MAX(PFERMP(2),PFERMN(2))
4814       ENDIF
4815       PTF = -PTF
4816       PPF = SCPF*PPF
4817       PTF = SCPF*PTF
4818       IF (IJP.EQ.7) THEN
4819          AMP2  = SIGN(PMASS(1)**2,PMASS(1))
4820          PP(3) = PPCM
4821          PP(4) = SQRT(AMP2+PP(3)**2)
4822       ELSE
4823          EPF = SQRT(PPF**2+PMASS(1)**2)
4824          CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
4825       ENDIF
4826       ETF = SQRT(PTF**2+PMASS(2)**2)
4827       CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
4828       ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
4829      &              (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
4830       IF (LSTART) THEN
4831          WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
4832  1001    FORMAT(
4833      &      ' DT_PHOINI:    PHOJET initialized for projectile A,Z = ',
4834      &      I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
4835          IF (NCOMPO.GT.0) THEN
4836             WRITE(LOUT,1002) SCPF,PTF,PT
4837          ELSE
4838             WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
4839          ENDIF
4840  1002    FORMAT(
4841      &      ' DT_PHOINI:    PHOJET initialized for target emulsion  ',
4842      &          /,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
4843  1003    FORMAT(
4844      &      ' DT_PHOINI:    PHOJET initialized for target     A,Z = ',
4845      &      I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
4846          WRITE(LOUT,1004) ECMINI
4847  1004    FORMAT(' E_cm = ',E10.3)
4848          IF (IJP.EQ.8) WRITE(LOUT,1005)
4849  1005    FORMAT(
4850      &      ' DT_PHOINI: warning! proton parameters used for neutron',
4851      &          ' projectile')
4852          LSTART = .FALSE.
4853       ENDIF
4854 * switch off new diffractive cross sections at low energies for nuclei
4855 * (temporary solution)
4856       IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
4857          WRITE(LOUT,'(1X,A)')
4858      &      ' DT_PHOINI: model-switch 30 for nuclei re-set !'
4859          CALL PHO_SETMDL(30,0,1)
4860       ENDIF
4861 *
4862 C     IF (IJP.EQ.7) THEN
4863 C        AMP2  = SIGN(PMASS(1)**2,PMASS(1))
4864 C        PP(3) = PPCM
4865 C        PP(4) = SQRT(AMP2+PP(3)**2)
4866 C     ELSE
4867 C        PFERMX = ZERO
4868 C        IF (IP.GT.1) PFERMX = 0.5D0
4869 C        EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
4870 C        CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
4871 C     ENDIF
4872 C     PFERMX = ZERO
4873 C     IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
4874 C     EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
4875 C     CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
4876 **sr 26.10.96
4877       ISAV = IPAMDL(13)
4878       IF ((ISHAD(2).EQ.1).AND.
4879      &   ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
4880      &    (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
4881 **
4882       CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
4883 **sr 26.10.96
4884       IPAMDL(13) = ISAV
4885 **
4886 *
4887 * patch for cascade calculations:
4888 * define parton distribution functions for other hadrons, i.e. other
4889 * then defined already in phojet
4890       IF (IOGLB.EQ.100) THEN
4891          WRITE(LOUT,1006)
4892  1006    FORMAT(/,1X,'PHOINI: additional parton distribution functions',
4893      &          ' assiged (ID,IPAR,ISET)',/)
4894          NPDF = 0
4895          DO 3 I=1,30
4896             IF (IPARPD(I).NE.0) THEN
4897                NPDF = NPDF+1
4898                IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
4899                IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
4900                   IDPDG = IDT_IPDGHA(I)
4901                   IPAR  = IPARPD(I)
4902                   ISET  = ISETPD(I)
4903                   WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
4904                   CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
4905                ENDIF
4906             ENDIF
4907     3    CONTINUE
4908       ENDIF
4909
4910 C     CALL PHO_PHIST(-1,SIGMAX)
4911       IF (IREJ1.NE.0) THEN
4912          WRITE(LOUT,1000)
4913  1000    FORMAT(1X,'PHOINI:   PHOJET event-initialization failed!')
4914          STOP
4915       ENDIF
4916
4917       RETURN
4918       END
4919
4920 *$ CREATE DT_EVENTD.FOR
4921 *COPY DT_EVENTD
4922 *
4923 *===eventd=============================================================*
4924 *
4925       SUBROUTINE DT_EVENTD(IREJ)
4926
4927 ************************************************************************
4928 * Quasi-elastic neutrino nucleus scattering.                           *
4929 * This version dated 29.04.00 is written by S. Roesler.                *
4930 ************************************************************************
4931
4932       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4933       SAVE
4934       PARAMETER ( LINP = 10 ,
4935      &            LOUT = 6 ,
4936      &            LDAT = 9 )
4937       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
4938       PARAMETER (SQTINF=1.0D+15)
4939
4940       LOGICAL LFIRST
4941
4942 * event history
4943       PARAMETER (NMXHKK=200000)
4944       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4945      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4946      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4947 * extended event history
4948       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4949      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4950      &                IHIST(2,NMXHKK)
4951 * flags for input different options
4952       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4953       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4954      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4955       PARAMETER (MAXLND=4000)
4956       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
4957 * properties of interacting particles
4958       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4959 * Lorentz-parameters of the current interaction
4960       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4961      &                UMO,PPCM,EPROJ,PPROJ
4962 * nuclear potential
4963       LOGICAL LFERMI
4964       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4965      &                EBINDP(2),EBINDN(2),EPOT(2,210),
4966      &                ETACOU(2),ICOUL,LFERMI
4967 * steering flags for qel neutrino scattering modules
4968       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
4969       COMMON /QNPOL/ POLARX(4),PMODUL
4970       INTEGER PYK
4971
4972       DATA LFIRST /.TRUE./
4973
4974       IREJ = 0
4975
4976       IF (LFIRST) THEN
4977          LFIRST = .FALSE.
4978          CALL DT_MASS_INI
4979       ENDIF
4980
4981 * JETSET parameter
4982       CALL DT_INITJS(0)
4983
4984 * interacting target nucleon
4985       LTYP = NEUTYP
4986       IF (NEUDEC.LE.9) THEN
4987          IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
4988             NUCTYP = 2112
4989             NUCTOP = 2
4990          ELSE
4991             NUCTYP = 2212
4992             NUCTOP = 1
4993          ENDIF
4994       ELSE
4995          RTYP  = DT_RNDM(RTYP)
4996          ZFRAC = DBLE(ITZ)/DBLE(IT)
4997          IF (RTYP.LE.ZFRAC) THEN
4998             NUCTYP = 2212
4999             NUCTOP = 1
5000          ELSE
5001             NUCTYP = 2112
5002             NUCTOP = 2
5003          ENDIF
5004       ENDIF
5005
5006 * select first nucleon in list with matching id and reset all other
5007 * nucleons which have been marked as "wounded" by ININUC
5008       IFOUND = 0
5009       DO 1 I=1,NHKK
5010          IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
5011             ISTHKK(I) = 12
5012             IFOUND    = 1
5013             IDX = I
5014          ELSE
5015             IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
5016          ENDIF
5017     1 CONTINUE
5018       IF (IFOUND.EQ.0)
5019      &   STOP ' EVENTD: interacting target nucleon not found! '
5020
5021 * correct position of proj. lepton: assume position of target nucleon
5022       DO 3 I=1,4
5023          VHKK(I,1) = VHKK(I,IDX)
5024          WHKK(I,1) = WHKK(I,IDX)
5025     3 CONTINUE
5026
5027 * load initial momenta for conservation check
5028       IF (LEMCCK) THEN
5029          CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
5030          CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
5031      &                                                      2,IDUM,IDUM)
5032       ENDIF
5033
5034 * quasi-elastic scattering
5035       IF (NEUDEC.LT.9) THEN
5036          CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
5037      &                                          PHKK(4,IDX),PHKK(5,IDX))
5038 *  CC event on p or n
5039       ELSEIF (NEUDEC.EQ.10) THEN
5040          CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
5041      &                     PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5042 *  NC event on p or n
5043       ELSEIF (NEUDEC.EQ.11) THEN
5044          CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
5045      &                     PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5046       ENDIF
5047
5048 * get final state particles from Lund-common and write them into HKKEVT
5049       NPOINT(1) = NHKK+1
5050       NPOINT(4) = NHKK+1
5051       NLINES = PYK(0,1)
5052       NHKK0  = NHKK+1
5053       DO 4 I=4,NLINES
5054          IF (K(I,1).EQ.1) THEN
5055             ID = K(I,2)
5056             PX = P(I,1)
5057             PY = P(I,2)
5058             PZ = P(I,3)
5059             PE = P(I,4)
5060             CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
5061             IDBJ = IDT_ICIHAD(ID)
5062             EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
5063             IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
5064                IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
5065             ENDIF
5066             VHKK(1,NHKK) = VHKK(1,IDX)
5067             VHKK(2,NHKK) = VHKK(2,IDX)
5068             VHKK(3,NHKK) = VHKK(3,IDX)
5069             VHKK(4,NHKK) = VHKK(4,IDX)
5070 C           IF (I.EQ.4) THEN
5071 C              WHKK(1,NHKK) = POLARX(1)
5072 C              WHKK(2,NHKK) = POLARX(2)
5073 C              WHKK(3,NHKK) = POLARX(3)
5074 C              WHKK(4,NHKK) = POLARX(4)
5075 C           ELSE
5076                WHKK(1,NHKK) = WHKK(1,IDX)
5077                WHKK(2,NHKK) = WHKK(2,IDX)
5078                WHKK(3,NHKK) = WHKK(3,IDX)
5079                WHKK(4,NHKK) = WHKK(4,IDX)
5080 C           ENDIF
5081             IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
5082          ENDIF
5083     4 CONTINUE
5084
5085       IF (LEMCCK) THEN
5086          CHKLEV = TINY5
5087          CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
5088          IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
5089       ENDIF
5090
5091 * transform momenta into cms (as required for inc etc.)
5092       DO 5 I=NHKK0,NHKK
5093          IF (ISTHKK(I).EQ.1) THEN
5094             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
5095             PHKK(3,I) = PZ
5096             PHKK(4,I) = PE
5097          ENDIF
5098     5 CONTINUE
5099
5100       RETURN
5101       END
5102
5103 *$ CREATE DT_KKEVNT.FOR
5104 *COPY DT_KKEVNT
5105 *
5106 *===kkevnt=============================================================*
5107 *
5108       SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
5109
5110 ************************************************************************
5111 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering   *
5112 * without nuclear effects (one event).                                 *
5113 * This subroutine is an update of the previous version (KKEVT) written *
5114 * by J. Ranft/ H.-J. Moehring.                                         *
5115 * This version dated 20.04.95 is written by S. Roesler                 *
5116 ************************************************************************
5117
5118       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5119       SAVE
5120       PARAMETER ( LINP = 10 ,
5121      &            LOUT = 6 ,
5122      &            LDAT = 9 )
5123       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
5124
5125       PARAMETER ( MAXNCL = 260,
5126      &            MAXVQU = MAXNCL,
5127      &            MAXSQU = 20*MAXVQU,
5128      &            MAXINT = MAXVQU+MAXSQU)
5129 * event history
5130       PARAMETER (NMXHKK=200000)
5131       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5132      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5133      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5134 * extended event history
5135       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5136      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5137      &                IHIST(2,NMXHKK)
5138 * flags for input different options
5139       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5140       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5141      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5142 * rejection counter
5143       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
5144      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
5145      &                IREXCI(3),IRDIFF(2),IRINC
5146 * statistics
5147       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5148      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5149      &                ICEVTG(8,0:30)
5150 * properties of interacting particles
5151       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5152 * Lorentz-parameters of the current interaction
5153       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5154      &                UMO,PPCM,EPROJ,PPROJ
5155 * flags for diffractive interactions (DTUNUC 1.x)
5156       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5157 * interface HADRIN-DPM
5158       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5159 * nucleon-nucleon event-generator
5160       CHARACTER*8 CMODEL
5161       LOGICAL LPHOIN
5162       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
5163 * coordinates of nucleons
5164       COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
5165 * interface between Glauber formalism and DPM
5166       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
5167      &                INTER1(MAXINT),INTER2(MAXINT)
5168 * Glauber formalism: collision properties
5169       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5170      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5171 * central particle production, impact parameter biasing
5172       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5173 **temporary
5174 * statistics: Glauber-formalism
5175       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5176 **
5177
5178       DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5179
5180       IREJ   = 0
5181       ICREQU = ICREQU+1
5182       NC     = 0
5183
5184     1 CONTINUE
5185       ICSAMP = ICSAMP+1
5186       NC     = NC+1
5187       IF (MOD(NC,10).EQ.0) THEN
5188          WRITE(LOUT,1000) NEVHKK
5189  1000    FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5190          GOTO 9999
5191       ENDIF
5192
5193 * initialize DTEVT1/DTEVT2
5194       CALL DT_EVTINI
5195
5196 * We need the following only in order to sample nucleon coordinates.
5197 * However we don't have parameters (cross sections, slope etc.)
5198 * for neutrinos available. Therefore switch projectile to proton
5199 * in this case.
5200       IF (MCGENE.EQ.4) THEN
5201          JJPROJ = 1
5202       ELSE
5203          JJPROJ = IJPROJ
5204       ENDIF
5205
5206    10 CONTINUE
5207       IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5208 * make sure that Glauber-formalism is called each time the interaction
5209 * configuration changed
5210      &     (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5211      &     (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5212 * sample number of nucleon-nucleon coll. according to Glauber-form.
5213          CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5214          NWTSAM = NN
5215          NWASAM = NP
5216          NWBSAM = NT
5217          NEVOLD = NEVHKK
5218          IPOLD  = IP
5219          ITOLD  = IT
5220          JJPOLD = JJPROJ
5221          EPROLD = EPROJ
5222       ENDIF
5223
5224 * force diffractive particle production in h-K interactions
5225       IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5226      &    (IP.EQ.1).AND.(NN.NE.1)) THEN
5227          NEVOLD = 0
5228          GOTO 10
5229       ENDIF
5230
5231 * check number of involved proj. nucl. (NP) if central prod.is requested
5232       IF (ICENTR.GT.0) THEN
5233          CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5234          IF (IBACK.GT.0) GOTO 10
5235       ENDIF
5236
5237 * get initial nucleon-configuration in projectile and target
5238 * rest-system (including Fermi-momenta if requested)
5239       CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5240       MODE = 2
5241       IF (EPROJ.LE.EHADTH) MODE = 3
5242       CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5243
5244       IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5245
5246 * activate HADRIN at low energies (implemented for h-N scattering only)
5247          IF (EPROJ.LE.EHADHI) THEN
5248             IF (EHADTH.LT.ZERO) THEN
5249 *   smooth transition btwn. DPM and HADRIN
5250                FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5251                RR   = DT_RNDM(FRAC)
5252                IF (RR.GT.FRAC) THEN
5253                   IF (IP.EQ.1) THEN
5254                      CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5255                      IF (IREJ1.GT.0) GOTO 1
5256                      RETURN
5257                   ELSE
5258                      WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5259                   ENDIF
5260                ENDIF
5261             ELSE
5262 *   fixed threshold for onset of production via HADRIN
5263                IF (EPROJ.LE.EHADTH) THEN
5264                   IF (IP.EQ.1) THEN
5265                      CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5266                      IF (IREJ1.GT.0) GOTO 1
5267                      RETURN
5268                   ELSE
5269                      WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5270                   ENDIF
5271                ENDIF
5272             ENDIF
5273          ENDIF
5274  1001    FORMAT(1X,'KKEVNT:   warning! interaction of proj. (m=',
5275      &          I3,') with target (m=',I3,')',/,11X,
5276      &          'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5277      &          'GeV) cannot be handled')
5278
5279 * sampling of momentum-x fractions & flavors of chain ends
5280          CALL DT_SPLPTN(NN)
5281
5282 * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5283          CALL DT_NUC2CM
5284
5285 * collect momenta of chain ends and put them into DTEVT1
5286          CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5287          IF (IREJ1.NE.0) GOTO 1
5288
5289       ENDIF
5290
5291 * handle chains including fragmentation (two-chain approximation)
5292       IF (MCGENE.EQ.1) THEN
5293 *  two-chain approximation
5294          CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5295          IF (IREJ1.NE.0) THEN
5296             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5297             GOTO 1
5298          ENDIF
5299       ELSEIF (MCGENE.EQ.2) THEN
5300 *  multiple-Po exchange including minijets
5301          CALL DT_EVENTB(NCSY,IREJ1)
5302          IF (IREJ1.NE.0) THEN
5303             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5304             GOTO 1
5305          ENDIF
5306       ELSEIF (MCGENE.EQ.3) THEN
5307          STOP ' This version does not contain LEPTO !'
5308       ELSEIF (MCGENE.EQ.4) THEN
5309 *  quasi-elastic neutrino scattering
5310          CALL DT_EVENTD(IREJ1)
5311          IF (IREJ1.NE.0) THEN
5312             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5313             GOTO 1
5314          ENDIF
5315       ELSE
5316          WRITE(LOUT,1002) MCGENE
5317  1002    FORMAT(1X,'KKEVNT:   warning! event-generator',I4,
5318      &         ' not available - program stopped')
5319          STOP
5320       ENDIF
5321
5322       RETURN
5323
5324  9999 CONTINUE
5325       IREJ = 1
5326       RETURN
5327       END
5328
5329 *$ CREATE DT_CHKCEN.FOR
5330 *COPY DT_CHKCEN
5331 *
5332 *===chkcen=============================================================*
5333 *
5334       SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5335
5336 ************************************************************************
5337 * Check of number of involved projectile nucleons if central production*
5338 * is requested.                                                        *
5339 * Adopted from a part of the old KKEVT routine which was written by    *
5340 * J. Ranft/H.-J.Moehring.                                              *
5341 * This version dated 13.01.95 is written by S. Roesler                 *
5342 ************************************************************************
5343
5344       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5345       SAVE
5346       PARAMETER ( LINP = 10 ,
5347      &            LOUT = 6 ,
5348      &            LDAT = 9 )
5349
5350 * statistics
5351       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5352      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5353      &                ICEVTG(8,0:30)
5354 * central particle production, impact parameter biasing
5355       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5356
5357       IBACK = 0
5358
5359 * old version
5360       IF (ICENTR.EQ.2) THEN
5361          IF (IP.LT.IT) THEN
5362             IF (IP.LE.8) THEN
5363                IF (NP.LT.IP-1) IBACK = 1
5364             ELSEIF (IP.LE.16) THEN
5365                IF (NP.LT.IP-2) IBACK = 1
5366             ELSEIF (IP.LE.32) THEN
5367                IF (NP.LT.IP-3) IBACK = 1
5368             ELSEIF (IP.GE.33) THEN
5369                IF (NP.LT.IP-5) IBACK = 1
5370             ENDIF
5371          ELSEIF (IP.EQ.IT) THEN
5372             IF (IP.EQ.32) THEN
5373                IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5374             ELSE
5375                IF (NP.LT.IP-IP/8) IBACK = 1
5376             ENDIF
5377          ELSEIF (ABS(IP-IT).LT.3) THEN
5378             IF (NP.LT.IP-IP/8) IBACK = 1
5379          ENDIF
5380       ELSE
5381 * new version (DPMJET, 5.6.99)
5382          IF (IP.LT.IT) THEN
5383             IF (IP.LE.8) THEN
5384                IF (NP.LT.IP-1) IBACK = 1
5385             ELSEIF (IP.LE.16) THEN
5386                IF (NP.LT.IP-2) IBACK = 1
5387             ELSEIF (IP.LT.32) THEN
5388                IF (NP.LT.IP-3) IBACK = 1
5389             ELSEIF (IP.GE.32) THEN
5390                IF (IT.LE.150) THEN
5391 *   Example: S-Ag
5392                   IF (NP.LT.IP-1) IBACK = 1
5393                ELSE
5394 *   Example: S-Au
5395                   IF (NP.LT.IP) IBACK = 1
5396                ENDIF
5397             ENDIF
5398          ELSEIF (IP.EQ.IT) THEN
5399 *   Example: S-S
5400            IF (IP.EQ.32) THEN
5401               IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5402 *   Example: Pb-Pb
5403            ELSE
5404               IF (NP.LT.IP-IP/4) IBACK = 1
5405            ENDIF
5406          ELSEIF (ABS(IP-IT).LT.3) THEN
5407             IF (NP.LT.IP-IP/8) IBACK = 1
5408          ENDIF
5409       ENDIF
5410
5411       ICCPRO = ICCPRO+1
5412
5413       RETURN
5414       END
5415
5416 *$ CREATE DT_ININUC.FOR
5417 *COPY DT_ININUC
5418 *
5419 *===ininuc=============================================================*
5420 *
5421       SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5422
5423 ************************************************************************
5424 * Samples initial configuration of nucleons in nucleus with mass NMASS *
5425 * including Fermi-momenta (if reqested).                               *
5426 *          ID             BAMJET-code for hadrons (instead of nuclei)  *
5427 *          NMASS          mass number of nucleus (number of nucleons)  *
5428 *          NCH            charge of nucleus                            *
5429 *          COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5430 *          JS(NMASS) > 0  nucleon undergoes nucleon-nucleon interact.  *
5431 *          IMODE = 1      projectile nucleus                           *
5432 *                = 2      target     nucleus                           *
5433 *                = 3      target     nucleus (E_lab<E_thr for HADRIN)  *
5434 * Adopted from a part of the old KKEVT routine which was written by    *
5435 * J. Ranft/H.-J.Moehring.                                              *
5436 * This version dated 13.01.95 is written by S. Roesler                 *
5437 ************************************************************************
5438
5439       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5440       SAVE
5441       PARAMETER ( LINP = 10 ,
5442      &            LOUT = 6 ,
5443      &            LDAT = 9 )
5444       PARAMETER (FM2MM=1.0D-12)
5445
5446       PARAMETER ( MAXNCL = 260,
5447      &            MAXVQU = MAXNCL,
5448      &            MAXSQU = 20*MAXVQU,
5449      &            MAXINT = MAXVQU+MAXSQU)
5450 * event history
5451       PARAMETER (NMXHKK=200000)
5452       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5453      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5454      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5455 * extended event history
5456       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5457      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5458      &                IHIST(2,NMXHKK)
5459 * flags for input different options
5460       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5461       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5462      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5463 * auxiliary common for chain system storage (DTUNUC 1.x)
5464       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5465 * nuclear potential
5466       LOGICAL LFERMI
5467       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5468      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5469      &                ETACOU(2),ICOUL,LFERMI
5470 * properties of photon/lepton projectiles
5471       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5472 * particle properties (BAMJET index convention)
5473       CHARACTER*8  ANAME
5474       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5475      &                IICH(210),IIBAR(210),K1(210),K2(210)
5476 * Glauber formalism: collision properties
5477       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5478      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5479 * flavors of partons (DTUNUC 1.x)
5480       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5481      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5482      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5483      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5484      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5485      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5486      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5487 * interface HADRIN-DPM
5488       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5489
5490       DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5491
5492 * number of neutrons
5493       NNEU = NMASS-NCH
5494 * initializations
5495       NP = 0
5496       NN = 0
5497       DO 1 K=1,4
5498          PFTOT(K) = 0.0D0
5499     1 CONTINUE
5500       MODE   = IMODE
5501       IF (IMODE.GT.2) MODE = 2
5502 **sr 29.5. new NPOINT(1)-definition
5503 C     IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5504 **
5505       NHADRI = 0
5506       NC     = NHKK
5507
5508 * get initial configuration
5509       DO 2 I=1,NMASS
5510          NHKK = NHKK+1
5511          IF (JS(I).GT.0) THEN
5512             ISTHKK(NHKK) = 10+MODE
5513             IF (IMODE.EQ.3) THEN
5514 *   additional treatment if HADRIN-generator is requested
5515                NHADRI = NHADRI+1
5516                IF (NHADRI.EQ.1) IDXTA  = NHKK
5517                IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5518             ENDIF
5519          ELSE
5520             ISTHKK(NHKK) = 12+MODE
5521          ENDIF
5522          IF (NMASS.GE.2) THEN
5523 *   treatment for nuclei
5524             FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5525             RR   = DT_RNDM(FRAC)
5526             IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5527                IDX = 8
5528                NN  = NN+1
5529             ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5530                IDX = 1
5531                NP  = NP+1
5532             ELSEIF (NN.LT.NNEU) THEN
5533                IDX = 8
5534                NN  = NN+1
5535             ELSEIF (NP.LT.NCH)  THEN
5536                IDX = 1
5537                NP  = NP+1
5538             ENDIF
5539             IDHKK(NHKK) = IDT_IPDGHA(IDX)
5540             IDBAM(NHKK) = IDX
5541             IF (MODE.EQ.1) THEN
5542                IPOSP(I)  = NHKK
5543                KKPROJ(I) = IDX
5544             ELSE
5545                IPOST(I)  = NHKK
5546                KKTARG(I) = IDX
5547             ENDIF
5548             IF (IDX.EQ.1) THEN
5549                PFER = PFERMP(MODE)
5550                PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5551             ELSE
5552                PFER = PFERMN(MODE)
5553                PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5554             ENDIF
5555             CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5556             DO 3 K=1,4
5557                PFTOT(K) = PFTOT(K)+PF(K)
5558                PHKK(K,NHKK) = PF(K)
5559     3       CONTINUE
5560             PHKK(5,NHKK) = AAM(IDX)
5561          ELSE
5562 *   treatment for hadrons
5563             IDHKK(NHKK)  = IDT_IPDGHA(ID)
5564             IDBAM(NHKK)  = ID
5565             PHKK(4,NHKK) = AAM(ID)
5566             PHKK(5,NHKK) = AAM(ID)
5567 C* VDM assumption
5568 C            IF (IDHKK(NHKK).EQ.22) THEN
5569 C               PHKK(4,NHKK) = AAM(33)
5570 C               PHKK(5,NHKK) = AAM(33)
5571 C            ENDIF
5572             IF (MODE.EQ.1) THEN
5573                IPOSP(I)  = NHKK
5574                KKPROJ(I) = ID
5575                PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5576             ELSE
5577                IPOST(I)  = NHKK
5578                KKTARG(I) = ID
5579             ENDIF
5580          ENDIF
5581          DO 4 K=1,3
5582             VHKK(K,NHKK) = COORD(K,I)*FM2MM
5583             WHKK(K,NHKK) = COORD(K,I)*FM2MM
5584     4    CONTINUE
5585          IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5586          IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5587          VHKK(4,NHKK) = 0.0D0
5588          WHKK(4,NHKK) = 0.0D0
5589     2 CONTINUE
5590
5591 * balance Fermi-momenta
5592       IF (NMASS.GE.2) THEN
5593          DO 5 I=1,NMASS
5594             NC = NC+1
5595             DO 6 K=1,3
5596                PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5597     6       CONTINUE
5598             PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5599      &                        PHKK(2,NC)**2+PHKK(3,NC)**2)
5600     5    CONTINUE
5601       ENDIF
5602
5603       RETURN
5604       END
5605
5606 *$ CREATE DT_FER4M.FOR
5607 *COPY DT_FER4M
5608 *
5609 *===fer4m==============================================================*
5610 *
5611       SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
5612
5613 ************************************************************************
5614 * Sampling of nucleon Fermi-momenta from distributions at T=0.         *
5615 *                                   processed by S. Roesler, 17.10.95  *
5616 ************************************************************************
5617
5618       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5619       SAVE
5620       PARAMETER ( LINP = 10 ,
5621      &            LOUT = 6 ,
5622      &            LDAT = 9 )
5623
5624       LOGICAL LSTART
5625
5626 * particle properties (BAMJET index convention)
5627       CHARACTER*8  ANAME
5628       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5629      &                IICH(210),IIBAR(210),K1(210),K2(210)
5630 * nuclear potential
5631       LOGICAL LFERMI
5632       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5633      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5634      &                ETACOU(2),ICOUL,LFERMI
5635
5636       DATA LSTART /.TRUE./
5637
5638       ILOOP = 0
5639       IF (LFERMI) THEN
5640          IF (LSTART) THEN
5641             WRITE(LOUT,1000)
5642  1000       FORMAT(/,1X,'FER4M:   sampling of Fermi-momenta activated')
5643             LSTART = .FALSE.
5644          ENDIF
5645     1    CONTINUE
5646          CALL DT_DFERMI(PABS)
5647          PABS = PFERM*PABS
5648 C        IF (PABS.GE.PBIND) THEN
5649 C           ILOOP = ILOOP+1
5650 C           IF (MOD(ILOOP,500).EQ.0) THEN
5651 C              WRITE(LOUT,1001) PABS,PBIND,ILOOP
5652 C1001          FORMAT(1X,'FER4M:    Fermi-mom. corr. for binding',
5653 C    &                ' energy ',2E12.3,I6)
5654 C           ENDIF
5655 C           GOTO 1
5656 C        ENDIF
5657          CALL DT_DPOLI(POLC,POLS)
5658          CALL DT_DSFECF(SFE,CFE)
5659          CXTA = POLS*CFE
5660          CYTA = POLS*SFE
5661          CZTA = POLC
5662          ET   = SQRT(PABS*PABS+AAM(KT)**2)
5663          PXT  = CXTA*PABS
5664          PYT  = CYTA*PABS
5665          PZT  = CZTA*PABS
5666       ELSE
5667          ET   = AAM(KT)
5668          PXT  = 0.0D0
5669          PYT  = 0.0D0
5670          PZT  = 0.0D0
5671       ENDIF
5672
5673       RETURN
5674       END
5675
5676 *$ CREATE DT_NUC2CM.FOR
5677 *COPY DT_NUC2CM
5678 *
5679 *===nuc2cm=============================================================*
5680 *
5681       SUBROUTINE DT_NUC2CM
5682
5683 ************************************************************************
5684 * Lorentz-transformation of all wounded nucleons from Lab. to nucl.-   *
5685 * nucl. cms. (This subroutine replaces NUCMOM.)                        *
5686 * This version dated 15.01.95 is written by S. Roesler                 *
5687 ************************************************************************
5688
5689       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5690       SAVE
5691       PARAMETER ( LINP = 10 ,
5692      &            LOUT = 6 ,
5693      &            LDAT = 9 )
5694       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
5695
5696 * event history
5697       PARAMETER (NMXHKK=200000)
5698       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5699      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5700      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5701 * extended event history
5702       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5703      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5704      &                IHIST(2,NMXHKK)
5705 * statistics
5706       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5707      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5708      &                ICEVTG(8,0:30)
5709 * properties of photon/lepton projectiles
5710       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5711 * particle properties (BAMJET index convention)
5712       CHARACTER*8  ANAME
5713       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5714      &                IICH(210),IIBAR(210),K1(210),K2(210)
5715 * Glauber formalism: collision properties
5716       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5717      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5718 **temporary
5719 * statistics: Glauber-formalism
5720       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5721 **
5722
5723       ICWP = 0
5724       ICWT = 0
5725       NWTACC = 0
5726       NWAACC = 0
5727       NWBACC = 0
5728
5729       NPOINT(1) = NHKK+1
5730       NEND      = NHKK
5731       DO 1 I=1,NEND
5732          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
5733             IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
5734             IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
5735             MODE = ISTHKK(I)-9
5736 C            IF (IDHKK(I).EQ.22) THEN
5737 C* VDM assumption
5738 C               PEIN = AAM(33)
5739 C               IDB  = 33
5740 C            ELSE
5741 C               PEIN = PHKK(4,I)
5742 C               IDB  = IDBAM(I)
5743 C            ENDIF
5744 C            CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
5745 C     &           PX,PY,PZ,PE,IDB,MODE)
5746             IF (PHKK(5,I).GT.ZERO) THEN
5747                CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
5748      &              PX,PY,PZ,PE,IDBAM(I),MODE)
5749             ELSE
5750                PX = PGAMM(1)
5751                PY = PGAMM(2)
5752                PZ = PGAMM(3)
5753                PE = PGAMM(4)
5754             ENDIF
5755             IST = ISTHKK(I)-2
5756             ID  = IDHKK(I)
5757 C* VDM assumption
5758 C            IF (ID.EQ.22) ID = 113
5759             CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
5760             IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
5761             IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
5762          ENDIF
5763     1 CONTINUE
5764
5765       NWTACC = MAX(NWAACC,NWBACC)
5766       ICDPR  = ICDPR+ICWP
5767       ICDTA  = ICDTA+ICWT
5768 **temporary
5769       IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
5770          CALL DT_EVTOUT(4)
5771          STOP
5772       ENDIF
5773
5774       RETURN
5775       END
5776
5777 *$ CREATE DT_SPLPTN.FOR
5778 *COPY DT_SPLPTN
5779 *
5780 *===splptn=============================================================*
5781 *
5782       SUBROUTINE DT_SPLPTN(NN)
5783
5784 ************************************************************************
5785 * SamPLing of ParToN momenta and flavors.                              *
5786 * This version dated 15.01.95 is written by S. Roesler                 *
5787 ************************************************************************
5788
5789       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5790       SAVE
5791       PARAMETER ( LINP = 10 ,
5792      &            LOUT = 6 ,
5793      &            LDAT = 9 )
5794
5795 * Lorentz-parameters of the current interaction
5796       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5797      &                UMO,PPCM,EPROJ,PPROJ
5798
5799 * sample flavors of sea-quarks
5800       CALL DT_SPLFLA(NN,1)
5801
5802 * sample x-values of partons at chain ends
5803       ECM = UMO
5804       CALL DT_XKSAMP(NN,ECM)
5805
5806 * samle flavors
5807       CALL DT_SPLFLA(NN,2)
5808
5809       RETURN
5810       END
5811
5812 *$ CREATE DT_SPLFLA.FOR
5813 *COPY DT_SPLFLA
5814 *
5815 *===splfla=============================================================*
5816 *
5817       SUBROUTINE DT_SPLFLA(NN,MODE)
5818
5819 ************************************************************************
5820 * SamPLing of FLAvors of partons at chain ends.                        *
5821 * This subroutine replaces FLKSAA/FLKSAM.                              *
5822 *            NN            number of nucleon-nucleon interactions      *
5823 *            MODE = 1      sea-flavors                                 *
5824 *                 = 2      valence-flavors                             *
5825 * Based on the original version written by J. Ranft/H.-J. Moehring.    *
5826 * This version dated 16.01.95 is written by S. Roesler                 *
5827 ************************************************************************
5828
5829       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5830       SAVE
5831       PARAMETER ( LINP = 10 ,
5832      &            LOUT = 6 ,
5833      &            LDAT = 9 )
5834
5835       PARAMETER ( MAXNCL = 260,
5836      &            MAXVQU = MAXNCL,
5837      &            MAXSQU = 20*MAXVQU,
5838      &            MAXINT = MAXVQU+MAXSQU)
5839 * flavors of partons (DTUNUC 1.x)
5840       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5841      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5842      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5843      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5844      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5845      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5846      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5847 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5848       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5849      &                IXPV,IXPS,IXTV,IXTS,
5850      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
5851      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
5852      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
5853      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
5854      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
5855      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
5856      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
5857      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
5858 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5859       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5860      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5861 * particle properties (BAMJET index convention)
5862       CHARACTER*8  ANAME
5863       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5864      &                IICH(210),IIBAR(210),K1(210),K2(210)
5865 * various options for treatment of partons (DTUNUC 1.x)
5866 * (chain recombination, Cronin,..)
5867       LOGICAL LCO2CR,LINTPT
5868       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
5869      &                LCO2CR,LINTPT
5870
5871       IF (MODE.EQ.1) THEN
5872 * sea-flavors
5873          DO 1 I=1,NN
5874             IPSQ(I)  = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5875             IPSAQ(I) = -IPSQ(I)
5876     1    CONTINUE
5877          DO 2 I=1,NN
5878             ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5879             ITSAQ(I)= -ITSQ(I)
5880     2    CONTINUE
5881       ELSEIF (MODE.EQ.2) THEN
5882 * valence flavors
5883          DO 3 I=1,IXPV
5884             CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
5885     3    CONTINUE
5886          DO 4 I=1,IXTV
5887             CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
5888     4    CONTINUE
5889       ENDIF
5890
5891       RETURN
5892       END
5893
5894 *$ CREATE DT_GETPTN.FOR
5895 *COPY DT_GETPTN
5896 *
5897 *===getptn=============================================================*
5898 *
5899       SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
5900
5901 ************************************************************************
5902 * This subroutine collects partons at chain ends from temporary        *
5903 * commons and puts them into DTEVT1.                                   *
5904 * This version dated 15.01.95 is written by S. Roesler                 *
5905 ************************************************************************
5906
5907       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5908       SAVE
5909       PARAMETER ( LINP = 10 ,
5910      &            LOUT = 6 ,
5911      &            LDAT = 9 )
5912       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
5913
5914       LOGICAL LCHK
5915
5916       PARAMETER ( MAXNCL = 260,
5917      &            MAXVQU = MAXNCL,
5918      &            MAXSQU = 20*MAXVQU,
5919      &            MAXINT = MAXVQU+MAXSQU)
5920 * event history
5921       PARAMETER (NMXHKK=200000)
5922       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5923      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5924      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5925 * extended event history
5926       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5927      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5928      &                IHIST(2,NMXHKK)
5929 * flags for input different options
5930       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5931       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5932      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5933 * auxiliary common for chain system storage (DTUNUC 1.x)
5934       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5935 * statistics
5936       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5937      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5938      &                ICEVTG(8,0:30)
5939 * flags for diffractive interactions (DTUNUC 1.x)
5940       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5941 * x-values of partons (DTUNUC 1.x)
5942       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
5943      &                XTVQ(MAXVQU),XTVD(MAXVQU),
5944      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
5945      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
5946 * flavors of partons (DTUNUC 1.x)
5947       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5948      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5949      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5950      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5951      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5952      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5953      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5954 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5955       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5956      &                IXPV,IXPS,IXTV,IXTS,
5957      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
5958      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
5959      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
5960      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
5961      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
5962      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
5963      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
5964      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
5965 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5966       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5967      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5968
5969       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
5970
5971       DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
5972
5973       IREJ      = 0
5974       NCSY      = 0
5975       NPOINT(2) = NHKK+1
5976
5977 * sea-sea chains
5978       DO 10 I=1,NSS
5979          IF (ISKPCH(1,I).EQ.99) GOTO 10
5980          ICCHAI(1,1) = ICCHAI(1,1)+2
5981          IDXP = INTSS1(I)
5982          IDXT = INTSS2(I)
5983          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
5984          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
5985          DO 11 K=1,4
5986             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
5987             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
5988             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
5989             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
5990    11    CONTINUE
5991          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
5992      &                                  +(PP1(3)+PT1(3))**2)
5993          ECH   = PP1(4)+PT1(4)
5994          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
5995          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
5996      &                                  +(PP2(3)+PT2(3))**2)
5997          ECH   = PP2(4)+PT2(4)
5998          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
5999          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6000             AM1 = SQRT(AM1)
6001             AM2 = SQRT(AM2)
6002             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6003 C              WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6004  5000          FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6005             ENDIF
6006          ELSE
6007             WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6008          ENDIF
6009          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6010          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6011          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6012          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6013          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6014      &                                                    0,0,1)
6015          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6016      &                                                    0,0,1)
6017          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6018      &                                                    0,0,1)
6019          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6020      &                                                    0,0,1)
6021          NCSY = NCSY+1
6022    10 CONTINUE
6023
6024 * disea-sea chains
6025       DO 20 I=1,NDS
6026          IF (ISKPCH(2,I).EQ.99) GOTO 20
6027          ICCHAI(1,2) = ICCHAI(1,2)+2
6028          IDXP = INTDS1(I)
6029          IDXT = INTDS2(I)
6030          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6031          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6032          DO 21 K=1,4
6033             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6034             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6035             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6036             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6037    21    CONTINUE
6038          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6039      &                                  +(PP1(3)+PT1(3))**2)
6040          ECH   = PP1(4)+PT1(4)
6041          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6042          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6043      &                                  +(PP2(3)+PT2(3))**2)
6044          ECH   = PP2(4)+PT2(4)
6045          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6046          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6047             AM1 = SQRT(AM1)
6048             AM2 = SQRT(AM2)
6049             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6050 C              WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6051  5001          FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6052             ENDIF
6053          ELSE
6054             WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6055          ENDIF
6056          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6057          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6058          IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6059          IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6060          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6061      &                                                    0,0,2)
6062          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6063      &                                                    0,0,2)
6064          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6065      &                                                    0,0,2)
6066          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6067      &                                                    0,0,2)
6068          NCSY = NCSY+1
6069    20 CONTINUE
6070
6071 * sea-disea chains
6072       DO 30 I=1,NSD
6073          IF (ISKPCH(3,I).EQ.99) GOTO 30
6074          ICCHAI(1,3) = ICCHAI(1,3)+2
6075          IDXP = INTSD1(I)
6076          IDXT = INTSD2(I)
6077          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6078          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6079          DO 31 K=1,4
6080             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6081             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6082             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6083             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6084    31    CONTINUE
6085          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6086      &                                  +(PP1(3)+PT1(3))**2)
6087          ECH   = PP1(4)+PT1(4)
6088          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6089          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6090      &                                  +(PP2(3)+PT2(3))**2)
6091          ECH   = PP2(4)+PT2(4)
6092          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6093          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6094             AM1 = SQRT(AM1)
6095             AM2 = SQRT(AM2)
6096             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6097 C              WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6098  5002          FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6099             ENDIF
6100          ELSE
6101             WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6102          ENDIF
6103          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6104          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6105          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6106          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6107          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6108      &                                                    0,0,3)
6109          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6110      &                                                    0,0,3)
6111          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6112      &                                                    0,0,3)
6113          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6114      &                                                    0,0,3)
6115          NCSY = NCSY+1
6116    30 CONTINUE
6117
6118 * disea-valence chains
6119       DO 50 I=1,NDV
6120          IF (ISKPCH(5,I).EQ.99) GOTO 50
6121          ICCHAI(1,5) = ICCHAI(1,5)+2
6122          IDXP = INTDV1(I)
6123          IDXT = INTDV2(I)
6124          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6125          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6126          DO 51 K=1,4
6127             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6128             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6129             PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6130             PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6131    51    CONTINUE
6132          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6133      &                                  +(PP1(3)+PT1(3))**2)
6134          ECH   = PP1(4)+PT1(4)
6135          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6136          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6137      &                                  +(PP2(3)+PT2(3))**2)
6138          ECH   = PP2(4)+PT2(4)
6139          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6140          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6141             AM1 = SQRT(AM1)
6142             AM2 = SQRT(AM2)
6143             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6144 C              WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6145  5003          FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6146             ENDIF
6147          ELSE
6148             WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6149          ENDIF
6150          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6151          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6152          IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6153          IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6154          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6155      &                                                    0,0,5)
6156          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6157      &                                                    0,0,5)
6158          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6159      &                                                    0,0,5)
6160          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6161      &                                                    0,0,5)
6162          NCSY = NCSY+1
6163    50 CONTINUE
6164
6165 * valence-sea chains
6166       DO 60 I=1,NVS
6167          IF (ISKPCH(6,I).EQ.99) GOTO 60
6168          ICCHAI(1,6) = ICCHAI(1,6)+2
6169          IDXP = INTVS1(I)
6170          IDXT = INTVS2(I)
6171          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6172          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6173          DO 61 K=1,4
6174             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6175             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6176             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6177             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6178    61    CONTINUE
6179          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6180          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6181          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6182          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6183          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6184          IF (LCHK) THEN
6185             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6186      &                                                       0,0,6)
6187             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6188      &                                                       0,0,6)
6189             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6190      &                                                       0,0,6)
6191             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6192      &                                                       0,0,6)
6193             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6194      &                                     +(PP1(3)+PT1(3))**2)
6195             ECH   = PP1(4)+PT1(4)
6196             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6197             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6198      &                                     +(PP2(3)+PT2(3))**2)
6199             ECH   = PP2(4)+PT2(4)
6200             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6201          ELSE
6202             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6203      &                                                       0,0,6)
6204             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6205      &                                                       0,0,6)
6206             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6207      &                                                       0,0,6)
6208             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6209      &                                                       0,0,6)
6210             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6211      &                                     +(PP1(3)+PT2(3))**2)
6212             ECH   = PP1(4)+PT2(4)
6213             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6214             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6215      &                                     +(PP2(3)+PT1(3))**2)
6216             ECH   = PP2(4)+PT1(4)
6217             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6218          ENDIF
6219          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6220             AM1 = SQRT(AM1)
6221             AM2 = SQRT(AM2)
6222             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6223 C              WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6224  5004          FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6225             ENDIF
6226          ELSE
6227             WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6228          ENDIF
6229          NCSY = NCSY+1
6230    60 CONTINUE
6231
6232 * sea-valence chains
6233       DO 40 I=1,NSV
6234          IF (ISKPCH(4,I).EQ.99) GOTO 40
6235          ICCHAI(1,4) = ICCHAI(1,4)+2
6236          IDXP = INTSV1(I)
6237          IDXT = INTSV2(I)
6238          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6239          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6240          DO 41 K=1,4
6241             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6242             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6243             PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6244             PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6245    41    CONTINUE
6246          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6247      &                                  +(PP1(3)+PT1(3))**2)
6248          ECH   = PP1(4)+PT1(4)
6249          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6250          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6251      &                                  +(PP2(3)+PT2(3))**2)
6252          ECH   = PP2(4)+PT2(4)
6253          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6254          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6255             AM1 = SQRT(AM1)
6256             AM2 = SQRT(AM2)
6257             IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6258 C              WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6259  5005          FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6260             ENDIF
6261          ELSE
6262             WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6263          ENDIF
6264          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6265          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6266          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6267          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6268          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6269      &                                                    0,0,4)
6270          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6271      &                                                    0,0,4)
6272          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6273      &                                                    0,0,4)
6274          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6275      &                                                    0,0,4)
6276          NCSY = NCSY+1
6277    40 CONTINUE
6278
6279 * valence-disea chains
6280       DO 70 I=1,NVD
6281          IF (ISKPCH(7,I).EQ.99) GOTO 70
6282          ICCHAI(1,7) = ICCHAI(1,7)+2
6283          IDXP = INTVD1(I)
6284          IDXT = INTVD2(I)
6285          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6286          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6287          DO 71 K=1,4
6288             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6289             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6290             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6291             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6292    71    CONTINUE
6293          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6294          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6295          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6296          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6297          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6298          IF (LCHK) THEN
6299             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6300      &                                                       0,0,7)
6301             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6302      &                                                       0,0,7)
6303             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6304      &                                                       0,0,7)
6305             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6306      &                                                       0,0,7)
6307             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6308      &                                     +(PP1(3)+PT1(3))**2)
6309             ECH   = PP1(4)+PT1(4)
6310             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6311             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6312      &                                     +(PP2(3)+PT2(3))**2)
6313             ECH   = PP2(4)+PT2(4)
6314             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6315          ELSE
6316             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6317      &                                                       0,0,7)
6318             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6319      &                                                       0,0,7)
6320             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6321      &                                                       0,0,7)
6322             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6323      &                                                       0,0,7)
6324             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6325      &                                     +(PP1(3)+PT2(3))**2)
6326             ECH   = PP1(4)+PT2(4)
6327             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6328             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6329      &                                     +(PP2(3)+PT1(3))**2)
6330             ECH   = PP2(4)+PT1(4)
6331             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6332          ENDIF
6333          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6334             AM1 = SQRT(AM1)
6335             AM2 = SQRT(AM2)
6336             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6337 C              WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6338  5006          FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6339             ENDIF
6340          ELSE
6341             WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6342          ENDIF
6343          NCSY = NCSY+1
6344    70 CONTINUE
6345
6346 * valence-valence chains
6347       DO 80 I=1,NVV
6348          IF (ISKPCH(8,I).EQ.99) GOTO 80
6349          ICCHAI(1,8) = ICCHAI(1,8)+2
6350          IDXP = INTVV1(I)
6351          IDXT = INTVV2(I)
6352          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6353          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6354          DO 81 K=1,4
6355             PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6356             PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6357             PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6358             PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6359    81    CONTINUE
6360          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6361          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6362          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6363          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6364
6365 * check for diffractive event
6366          IDIFF = 0
6367          IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6368      &        (IP.EQ.1).AND.(NN.EQ.1)) THEN
6369             DO 800 K=1,4
6370                PP(K) = PP1(K)+PP2(K)
6371                PT(K) = PT1(K)+PT2(K)
6372   800       CONTINUE
6373             ISTCK = NHKK
6374             CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6375      &                  IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6376 C           IF (IREJ1.NE.0) GOTO 9999
6377             IF (IREJ1.NE.0) THEN
6378                IDIFF = 0
6379                NHKK  = ISTCK
6380             ENDIF
6381          ELSE
6382             IDIFF = 0
6383          ENDIF
6384
6385          IF (IDIFF.EQ.0) THEN
6386 *   valence-valence chain system
6387             CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6388             IF (LCHK) THEN
6389 *    baryon-baryon
6390                CALL DT_EVTPUT(-21,IFP1,MOP,0,
6391      &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6392                CALL DT_EVTPUT(-22,IFT1,MOT,0,
6393      &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6394                CALL DT_EVTPUT(-21,IFP2,MOP,0,
6395      &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6396                CALL DT_EVTPUT(-22,IFT2,MOT,0,
6397      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6398                PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6399      &                                        +(PP1(3)+PT1(3))**2)
6400                ECH   = PP1(4)+PT1(4)
6401                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6402                PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6403      &                                        +(PP2(3)+PT2(3))**2)
6404                ECH   = PP2(4)+PT2(4)
6405                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6406             ELSE
6407 *    antibaryon-baryon
6408                CALL DT_EVTPUT(-21,IFP1,MOP,0,
6409      &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6410                CALL DT_EVTPUT(-22,IFT2,MOT,0,
6411      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6412                CALL DT_EVTPUT(-21,IFP2,MOP,0,
6413      &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6414                CALL DT_EVTPUT(-22,IFT1,MOT,0,
6415      &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6416                PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6417      &                                        +(PP1(3)+PT2(3))**2)
6418                ECH   = PP1(4)+PT2(4)
6419                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6420                PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6421      &                                        +(PP2(3)+PT1(3))**2)
6422                ECH   = PP2(4)+PT1(4)
6423                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6424             ENDIF
6425             IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6426                AM1 = SQRT(AM1)
6427                AM2 = SQRT(AM2)
6428                IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6429 C                 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6430  5007             FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6431                ENDIF
6432             ELSE
6433                WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6434             ENDIF
6435             NCSY = NCSY+1
6436          ENDIF
6437    80 CONTINUE
6438       IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6439
6440 * energy-momentum & flavor conservation check
6441       IF (ABS(IDIFF).NE.1) THEN
6442          IF (IDIFF.NE.0) THEN
6443             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6444      &                                              1,3,10,IREJ)
6445          ELSE
6446             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6447      &                                              1,3,10,IREJ)
6448          ENDIF
6449          IF (IREJ.NE.0) THEN
6450             CALL DT_EVTOUT(4)
6451             STOP
6452          ENDIF
6453       ENDIF
6454
6455       RETURN
6456
6457  9999 CONTINUE
6458       IREJ  = 1
6459       RETURN
6460       END
6461
6462 *$ CREATE DT_CHKCSY.FOR
6463 *COPY DT_CHKCSY
6464 *
6465 *===chkcsy=============================================================*
6466 *
6467       SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6468
6469 ************************************************************************
6470 * CHeCk Chain SYstem for consistency of partons at chain ends.         *
6471 *            ID1,ID2        PDG-numbers of partons at chain ends       *
6472 *            LCHK = .true.  consistent chain                           *
6473 *                 = .false. inconsistent chain                         *
6474 * This version dated 18.01.95 is written by S. Roesler                 *
6475 ************************************************************************
6476
6477       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6478       SAVE
6479       PARAMETER ( LINP = 10 ,
6480      &            LOUT = 6 ,
6481      &            LDAT = 9 )
6482
6483       LOGICAL LCHK
6484
6485       LCHK = .TRUE.
6486
6487 * q-aq chain
6488       IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6489          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6490 * q-qq, aq-aqaq chain
6491       ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6492      &        ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6493          IF (ID1*ID2.LT.0) LCHK = .FALSE.
6494 * qq-aqaq chain
6495       ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6496          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6497       ENDIF
6498
6499       RETURN
6500       END
6501
6502 *$ CREATE DT_EVENTA.FOR
6503 *COPY DT_EVENTA
6504 *
6505 *===eventa=============================================================*
6506 *
6507       SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6508
6509 ************************************************************************
6510 * Treatment of nucleon-nucleon interactions in a two-chain             *
6511 * approximation.                                                       *
6512 *  (input) ID       BAMJET-index of projectile hadron (in case of      *
6513 *                   h-K scattering)                                    *
6514 *          IP/IT    mass number of projectile/target nucleus           *
6515 *          NCSY     number of two chain systems                        *
6516 *          IREJ     rejection flag                                     *
6517 * This version dated 15.01.95 is written by S. Roesler                 *
6518 ************************************************************************
6519
6520       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6521       SAVE
6522       PARAMETER ( LINP = 10 ,
6523      &            LOUT = 6 ,
6524      &            LDAT = 9 )
6525       PARAMETER (TINY10=1.0D-10)
6526
6527 * event history
6528       PARAMETER (NMXHKK=200000)
6529       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6530      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6531      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6532 * extended event history
6533       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6534      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6535      &                IHIST(2,NMXHKK)
6536 * rejection counter
6537       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6538      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6539      &                IREXCI(3),IRDIFF(2),IRINC
6540 * flags for diffractive interactions (DTUNUC 1.x)
6541       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6542 * particle properties (BAMJET index convention)
6543       CHARACTER*8  ANAME
6544       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6545      &                IICH(210),IIBAR(210),K1(210),K2(210)
6546 * flags for input different options
6547       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6548       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6549      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6550 * various options for treatment of partons (DTUNUC 1.x)
6551 * (chain recombination, Cronin,..)
6552       LOGICAL LCO2CR,LINTPT
6553       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6554      &                LCO2CR,LINTPT
6555
6556       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
6557
6558       IREJ      = 0
6559       NPOINT(3) = NHKK+1
6560
6561 * skip following treatment for low-mass diffraction
6562       IF (ABS(IFLAGD).EQ.1) THEN
6563          NPOINT(3) = NPOINT(2)
6564          GOTO 5
6565       ENDIF
6566
6567 * multiple scattering of chain ends
6568       IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
6569       IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
6570
6571       NC = NPOINT(2)
6572 * get a two-chain system from DTEVT1
6573       DO 3 I=1,NCSY
6574          IFP1 = IDHKK(NC)
6575          IFT1 = IDHKK(NC+1)
6576          IFP2 = IDHKK(NC+2)
6577          IFT2 = IDHKK(NC+3)
6578          DO 4 K=1,4
6579             PP1(K) = PHKK(K,NC)
6580             PT1(K) = PHKK(K,NC+1)
6581             PP2(K) = PHKK(K,NC+2)
6582             PT2(K) = PHKK(K,NC+3)
6583     4    CONTINUE
6584          MOP1 = NC
6585          MOT1 = NC+1
6586          MOP2 = NC+2
6587          MOT2 = NC+3
6588          CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
6589      &               IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
6590          IF (IREJ1.GT.0) THEN
6591             IRHHA = IRHHA+1
6592             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
6593             GOTO 9999
6594          ENDIF
6595          NC = NC+4
6596     3 CONTINUE
6597
6598 * meson/antibaryon projectile:
6599 * sample single-chain valence-valence systems (Reggeon contrib.)
6600       IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
6601          IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
6602       ENDIF
6603
6604       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6605 * check DTEVT1 for remaining resonance mass corrections
6606          CALL DT_EVTRES(IREJ1)
6607          IF (IREJ1.GT.0) THEN
6608             IRRES(1) = IRRES(1)+1
6609             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
6610             GOTO 9999
6611          ENDIF
6612       ENDIF
6613
6614 * assign p_t to two-"chain" systems consisting of two resonances only
6615 * since only entries for chains will be affected, this is obsolete
6616 * in case of JETSET-fragmetation
6617       CALL DT_RESPT
6618
6619 * combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
6620       IF (LCO2CR) CALL DT_COM2CR
6621
6622     5 CONTINUE
6623
6624 * fragmentation of the complete event
6625 **uncomment for internal phojet-fragmentation
6626 C     CALL DT_EVTFRA(IREJ1)
6627       CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
6628       IF (IREJ1.GT.0) THEN
6629          IRFRAG = IRFRAG+1
6630          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
6631          GOTO 9999
6632       ENDIF
6633
6634 * decay of possible resonances (should be obsolete)
6635       CALL DT_DECAY1
6636
6637       RETURN
6638
6639  9999 CONTINUE
6640       IREVT = IREVT+1
6641       IREJ  = 1
6642       RETURN
6643       END
6644
6645 *$ CREATE DT_GETCSY.FOR
6646 *COPY DT_GETCSY
6647 *
6648 *===getcsy=============================================================*
6649 *
6650       SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
6651      &                  IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
6652
6653 ************************************************************************
6654 * This version dated 15.01.95 is written by S. Roesler                 *
6655 ************************************************************************
6656
6657       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6658       SAVE
6659       PARAMETER ( LINP = 10 ,
6660      &            LOUT = 6 ,
6661      &            LDAT = 9 )
6662       PARAMETER (TINY10=1.0D-10)
6663
6664 * event history
6665       PARAMETER (NMXHKK=200000)
6666       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6667      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6668      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6669 * extended event history
6670       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6671      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6672      &                IHIST(2,NMXHKK)
6673 * rejection counter
6674       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6675      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6676      &                IREXCI(3),IRDIFF(2),IRINC
6677 * flags for input different options
6678       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6679       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6680      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6681 * flags for diffractive interactions (DTUNUC 1.x)
6682       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6683
6684       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
6685      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
6686
6687       IREJ  = 0
6688
6689 * get quark content of partons
6690       DO 1 I=1,2
6691          IFP1(I) = 0
6692          IFP2(I) = 0
6693          IFT1(I) = 0
6694          IFT2(I) = 0
6695     1 CONTINUE
6696       IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
6697       IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
6698       IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
6699       IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
6700       IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
6701       IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
6702       IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
6703       IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
6704
6705 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
6706       IDCH1 = 2
6707       IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
6708       IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
6709       IDCH2 = 2
6710       IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
6711       IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
6712
6713 * store initial configuration for energy-momentum cons. check
6714       IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
6715
6716 * sample intrinsic p_t at chain-ends
6717       CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
6718      &            PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
6719      &            AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
6720       IF (IREJ1.NE.0) THEN
6721          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
6722          IRPT = IRPT+1
6723          GOTO 9999
6724       ENDIF
6725
6726 C      IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6727 C         IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
6728 C* check second chain for resonance
6729 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6730 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
6731 C            IF (IREJ1.NE.0) GOTO 9999
6732 C            IF (IDR2.NE.0) THEN
6733 C               CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6734 C     &                     AMCH2,AMCH2N,AMCH1,IREJ1)
6735 C               IF (IREJ1.NE.0) GOTO 9999
6736 C            ENDIF
6737 C* check first chain for resonance
6738 C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6739 C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
6740 C            IF (IREJ1.NE.0) GOTO 9999
6741 C            IF (IDR1.NE.0) IDR1 = 100*IDR1
6742 C         ELSE
6743 C* check first chain for resonance
6744 C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6745 C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
6746 C            IF (IREJ1.NE.0) GOTO 9999
6747 C            IF (IDR1.NE.0) THEN
6748 C               CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6749 C     &                     AMCH1,AMCH1N,AMCH2,IREJ1)
6750 C               IF (IREJ1.NE.0) GOTO 9999
6751 C            ENDIF
6752 C* check second chain for resonance
6753 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6754 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
6755 C            IF (IREJ1.NE.0) GOTO 9999
6756 C            IF (IDR2.NE.0) IDR2 = 100*IDR2
6757 C         ENDIF
6758 C      ENDIF
6759
6760       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6761 * check chains for resonances
6762          CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6763      &               AMCH1,AMCH1N,IDCH1,IREJ1)
6764          IF (IREJ1.NE.0) GOTO 9999
6765          CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6766      &               AMCH2,AMCH2N,IDCH2,IREJ1)
6767          IF (IREJ1.NE.0) GOTO 9999
6768 * change kinematics corresponding to resonance-masses
6769          IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
6770             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6771      &                                 AMCH1,AMCH1N,AMCH2,IREJ1)
6772             IF (IREJ1.GT.0) GOTO 9999
6773             IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6774             CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6775      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
6776             IF (IREJ1.NE.0) GOTO 9999
6777             IF (IDR2.NE.0) IDR2 = 100*IDR2
6778          ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
6779             CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6780      &                                 AMCH2,AMCH2N,AMCH1,IREJ1)
6781             IF (IREJ1.GT.0) GOTO 9999
6782             IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6783             CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6784      &                  AMCH1,AMCH1N,IDCH1,IREJ1)
6785             IF (IREJ1.NE.0) GOTO 9999
6786             IF (IDR1.NE.0) IDR1 = 100*IDR1
6787          ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
6788             AMDIF1 = ABS(AMCH1-AMCH1N)
6789             AMDIF2 = ABS(AMCH2-AMCH2N)
6790             IF (AMDIF2.LT.AMDIF1) THEN
6791                CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6792      &                                    AMCH2,AMCH2N,AMCH1,IREJ1)
6793                IF (IREJ1.GT.0) GOTO 9999
6794                IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6795                CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
6796      &                     IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
6797                IF (IREJ1.NE.0) GOTO 9999
6798                IF (IDR1.NE.0) IDR1 = 100*IDR1
6799             ELSE
6800                CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6801      &                                    AMCH1,AMCH1N,AMCH2,IREJ1)
6802                IF (IREJ1.GT.0) GOTO 9999
6803                IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6804                CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
6805      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
6806                IF (IREJ1.NE.0) GOTO 9999
6807                IF (IDR2.NE.0) IDR2 = 100*IDR2
6808             ENDIF
6809          ENDIF
6810       ENDIF
6811
6812 * store final configuration for energy-momentum cons. check
6813       IF (LEMCCK) THEN
6814          CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
6815          CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
6816          IF (IREJ1.NE.0) GOTO 9999
6817       ENDIF
6818
6819 * put partons and chains into DTEVT1
6820       DO 10 I=1,4
6821          PCH1(I) = PP1(I)+PT1(I)
6822          PCH2(I) = PP2(I)+PT2(I)
6823    10 CONTINUE
6824       CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
6825      &                                      PP1(3),PP1(4),0,0,0)
6826       CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
6827      &                                      PT1(3),PT1(4),0,0,0)
6828       KCH = 100+IDCH(MOP1)*10+1
6829       CALL DT_EVTPUT(KCH,88888,-2,-1,
6830      &           PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
6831       CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
6832      &                                      PP2(3),PP2(4),0,0,0)
6833       CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
6834      &                                      PT2(3),PT2(4),0,0,0)
6835       KCH = KCH+1
6836       CALL DT_EVTPUT(KCH,88888,-2,-1,
6837      &           PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
6838
6839       RETURN
6840
6841  9999 CONTINUE
6842       IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
6843 * "cancel" sea-sea chains
6844          CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
6845          IF (IREJ1.NE.0) GOTO 9998
6846 **sr 16.5. flag for EVENTB
6847          IREJ = -1
6848          RETURN
6849       ENDIF
6850  9998 CONTINUE
6851       IREJ = 1
6852       RETURN
6853       END
6854
6855 *$ CREATE DT_CHKINE.FOR
6856 *COPY DT_CHKINE
6857 *
6858 *===chkine=============================================================*
6859 *
6860       SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
6861      &                  AMCH1,AMCH1N,AMCH2,IREJ)
6862
6863 ************************************************************************
6864 * This subroutine replaces CORMOM.                                     *
6865 * This version dated 05.01.95 is written by S. Roesler                 *
6866 ************************************************************************
6867
6868       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6869       SAVE
6870       PARAMETER ( LINP = 10 ,
6871      &            LOUT = 6 ,
6872      &            LDAT = 9 )
6873       PARAMETER (TINY10=1.0D-10)
6874
6875 * flags for input different options
6876       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6877       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6878      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6879 * rejection counter
6880       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6881      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6882      &                IREXCI(3),IRDIFF(2),IRINC
6883
6884       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
6885      &          PP1I(4),PP2I(4),PT1I(4),PT2I(4)
6886
6887       IREJ  = 0
6888       JMSHL = IMSHL
6889
6890       SCALE  = AMCH1N/MAX(AMCH1,TINY10)
6891       DO 10 I=1,4
6892          PP1(I) = PP1I(I)
6893          PP2(I) = PP2I(I)
6894          PT1(I) = PT1I(I)
6895          PT2(I) = PT2I(I)
6896          PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
6897          PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
6898          PP1(I) = SCALE*PP1(I)
6899          PT1(I) = SCALE*PT1(I)
6900    10 CONTINUE
6901       IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
6902      &    (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
6903
6904       ECH = PP2(4)+PT2(4)
6905       PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
6906      &                               (PP2(3)+PT2(3))**2 )
6907       AMCH22 = (ECH-PCH)*(ECH+PCH)
6908       IF (AMCH22.LT.0.0D0) THEN
6909          IF (IOULEV(1).GT.0)
6910      &      WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
6911          GOTO 9997
6912       ENDIF
6913
6914       AMCH1 = AMCH1N
6915       AMCH2 = SQRT(AMCH22)
6916
6917 * put partons again on mass shell
6918    13 CONTINUE
6919       XM1 = 0.0D0
6920       XM2 = 0.0D0
6921       IF (JMSHL.EQ.1) THEN
6922          XM1 = PYMASS(IFP1)
6923          XM2 = PYMASS(IFT1)
6924       ENDIF
6925       CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
6926       IF (IREJ1.NE.0) THEN
6927          IF (JMSHL.EQ.0) GOTO 9998
6928          JMSHL = 0
6929          GOTO 13
6930       ENDIF
6931       JMSHL = IMSHL
6932       DO 11 I=1,4
6933          PP1(I) = P1(I)
6934          PT1(I) = P2(I)
6935    11 CONTINUE
6936    14 CONTINUE
6937       XM1 = 0.0D0
6938       XM2 = 0.0D0
6939       IF (JMSHL.EQ.1) THEN
6940          XM1 = PYMASS(IFP2)
6941          XM2 = PYMASS(IFT2)
6942       ENDIF
6943       CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
6944       IF (IREJ1.NE.0) THEN
6945          IF (JMSHL.EQ.0) GOTO 9998
6946          JMSHL = 0
6947          GOTO 14
6948       ENDIF
6949       DO 12 I=1,4
6950          PP2(I) = P1(I)
6951          PT2(I) = P2(I)
6952    12 CONTINUE
6953       DO 15 I=1,4
6954          PP1I(I) = PP1(I)
6955          PP2I(I) = PP2(I)
6956          PT1I(I) = PT1(I)
6957          PT2I(I) = PT2(I)
6958    15 CONTINUE
6959       RETURN
6960
6961  9997 IRCHKI(1) = IRCHKI(1)+1
6962 **sr
6963 C     GOTO 9999
6964       IREJ = -1
6965       RETURN
6966 **
6967  9998 IRCHKI(2) = IRCHKI(2)+1
6968
6969  9999 CONTINUE
6970       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
6971       IREJ = 1
6972       RETURN
6973       END
6974
6975 *$ CREATE DT_CH2RES.FOR
6976 *COPY DT_CH2RES
6977 *
6978 *===ch2res=============================================================*
6979 *
6980       SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
6981      &                  AM,AMN,IMODE,IREJ)
6982
6983 ************************************************************************
6984 * Check chains for resonance production.                               *
6985 * This subroutine replaces COMCMA/COBCMA/COMCM2                        *
6986 *    input:                                                            *
6987 *          IF1,2,3,4    input flavors (q,aq in any order)              *
6988 *          AM           chain mass                                     *
6989 *          MODE = 1     check q-aq chain for meson-resonance           *
6990 *               = 2     check q-qq, aq-aqaq chain for baryon-resonance *
6991 *               = 3     check qq-aqaq chain for lower mass cut         *
6992 *    output:                                                           *
6993 *          IDR = 0      no resonances found                            *
6994 *              = -1     pseudoscalar meson/octet baryon                *
6995 *              = 1      vector-meson/decuplet baryon                   *
6996 *          IDXR         BAMJET-index of corresponding resonance        *
6997 *          AMN          mass of corresponding resonance                *
6998 *                                                                      *
6999 *          IREJ         rejection flag                                 *
7000 * This version dated 06.01.95 is written by S. Roesler                 *
7001 ************************************************************************
7002
7003       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7004       SAVE
7005       PARAMETER ( LINP = 10 ,
7006      &            LOUT = 6 ,
7007      &            LDAT = 9 )
7008
7009 * particle properties (BAMJET index convention)
7010       CHARACTER*8  ANAME
7011       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7012      &                IICH(210),IIBAR(210),K1(210),K2(210)
7013 * quark-content to particle index conversion (DTUNUC 1.x)
7014       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7015      &                IA08(6,21),IA10(6,21)
7016 * rejection counter
7017       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7018      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7019      &                IREXCI(3),IRDIFF(2),IRINC
7020 * flags for input different options
7021       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7022       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7023      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7024
7025       DIMENSION IF(4),JF(4)
7026
7027 **sr 4.7. test
7028 C     DATA AMLOM,AMLOB /0.08D0,0.2D0/
7029       DATA AMLOM,AMLOB /0.1D0,0.7D0/
7030 **
7031 C     DATA AMLOM,AMLOB /0.001D0,0.001D0/
7032
7033       MODE = ABS(IMODE)
7034
7035       IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7036          WRITE(LOUT,1000) MODE
7037  1000    FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7038      &          1X,'        program stopped')
7039          STOP
7040       ENDIF
7041
7042       AMX  = AM
7043       IREJ = 0
7044       IDR  = 0
7045       IDXR = 0
7046       AMN  = AMX
7047       IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7048       IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7049
7050       IF(1) = IF1
7051       IF(2) = IF2
7052       IF(3) = IF3
7053       IF(4) = IF4
7054       NF = 0
7055       DO 100 I=1,4
7056          IF (IF(I).NE.0) THEN
7057             NF = NF+1
7058             JF(NF) = IF(I)
7059          ENDIF
7060   100 CONTINUE
7061       IF (NF.LE.MODE) THEN
7062          WRITE(LOUT,1001) MODE,IF
7063  1001    FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7064      &   I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7065          GOTO 9999
7066       ENDIF
7067
7068       GOTO (1,2,3) MODE
7069
7070 * check for meson resonance
7071     1 CONTINUE
7072       IFQ  = JF(1)
7073       IFAQ = ABS(JF(2))
7074       IF (JF(2).GT.0) THEN
7075          IFQ  = JF(2)
7076          IFAQ = ABS(JF(1))
7077       ENDIF
7078       IFPS = IMPS(IFAQ,IFQ)
7079       IFV  = IMVE(IFAQ,IFQ)
7080       AMPS = AAM(IFPS)
7081       AMV  = AAM(IFV)
7082       AMHI = AMV+0.3D0
7083       IF (AMX.LT.AMV) THEN
7084          IF (AMX.LT.AMPS) THEN
7085             IF (IMODE.GT.0) THEN
7086                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7087             ELSE
7088                IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7089             ENDIF
7090             LOMRES = LOMRES+1
7091          ENDIF
7092 *    replace chain by pseudoscalar meson
7093          IDR  = -1
7094          IDXR = IFPS
7095          AMN  = AMPS
7096       ELSEIF (AMX.LT.AMHI) THEN
7097 *    replace chain by vector-meson
7098          IDR  = 1
7099          IDXR = IFV
7100          AMN  = AMV
7101       ENDIF
7102       RETURN
7103
7104 * check for baryon resonance
7105     2 CONTINUE
7106       CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7107       AM8  = AAM(JB8)
7108       AM10 = AAM(JB10)
7109       AMHI = AM10+0.3D0
7110       IF (AMX.LT.AM10) THEN
7111          IF (AMX.LT.AM8) THEN
7112             IF (IMODE.GT.0) THEN
7113                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7114             ELSE
7115                IF (AMX.LT.0.8D0*AM8) GOTO 9999
7116             ENDIF
7117             LOBRES = LOBRES+1
7118          ENDIF
7119 *    replace chain by oktet baryon
7120          IDR  = -1
7121          IDXR = JB8
7122          AMN  = AM8
7123       ELSEIF (AMX.LT.AMHI) THEN
7124          IDR  = 1
7125          IDXR = JB10
7126          AMN  = AM10
7127       ENDIF
7128       RETURN
7129
7130 * check qq-aqaq for lower mass cut
7131     3 CONTINUE
7132 *   empirical definition of AMHI to allow for (b-antib)-pair prod.
7133       AMHI = 2.5D0
7134       IF (AMX.LT.AMHI) GOTO 9999
7135       RETURN
7136
7137  9999 CONTINUE
7138       IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7139      &    WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7140       IREJ = 1
7141       IRRES(2) = IRRES(2)+1
7142       RETURN
7143       END
7144
7145 *$ CREATE DT_RJSEAC.FOR
7146 *COPY DT_RJSEAC
7147 *
7148 *===rjseac=============================================================*
7149 *
7150       SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7151
7152 ************************************************************************
7153 * ReJection of SEA-sea Chains.                                         *
7154 *         MOP1/2       entries of projectile sea-partons in DTEVT1     *
7155 *         MOT1/2       entries of projectile sea-partons in DTEVT1     *
7156 * This version dated 16.01.95 is written by S. Roesler                 *
7157 ************************************************************************
7158
7159       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7160       SAVE
7161       PARAMETER ( LINP = 10 ,
7162      &            LOUT = 6 ,
7163      &            LDAT = 9 )
7164       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7165
7166 * event history
7167       PARAMETER (NMXHKK=200000)
7168       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7169      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7170      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7171 * extended event history
7172       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7173      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7174      &                IHIST(2,NMXHKK)
7175 * statistics
7176       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7177      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7178      &                ICEVTG(8,0:30)
7179
7180       DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7181
7182       IREJ = 0
7183
7184 * projectile sea q-aq-pair
7185 *    indices of sea-pair
7186       IDXSEA(1,1) = MOP1
7187       IDXSEA(1,2) = MOP2
7188 *    index of mother-nucleon
7189       IDXNUC(1)   = JMOHKK(1,MOP1)
7190 *    status of valence quarks to be corrected
7191       ISTVAL(1)   = -21
7192
7193 * target sea q-aq-pair
7194 *    indices of sea-pair
7195       IDXSEA(2,1) = MOT1
7196       IDXSEA(2,2) = MOT2
7197 *    index of mother-nucleon
7198       IDXNUC(2)   = JMOHKK(1,MOT1)
7199 *    status of valence quarks to be corrected
7200       ISTVAL(2)   = -22
7201
7202       DO 1 N=1,2
7203          IDONE = 0
7204          DO 2 I=NPOINT(2),NHKK
7205             IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7206      &          (JMOHKK(1,I).EQ.IDXNUC(N)))   THEN
7207 * valence parton found
7208 *    inrease 4-momentum by sea 4-momentum
7209                DO 3 K=1,4
7210                   PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7211      &                                  PHKK(K,IDXSEA(N,2))
7212     3          CONTINUE
7213                PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7214      &                              PHKK(2,I)**2-PHKK(3,I)**2))
7215 *    "cancel" sea-pair
7216                DO 4 J=1,2
7217                   ISTHKK(IDXSEA(N,J))   = 100
7218                   IDHKK(IDXSEA(N,J))    = 0
7219                   JMOHKK(1,IDXSEA(N,J)) = 0
7220                   JMOHKK(2,IDXSEA(N,J)) = 0
7221                   JDAHKK(1,IDXSEA(N,J)) = 0
7222                   JDAHKK(2,IDXSEA(N,J)) = 0
7223                   DO 5 K=1,4
7224                      PHKK(K,IDXSEA(N,J)) = ZERO
7225                      VHKK(K,IDXSEA(N,J)) = ZERO
7226                      WHKK(K,IDXSEA(N,J)) = ZERO
7227     5             CONTINUE
7228                   PHKK(5,IDXSEA(N,J)) = ZERO
7229     4          CONTINUE
7230                IDONE = 1
7231             ENDIF
7232     2    CONTINUE
7233          IF (IDONE.NE.1) THEN
7234             WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7235  1000       FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7236      &                '-record!',/,1X,'        sea-quark pairs   ',
7237      &                2I5,4X,2I5,'   could not be canceled!')
7238             GOTO 9999
7239          ENDIF
7240     1 CONTINUE
7241       ICRJSS = ICRJSS+1
7242       RETURN
7243
7244  9999 CONTINUE
7245       IREJ = 1
7246       RETURN
7247       END
7248
7249 *$ CREATE DT_VV2SCH.FOR
7250 *COPY DT_VV2SCH
7251 *
7252 *===vv2sch=============================================================*
7253 *
7254       SUBROUTINE DT_VV2SCH
7255
7256 ************************************************************************
7257 * Change Valence-Valence chain systems to Single CHain systems for     *
7258 * hadron-nucleus collisions with meson or antibaryon projectile.       *
7259 * (Reggeon contribution)                                               *
7260 * The single chain system is approximately treated as one chain and a  *
7261 * meson at rest.                                                       *
7262 * This version dated 18.01.95 is written by S. Roesler                 *
7263 ************************************************************************
7264
7265       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7266       SAVE
7267       PARAMETER ( LINP = 10 ,
7268      &            LOUT = 6 ,
7269      &            LDAT = 9 )
7270       PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7271
7272       LOGICAL LSTART
7273
7274 * event history
7275       PARAMETER (NMXHKK=200000)
7276       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7277      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7278      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7279 * extended event history
7280       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7281      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7282      &                IHIST(2,NMXHKK)
7283 * flags for input different options
7284       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7285       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7286      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7287 * statistics
7288       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7289      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7290      &                ICEVTG(8,0:30)
7291
7292       DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7293      &          PCH2(4)
7294
7295       DATA LSTART /.TRUE./
7296
7297       IFSC  = 0
7298       IF (LSTART) THEN
7299          WRITE(LOUT,1000)
7300  1000    FORMAT(/,1X,'VV2SCH:  Reggeon contribution to valance-',
7301      &          'valence chains treated')
7302          LSTART = .FALSE.
7303       ENDIF
7304
7305       NSTOP = NHKK
7306
7307 * get index of first chain
7308       DO 1 I=NPOINT(3),NHKK
7309          IF (IDHKK(I).EQ.88888) THEN
7310             NC = I
7311             GOTO 2
7312          ENDIF
7313     1 CONTINUE
7314
7315     2 CONTINUE
7316       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7317      &                        .AND.(NC.LT.NSTOP)) THEN
7318 * get valence-valence chains
7319          IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7320 *   get "mother"-hadron indices
7321             MO1   = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7322             MO2   = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7323             KPROJ = IDT_ICIHAD(IDHKK(MO1))
7324             KTARG = IDT_ICIHAD(IDHKK(MO2))
7325 *   Lab momentum of projectile hadron
7326             CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7327             PTOT  = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7328      &                                  PHKK(3,MO1)**2)
7329
7330             SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7331             IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7332                ICVV2S = ICVV2S+1
7333 *   single chain requested
7334 *      get flavors of chain-end partons
7335                MO(1) = JMOHKK(1,NC)
7336                MO(2) = JMOHKK(2,NC)
7337                MO(3) = JMOHKK(1,NC+3)
7338                MO(4) = JMOHKK(2,NC+3)
7339                DO 3 I=1,4
7340                   IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7341                   IF(I,2) = 0
7342                   IF (ABS(IDHKK(MO(I))).GE.1000)
7343      &               IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7344     3          CONTINUE
7345 *      which one is the q-aq chain?
7346 *        N1,N1+1 - DTEVT1-entries for q-aq system
7347 *        N2,N2+1 - DTEVT1-entries for the other chain
7348                IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7349                   K1 = 1
7350                   K2 = 3
7351                   N1 = NC-2
7352                   N2 = NC+1
7353                ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7354                   K1 = 3
7355                   K2 = 1
7356                   N1 = NC+1
7357                   N2 = NC-2
7358                ELSE
7359                   GOTO 10
7360                ENDIF
7361                DO 4 K=1,4
7362                   PP1(K) = PHKK(K,N1)
7363                   PT1(K) = PHKK(K,N1+1)
7364                   PP2(K) = PHKK(K,N2)
7365                   PT2(K) = PHKK(K,N2+1)
7366     4          CONTINUE
7367                AMCH1 = PHKK(5,N1+2)
7368                AMCH2 = PHKK(5,N2+2)
7369 *      get meson-identity corresponding to flavors of q-aq chain
7370                ITMP   = IRESRJ
7371                IRESRJ = 0
7372                CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7373      &                     ZERO,AMCH1N,1,IDUM)
7374                IRESRJ = ITMP
7375 *      change kinematics of chains
7376                CALL DT_CHKINE(PP1,IDHKK(N1),  PP2,IDHKK(N2),
7377      &                     PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7378      &                     AMCH1,AMCH1N,AMCH2,IREJ1)
7379                IF (IREJ1.NE.0) GOTO 10
7380 *      check second chain for resonance
7381                IDCHAI = 2
7382                IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7383                CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7384      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7385                IF (IREJ1.NE.0) GOTO 10
7386                IF (IDR2.NE.0) IDR2 = 100*IDR2
7387 *      add partons and chains to DTEVT1
7388                DO 5 K=1,4
7389                   PCH1(K) = PP1(K)+PT1(K)
7390                   PCH2(K) = PP2(K)+PT2(K)
7391     5          CONTINUE
7392                CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7393      &                                             PP1(3),PP1(4),0,0,0)
7394                CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7395      &                                      PT1(2),PT1(3),PT1(4),0,0,0)
7396                KCH = ISTHKK(N1+2)+100
7397                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7398      &                     PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7399                IDHKK(N1+2) = 22222
7400                CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7401      &                                             PP2(3),PP2(4),0,0,0)
7402                CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7403      &                                      PT2(2),PT2(3),PT2(4),0,0,0)
7404                KCH = ISTHKK(N2+2)+100
7405                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7406      &                     PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7407                IDHKK(N2+2) = 22222
7408             ENDIF
7409          ENDIF
7410       ELSE
7411          GOTO 11
7412       ENDIF
7413    10 CONTINUE
7414       NC = NC+6
7415       GOTO 2
7416
7417    11 CONTINUE
7418
7419       RETURN
7420       END
7421
7422 *$ CREATE DT_PHNSCH.FOR
7423 *COPY DT_PHNSCH
7424 *
7425 *=== phnsch ===========================================================*
7426 *
7427       DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7428
7429 *----------------------------------------------------------------------*
7430 *                                                                      *
7431 *     Probability for Hadron Nucleon Single CHain interactions:        *
7432 *                                                                      *
7433 *     Created on 30 december 1993  by    Alfredo Ferrari & Paola Sala  *
7434 *                                                   Infn - Milan       *
7435 *                                                                      *
7436 *     Last change on 04-jan-94     by    Alfredo Ferrari               *
7437 *                                                                      *
7438 *             modified by J.R.for use in DTUNUC  6.1.94                *
7439 *                                                                      *
7440 *     Input variables:                                                 *
7441 *                      Kp = hadron projectile index (Part numbering    *
7442 *                           scheme)                                    *
7443 *                   Ktarg = target nucleon index (1=proton, 8=neutron) *
7444 *                    Plab = projectile laboratory momentum (GeV/c)     *
7445 *     Output variable:                                                 *
7446 *                  Phnsch = probability per single chain (particle     *
7447 *                           exchange) interactions                     *
7448 *                                                                      *
7449 *----------------------------------------------------------------------*
7450
7451       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7452       SAVE
7453
7454       PARAMETER ( LUNOUT = 6  )
7455       PARAMETER ( LUNERR = 6  )
7456       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
7457       PARAMETER ( ZERZER = 0.D+00 )
7458       PARAMETER ( ONEONE = 1.D+00 )
7459       PARAMETER ( TWOTWO = 2.D+00 )
7460       PARAMETER ( FIVFIV = 5.D+00 )
7461       PARAMETER ( HLFHLF = 0.5D+00 )
7462
7463       PARAMETER ( NALLWP = 39   )
7464       PARAMETER ( IDMAXP = 210  )
7465
7466       DIMENSION ICHRGE(39),AM(39)
7467
7468 * particle properties (BAMJET index convention)
7469       CHARACTER*8  ANAME
7470       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7471      &                IICH(210),IIBAR(210),K1(210),K2(210)
7472
7473       DIMENSION KPTOIP(210)
7474 * auxiliary common for reggeon exchange (DTUNUC 1.x)
7475       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7476      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7477      &                IQTCHR(-6:6),MQUARK(3,39)
7478
7479       DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7480       DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7481 CPH      SAVE SGTCOE, IHLP
7482 CPH      SAVE IQFSC1, IQFSC2, IQBSC1, IQBSC2
7483       EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7484       EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7485       EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7486
7487 * Conversion from part to paprop numbering
7488       DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7489      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7490      & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7491
7492 *  1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7493       DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7494      &    2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7495 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7496       DATA  SGTCO1  /
7497 * 1st reaction: gamma p total
7498      &0.147 D+00, ZERZER  , ZERZER   , 0.0022D+00, -0.0170D+00,
7499 * 2nd reaction: gamma d total
7500      &0.300 D+00, ZERZER  , ZERZER   , 0.0095D+00, -0.057 D+00,
7501 * 3rd reaction: pi+ p total
7502      &16.4  D+00, 19.3D+00, -0.42D+00, 0.19  D+00, ZERZER     ,
7503 * 4th reaction: pi- p total
7504      &33.0  D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03  D+00,
7505 * 5th reaction: pi+/- d total
7506      &56.8  D+00, 42.2D+00, -1.45D+00, 0.65  D+00, -5.39  D+00,
7507 * 6th reaction: K+ p total
7508      &18.1  D+00, ZERZER  , ZERZER   , 0.26  D+00, -1.0   D+00,
7509 * 7th reaction: K+ n total
7510      &18.7  D+00, ZERZER  , ZERZER   , 0.21  D+00, -0.89  D+00,
7511 * 8th reaction: K+ d total
7512      &34.2  D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99  D+00,
7513 * 9th reaction: K- p total
7514      &32.1  D+00, ZERZER  , ZERZER   , 0.66  D+00, -5.6   D+00,
7515 * 10th reaction: K- n total
7516      &25.2  D+00, ZERZER  , ZERZER   , 0.38  D+00, -2.9   D+00/
7517 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7518       DATA  SGTCO2  /
7519 * 11th reaction: K- d total
7520      &57.6  D+00, ZERZER  , ZERZER   , 1.17  D+00, -9.5   D+00,
7521 * 12th reaction: p p total
7522      &48.0  D+00, ZERZER  , ZERZER   , 0.522 D+00, -4.51  D+00,
7523 * 13th reaction: p n total
7524      &47.30 D+00, ZERZER  , ZERZER   , 0.513 D+00, -4.27  D+00,
7525 * 14th reaction: p d total
7526      &91.3  D+00, ZERZER  , ZERZER   , 1.05  D+00, -8.8   D+00,
7527 * 15th reaction: pbar p total
7528      &38.4  D+00, 77.6D+00, -0.64D+00, 0.26  D+00, -1.2   D+00,
7529 * 16th reaction: pbar n total
7530      &ZERZER    ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7   D+00,
7531 * 17th reaction: pbar d total
7532      &112.  D+00, 125.D+00, -1.08D+00, 1.14  D+00, -12.4  D+00,
7533 * 18th reaction: Lamda p total
7534      &30.4  D+00, ZERZER  , ZERZER   , ZERZER    , 1.6    D+00/
7535 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
7536       DATA SGTCO3  /
7537 * 19th reaction: pi+ p elastic
7538      &ZERZER    , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER     ,
7539 * 20th reaction: pi- p elastic
7540      &1.76  D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER     ,
7541 * 21st reaction: K+ p elastic
7542      &5.0   D+00, 8.1 D+00, -1.8 D+00, 0.16  D+00, -1.3   D+00,
7543 * 22nd reaction: K- p elastic
7544      &7.3   D+00, ZERZER  , ZERZER   , 0.29  D+00, -2.40  D+00,
7545 * 23rd reaction: p p elastic
7546      &11.9  D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85  D+00,
7547 * 24th reaction: p d elastic
7548      &16.1  D+00, ZERZER  , ZERZER   , 0.32  D+00, -3.4   D+00,
7549 * 25th reaction: pbar p elastic
7550      &10.2  D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28  D+00,
7551 * 26th reaction: pbar p elastic bis
7552      &10.6  D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41  D+00,
7553 * 27th reaction: pbar n elastic
7554      &36.5  D+00, ZERZER  , ZERZER   , ZERZER    , -11.9  D+00,
7555 * 28th reaction: Lamda p elastic
7556      &12.3  D+00, ZERZER  , ZERZER   , ZERZER    , -2.4   D+00,
7557 * 29th reaction: K- p ela bis
7558      &7.24  D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35  D+00,
7559 * 30th reaction: pi- p cx
7560      &ZERZER    ,0.912D+00, -1.22D+00, ZERZER    , ZERZER     ,
7561 * 31st reaction: K- p cx
7562      &ZERZER    , 3.39D+00, -1.75D+00, ZERZER    , ZERZER     ,
7563 * 32nd reaction: K+ n cx
7564      &ZERZER    , 7.18D+00, -2.01D+00, ZERZER    , ZERZER     ,
7565 * 33rd reaction: pbar p cx
7566      &ZERZER    , 18.8D+00, -2.01D+00, ZERZER    , ZERZER     /
7567 *
7568 *  +-------------------------------------------------------------------*
7569          ICHRGE(KTARG)=IICH(KTARG)
7570          AM    (KTARG)=AAM (KTARG)
7571 *  |  Check for pi0 (d-dbar)
7572       IF ( KP .NE. 26 ) THEN
7573          IP  = KPTOIP (KP)
7574          IF(IP.EQ.0)IP=1
7575          ICHRGE(IP)=IICH(KP)
7576          AM    (IP)=AAM (KP)
7577 *  |
7578 *  +-------------------------------------------------------------------*
7579 *  |
7580       ELSE
7581          IP = 23
7582          ICHRGE(IP)=0
7583       END IF
7584 *  |
7585 *  +-------------------------------------------------------------------*
7586 *  +-------------------------------------------------------------------*
7587 *  |  No such interactions for baryon-baryon
7588       IF ( IIBAR (KP) .GT. 0 ) THEN
7589          DT_PHNSCH = ZERZER
7590          RETURN
7591 *  |
7592 *  +-------------------------------------------------------------------*
7593 *  |  No "annihilation" diagram possible for K+ p/n
7594       ELSE IF ( IP .EQ. 15 ) THEN
7595          DT_PHNSCH = ZERZER
7596          RETURN
7597 *  |
7598 *  +-------------------------------------------------------------------*
7599 *  |  No "annihilation" diagram possible for K0 p/n
7600       ELSE IF ( IP .EQ. 24 ) THEN
7601          DT_PHNSCH = ZERZER
7602          RETURN
7603 *  |
7604 *  +-------------------------------------------------------------------*
7605 *  |  No "annihilation" diagram possible for Omebar p/n
7606       ELSE IF ( IP .GE. 38 ) THEN
7607          DT_PHNSCH = ZERZER
7608          RETURN
7609       END IF
7610 *  |
7611 *  +-------------------------------------------------------------------*
7612 *  +-------------------------------------------------------------------*
7613 *  |  If the momentum is larger than 50 GeV/c, compute the single
7614 *  |  chain probability at 50 GeV/c and extrapolate to the present
7615 *  |  momentum according to 1/sqrt(s)
7616 *  |  sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
7617 *  |  P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
7618 *  |  sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
7619 *  |  sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
7620 *  |                        x sqrt(s/s(50))
7621 *  |  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
7622       IF ( PLAB .GT. 50.D+00 ) THEN
7623          PLA    = 50.D+00
7624          AMPSQ  = AM (IP)**2
7625          AMTSQ  = AM (KTARG)**2
7626          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
7627          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7628          EPROJ  = SQRT ( PLA**2 + AMPSQ )
7629          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7630          UMORAT = SQRT ( UMOSQ / UMO50 )
7631 *  |
7632 *  +-------------------------------------------------------------------*
7633 *  |  P < 3 GeV/c
7634       ELSE IF ( PLAB .LT. 3.D+00 ) THEN
7635          PLA    = 3.D+00
7636          AMPSQ  = AM (IP)**2
7637          AMTSQ  = AM (KTARG)**2
7638          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
7639          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7640          EPROJ  = SQRT ( PLA**2 + AMPSQ )
7641          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7642          UMORAT = SQRT ( UMOSQ / UMO50 )
7643 *  |
7644 *  +-------------------------------------------------------------------*
7645 *  |  P < 50 GeV/c
7646       ELSE
7647          PLA    = PLAB
7648          UMORAT = ONEONE
7649       END IF
7650 *  |
7651 *  +-------------------------------------------------------------------*
7652       ALGPLA = LOG (PLA)
7653 *  +-------------------------------------------------------------------*
7654 *  |  Pions:
7655       IF ( IHLP (IP) .EQ. 2 ) THEN
7656          ACOF = SGTCOE (1,3)
7657          BCOF = SGTCOE (2,3)
7658          ENNE = SGTCOE (3,3)
7659          CCOF = SGTCOE (4,3)
7660          DCOF = SGTCOE (5,3)
7661 *  |  Compute the pi+ p total cross section:
7662          SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7663      &          + DCOF * ALGPLA
7664          ACOF = SGTCOE (1,19)
7665          BCOF = SGTCOE (2,19)
7666          ENNE = SGTCOE (3,19)
7667          CCOF = SGTCOE (4,19)
7668          DCOF = SGTCOE (5,19)
7669 *  |  Compute the pi+ p elastic cross section:
7670          SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7671      &          + DCOF * ALGPLA
7672 *  |  Compute the pi+ p inelastic cross section:
7673          SPPPIN = SPPPTT - SPPPEL
7674          ACOF = SGTCOE (1,4)
7675          BCOF = SGTCOE (2,4)
7676          ENNE = SGTCOE (3,4)
7677          CCOF = SGTCOE (4,4)
7678          DCOF = SGTCOE (5,4)
7679 *  |  Compute the pi- p total cross section:
7680          SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7681      &          + DCOF * ALGPLA
7682          ACOF = SGTCOE (1,20)
7683          BCOF = SGTCOE (2,20)
7684          ENNE = SGTCOE (3,20)
7685          CCOF = SGTCOE (4,20)
7686          DCOF = SGTCOE (5,20)
7687 *  |  Compute the pi- p elastic cross section:
7688          SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7689      &          + DCOF * ALGPLA
7690 *  |  Compute the pi- p inelastic cross section:
7691          SPMPIN = SPMPTT - SPMPEL
7692          SIGDIA = SPMPIN - SPPPIN
7693 *  |  +----------------------------------------------------------------*
7694 *  |  |  Charged pions: besides isospin consideration it is supposed
7695 *  |  |                 that (pi+ n)el is almost equal to (pi- p)el
7696 *  |  |                 and  (pi+ p)el "    "     "    "  (pi- n)el
7697 *  |  |                 and all are almost equal among each others
7698 *  |  |                 (reasonable above 5 GeV/c)
7699          IF ( ICHRGE (IP) .NE. 0 ) THEN
7700             KHELP = KTARG / 8
7701             JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
7702             ACOF = SGTCOE (1,JREAC)
7703             BCOF = SGTCOE (2,JREAC)
7704             ENNE = SGTCOE (3,JREAC)
7705             CCOF = SGTCOE (4,JREAC)
7706             DCOF = SGTCOE (5,JREAC)
7707 *  |  |  Compute the total cross section:
7708             SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7709      &             + DCOF * ALGPLA
7710             JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
7711             ACOF = SGTCOE (1,JREAC)
7712             BCOF = SGTCOE (2,JREAC)
7713             ENNE = SGTCOE (3,JREAC)
7714             CCOF = SGTCOE (4,JREAC)
7715             DCOF = SGTCOE (5,JREAC)
7716 *  |  |  Compute the elastic cross section:
7717             SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7718      &             + DCOF * ALGPLA
7719 *  |  |  Compute the inelastic cross section:
7720             SHNCIN = SHNCTT - SHNCEL
7721 *  |  |  Number of diagrams:
7722             NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
7723 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7724             IQFSC1 = 1 + IP - 13
7725             IQFSC2 = 0
7726             IQBSC1 = 1 + KHELP
7727             IQBSC2 = 1 + IP - 13
7728 *  |  |
7729 *  |  +----------------------------------------------------------------*
7730 *  |  |  pi0: besides isospin consideration it is supposed that the
7731 *  |  |       elastic cross section is not very different from
7732 *  |  |       pi+ p and/or pi- p (reasonable above 5 GeV/c)
7733          ELSE
7734             KHELP  = KTARG / 8
7735             K2HLP  = ( KP - 23 ) / 3
7736 *  |  |  Number of diagrams:
7737 *  |  |  For u ubar (k2hlp=0):
7738 *           NDIAGR = 2 - KHELP
7739 *  |  |  For d dbar (k2hlp=1):
7740 *           NDIAGR = 2 + KHELP - K2HLP
7741             NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
7742             SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
7743 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7744             IQFSC1 = 1 + K2HLP
7745             IQFSC2 = 0
7746             IQBSC1 = 1 + KHELP
7747             IQBSC2 = 2 - K2HLP
7748          END IF
7749 *  |  |
7750 *  |  +----------------------------------------------------------------*
7751 *  |                                                   end pi's
7752 *  +-------------------------------------------------------------------*
7753 *  |  Kaons:
7754       ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
7755          ACOF = SGTCOE (1,6)
7756          BCOF = SGTCOE (2,6)
7757          ENNE = SGTCOE (3,6)
7758          CCOF = SGTCOE (4,6)
7759          DCOF = SGTCOE (5,6)
7760 *  |  Compute the K+ p total cross section:
7761          SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7762      &          + DCOF * ALGPLA
7763          ACOF = SGTCOE (1,21)
7764          BCOF = SGTCOE (2,21)
7765          ENNE = SGTCOE (3,21)
7766          CCOF = SGTCOE (4,21)
7767          DCOF = SGTCOE (5,21)
7768 *  |  Compute the K+ p elastic cross section:
7769          SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7770      &          + DCOF * ALGPLA
7771 *  |  Compute the K+ p inelastic cross section:
7772          SKPPIN = SKPPTT - SKPPEL
7773          ACOF = SGTCOE (1,9)
7774          BCOF = SGTCOE (2,9)
7775          ENNE = SGTCOE (3,9)
7776          CCOF = SGTCOE (4,9)
7777          DCOF = SGTCOE (5,9)
7778 *  |  Compute the K- p total cross section:
7779          SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7780      &          + DCOF * ALGPLA
7781          ACOF = SGTCOE (1,22)
7782          BCOF = SGTCOE (2,22)
7783          ENNE = SGTCOE (3,22)
7784          CCOF = SGTCOE (4,22)
7785          DCOF = SGTCOE (5,22)
7786 *  |  Compute the K- p elastic cross section:
7787          SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7788      &          + DCOF * ALGPLA
7789 *  |  Compute the K- p inelastic cross section:
7790          SKMPIN = SKMPTT - SKMPEL
7791          SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
7792 *  |  +----------------------------------------------------------------*
7793 *  |  |  Charged Kaons: actually only K-
7794          IF ( ICHRGE (IP) .NE. 0 ) THEN
7795             KHELP = KTARG / 8
7796 *  |  |  +-------------------------------------------------------------*
7797 *  |  |  |  Proton target:
7798             IF ( KHELP .EQ. 0 ) THEN
7799                SHNCIN = SKMPIN
7800 *  |  |  |  Number of diagrams:
7801                NDIAGR = 2
7802 *  |  |  |
7803 *  |  |  +-------------------------------------------------------------*
7804 *  |  |  |  Neutron target: besides isospin consideration it is supposed
7805 *  |  |  |              that (K- n)el is almost equal to (K- p)el
7806 *  |  |  |              (reasonable above 5 GeV/c)
7807             ELSE
7808                ACOF = SGTCOE (1,10)
7809                BCOF = SGTCOE (2,10)
7810                ENNE = SGTCOE (3,10)
7811                CCOF = SGTCOE (4,10)
7812                DCOF = SGTCOE (5,10)
7813 *  |  |  |  Compute the total cross section:
7814                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7815      &                + DCOF * ALGPLA
7816 *  |  |  |  Compute the elastic cross section:
7817                SHNCEL = SKMPEL
7818 *  |  |  |  Compute the inelastic cross section:
7819                SHNCIN = SHNCTT - SHNCEL
7820 *  |  |  |  Number of diagrams:
7821                NDIAGR = 1
7822             END IF
7823 *  |  |  |
7824 *  |  |  +-------------------------------------------------------------*
7825 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7826             IQFSC1 = 3
7827             IQFSC2 = 0
7828             IQBSC1 = 1 + KHELP
7829             IQBSC2 = 2
7830 *  |  |
7831 *  |  +----------------------------------------------------------------*
7832 *  |  |  K0's: (actually only K0bar)
7833          ELSE
7834             KHELP  = KTARG / 8
7835 *  |  |  +-------------------------------------------------------------*
7836 *  |  |  |  Proton target: (K0bar p)in supposed to be given by
7837 *  |  |  |                 (K- p)in - Sig_diagr
7838             IF ( KHELP .EQ. 0 ) THEN
7839                SHNCIN = SKMPIN - SIGDIA
7840 *  |  |  |  Number of diagrams:
7841                NDIAGR = 1
7842 *  |  |  |
7843 *  |  |  +-------------------------------------------------------------*
7844 *  |  |  |  Neutron target: (K0bar n)in supposed to be given by
7845 *  |  |  |                 (K- n)in + Sig_diagr
7846 *  |  |  |              besides isospin consideration it is supposed
7847 *  |  |  |              that (K- n)el is almost equal to (K- p)el
7848 *  |  |  |              (reasonable above 5 GeV/c)
7849             ELSE
7850                ACOF = SGTCOE (1,10)
7851                BCOF = SGTCOE (2,10)
7852                ENNE = SGTCOE (3,10)
7853                CCOF = SGTCOE (4,10)
7854                DCOF = SGTCOE (5,10)
7855 *  |  |  |  Compute the total cross section:
7856                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7857      &                + DCOF * ALGPLA
7858 *  |  |  |  Compute the elastic cross section:
7859                SHNCEL = SKMPEL
7860 *  |  |  |  Compute the inelastic cross section:
7861                SHNCIN = SHNCTT - SHNCEL + SIGDIA
7862 *  |  |  |  Number of diagrams:
7863                NDIAGR = 2
7864             END IF
7865 *  |  |  |
7866 *  |  |  +-------------------------------------------------------------*
7867 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7868             IQFSC1 = 3
7869             IQFSC2 = 0
7870             IQBSC1 = 1
7871             IQBSC2 = 1 + KHELP
7872          END IF
7873 *  |  |
7874 *  |  +----------------------------------------------------------------*
7875 *  |                                                   end Kaon's
7876 *  +-------------------------------------------------------------------*
7877 *  |  Antinucleons:
7878       ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
7879 *  |  For momenta between 3 and 5 GeV/c the use of tabulated data
7880 *  |  should be implemented!
7881          ACOF = SGTCOE (1,15)
7882          BCOF = SGTCOE (2,15)
7883          ENNE = SGTCOE (3,15)
7884          CCOF = SGTCOE (4,15)
7885          DCOF = SGTCOE (5,15)
7886 *  |  Compute the pbar p total cross section:
7887          SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7888      &          + DCOF * ALGPLA
7889          IF ( PLA .LT. FIVFIV ) THEN
7890             JREAC = 26
7891          ELSE
7892             JREAC = 25
7893          END IF
7894          ACOF = SGTCOE (1,JREAC)
7895          BCOF = SGTCOE (2,JREAC)
7896          ENNE = SGTCOE (3,JREAC)
7897          CCOF = SGTCOE (4,JREAC)
7898          DCOF = SGTCOE (5,JREAC)
7899 *  |  Compute the pbar p elastic cross section:
7900          SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7901      &          + DCOF * ALGPLA
7902 *  |  Compute the pbar p inelastic cross section:
7903          SAPPIN = SAPPTT - SAPPEL
7904          ACOF = SGTCOE (1,12)
7905          BCOF = SGTCOE (2,12)
7906          ENNE = SGTCOE (3,12)
7907          CCOF = SGTCOE (4,12)
7908          DCOF = SGTCOE (5,12)
7909 *  |  Compute the p p total cross section:
7910          SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7911      &          + DCOF * ALGPLA
7912          ACOF = SGTCOE (1,23)
7913          BCOF = SGTCOE (2,23)
7914          ENNE = SGTCOE (3,23)
7915          CCOF = SGTCOE (4,23)
7916          DCOF = SGTCOE (5,23)
7917 *  |  Compute the p p elastic cross section:
7918          SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7919      &          + DCOF * ALGPLA
7920 *  |  Compute the K- p inelastic cross section:
7921          SPPINE = SPPTOT - SPPELA
7922          SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
7923          KHELP  = KTARG / 8
7924 *  |  +----------------------------------------------------------------*
7925 *  |  |  Pbar:
7926          IF ( ICHRGE (IP) .NE. 0 ) THEN
7927             NDIAGR = 5 - KHELP
7928 *  |  |  +-------------------------------------------------------------*
7929 *  |  |  |  Proton target:
7930             IF ( KHELP .EQ. 0 ) THEN
7931 *  |  |  |  Number of diagrams:
7932                SHNCIN = SAPPIN
7933                PUUBAR = 0.8D+00
7934 *  |  |  |
7935 *  |  |  +-------------------------------------------------------------*
7936 *  |  |  |  Neutron target: it is supposed that (ap n)el is almost equal
7937 *  |  |  |                  to (ap p)el (reasonable above 5 GeV/c)
7938             ELSE
7939                ACOF = SGTCOE (1,16)
7940                BCOF = SGTCOE (2,16)
7941                ENNE = SGTCOE (3,16)
7942                CCOF = SGTCOE (4,16)
7943                DCOF = SGTCOE (5,16)
7944 *  |  |  |  Compute the total cross section:
7945                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7946      &                + DCOF * ALGPLA
7947 *  |  |  |  Compute the elastic cross section:
7948                SHNCEL = SAPPEL
7949 *  |  |  |  Compute the inelastic cross section:
7950                SHNCIN = SHNCTT - SHNCEL
7951                PUUBAR = HLFHLF
7952             END IF
7953 *  |  |  |
7954 *  |  |  +-------------------------------------------------------------*
7955 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7956 *  |  |  there are different possibilities, make a random choiche:
7957             IQFSC1 = -1
7958             RNCHEN = DT_RNDM(PUUBAR)
7959             IF ( RNCHEN .LT. PUUBAR ) THEN
7960                IQFSC2 = -2
7961             ELSE
7962                IQFSC2 = -1
7963             END IF
7964             IQBSC1 = -IQFSC1 + KHELP
7965             IQBSC2 = -IQFSC2
7966 *  |  |
7967 *  |  +----------------------------------------------------------------*
7968 *  |  |  nbar:
7969          ELSE
7970             NDIAGR = 4 + KHELP
7971 *  |  |  +-------------------------------------------------------------*
7972 *  |  |  |  Proton target: (nbar p)in supposed to be given by
7973 *  |  |  |                 (pbar p)in - Sig_diagr
7974             IF ( KHELP .EQ. 0 ) THEN
7975                SHNCIN = SAPPIN - SIGDIA
7976                PDDBAR = HLFHLF
7977 *  |  |  |
7978 *  |  |  +-------------------------------------------------------------*
7979 *  |  |  |  Neutron target: (nbar n)el is supposed to be equal to
7980 *  |  |  |                  (pbar p)el (reasonable above 5 GeV/c)
7981             ELSE
7982 *  |  |  |  Compute the total cross section:
7983                SHNCTT = SAPPTT
7984 *  |  |  |  Compute the elastic cross section:
7985                SHNCEL = SAPPEL
7986 *  |  |  |  Compute the inelastic cross section:
7987                SHNCIN = SHNCTT - SHNCEL
7988                PDDBAR = 0.8D+00
7989             END IF
7990 *  |  |  |
7991 *  |  |  +-------------------------------------------------------------*
7992 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7993 *  |  |  there are different possibilities, make a random choiche:
7994             IQFSC1 = -2
7995             RNCHEN = DT_RNDM(RNCHEN)
7996             IF ( RNCHEN .LT. PDDBAR ) THEN
7997                IQFSC2 = -1
7998             ELSE
7999                IQFSC2 = -2
8000             END IF
8001             IQBSC1 = -IQFSC1 + KHELP - 1
8002             IQBSC2 = -IQFSC2
8003          END IF
8004 *  |  |
8005 *  |  +----------------------------------------------------------------*
8006 *  |
8007 *  +-------------------------------------------------------------------*
8008 *  |  Others: not yet implemented
8009       ELSE
8010          SIGDIA = ZERZER
8011          SHNCIN = ONEONE
8012          NDIAGR = 0
8013          DT_PHNSCH = ZERZER
8014          RETURN
8015       END IF
8016 *  |                                                   end others
8017 *  +-------------------------------------------------------------------*
8018       DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8019       IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8020      &       + IQECHR (IQBSC2)
8021       IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8022      &       + IQBCHR (IQBSC2)
8023       IQECHC = IQECHC / 3
8024       IQBCHC = IQBCHC / 3
8025       IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8026      &       + IQSCHR (IQBSC2)
8027       IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8028      &       + IQSCHR (MQUARK(3,IP))
8029 *  +-------------------------------------------------------------------*
8030 *  |  Consistency check:
8031       IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8032          WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8033      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8034          WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8035      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8036          DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8037          DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8038       END IF
8039 *  |
8040 *  +-------------------------------------------------------------------*
8041 *  +-------------------------------------------------------------------*
8042 *  |  Consistency check:
8043       IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8044      &     .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8045          WRITE (LUNOUT,*)
8046      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8047      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8048          WRITE (LUNERR,*)
8049      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8050      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8051       END IF
8052 *  |
8053 *  +-------------------------------------------------------------------*
8054 *  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8055       IF ( UMORAT .GT. ONEPLS )
8056      &   DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8057      &                                 - ONEONE ) * UMORAT + ONEONE )
8058       RETURN
8059 *
8060       ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8061       DT_SCHQUA = ONEONE
8062       JQFSC1 = IQFSC1
8063       JQFSC2 = IQFSC2
8064       JQBSC1 = IQBSC1
8065       JQBSC2 = IQBSC2
8066 *=== End of function Phnsch ===========================================*
8067       RETURN
8068       END
8069
8070 *$ CREATE DT_RESPT.FOR
8071 *COPY DT_RESPT
8072 *
8073 *===respt==============================================================*
8074 *
8075       SUBROUTINE DT_RESPT
8076
8077 ************************************************************************
8078 * Check DTEVT1 for two-resonance systems and sample intrinsic p_t.     *
8079 * This version dated 18.01.95 is written by S. Roesler                 *
8080 ************************************************************************
8081
8082       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8083       SAVE
8084       PARAMETER ( LINP = 10 ,
8085      &            LOUT = 6 ,
8086      &            LDAT = 9 )
8087       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8088
8089 * event history
8090       PARAMETER (NMXHKK=200000)
8091       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8092      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8093      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8094 * extended event history
8095       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8096      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8097      &                IHIST(2,NMXHKK)
8098
8099 * get index of first chain
8100       DO 1 I=NPOINT(3),NHKK
8101          IF (IDHKK(I).EQ.88888) THEN
8102             NC = I
8103             GOTO 2
8104          ENDIF
8105     1 CONTINUE
8106
8107     2 CONTINUE
8108       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8109 C        WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8110 * skip VV-,SS- systems
8111          IF ((IDCH(NC  ).NE.1).AND.(IDCH(NC  ).NE.8).AND.
8112      &       (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8113 * check if both "chains" are resonances
8114             IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8115                CALL DT_SAPTRE(NC,NC+3)
8116             ENDIF
8117          ENDIF
8118       ELSE
8119          GOTO 3
8120       ENDIF
8121       NC = NC+6
8122       GOTO 2
8123
8124     3 CONTINUE
8125
8126       RETURN
8127       END
8128
8129 *$ CREATE DT_EVTRES.FOR
8130 *COPY DT_EVTRES
8131 *
8132 *===evtres=============================================================*
8133 *
8134       SUBROUTINE DT_EVTRES(IREJ)
8135
8136 ************************************************************************
8137 * This version dated 14.12.94 is written by S. Roesler                 *
8138 ************************************************************************
8139
8140       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8141       SAVE
8142       PARAMETER ( LINP = 10 ,
8143      &            LOUT = 6 ,
8144      &            LDAT = 9 )
8145       PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8146
8147 * event history
8148       PARAMETER (NMXHKK=200000)
8149       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8150      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8151      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8152 * extended event history
8153       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8154      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8155      &                IHIST(2,NMXHKK)
8156 * flags for input different options
8157       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8158       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8159      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8160 * particle properties (BAMJET index convention)
8161       CHARACTER*8  ANAME
8162       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8163      &                IICH(210),IIBAR(210),K1(210),K2(210)
8164
8165       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8166
8167       IREJ = 0
8168
8169       DO 1 I=NPOINT(3),NHKK
8170          IF (ABS(IDRES(I)).GE.100) THEN
8171             AMMX = 0.0D0
8172             DO 2 J=NPOINT(3),NHKK
8173                IF (IDHKK(J).EQ.88888) THEN
8174                   IF (PHKK(5,J).GT.AMMX) THEN
8175                      AMMX = PHKK(5,J)
8176                      IMMX = J
8177                   ENDIF
8178                ENDIF
8179     2       CONTINUE
8180             IF (IDRES(IMMX).NE.0) THEN
8181                IF (IOULEV(3).GT.0) THEN
8182                   WRITE(LOUT,'(1X,A)')
8183      &               'EVTRES: no chain for correc. found'
8184 C                 GOTO 6
8185                   GOTO 9999
8186                ELSE
8187                   GOTO 9999
8188                ENDIF
8189             ENDIF
8190             IMO11  = JMOHKK(1,I)
8191             IMO12  = JMOHKK(2,I)
8192             IF (PHKK(3,IMO11).LT.0.0D0) THEN
8193                IMO11 = JMOHKK(2,I)
8194                IMO12 = JMOHKK(1,I)
8195             ENDIF
8196             IMO21  = JMOHKK(1,IMMX)
8197             IMO22  = JMOHKK(2,IMMX)
8198             IF (PHKK(3,IMO21).LT.0.0D0) THEN
8199                IMO21 = JMOHKK(2,IMMX)
8200                IMO22 = JMOHKK(1,IMMX)
8201             ENDIF
8202             AMCH1  = PHKK(5,I)
8203             AMCH1N = AAM(IDXRES(I))
8204
8205             IFPR1 = IDHKK(IMO11)
8206             IFPR2 = IDHKK(IMO21)
8207             IFTA1 = IDHKK(IMO12)
8208             IFTA2 = IDHKK(IMO22)
8209             DO 4 J=1,4
8210                PP1(J) = PHKK(J,IMO11)
8211                PP2(J) = PHKK(J,IMO21)
8212                PT1(J) = PHKK(J,IMO12)
8213                PT2(J) = PHKK(J,IMO22)
8214     4       CONTINUE
8215 * store initial configuration for energy-momentum cons. check
8216             IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8217 * correct kinematics of second chain
8218             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8219      &                  AMCH1,AMCH1N,AMCH2,IREJ1)
8220             IF (IREJ1.NE.0) GOTO 9999
8221 * check now this chain for resonance mass
8222             IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8223             IFP(2) = 0
8224             IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8225             IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8226             IFT(2) = 0
8227             IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8228             IDCH2 = 2
8229             IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8230             IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8231             CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8232      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
8233             IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8234                IF (IOULEV(1).GT.0)
8235      &            WRITE(LOUT,*) ' correction for resonance not poss.'
8236 **sr test
8237 C              GOTO 1
8238 C              GOTO 9999
8239 **
8240             ENDIF
8241 * store final configuration for energy-momentum cons. check
8242             IF (LEMCCK) THEN
8243                CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8244                CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8245                IF (IREJ1.NE.0) GOTO 9999
8246             ENDIF
8247             DO 5 J=1,4
8248                PHKK(J,IMO11) = PP1(J)
8249                PHKK(J,IMO21) = PP2(J)
8250                PHKK(J,IMO12) = PT1(J)
8251                PHKK(J,IMO22) = PT2(J)
8252     5       CONTINUE
8253 * correct entries of chains
8254             DO 3 K=1,4
8255                PHKK(K,I)    = PHKK(K,IMO11)+PHKK(K,IMO12)
8256                PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8257     3       CONTINUE
8258             AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8259             AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8260      &            PHKK(3,IMMX)**2
8261 * ?? the following should now be obsolete
8262 **sr test
8263 C           IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8264             IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8265 **
8266                WRITE(LOUT,'(1X,A,4G10.3)')
8267      &          'EVTRES: inonsistent mass-corr.',AM1,AM2
8268 C              GOTO 9999
8269                GOTO 1
8270             ENDIF
8271             PHKK(5,I)    = SQRT(AM1)
8272             PHKK(5,IMMX) = SQRT(AM2)
8273             IDRES(I)     = IDRES(I)/100
8274             IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8275      &          (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8276                WRITE(LOUT,'(1X,A,4G10.3)')
8277      &          'EVTRES: inconsistent chain-masses',
8278      &          PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8279                GOTO 9999
8280             ENDIF
8281          ENDIF
8282     1 CONTINUE
8283     6 CONTINUE
8284       RETURN
8285
8286  9999 CONTINUE
8287       IREJ = 1
8288       RETURN
8289       END
8290
8291 *$ CREATE DT_GETSPT.FOR
8292 *COPY DT_GETSPT
8293 *
8294 *===getspt=============================================================*
8295 *
8296       SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8297      &                  PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8298      &                  AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8299
8300 ************************************************************************
8301 * This version dated 12.12.94 is written by S. Roesler                 *
8302 ************************************************************************
8303
8304       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8305       SAVE
8306       PARAMETER ( LINP = 10 ,
8307      &            LOUT = 6 ,
8308      &            LDAT = 9 )
8309       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8310
8311 * various options for treatment of partons (DTUNUC 1.x)
8312 * (chain recombination, Cronin,..)
8313       LOGICAL LCO2CR,LINTPT
8314       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8315      &                LCO2CR,LINTPT
8316 * flags for input different options
8317       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8318       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8319      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8320 * flags for diffractive interactions (DTUNUC 1.x)
8321       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8322
8323       DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8324      &          PT2(4),PT2I(4),P1(4),P2(4),
8325      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8326      &          PTOTI(4),PTOTF(4),DIFF(4)
8327
8328       IC   = 0
8329       IREJ = 0
8330 C     B33P = 4.0D0
8331 C     B33T = 4.0D0
8332 C     IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8333 C     IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8334       REDU = 1.0D0
8335 C     B33P = 3.5D0
8336 C     B33T = 3.5D0
8337       B33P = 4.0D0
8338       B33T = 4.0D0
8339       IF (IDIFF.NE.0) THEN
8340          B33P = 16.0D0
8341          B33T = 16.0D0
8342       ENDIF
8343
8344       DO 1 I=1,4
8345          PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8346          PP1(I)   = PP1I(I)
8347          PP2(I)   = PP2I(I)
8348          PT1(I)   = PT1I(I)
8349          PT2(I)   = PT2I(I)
8350     1 CONTINUE
8351 * get initial chain masses
8352       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8353      &                               +(PP1(3)+PT1(3))**2)
8354       ECH   = PP1(4)+PT1(4)
8355       AM1   = (ECH+PTOCH)*(ECH-PTOCH)
8356       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8357      &                               +(PP2(3)+PT2(3))**2)
8358       ECH   = PP2(4)+PT2(4)
8359       AM2   = (ECH+PTOCH)*(ECH-PTOCH)
8360       IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8361          IF (IOULEV(1).GT.0)
8362      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8363      &                              AM1,AM2
8364          GOTO 9999
8365       ENDIF
8366       AM1  = SQRT(AM1)
8367       AM2  = SQRT(AM2)
8368       AM1N = ZERO
8369       AM2N = ZERO
8370
8371       MODE = 0
8372 C      IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8373 C        MODE = 0
8374 C      ELSE
8375 C         MODE = 1
8376 C         IF (AM1.LT.0.6) THEN
8377 C            B33P = 10.0D0
8378 C         ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8379 CC           B33P = 4.0D0
8380 C         ENDIF
8381 C         IF (AM2.LT.0.6) THEN
8382 C            B33T = 10.0D0
8383 C         ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8384 CC           B33T = 4.0D0
8385 C         ENDIF
8386 C      ENDIF
8387
8388 * check chain masses for very low mass chains
8389 C     CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8390 C    &            AM1,DUM,-IDCH1,IREJ1)
8391 C     CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8392 C    &            AM2,DUM,-IDCH2,IREJ2)
8393 C     IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8394 C        B33P = 20.0D0
8395 C        B33T = 20.0D0
8396 C     ENDIF
8397
8398       JMSHL = IMSHL
8399
8400     2 CONTINUE
8401       IC = IC+1
8402       IF (MOD(IC,15).EQ.0) B33P  = 2.0D0*B33P
8403       IF (MOD(IC,15).EQ.0) B33T  = 2.0D0*B33T
8404       IF (MOD(IC,18).EQ.0) REDU  = 0.0D0
8405 C     IF (MOD(IC,19).EQ.0) JMSHL = 0
8406       IF (MOD(IC,20).EQ.0) GOTO 7
8407 C        WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8408 C        RETURN
8409 C        GOTO 9999
8410 C     ENDIF
8411
8412 * get transverse momentum
8413       IF (LINTPT) THEN
8414          ES   = -2.0D0/(B33P**2)
8415      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8416          HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8417          HPSP = HPSP*REDU
8418          ES   = -2.0D0/(B33T**2)
8419      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8420          HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8421          HPST = HPST*REDU
8422       ELSE
8423          HPSP = ZERO
8424          HPST = ZERO
8425       ENDIF
8426       CALL DT_DSFECF(SFE1,CFE1)
8427       CALL DT_DSFECF(SFE2,CFE2)
8428       IF (MODE.EQ.0) THEN
8429          PP1(1) = PP1I(1)+HPSP*CFE1
8430          PP1(2) = PP1I(2)+HPSP*SFE1
8431          PP2(1) = PP2I(1)-HPSP*CFE1
8432          PP2(2) = PP2I(2)-HPSP*SFE1
8433          PT1(1) = PT1I(1)+HPST*CFE2
8434          PT1(2) = PT1I(2)+HPST*SFE2
8435          PT2(1) = PT2I(1)-HPST*CFE2
8436          PT2(2) = PT2I(2)-HPST*SFE2
8437       ELSE
8438          PP1(1) = PP1I(1)+HPSP*CFE1
8439          PP1(2) = PP1I(2)+HPSP*SFE1
8440          PT1(1) = PT1I(1)-HPSP*CFE1
8441          PT1(2) = PT1I(2)-HPSP*SFE1
8442          PP2(1) = PP2I(1)+HPST*CFE2
8443          PP2(2) = PP2I(2)+HPST*SFE2
8444          PT2(1) = PT2I(1)-HPST*CFE2
8445          PT2(2) = PT2I(2)-HPST*SFE2
8446       ENDIF
8447
8448 * put partons on mass shell
8449       XMP1 = 0.0D0
8450       XMT1 = 0.0D0
8451       IF (JMSHL.EQ.1) THEN
8452          XMP1 = PYMASS(IFPR1)
8453          XMT1 = PYMASS(IFTA1)
8454       ENDIF
8455       CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8456       IF (IREJ1.NE.0) GOTO 2
8457       DO 3 I=1,4
8458          PTOTF(I) = P1(I)+P2(I)
8459          PP1(I)   = P1(I)
8460          PT1(I)   = P2(I)
8461     3 CONTINUE
8462       XMP2 = 0.0D0
8463       XMT2 = 0.0D0
8464       IF (JMSHL.EQ.1) THEN
8465          XMP2 = PYMASS(IFPR2)
8466          XMT2 = PYMASS(IFTA2)
8467       ENDIF
8468       CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8469       IF (IREJ1.NE.0) GOTO 2
8470       DO 4 I=1,4
8471          PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8472          PP2(I)   = P1(I)
8473          PT2(I)   = P2(I)
8474     4 CONTINUE
8475
8476 * check consistency
8477       DO 5 I=1,4
8478          DIFF(I) = PTOTI(I)-PTOTF(I)
8479     5 CONTINUE
8480       IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8481      &    (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8482          WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8483          GOTO 9999
8484       ENDIF
8485       PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8486       AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8487       PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8488       AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8489       PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8490       AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8491       PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8492       AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8493       IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8494      &    (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8495      &                                                           THEN
8496          WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8497      &     'GETSPT: inconsistent masses',
8498      &     AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8499 * sr 22.11.00: commented. It should only have inconsistent masses for
8500 * ultrahigh energies due to rounding problems
8501 C        GOTO 9999
8502       ENDIF
8503
8504 * get chain masses
8505       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8506      &                               +(PP1(3)+PT1(3))**2)
8507       ECH   = PP1(4)+PT1(4)
8508       AM1N  = (ECH+PTOCH)*(ECH-PTOCH)
8509       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8510      &                               +(PP2(3)+PT2(3))**2)
8511       ECH   = PP2(4)+PT2(4)
8512       AM2N  = (ECH+PTOCH)*(ECH-PTOCH)
8513       IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
8514          IF (IOULEV(1).GT.0)
8515      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
8516      &                              AM1N,AM2N
8517          GOTO 2
8518       ENDIF
8519       AM1N = SQRT(AM1N)
8520       AM2N = SQRT(AM2N)
8521
8522 * check chain masses for very low mass chains
8523       CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8524      &            AM1N,DUM,-IDCH1,IREJ1)
8525       IF (IREJ1.NE.0) GOTO 2
8526       CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8527      &            AM2N,DUM,-IDCH2,IREJ2)
8528       IF (IREJ2.NE.0) GOTO 2
8529
8530     7 CONTINUE
8531       IF (AM1N.GT.ZERO) THEN
8532          AM1 = AM1N
8533          AM2 = AM2N
8534       ENDIF
8535       DO 6 I=1,4
8536          PP1I(I)   = PP1(I)
8537          PP2I(I)   = PP2(I)
8538          PT1I(I)   = PT1(I)
8539          PT2I(I)   = PT2(I)
8540     6 CONTINUE
8541
8542       RETURN
8543
8544  9999 CONTINUE
8545       IREJ = 1
8546       RETURN
8547       END
8548
8549 *$ CREATE DT_SAPTRE.FOR
8550 *COPY DT_SAPTRE
8551 *
8552 *===saptre=============================================================*
8553 *
8554       SUBROUTINE DT_SAPTRE(IDX1,IDX2)
8555
8556 ************************************************************************
8557 * p-t sampling for two-resonance systems. ("BAMJET-like" method)       *
8558 *        IDX1,IDX2       indices of resonances ("chains") in DTEVT1    *
8559 * Adopted from the original SAPTRE written by J. Ranft.                *
8560 * This version dated 18.01.95 is written by S. Roesler                 *
8561 ************************************************************************
8562
8563       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8564       SAVE
8565       PARAMETER ( LINP = 10 ,
8566      &            LOUT = 6 ,
8567      &            LDAT = 9 )
8568       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8569
8570 * event history
8571       PARAMETER (NMXHKK=200000)
8572       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8573      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8574      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8575 * extended event history
8576       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8577      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8578      &                IHIST(2,NMXHKK)
8579 * flags for input different options
8580       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8581       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8582      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8583
8584       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
8585
8586       DATA B3 /4.0D0/
8587
8588       ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
8589       ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
8590       ESMAX  = MIN(ESMAX1,ESMAX2)
8591       IF (ESMAX.LE.0.05D0) RETURN
8592
8593       HMA    = PHKK(5,IDX1)
8594       DO 1 K=1,4
8595          PA1(K) = PHKK(K,IDX1)
8596          PA2(K) = PHKK(K,IDX2)
8597     1 CONTINUE
8598
8599       IF (LEMCCK) THEN
8600          CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
8601          CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
8602       ENDIF
8603
8604       EXEB   = 0.0D0
8605       IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
8606       BEXP   = HMA*(1.0D0-EXEB)/B3
8607       AXEXP  = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
8608       WA     = AXEXP/(BEXP+AXEXP)
8609       XAB    = DT_RNDM(WA)
8610    10 CONTINUE
8611 * ES is the transverse kinetic energy
8612       IF (XAB.LT.WA)THEN
8613         X  = DT_RNDM(WA)
8614         Y  = DT_RNDM(WA)
8615         ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
8616       ELSE
8617         X  = DT_RNDM(Y)
8618         ES = ABS(-LOG(X+TINY7)/B3)
8619       ENDIF
8620       IF (ES.GT.ESMAX) GOTO 10
8621       ES  = ES+HMA
8622 * transverse momentum
8623       HPS = SQRT((ES-HMA)*(ES+HMA))
8624
8625       CALL DT_DSFECF(SFE,CFE)
8626       HPX = HPS*CFE
8627       HPY = HPS*SFE
8628       PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
8629       PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
8630       IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
8631
8632 C     PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
8633 C     PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
8634       PA1(1) = PA1(1)+HPX
8635       PA1(2) = PA1(2)+HPY
8636       PA2(1) = PA2(1)-HPX
8637       PA2(2) = PA2(2)-HPY
8638
8639 * put resonances on mass-shell again
8640       XM1 = PHKK(5,IDX1)
8641       XM2 = PHKK(5,IDX2)
8642       CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
8643       IF (IREJ1.NE.0) RETURN
8644
8645       IF (LEMCCK) THEN
8646          CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
8647          CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
8648          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
8649          IF (IREJ1.NE.0) RETURN
8650       ENDIF
8651
8652       DO 2 K=1,4
8653          PHKK(K,IDX1) = P1(K)
8654          PHKK(K,IDX2) = P2(K)
8655     2 CONTINUE
8656
8657       RETURN
8658       END
8659
8660 *$ CREATE DT_CRONIN.FOR
8661 *COPY DT_CRONIN
8662 *
8663 *===cronin=============================================================*
8664 *
8665       SUBROUTINE DT_CRONIN(INCL)
8666
8667 ************************************************************************
8668 * Cronin-Effect. Multiple scattering of partons at chain ends.         *
8669 *             INCL = 1     multiple sc. in projectile                  *
8670 *                  = 2     multiple sc. in target                      *
8671 * This version dated 05.01.96 is written by S. Roesler.                *
8672 ************************************************************************
8673
8674       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8675       SAVE
8676       PARAMETER ( LINP = 10 ,
8677      &            LOUT = 6 ,
8678      &            LDAT = 9 )
8679       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8680
8681 * event history
8682       PARAMETER (NMXHKK=200000)
8683       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8684      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8685      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8686 * extended event history
8687       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8688      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8689      &                IHIST(2,NMXHKK)
8690 * rejection counter
8691       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8692      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8693      &                IREXCI(3),IRDIFF(2),IRINC
8694 * Glauber formalism: collision properties
8695       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8696      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8697
8698       DIMENSION R(3),PIN(4),POUT(4),DEV(4)
8699
8700       DO 1 K=1,4
8701          DEV(K) = ZERO
8702     1 CONTINUE
8703
8704       DO 2 I=NPOINT(2),NHKK
8705          IF (ISTHKK(I).LT.0) THEN
8706 * get z-position of the chain
8707             R(1) = VHKK(1,I)*1.0D12
8708             IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
8709             R(2) = VHKK(2,I)*1.0D12
8710             IDXNU = JMOHKK(1,I)
8711             IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
8712      &                             IDXNU = JMOHKK(1,I-1)
8713             IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
8714      &                             IDXNU = JMOHKK(1,I+1)
8715             R(3) = VHKK(3,IDXNU)*1.0D12
8716 * position of target parton the chain is connected to
8717             DO 3 K=1,4
8718                PIN(K) = PHKK(K,I)
8719     3       CONTINUE
8720 * multiple scattering of parton with DTEVT1-index I
8721             CALL DT_CROMSC(PIN,R,POUT,INCL)
8722 **testprint
8723 C           IF (NEVHKK.EQ.5) THEN
8724 C              AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
8725 C              AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
8726 C              AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
8727 C              AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
8728 C              WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
8729 C              WRITE(6,'(A,4E15.5)')'PIN:       ',PIN
8730 C              WRITE(6,'(A,4E15.5)')'POUT:      ',POUT
8731 C           ENDIF
8732 **
8733 * increase accumulator by energy-momentum difference
8734             DO 4 K=1,4
8735                DEV(K)    = DEV(K)+POUT(K)-PIN(K)
8736                PHKK(K,I) = POUT(K)
8737     4       CONTINUE
8738             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8739      &                           PHKK(2,I)**2-PHKK(3,I)**2))
8740          ENDIF
8741     2 CONTINUE
8742
8743 * dump accumulator to momenta of valence partons
8744       NVAL = 0
8745       ETOT = 0.0D0
8746       DO 5 I=NPOINT(2),NHKK
8747          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8748             NVAL = NVAL+1
8749             ETOT = ETOT+PHKK(4,I)
8750          ENDIF
8751     5 CONTINUE
8752 C     WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
8753  1000 FORMAT(1X,'CRONIN :  number of val. partons ',I4,/,
8754      &       9X,4E12.4)
8755       DO 6 I=NPOINT(2),NHKK
8756          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8757             E = PHKK(4,I)
8758             DO 7 K=1,4
8759 C              PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
8760                PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
8761     7       CONTINUE
8762             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8763      &                           PHKK(2,I)**2-PHKK(3,I)**2))
8764          ENDIF
8765     6 CONTINUE
8766
8767       RETURN
8768       END
8769
8770 *$ CREATE DT_CROMSC.FOR
8771 *COPY DT_CROMSC
8772 *
8773 *===cromsc=============================================================*
8774 *
8775       SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
8776
8777 ************************************************************************
8778 * Cronin-Effect. Multiple scattering of one parton passing through     *
8779 * nuclear matter.                                                      *
8780 *            PIN(4)       input 4-momentum of parton                   *
8781 *            POUT(4)      4-momentum of parton after mult. scatt.      *
8782 *            R(3)         spatial position of parton in target nucleus *
8783 *            INCL = 1     multiple sc. in projectile                   *
8784 *                 = 2     multiple sc. in target                       *
8785 * This is a revised version of the original version written by J. Ranft*
8786 * This version dated 17.01.95 is written by S. Roesler.                *
8787 ************************************************************************
8788
8789       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8790       SAVE
8791       PARAMETER ( LINP = 10 ,
8792      &            LOUT = 6 ,
8793      &            LDAT = 9 )
8794       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8795
8796       LOGICAL LSTART
8797
8798 * rejection counter
8799       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8800      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8801      &                IREXCI(3),IRDIFF(2),IRINC
8802 * Glauber formalism: collision properties
8803       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8804      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8805 * various options for treatment of partons (DTUNUC 1.x)
8806 * (chain recombination, Cronin,..)
8807       LOGICAL LCO2CR,LINTPT
8808       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8809      &                LCO2CR,LINTPT
8810
8811       DIMENSION PIN(4),POUT(4),R(3)
8812
8813       DATA LSTART /.TRUE./
8814
8815       IRCRON(1) = IRCRON(1)+1
8816
8817       IF (LSTART) THEN
8818          WRITE(LOUT,1000) CRONCO
8819  1000    FORMAT(/,1X,'CROMSC:  multiple scattering of chain ends',
8820      &          ' treated',/,10X,'with parameter CRONCO = ',F5.2)
8821          LSTART = .FALSE.
8822       ENDIF
8823
8824       NCBACK = 0
8825       RNCL   = RPROJ
8826       IF (INCL.EQ.2) RNCL = RTARG
8827
8828 * Lorentz-transformation into Lab.
8829       MODE = -(INCL+1)
8830       CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
8831
8832       PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
8833       IF (PTOT.LE.8.0D0) GOTO 9997
8834
8835 * direction cosines of parton before mult. scattering
8836       COSX = PIN(1)/PTOT
8837       COSY = PIN(2)/PTOT
8838       COSZ = PZ/PTOT
8839
8840       RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
8841       IF (RTESQ.GE.-TINY3) GOTO 9999
8842
8843 * calculate distance (DIST) from R to surface of nucleus (radius RNCL)
8844 * in the direction of particle motion
8845
8846       A    = COSX*R(1)+COSY*R(2)+COSZ*R(3)
8847       TMP  = A**2-RTESQ
8848       IF (TMP.LT.ZERO) GOTO 9998
8849       DIST = -A+SQRT(TMP)
8850
8851 * multiple scattering angle
8852       THETO = CRONCO*SQRT(DIST)/PTOT
8853       IF (THETO.GT.0.1D0) THETO=0.1D0
8854
8855     1 CONTINUE
8856 * Gaussian sampling of spatial angle
8857       CALL DT_RANNOR(R1,R2)
8858       THETA = ABS(R1*THETO)
8859       IF (THETA.GT.0.3D0) GOTO 9997
8860       CALL DT_DSFECF(SFE,CFE)
8861       COSTH = COS(THETA)
8862       SINTH = SIN(THETA)
8863
8864 * new direction cosines
8865       CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
8866      &                               COSXN,COSYN,COSZN)
8867
8868       POUT(1) = COSXN*PTOT
8869       POUT(2) = COSYN*PTOT
8870       PZ      = COSZN*PTOT
8871 * Lorentz-transformation into nucl.-nucl. cms
8872       MODE = INCL+1
8873       CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
8874
8875 C     IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
8876 C     IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
8877       IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
8878          THETO = THETO/2.0D0
8879          NCBACK = NCBACK+1
8880          IF (MOD(NCBACK,200).EQ.0) THEN
8881             WRITE(LOUT,1001) THETO,PIN,POUT
8882  1001       FORMAT(1X,'CROMSC: inconsistent scattering angle ',
8883      &             E12.4,/,1X,'        PIN :',4E12.4,/,
8884      &             1X,'       POUT:',4E12.4)
8885             GOTO 9997
8886          ENDIF
8887          GOTO 1
8888       ENDIF
8889
8890       RETURN
8891
8892  9997 IRCRON(2) = IRCRON(2)+1
8893       GOTO 9999
8894  9998 IRCRON(3) = IRCRON(3)+1
8895
8896  9999 CONTINUE
8897       DO 100 K=1,4
8898          POUT(K) = PIN(K)
8899   100 CONTINUE
8900       RETURN
8901       END
8902
8903 *$ CREATE DT_COM2CR.FOR
8904 *COPY DT_COM2CR
8905 *
8906 *===com2sr=============================================================*
8907 *
8908       SUBROUTINE DT_COM2CR
8909
8910 ************************************************************************
8911 * COMbine q-aq chains to Color Ropes (qq-aqaq).                        *
8912 *        CUTOF      parameter determining minimum number of not        *
8913 *                   combined q-aq chains                               *
8914 * This subroutine replaces KKEVCC etc.                                 *
8915 * This version dated 11.01.95 is written by S. Roesler.                *
8916 ************************************************************************
8917
8918       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8919       SAVE
8920       PARAMETER ( LINP = 10 ,
8921      &            LOUT = 6 ,
8922      &            LDAT = 9 )
8923
8924 * event history
8925       PARAMETER (NMXHKK=200000)
8926       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8927      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8928      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8929 * extended event history
8930       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8931      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8932      &                IHIST(2,NMXHKK)
8933 * statistics
8934       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
8935      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
8936      &                ICEVTG(8,0:30)
8937 * various options for treatment of partons (DTUNUC 1.x)
8938 * (chain recombination, Cronin,..)
8939       LOGICAL LCO2CR,LINTPT
8940       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8941      &                LCO2CR,LINTPT
8942
8943       DIMENSION IDXQA(248),IDXAQ(248)
8944
8945       ICCHAI(1,9) = ICCHAI(1,9)+1
8946       NQA = 0
8947       NAQ = 0
8948 * scan DTEVT1 for q-aq, aq-q chains
8949       DO 10 I=NPOINT(3),NHKK
8950 * skip "chains" which are resonances
8951          IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
8952             MO1 = JMOHKK(1,I)
8953             MO2 = JMOHKK(2,I)
8954             IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
8955 * q-aq, aq-q chain found, keep index
8956                IF (IDHKK(MO1).GT.0) THEN
8957                   NQA = NQA+1
8958                   IDXQA(NQA) = I
8959                ELSE
8960                   NAQ = NAQ+1
8961                   IDXAQ(NAQ) = I
8962                ENDIF
8963             ENDIF
8964          ENDIF
8965    10 CONTINUE
8966
8967 * minimum number of q-aq chains requested for the same projectile/
8968 * target
8969       NCHMIN = IDT_NPOISS(CUTOF)
8970
8971 * combine q-aq chains of the same projectile
8972       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
8973 * combine q-aq chains of the same target
8974       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
8975 * combine aq-q chains of the same projectile
8976       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
8977 * combine aq-q chains of the same target
8978       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
8979
8980       RETURN
8981       END
8982
8983 *$ CREATE DT_SCN4CR.FOR
8984 *COPY DT_SCN4CR
8985 *
8986 *===scn4cr=============================================================*
8987 *
8988       SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
8989
8990 ************************************************************************
8991 * SCan q-aq chains for Color Ropes.                                    *
8992 * This version dated 11.01.95 is written by S. Roesler.                *
8993 ************************************************************************
8994
8995       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8996       SAVE
8997       PARAMETER ( LINP = 10 ,
8998      &            LOUT = 6 ,
8999      &            LDAT = 9 )
9000
9001 * event history
9002       PARAMETER (NMXHKK=200000)
9003       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9004      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9005      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9006 * extended event history
9007       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9008      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9009      &                IHIST(2,NMXHKK)
9010
9011       DIMENSION IDXCH(248),IDXJN(248)
9012
9013       DO 1 I=1,NCH
9014          IF (IDXCH(I).GT.0) THEN
9015             NJOIN = 1
9016             IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9017             IDXJN(NJOIN) = I
9018             IF (I.LT.NCH) THEN
9019                DO 2 J=I+1,NCH
9020                   IF (IDXCH(J).GT.0) THEN
9021                      IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9022                      IF (IDXMO.EQ.IDXMO1) THEN
9023                         NJOIN = NJOIN+1
9024                         IDXJN(NJOIN) = J
9025                      ENDIF
9026                   ENDIF
9027     2          CONTINUE
9028             ENDIF
9029             IF (NJOIN.GE.NCHMIN+2) THEN
9030                NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9031                DO 3 J=1,2*NJ,2
9032                   CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9033                   IF (IREJ1.NE.0) GOTO 3
9034                   IDXCH(IDXJN(J))   = 0
9035                   IDXCH(IDXJN(J+1)) = 0
9036     3          CONTINUE
9037             ENDIF
9038          ENDIF
9039     1 CONTINUE
9040
9041       RETURN
9042       END
9043
9044 *$ CREATE DT_JOIN.FOR
9045 *COPY DT_JOIN
9046 *
9047 *===join===============================================================*
9048 *
9049       SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9050
9051 ************************************************************************
9052 * This subroutine joins two q-aq chains to one qq-aqaq chain.          *
9053 *     IDX1, IDX2       DTEVT1 indices of chains to be joined           *
9054 * This version dated 11.01.95 is written by S. Roesler.                *
9055 ************************************************************************
9056
9057       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9058       SAVE
9059       PARAMETER ( LINP = 10 ,
9060      &            LOUT = 6 ,
9061      &            LDAT = 9 )
9062
9063 * event history
9064       PARAMETER (NMXHKK=200000)
9065       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9066      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9067      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9068 * extended event history
9069       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9070      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9071      &                IHIST(2,NMXHKK)
9072 * flags for input different options
9073       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9074       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9075      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9076 * statistics
9077       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9078      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9079      &                ICEVTG(8,0:30)
9080
9081       DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9082
9083       IREJ   = 0
9084
9085       IDX(1) = IDX1
9086       IDX(2) = IDX2
9087       DO 1 I=1,2
9088          DO 2 J=1,2
9089             MO(I,J) = JMOHKK(J,IDX(I))
9090             ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9091     2    CONTINUE
9092     1 CONTINUE
9093
9094 * check consistency
9095       IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9096      &    (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9097      &    ((ID(1,1)*ID(2,1)).LT.0).OR.
9098      &    ((ID(1,2)*ID(2,2)).LT.0)) THEN
9099          WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9100      &                    MO(2,2)
9101  1000    FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9102      &             2I5,' chain ',I4,':',2I5)
9103       ENDIF
9104
9105 * join chains
9106       DO 3 K=1,4
9107          PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9108          PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9109     3 CONTINUE
9110       IF1  = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9111       IF2  = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9112       IST1 = ISTHKK(MO(1,1))
9113       IST2 = ISTHKK(MO(1,2))
9114
9115 * put partons again on mass shell
9116       XM1 = 0.0D0
9117       XM2 = 0.0D0
9118       IF (IMSHL.EQ.1) THEN
9119          XM1 = PYMASS(IF1)
9120          XM2 = PYMASS(IF2)
9121       ENDIF
9122       CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9123       IF (IREJ1.NE.0) GOTO 9999
9124       DO 4 I=1,4
9125          PP(I) = P1(I)
9126          PT(I) = P2(I)
9127     4 CONTINUE
9128
9129 * store new partons in DTEVT1
9130       CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9131      &                                                       0,0,0)
9132       CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9133      &                                                       0,0,0)
9134       DO 5 K=1,4
9135          PCH(K) = PP(K)+PT(K)
9136     5 CONTINUE
9137
9138 * check new chain for lower mass limit
9139       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9140          AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9141          CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9142      &               AMCH,AMCHN,3,IREJ1)
9143          IF (IREJ1.NE.0) THEN
9144             NHKK = NHKK-2
9145             GOTO 9999
9146          ENDIF
9147       ENDIF
9148
9149       ICCHAI(2,9) = ICCHAI(2,9)+1
9150 * store new chain in DTEVT1
9151       KCH = 191
9152       CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9153       IDHKK(IDX(1)) = 22222
9154       IDHKK(IDX(2)) = 22222
9155 * special treatment for space-time coordinates
9156       DO 6 K=1,4
9157          VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9158          WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9159     6 CONTINUE
9160       RETURN
9161
9162  9999 CONTINUE
9163       IREJ = 1
9164       RETURN
9165       END
9166
9167 *$ CREATE DT_XSGLAU.FOR
9168 *COPY DT_XSGLAU
9169 *
9170 *===xsglau=============================================================*
9171 *
9172       SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9173
9174 ************************************************************************
9175 * Total, elastic, quasi-elastic, inelastic cross sections according to *
9176 * Glauber's approach.                                                  *
9177 *  NA / NB     mass numbers of proj./target nuclei                     *
9178 *  JJPROJ      bamjet-index of projectile (=1 in case of proj.nucleus) *
9179 *  XI,Q2I,ECMI kinematical variables x, Q^2, E_cm                      *
9180 *  IE,IQ       indices of energy and virtuality (the latter for gamma  *
9181 *              projectiles only)                                       *
9182 *  NIDX        index of projectile/target nucleus                      *
9183 * This version dated 17.3.98  is written by S. Roesler                 *
9184 ************************************************************************
9185
9186       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9187       SAVE
9188       PARAMETER ( LINP = 10 ,
9189      &            LOUT = 6 ,
9190      &            LDAT = 9 )
9191
9192       COMPLEX*16 CZERO,CONE,CTWO
9193       CHARACTER*12 CFILE
9194       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9195      &           ONETHI=ONE/THREE,TINY25=1.0D-25)
9196       PARAMETER (TWOPI  = 6.283185307179586454D+00,
9197      &           PI     = TWOPI/TWO,
9198      &           GEV2MB = 0.38938D0,
9199      &           GEV2FM = 0.1972D0,
9200      &           ALPHEM = ONE/137.0D0,
9201 * proton mass
9202      &           AMP    = 0.938D0,
9203      &           AMP2   = AMP**2,
9204 * approx. nucleon radius
9205      &           RNUCLE = 1.12D0)
9206
9207 * particle properties (BAMJET index convention)
9208       CHARACTER*8  ANAME
9209       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9210      &                IICH(210),IIBAR(210),K1(210),K2(210)
9211       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9212       PARAMETER ( MAXNCL = 260,
9213      &            MAXVQU = MAXNCL,
9214      &            MAXSQU = 20*MAXVQU,
9215      &            MAXINT = MAXVQU+MAXSQU)
9216 * Glauber formalism: parameters
9217       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9218      &                BMAX(NCOMPX),BSTEP(NCOMPX),
9219      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9220      &                NSITEB,NSTATB
9221 * Glauber formalism: cross sections
9222       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9223      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9224      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9225      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9226      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9227      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9228      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9229      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9230      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9231      &                BSLOPE,NEBINI,NQBINI
9232 * Glauber formalism: flags and parameters for statistics
9233       LOGICAL LPROD
9234       CHARACTER*8 CGLB
9235       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9236 * nucleon-nucleon event-generator
9237       CHARACTER*8 CMODEL
9238       LOGICAL LPHOIN
9239       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9240 * VDM parameter for photon-nucleus interactions
9241       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9242 * parameters for hA-diffraction
9243       COMMON /DTDIHA/ DIBETA,DIALPH
9244
9245       COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9246      &           OMPP11,OMPP12,OMPP21,OMPP22,
9247      &           DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9248      &           PPTMP1,PPTMP2
9249       COMPLEX*16 C,CA,CI
9250       DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9251      &          COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9252      &          BPROD(KSITEB)
9253
9254       PARAMETER (NPOINT=16)
9255       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9256
9257       LOGICAL LFIRST,LOPEN
9258       DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9259
9260       NTARG = ABS(NIDX)
9261 * for quasi-elastic neutrino scattering set projectile to proton
9262 * it should not have an effect since the whole Glauber-formalism is
9263 * not needed for these interactions..
9264       IF (MCGENE.EQ.4) THEN
9265          IJPROJ = 1
9266       ELSE
9267          IJPROJ = JJPROJ
9268       ENDIF
9269
9270       IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9271          I = INDEX(CGLB,' ')
9272          IF (I.EQ.0) THEN
9273             CFILE = CGLB//'.glb'
9274             OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9275          ELSEIF (I.GT.1) THEN
9276             CFILE = CGLB(1:I-1)//'.glb'
9277             OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9278          ELSE
9279             STOP 'XSGLAU 1'
9280          ENDIF
9281          LOPEN = .TRUE.
9282       ENDIF
9283
9284       CZERO  = DCMPLX(ZERO,ZERO)
9285       CONE   = DCMPLX(ONE,ZERO)
9286       CTWO   = DCMPLX(TWO,ZERO)
9287       NEBINI = IE
9288       NQBINI = IQ
9289
9290 * re-define kinematics
9291       S  = ECMI**2
9292       Q2 = Q2I
9293       X  = XI
9294 *  g(Q2=0)-A, h-A, A-A scattering
9295       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9296          Q2 = 0.0001D0
9297          X  = Q2/(S+Q2-AMP2)
9298 *  g(Q2>0)-A scattering
9299       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9300          X  = Q2/(S+Q2-AMP2)
9301       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9302          Q2 = (S-AMP2)*X/(ONE-X)
9303       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9304          S  = Q2*(ONE-X)/X+AMP2
9305       ELSE
9306          WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9307          STOP
9308       ENDIF
9309       ECMNN(IE) = SQRT(S)
9310       Q2G(IQ)   = Q2
9311       XNU = (S+Q2-AMP2)/(TWO*AMP)
9312
9313 * parameters determining statistics in evaluating Glauber-xsection
9314       NSTATB = JSTATB
9315       NSITEB = JBINSB
9316       IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9317
9318 * set up interaction geometry (common /DTGLAM/)
9319 *  projectile/target radii
9320       RPRNCL = DT_RNCLUS(NA)
9321       RTANCL = DT_RNCLUS(NB)
9322       IF (IJPROJ.EQ.7) THEN
9323          RASH(1) = ZERO
9324          RBSH(NTARG) = RTANCL
9325          BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9326       ELSE
9327          IF (NIDX.LE.-1) THEN
9328             RASH(1)     = RPRNCL
9329             RBSH(NTARG) = RTANCL
9330             BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9331          ELSE
9332             RASH(NTARG) = RPRNCL
9333             RBSH(1)     = RTANCL
9334             BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9335          ENDIF
9336       ENDIF
9337 *  maximum impact-parameter
9338       BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9339
9340 * slope, rho ( Re(f(0))/Im(f(0)) )
9341       IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9342          IF (MCGENE.EQ.2) THEN
9343             ZERO1 = ZERO
9344             CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9345      &                                                   BSLOPE,0)
9346          ELSE
9347             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9348          ENDIF
9349          IF (ECMNN(IE).LE.3.0D0) THEN
9350             ROSH = -0.43D0
9351          ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9352             ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9353          ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9354             ROSH = 0.1D0
9355          ENDIF
9356       ELSEIF (IJPROJ.EQ.7) THEN
9357          ROSH = 0.1D0
9358       ELSE
9359          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9360          ROSH   = 0.01D0
9361       ENDIF
9362
9363 * projectile-nucleon xsection (in fm)
9364       IF (IJPROJ.EQ.7) THEN
9365          SIGSH = DT_SIGVP(X,Q2)/10.0D0
9366       ELSE
9367          ELAB  = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9368          PLAB  = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9369 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9370          DUMZER = ZERO
9371          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9372          SIGSH = SIGSH/10.0D0
9373       ENDIF
9374
9375 * parameters for projectile diffraction (hA scattering only)
9376       IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9377      &                               .AND.(DIBETA.GE.ZERO)) THEN
9378          ZERO1 = ZERO
9379          CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9380 C        DIBETA = SDIF1/STOT
9381          DIBETA = 0.2D0
9382          DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9383          IF (DIBETA.LE.ZERO) THEN
9384             ALPGAM = ONE
9385          ELSE
9386             ALPGAM = DIALPH/DIGAMM
9387          ENDIF
9388          FACDI1 = ONE-ALPGAM
9389          FACDI2 = ONE+ALPGAM
9390          FACDI  = SQRT(FACDI1*FACDI2)
9391          WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9392       ELSE
9393          DIBETA = -1.0D0
9394          DIALPH = ZERO
9395          DIGAMM = ZERO
9396          FACDI1 = ZERO
9397          FACDI2 = 2.0D0
9398          FACDI  = ZERO
9399       ENDIF
9400
9401 * initializations
9402       DO 10 I=1,NSITEB
9403          BSITE( 0,IQ,NTARG,I) = ZERO
9404          BSITE(IE,IQ,NTARG,I) = ZERO
9405          BPROD(I) = ZERO
9406    10 CONTINUE
9407       STOT  = ZERO
9408       STOT2 = ZERO
9409       SELA  = ZERO
9410       SELA2 = ZERO
9411       SQEP  = ZERO
9412       SQEP2 = ZERO
9413       SQET  = ZERO
9414       SQET2 = ZERO
9415       SQE2  = ZERO
9416       SQE22 = ZERO
9417       SPRO  = ZERO
9418       SPRO2 = ZERO
9419       SDEL  = ZERO
9420       SDEL2 = ZERO
9421       SDQE  = ZERO
9422       SDQE2 = ZERO
9423       FACN   = ONE/DBLE(NSTATB)
9424
9425       IPNT = 0
9426       RPNT = ZERO
9427
9428 *  initialize Gauss-integration for photon-proj.
9429       JPOINT = 1
9430       IF (IJPROJ.EQ.7) THEN
9431          IF (INTRGE(1).EQ.1) THEN
9432             AMLO2 = (3.0D0*AAM(13))**2
9433          ELSEIF (INTRGE(1).EQ.2) THEN
9434             AMLO2 = AAM(33)**2
9435          ELSE
9436             AMLO2 = AAM(96)**2
9437          ENDIF
9438          IF (INTRGE(2).EQ.1) THEN
9439             AMHI2 = S/TWO
9440          ELSEIF (INTRGE(2).EQ.2) THEN
9441             AMHI2 = S/4.0D0
9442          ELSE
9443             AMHI2 = S
9444          ENDIF
9445          AMHI20 = (ECMNN(IE)-AMP)**2
9446          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9447          XAMLO = LOG( AMLO2+Q2 )
9448          XAMHI = LOG( AMHI2+Q2 )
9449 **PHOJET105a
9450 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9451 **PHOJET112
9452          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9453 **
9454          JPOINT = NPOINT
9455 * ratio direct/total photon-nucleon xsection
9456          CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
9457       ENDIF
9458
9459 * read pre-initialized profile-function from file
9460       IF (IOGLB.EQ.1) THEN
9461          READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
9462          IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
9463             WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
9464      &                             NA,NB,NSTATB,NSITEB
9465  1000       FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
9466      &             ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
9467      &             ' (NA,NB,NSTATB,NSITEB) ',4I10)
9468             STOP
9469          ENDIF
9470          IF (LFIRST) WRITE(LOUT,1001) CFILE
9471  1001    FORMAT(/,' XSGLAU: impact parameter distribution read from ',
9472      &          'file ',A12,/)
9473          READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
9474      &                         XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
9475      &                         XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9476          READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
9477      &                         XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
9478      &                         XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9479          NLINES = INT(DBLE(NSITEB)/7.0D0)
9480          IF (NLINES.GT.0) THEN
9481             DO 21 I=1,NLINES
9482                ISTART = 7*I-6
9483                READ(LDAT,'(7E11.4)')
9484      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9485    21       CONTINUE
9486          ENDIF
9487          ISTART = 7*NLINES+1
9488          IF (ISTART.LE.NSITEB) THEN
9489             READ(LDAT,'(7E11.4)')
9490      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9491          ENDIF
9492          LFIRST = .FALSE.
9493          GOTO 100
9494 * variable projectile/target/energy runs:
9495 * read pre-initialized profile-functions from file
9496       ELSEIF (IOGLB.EQ.100) THEN
9497          CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
9498          GOTO 100
9499       ENDIF
9500
9501 * cross sections averaged over NSTATB nucleon configurations
9502       DO 11 IS=1,NSTATB
9503 C        IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
9504          STOTN = ZERO
9505          SELAN = ZERO
9506          SQEPN = ZERO
9507          SQETN = ZERO
9508          SQE2N = ZERO
9509          SPRON = ZERO
9510          SDELN = ZERO
9511          SDQEN = ZERO
9512
9513          IF (NIDX.LE.-1) THEN
9514             CALL DT_CONUCL(COOP1,NA,RASH(1),0)
9515             CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
9516             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9517                CALL DT_CONUCL(COOP2,NA,RASH(1),0)
9518                CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
9519             ENDIF
9520          ELSE
9521             CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
9522             CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
9523             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9524                CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
9525                CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
9526             ENDIF
9527          ENDIF
9528
9529 *  integration over impact parameter B
9530          DO 12 IB=1,NSITEB-1
9531             STOTB = ZERO
9532             SELAB = ZERO
9533             SQEPB = ZERO
9534             SQETB = ZERO
9535             SQE2B = ZERO
9536             SPROB = ZERO
9537             SDIR  = ZERO
9538             SDELB = ZERO
9539             SDQEB = ZERO
9540             B     = DBLE(IB)*BSTEP(NTARG)
9541             FACB  = 10.0D0*TWOPI*B*BSTEP(NTARG)
9542
9543 *   integration over M_V^2 for photon-proj.
9544             DO 14 IM=1,JPOINT
9545                PP11(1) = CONE
9546                PP12(1) = CONE
9547                PP21(1) = CONE
9548                PP22(1) = CONE
9549                IF (IJPROJ.EQ.7) THEN
9550                   DO 13 K=2,NB
9551                      PP11(K) = CONE
9552                      PP12(K) = CONE
9553                      PP21(K) = CONE
9554                      PP22(K) = CONE
9555    13             CONTINUE
9556                ENDIF
9557                SHI  = ZERO
9558                FACM = ONE
9559                DCOH = 1.0D10
9560
9561                IF (IJPROJ.EQ.7) THEN
9562                   AMV2 = EXP(ABSZX(IM))-Q2
9563                   AMV  = SQRT(AMV2)
9564                   IF (AMV2.LT.16.0D0) THEN
9565                      R = TWO
9566                   ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
9567                      R = 10.0D0/3.0D0
9568                   ELSE
9569                      R = 11.0D0/3.0D0
9570                   ENDIF
9571 *    define M_V dependent properties of nucleon scattering amplitude
9572 *     V_M-nucleon xsection
9573                   SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
9574                   SIGMV  = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
9575 *     slope-parametrisation a la Kaidalov
9576                   BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
9577      &                           +0.25D0*LOG(S/(AMV2+Q2)))
9578 *    coherence length
9579                   IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
9580 *    integration weight factor
9581                   FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
9582      &                  R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
9583                ENDIF
9584                GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
9585                GAM = GSH
9586                IF (IJPROJ.EQ.7) THEN
9587                   RCA = GAM*SIGMV/TWOPI
9588                ELSE
9589                   RCA = GAM*SIGSH/TWOPI
9590                ENDIF
9591                FCA = -ROSH*RCA
9592                CA  = DCMPLX(RCA,FCA)
9593                CI  = CONE
9594
9595                DO 15 INA=1,NA
9596                   KK1  = 1
9597                   INT1 = 1
9598                   KK2  = 1
9599                   INT2 = 1
9600                   DO 16 INB=1,NB
9601 *    photon-projectile: check for supression by coherence length
9602                      IF (IJPROJ.EQ.7) THEN
9603                         IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
9604                            KK1  = INB
9605                            INT1 = INT1+1
9606                         ENDIF
9607                         IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
9608                            KK2  = INB
9609                            INT2 = INT2+1
9610                         ENDIF
9611                      ENDIF
9612
9613                      X11 = B+COOT1(1,INB)-COOP1(1,INA)
9614                      Y11 =   COOT1(2,INB)-COOP1(2,INA)
9615                      XY11 = GAM*(X11*X11+Y11*Y11)
9616                      IF (XY11.LE.15.0D0) THEN
9617                         C = CONE-CA*EXP(-XY11)
9618                         AR = DBLE(PP11(INT1))
9619                         AI = DIMAG(PP11(INT1))
9620                         IF (ABS(AR).LT.TINY25) AR = ZERO
9621                         IF (ABS(AI).LT.TINY25) AI = ZERO
9622                         PP11(INT1) = DCMPLX(AR,AI)
9623                         PP11(INT1) = PP11(INT1)*C
9624                         AR  = DBLE(C)
9625                         AI  = DIMAG(C)
9626                         SHI = SHI+LOG(AR*AR+AI*AI)
9627                      ENDIF
9628                      IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9629                         X12 = B+COOT2(1,INB)-COOP1(1,INA)
9630                         Y12 =   COOT2(2,INB)-COOP1(2,INA)
9631                         XY12 = GAM*(X12*X12+Y12*Y12)
9632                         IF (XY12.LE.15.0D0) THEN
9633                            C = CONE-CA*EXP(-XY12)
9634                            AR = DBLE(PP12(INT2))
9635                            AI = DIMAG(PP12(INT2))
9636                            IF (ABS(AR).LT.TINY25) AR = ZERO
9637                            IF (ABS(AI).LT.TINY25) AI = ZERO
9638                            PP12(INT2) = DCMPLX(AR,AI)
9639                            PP12(INT2) = PP12(INT2)*C
9640                         ENDIF
9641                         X21 = B+COOT1(1,INB)-COOP2(1,INA)
9642                         Y21 =   COOT1(2,INB)-COOP2(2,INA)
9643                         XY21 = GAM*(X21*X21+Y21*Y21)
9644                         IF (XY21.LE.15.0D0) THEN
9645                            C = CONE-CA*EXP(-XY21)
9646                            AR = DBLE(PP21(INT1))
9647                            AI = DIMAG(PP21(INT1))
9648                            IF (ABS(AR).LT.TINY25) AR = ZERO
9649                            IF (ABS(AI).LT.TINY25) AI = ZERO
9650                            PP21(INT1) = DCMPLX(AR,AI)
9651                            PP21(INT1) = PP21(INT1)*C
9652                         ENDIF
9653                         X22 = B+COOT2(1,INB)-COOP2(1,INA)
9654                         Y22 =   COOT2(2,INB)-COOP2(2,INA)
9655                         XY22 = GAM*(X22*X22+Y22*Y22)
9656                         IF (XY22.LE.15.0D0) THEN
9657                            C = CONE-CA*EXP(-XY22)
9658                            AR = DBLE(PP22(INT2))
9659                            AI = DIMAG(PP22(INT2))
9660                            IF (ABS(AR).LT.TINY25) AR = ZERO
9661                            IF (ABS(AI).LT.TINY25) AI = ZERO
9662                            PP22(INT2) = DCMPLX(AR,AI)
9663                            PP22(INT2) = PP22(INT2)*C
9664                         ENDIF
9665                      ENDIF
9666    16             CONTINUE
9667    15          CONTINUE
9668
9669                OMPP11 = CZERO
9670                OMPP21 = CZERO
9671                DIPP11 = CZERO
9672                DIPP21 = CZERO
9673                DO 17 K=1,INT1
9674                   IF (PP11(K).EQ.CZERO) THEN
9675                      PPTMP1 = CZERO
9676                      PPTMP2 = CZERO
9677                   ELSE
9678                      PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
9679                      PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
9680                   ENDIF
9681                   AVDIPP = 0.5D0*
9682      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9683                   OMPP11 = OMPP11+AVDIPP
9684 C                 OMPP11 = OMPP11+(CONE-PP11(K))
9685                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9686                   DIPP11 = DIPP11+AVDIPP
9687                   IF (PP21(K).EQ.CZERO) THEN
9688                      PPTMP1 = CZERO
9689                      PPTMP2 = CZERO
9690                   ELSE
9691                      PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
9692                      PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
9693                   ENDIF
9694                   AVDIPP = 0.5D0*
9695      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9696                   OMPP21 = OMPP21+AVDIPP
9697 C                 OMPP21 = OMPP21+(CONE-PP21(K))
9698                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9699                   DIPP21 = DIPP21+AVDIPP
9700    17          CONTINUE
9701                OMPP12 = CZERO
9702                OMPP22 = CZERO
9703                DIPP12 = CZERO
9704                DIPP22 = CZERO
9705                DO 18 K=1,INT2
9706                   IF (PP12(K).EQ.CZERO) THEN
9707                      PPTMP1 = CZERO
9708                      PPTMP2 = CZERO
9709                   ELSE
9710                      PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
9711                      PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
9712                   ENDIF
9713                   AVDIPP = 0.5D0*
9714      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9715                   OMPP12 = OMPP12+AVDIPP
9716 C                 OMPP12 = OMPP12+(CONE-PP12(K))
9717                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9718                   DIPP12 = DIPP12+AVDIPP
9719                   IF (PP22(K).EQ.CZERO) THEN
9720                      PPTMP1 = CZERO
9721                      PPTMP2 = CZERO
9722                   ELSE
9723                      PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
9724                      PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
9725                   ENDIF
9726                   AVDIPP = 0.5D0*
9727      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9728                   OMPP22 = OMPP22+AVDIPP
9729 C                 OMPP22 = OMPP22+(CONE-PP22(K))
9730                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9731                   DIPP22 = DIPP22+AVDIPP
9732    18          CONTINUE
9733
9734                SPROM = ONE-EXP(SHI)
9735                SPROB = SPROB+FACM*SPROM
9736                IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9737                   STOTM = DBLE(OMPP11+OMPP22)
9738                   SELAM = DBLE(OMPP11*DCONJG(OMPP22))
9739                   SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
9740                   SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
9741                   SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
9742                   SDELM = DBLE(DIPP11*DCONJG(DIPP22))
9743                   SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
9744                   STOTB = STOTB+FACM*STOTM
9745                   SELAB = SELAB+FACM*SELAM
9746                   SDELB = SDELB+FACM*SDELM
9747                   IF (NB.GT.1) THEN
9748                      SQEPB = SQEPB+FACM*SQEPM
9749                      SDQEB = SDQEB+FACM*SDQEM
9750                   ENDIF
9751                   IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
9752                   IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
9753                   IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
9754                ENDIF
9755
9756    14       CONTINUE
9757
9758             STOTN = STOTN+FACB*STOTB
9759             SELAN = SELAN+FACB*SELAB
9760             SQEPN = SQEPN+FACB*SQEPB
9761             SQETN = SQETN+FACB*SQETB
9762             SQE2N = SQE2N+FACB*SQE2B
9763             SPRON = SPRON+FACB*SPROB
9764             SDELN = SDELN+FACB*SDELB
9765             SDQEN = SDQEN+FACB*SDQEB
9766
9767             IF (IJPROJ.EQ.7) THEN
9768                BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
9769             ELSE
9770                IF (DIBETA.GT.ZERO) THEN
9771                   BPROD(IB+1)= BPROD(IB+1)
9772      &                        +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
9773                ELSE
9774                   BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
9775                ENDIF
9776             ENDIF
9777
9778    12    CONTINUE
9779
9780          STOT  = STOT +FACN*STOTN
9781          STOT2 = STOT2+FACN*STOTN**2
9782          SELA  = SELA +FACN*SELAN
9783          SELA2 = SELA2+FACN*SELAN**2
9784          SQEP  = SQEP +FACN*SQEPN
9785          SQEP2 = SQEP2+FACN*SQEPN**2
9786          SQET  = SQET +FACN*SQETN
9787          SQET2 = SQET2+FACN*SQETN**2
9788          SQE2  = SQE2 +FACN*SQE2N
9789          SQE22 = SQE22+FACN*SQE2N**2
9790          SPRO  = SPRO +FACN*SPRON
9791          SPRO2 = SPRO2+FACN*SPRON**2
9792          SDEL  = SDEL +FACN*SDELN
9793          SDEL2 = SDEL2+FACN*SDELN**2
9794          SDQE  = SDQE +FACN*SDQEN
9795          SDQE2 = SDQE2+FACN*SDQEN**2
9796
9797    11 CONTINUE
9798
9799 * final cross sections
9800 * 1) total
9801       XSTOT(IE,IQ,NTARG) = STOT
9802       IF (IJPROJ.EQ.7)
9803      &   XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
9804 * 2) elastic
9805       XSELA(IE,IQ,NTARG) = SELA
9806 * 3) quasi-el.: A+B-->A+X (excluding 2)
9807       XSQEP(IE,IQ,NTARG) = SQEP
9808 * 4) quasi-el.: A+B-->X+B (excluding 2)
9809       XSQET(IE,IQ,NTARG) = SQET
9810 * 5) quasi-el.: A+B-->X (excluding 2-4)
9811       XSQE2(IE,IQ,NTARG) = SQE2
9812 * 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
9813       IF (SDEL.GT.ZERO) THEN
9814          XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
9815       ELSE
9816          XSPRO(IE,IQ,NTARG) = SPRO
9817       ENDIF
9818 * 7) projectile diffraction (el. scatt. off target)
9819       XSDEL(IE,IQ,NTARG) = SDEL
9820 * 8) projectile diffraction (quasi-el. scatt. off target)
9821       XSDQE(IE,IQ,NTARG) = SDQE
9822 *  stat. errors
9823       XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
9824       XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
9825       XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
9826       XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
9827       XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
9828       XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
9829       XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
9830       XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
9831
9832       IF (IJPROJ.EQ.7) THEN
9833          BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
9834      &          -XSQEP(IE,IQ,NTARG)
9835       ELSE
9836          BNORM = XSPRO(IE,IQ,NTARG)
9837       ENDIF
9838       DO 19 I=2,NSITEB
9839          BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
9840          IF ((IE.EQ.1).AND.(IQ.EQ.1))
9841      &      BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
9842    19 CONTINUE
9843
9844 * write profile function data into file
9845       IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
9846          WRITE(LDAT,'(5I10,1P,E15.5)')
9847      &      IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
9848          WRITE(LDAT,'(1P,6E12.5)')
9849      &      XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
9850      &      XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9851          WRITE(LDAT,'(1P,6E12.5)')
9852      &      XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
9853      &      XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9854          NLINES = INT(DBLE(NSITEB)/7.0D0)
9855          IF (NLINES.GT.0) THEN
9856             DO 20 I=1,NLINES
9857                ISTART = 7*I-6
9858                WRITE(LDAT,'(1P,7E11.4)')
9859      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9860    20       CONTINUE
9861          ENDIF
9862          ISTART = 7*NLINES+1
9863          IF (ISTART.LE.NSITEB) THEN
9864             WRITE(LDAT,'(1P,7E11.4)')
9865      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9866          ENDIF
9867       ENDIF
9868
9869   100 CONTINUE
9870
9871 C     IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
9872
9873       RETURN
9874       END
9875
9876 *$ CREATE DT_GETBXS.FOR
9877 *COPY DT_GETBXS
9878 *
9879 *===getbxs=============================================================*
9880 *
9881       SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
9882
9883 ************************************************************************
9884 * Biasing in impact parameter space.                                   *
9885 *     XSFRAC = 0 :  BLO    - minimum impact parameter  (input)         *
9886 *                   BHI    - maximum impact parameter  (input)         *
9887 *                   XSFRAC - fraction of cross section corresponding   *
9888 *                            to impact parameter range (BLO,BHI)       *
9889 *                                                      (output)        *
9890 *     XSFRAC > 0 :  XSFRAC - fraction of cross section (input)         *
9891 *                   BHI    - maximum impact parameter giving requested *
9892 *                            fraction of cross section in impact       *
9893 *                            parameter range (0,BMAX)  (output)        *
9894 * This version dated 17.03.00  is written by S. Roesler                *
9895 ************************************************************************
9896
9897       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9898       SAVE
9899       PARAMETER ( LINP = 10 ,
9900      &            LOUT = 6 ,
9901      &            LDAT = 9 )
9902
9903       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9904 * Glauber formalism: parameters
9905       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9906      &                BMAX(NCOMPX),BSTEP(NCOMPX),
9907      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9908      &                NSITEB,NSTATB
9909
9910       NTARG = ABS(NIDX)
9911       IF (XSFRAC.LE.0.0D0) THEN
9912          ILO    = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
9913          IHI    = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
9914          IF (ILO.GE.IHI) THEN
9915             XSFRAC = 0.0D0
9916             RETURN
9917          ENDIF
9918          IF (ILO.EQ.NSITEB-1) THEN
9919             FRCLO = BSITE(0,1,NTARG,NSITEB)
9920          ELSE
9921             FRCLO = BSITE(0,1,NTARG,ILO+1)
9922      &              +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
9923      &              *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
9924          ENDIF
9925          IF (IHI.EQ.NSITEB-1) THEN
9926             FRCHI = BSITE(0,1,NTARG,NSITEB)
9927          ELSE
9928             FRCHI = BSITE(0,1,NTARG,IHI+1)
9929      &              +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
9930      &              *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
9931          ENDIF
9932          XSFRAC = FRCHI-FRCLO
9933       ELSE
9934          BLO = 0.0D0
9935          BHI = BMAX(NTARG)
9936          DO 1 I=1,NSITEB-1
9937             IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
9938                FAC = (XSFRAC              -BSITE(0,1,NTARG,I))/
9939      &               (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
9940                BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
9941                GOTO 2
9942             ENDIF
9943     1    CONTINUE
9944     2    CONTINUE
9945       ENDIF
9946
9947       RETURN
9948       END
9949
9950 *$ CREATE DT_CONUCL.FOR
9951 *COPY DT_CONUCL
9952 *
9953 *===conucl=============================================================*
9954 *
9955       SUBROUTINE DT_CONUCL(X,N,R,MODE)
9956
9957 ************************************************************************
9958 * Calculation of coordinates of nucleons within nuclei.                *
9959 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
9960 *        N / R    number of nucleons / radius of nucleus   (input)     *
9961 *        MODE = 0 coordinates not sorted                               *
9962 *             = 1 coordinates sorted with increasing X(3,i)            *
9963 *             = 2 coordinates sorted with decreasing X(3,i)            *
9964 * This version dated 26.10.95 is revised by S. Roesler                 *
9965 ************************************************************************
9966
9967       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9968       SAVE
9969       PARAMETER ( LINP = 10 ,
9970      &            LOUT = 6 ,
9971      &            LDAT = 9 )
9972
9973       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9974      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
9975
9976       PARAMETER (TWOPI = 6.283185307179586454D+00 )
9977
9978       PARAMETER (NSRT=10)
9979       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
9980       DIMENSION X(3,N),XTMP(3,260)
9981
9982       CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
9983
9984       IF ((MODE.NE.0).AND.(N.GT.4)) THEN
9985          K = 0
9986          DO 1 I=1,NSRT
9987             IF (MODE.EQ.2) THEN
9988                ISRT = NSRT+1-I
9989             ELSE
9990                ISRT = I
9991             ENDIF
9992             K1 = K
9993             DO 2 J=1,ICSRT(ISRT)
9994                K = K+1
9995                X(1,K) = XTMP(1,IDXSRT(ISRT,J))
9996                X(2,K) = XTMP(2,IDXSRT(ISRT,J))
9997                X(3,K) = XTMP(3,IDXSRT(ISRT,J))
9998     2       CONTINUE
9999             IF (ICSRT(ISRT).GT.1) THEN
10000                I0 = K1+1
10001                I1 = K
10002                CALL DT_SORT(X,N,I0,I1,MODE)
10003             ENDIF
10004     1    CONTINUE
10005       ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
10006          DO 3 I=1,N
10007             X(1,I) = XTMP(1,I)
10008             X(2,I) = XTMP(2,I)
10009             X(3,I) = XTMP(3,I)
10010     3    CONTINUE
10011          CALL DT_SORT(X,N,1,N,MODE)
10012       ELSE
10013          DO 4 I=1,N
10014             X(1,I) = XTMP(1,I)
10015             X(2,I) = XTMP(2,I)
10016             X(3,I) = XTMP(3,I)
10017     4    CONTINUE
10018       ENDIF
10019
10020       RETURN
10021       END
10022
10023 *$ CREATE DT_COORDI.FOR
10024 *COPY DT_COORDI
10025 *
10026 *===coordi=============================================================*
10027 *
10028       SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10029
10030 ************************************************************************
10031 * Calculation of coordinates of nucleons within nuclei.                *
10032 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
10033 *        N / R    number of nucleons / radius of nucleus   (input)     *
10034 * Based on the original version by Shmakov et al.                      *
10035 * This version dated 26.10.95 is revised by S. Roesler                 *
10036 ************************************************************************
10037
10038       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10039       SAVE
10040       PARAMETER ( LINP = 10 ,
10041      &            LOUT = 6 ,
10042      &            LDAT = 9 )
10043
10044       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10045      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10046
10047       PARAMETER (TWOPI = 6.283185307179586454D+00 )
10048
10049       LOGICAL LSTART
10050
10051       PARAMETER (NSRT=10)
10052       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10053       DIMENSION X(3,260),WD(4),RD(3)
10054
10055       DATA PDIF/0.545D0/,R2MIN/0.16D0/
10056       DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10057       DATA RD /2.09D0, 0.935D0, 0.697D0/
10058
10059       X1SUM = ZERO
10060       X2SUM = ZERO
10061       X3SUM = ZERO
10062
10063       IF (N.EQ.1) THEN
10064          X(1,1) = ZERO
10065          X(2,1) = ZERO
10066          X(3,1) = ZERO
10067       ELSEIF (N.EQ.2) THEN
10068          EPS = DT_RNDM(RD(1))
10069          DO 30 I=1,3
10070             IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10071    30    CONTINUE
10072    40    CONTINUE
10073          DO 50 J=1,3
10074             CALL DT_RANNOR(X1,X2)
10075             X(J,1) = RD(I)*X1
10076             X(J,2) = -X(J,1)
10077    50    CONTINUE
10078       ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10079          SIGMA = R/SQRTWO
10080          LSTART = .TRUE.
10081          CALL DT_RANNOR(X3,X4)
10082          DO 100 I=1,N
10083             CALL DT_RANNOR(X1,X2)
10084             X(1,I) = SIGMA*X1
10085             X(2,I) = SIGMA*X2
10086             IF (LSTART) GOTO 80
10087             X(3,I) = SIGMA*X4
10088             CALL DT_RANNOR(X3,X4)
10089             GOTO 90
10090    80       CONTINUE
10091             X(3,I) = SIGMA*X3
10092    90       CONTINUE
10093             LSTART = .NOT.LSTART
10094             X1SUM = X1SUM+X(1,I)
10095             X2SUM = X2SUM+X(2,I)
10096             X3SUM = X3SUM+X(3,I)
10097   100    CONTINUE
10098          X1SUM = X1SUM/DBLE(N)
10099          X2SUM = X2SUM/DBLE(N)
10100          X3SUM = X3SUM/DBLE(N)
10101          DO 101 I=1,N
10102             X(1,I) = X(1,I)-X1SUM
10103             X(2,I) = X(2,I)-X2SUM
10104             X(3,I) = X(3,I)-X3SUM
10105   101    CONTINUE
10106       ELSE
10107
10108 * maximum nuclear radius for coordinate sampling
10109          RMAX = R+4.605D0*PDIF
10110
10111 * initialize pre-sorting
10112          DO 121 I=1,NSRT
10113             ICSRT(I) = 0
10114   121    CONTINUE
10115          DR = TWO*RMAX/DBLE(NSRT)
10116
10117 * sample coordinates for N nucleons
10118          DO 140 I=1,N
10119   120       CONTINUE
10120             RAD = RMAX*(DT_RNDM(DR))**ONETHI
10121             F   = DT_DENSIT(N,RAD,R)
10122             IF (DT_RNDM(RAD).GT.F) GOTO 120
10123 *   theta, phi uniformly distributed
10124             CT  = ONE-TWO*DT_RNDM(F)
10125             ST  = SQRT((ONE-CT)*(ONE+CT))
10126             CALL DT_DSFECF(SFE,CFE)
10127             X(1,I) = RAD*ST*CFE
10128             X(2,I) = RAD*ST*SFE
10129             X(3,I) = RAD*CT
10130 *   ensure that distance between two nucleons is greater than R2MIN
10131             IF (I.LT.2) GOTO 122
10132             I1 = I-1
10133             DO 130 I2=1,I1
10134                DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10135      &                 (X(3,I)-X(3,I2))**2
10136                IF (DIST2.LE.R2MIN) GOTO 120
10137   130       CONTINUE
10138   122       CONTINUE
10139 *   save index according to z-bin
10140             IDXZ        = INT( (X(3,I)+RMAX)/DR )+1
10141             ICSRT(IDXZ) = ICSRT(IDXZ)+1
10142             IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10143             X1SUM = X1SUM+X(1,I)
10144             X2SUM = X2SUM+X(2,I)
10145             X3SUM = X3SUM+X(3,I)
10146   140    CONTINUE
10147          X1SUM = X1SUM/DBLE(N)
10148          X2SUM = X2SUM/DBLE(N)
10149          X3SUM = X3SUM/DBLE(N)
10150          DO 141 I=1,N
10151             X(1,I) = X(1,I)-X1SUM
10152             X(2,I) = X(2,I)-X2SUM
10153             X(3,I) = X(3,I)-X3SUM
10154   141    CONTINUE
10155
10156       ENDIF
10157
10158       RETURN
10159       END
10160
10161 *$ CREATE DT_DENSIT.FOR
10162 *COPY DT_DENSIT
10163 *
10164 *===densit=============================================================*
10165 *
10166       DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10167
10168       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10169       SAVE
10170
10171       PARAMETER ( LINP = 10 ,
10172      &            LOUT = 6 ,
10173      &            LDAT = 9 )
10174       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10175       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10176      &           PI    = TWOPI/TWO)
10177
10178       DIMENSION R0(18),FNORM(18)
10179       DATA R0 /  ZERO,   ZERO,   ZERO,   ZERO, 2.12D0,
10180      &         2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10181      &         2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10182      &         2.72D0, 2.66D0, 2.79D0/
10183       DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10184      &            .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10185      &            .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10186      &            .1214D+01,.1265D+01,.1318D+01/
10187       DATA PDIF /0.545D0/
10188
10189       DT_DENSIT = ZERO
10190 * shell model
10191       IF (NA.LE.4) THEN
10192          STOP 'DT_DENSIT-0'
10193       ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10194          R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10195          DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10196      &            *EXP(-(R/R1)**2)/FNORM(NA)
10197 * Woods-Saxon
10198       ELSEIF (NA.GT.18) THEN
10199          DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10200       ENDIF
10201
10202       RETURN
10203       END
10204
10205 *$ CREATE DT_RNCLUS.FOR
10206 *COPY DT_RNCLUS
10207 *
10208 *===rnclus=============================================================*
10209 *
10210       DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10211
10212 ************************************************************************
10213 * Nuclear radius for nucleus with mass number N.                       *
10214 * This version dated 26.9.00  is written by S. Roesler                 *
10215 ************************************************************************
10216
10217       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10218       SAVE
10219
10220       PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10221
10222 * nucleon radius
10223       PARAMETER (RNUCLE = 1.12D0)
10224
10225 * nuclear radii for selected nuclei
10226       DIMENSION RADNUC(18)
10227       DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10228      &               2.58D0,2.71D0,2.66D0,2.71D0/
10229
10230       IF (N.LE.18) THEN
10231          IF (RADNUC(N).GT.0.0D0) THEN
10232             DT_RNCLUS = RADNUC(N)
10233          ELSE
10234             DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10235          ENDIF
10236       ELSE
10237          DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10238       ENDIF
10239
10240       RETURN
10241       END
10242
10243 *$ CREATE DT_DENTST.FOR
10244 *COPY DT_DENTST
10245 *
10246 *===dentst=============================================================*
10247 *
10248 C      PROGRAM DT_DENTST
10249       SUBROUTINE DT_DENTST
10250
10251       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10252       SAVE
10253
10254       OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10255       OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10256
10257       RMIN  = 0.0D0
10258       RMAX  = 8.0D0
10259       NBINS = 500.0D0
10260       DR    = (RMAX-RMIN)/DBLE(NBINS)
10261       DO 1 IA=5,18
10262          FMAX = 0.0D0
10263          DO 2 IR=1,NBINS+1
10264             R = RMIN+DBLE(IR-1)*DR
10265             F = DT_DENSIT(IA,R,R)
10266             IF (F.GT.FMAX) FMAX = F
10267             WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10268     2    CONTINUE
10269          WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10270     1 CONTINUE
10271
10272       CLOSE(40)
10273       CLOSE(41)
10274
10275       END
10276
10277 *$ CREATE DT_SHMAKI.FOR
10278 *COPY DT_SHMAKI
10279 *
10280 *===shmaki=============================================================*
10281 *
10282       SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10283
10284 ************************************************************************
10285 * Initialisation of Glauber formalism. This subroutine has to be       *
10286 * called once (in case of target emulsions as often as many different  *
10287 * target nuclei are considered) before events are sampled.             *
10288 *         NA / NCA   mass number/charge of projectile nucleus          *
10289 *         NB / NCB   mass number/charge of target     nucleus          *
10290 *         IJP        identity of projectile (hadrons/leptons/photons)  *
10291 *         PPN        projectile momentum (for projectile nuclei:       *
10292 *                    momentum per nucleon) in target rest system       *
10293 *         MODE = 0   Glauber formalism invoked                         *
10294 *              = 1   fitted results are loaded from data-file          *
10295 *              = 99  NTARG is forced to be 1                           *
10296 *                    (used in connection with GLAUBERI-card only)      *
10297 * This version dated 22.03.96 is based on the original SHMAKI-routine  *
10298 * and revised by S. Roesler.                                           *
10299 ************************************************************************
10300
10301       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10302       SAVE
10303       PARAMETER ( LINP = 10 ,
10304      &            LOUT = 6 ,
10305      &            LDAT = 9 )
10306       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10307      &           THREE=3.0D0)
10308
10309       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10310 * Glauber formalism: parameters
10311       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10312      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10313      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10314      &                NSITEB,NSTATB
10315 * Lorentz-parameters of the current interaction
10316       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10317      &                UMO,PPCM,EPROJ,PPROJ
10318 * properties of photon/lepton projectiles
10319       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10320 * kinematical cuts for lepton-nucleus interactions
10321       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10322      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10323 * Glauber formalism: cross sections
10324       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10325      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10326      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10327      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10328      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10329      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10330      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10331      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10332      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10333      &                BSLOPE,NEBINI,NQBINI
10334 * cuts for variable energy runs
10335       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10336 * nucleon-nucleon event-generator
10337       CHARACTER*8 CMODEL
10338       LOGICAL LPHOIN
10339       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10340 * Glauber formalism: flags and parameters for statistics
10341       LOGICAL LPROD
10342       CHARACTER*8 CGLB
10343       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10344
10345       DATA NTARG,ICOUT,IVEOUT /0,0,0/
10346
10347 C     CALL DT_HISHAD
10348 C     STOP
10349
10350       NTARG = NTARG+1
10351       IF (MODE.EQ.99) NTARG = 1
10352       NIDX = -NTARG
10353       IF (MODE.EQ.-1) NIDX = NTARG
10354
10355       IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10356       IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10357  1000    FORMAT(//,1X,'SHMAKI:    Glauber formalism (Shmakov et. al) -',
10358      &          ' initialization',/,12X,'--------------------------',
10359      &          '-------------------------',/)
10360
10361       IF (MODE.EQ.2) THEN
10362          CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10363          CALL DT_SHFAST(MODE,PPN,IBACK)
10364          STOP ' Glauber pre-initialization done'
10365       ENDIF
10366       IF (MODE.EQ.1) THEN
10367          CALL DT_PROFBI(NA,NB,PPN,NTARG)
10368       ELSE
10369          IBACK = 1
10370          IF (MODE.EQ.3)  CALL DT_SHFAST(MODE,PPN,IBACK)
10371          IF (IBACK.EQ.1) THEN
10372 * lepton-nucleus (variable energy runs)
10373             IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10374      &          (IJP.EQ.10).OR.(IJP.EQ.11))   THEN
10375                IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10376      &            WRITE(LOUT,1002) NB,NCB
10377  1002          FORMAT(1X,'variable energy run:     projectile-id:  7',
10378      &                '    target A/Z: ',I3,' /',I3,/,/,8X,
10379      &                'E_cm (GeV)    Q^2 (GeV^2)',
10380      &                '    Sigma_tot (mb)     Sigma_in (mb)',/,7X,
10381      &                '--------------------------------',
10382      &                '------------------------------')
10383                AECMLO = LOG10(MIN(UMO,ECMLI))
10384                AECMHI = LOG10(MIN(UMO,ECMHI))
10385                IESTEP = NEB-1
10386                DAECM  = (AECMHI-AECMLO)/DBLE(IESTEP)
10387                IF (AECMLO.EQ.AECMHI) IESTEP = 0
10388                DO 1 I=1,IESTEP+1
10389                   ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10390                   IF (Q2HI.GT.0.1D0) THEN
10391                      IF (Q2LI.LT.0.01D0) THEN
10392                         CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10393                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10394      &                     WRITE(LOUT,1003)
10395      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10396                         Q2LI = 0.01D0
10397                         IBIN = 2
10398                      ELSE
10399                         IBIN = 1
10400                      ENDIF
10401                      IQSTEP = NQB-IBIN
10402                      AQ2LO  = LOG10(Q2LI)
10403                      AQ2HI  = LOG10(Q2HI)
10404                      DAQ2   = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10405                      DO 2 J=IBIN,IQSTEP+IBIN
10406                         Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10407                         CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10408                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10409      &                     WRITE(LOUT,1003) ECMNN(I),
10410      &                     Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10411     2                CONTINUE
10412                   ELSE
10413                      CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10414                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10415      &                  WRITE(LOUT,1003)
10416      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10417                   ENDIF
10418  1003             FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10419     1          CONTINUE
10420                IVEOUT = 1
10421             ELSE
10422 * hadron/photon/nucleus-nucleus
10423                IF ((ABS(VAREHI).GT.ZERO).AND.
10424      &             (ABS(VAREHI).GT.ABS(VARELO))) THEN
10425                   IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10426                      WRITE(LOUT,1004) NA,NB,NCB
10427  1004                FORMAT(1X,'variable energy run:    projectile-id:',
10428      &                      I3,'    target A/Z: ',I3,' /',I3,/)
10429                      WRITE(LOUT,1005)
10430  1005                FORMAT('  E_cm (GeV)  E_Lab (GeV)  sig_tot^pp (mb)'
10431      &                      ,'  Sigma_tot (mb)  Sigma_prod (mb)',/,
10432      &                      ' -------------------------------------',
10433      &                      '--------------------------------------')
10434                   ENDIF
10435                   AECMLO = LOG10(VARCLO)
10436                   AECMHI = LOG10(VARCHI)
10437                   IESTEP = NEB-1
10438                   DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10439                   IF (AECMLO.EQ.AECMHI) IESTEP = 0
10440                   DO 3 I=1,IESTEP+1
10441                      ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10442                      AMP = 0.938D0
10443                      AMT = 0.938D0
10444                      AMP2 = AMP**2
10445                      AMT2 = AMT**2
10446                      ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
10447                      PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
10448                      CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
10449                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10450      &                 WRITE(LOUT,1006)
10451      &                 ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10452  1006             FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
10453     3             CONTINUE
10454                   IVEOUT = 1
10455                ELSE
10456                   CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10457                ENDIF
10458             ENDIF
10459          ENDIF
10460       ENDIF
10461
10462       IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
10463      &    (IOGLB.NE.100)) THEN
10464          WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
10465      &                    BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
10466  1001    FORMAT(38X,'projectile',
10467      &          '      target',/,1X,'Mass number / charge',
10468      &          17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
10469      &          'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
10470      &          'Parameters of elastic scattering amplitude:',/,5X,
10471      &          'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
10472      &          F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
10473      &          'statistics at each b-step',4X,I5,/,/,1X,
10474      &          'Prod. cross section  ',5X,F10.4,' mb',/)
10475       ENDIF
10476
10477       RETURN
10478       END
10479
10480 *$ CREATE DT_PROFBI.FOR
10481 *COPY DT_PROFBI
10482 *
10483 *===profbi=============================================================*
10484 *
10485       SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
10486
10487 ************************************************************************
10488 * Integral over profile function (to be used for impact-parameter      *
10489 * sampling during event generation).                                   *
10490 * Fitted results are used.                                             *
10491 *         NA / NB    mass numbers of proj./target nuclei               *
10492 *         PPN        projectile momentum (for projectile nuclei:       *
10493 *                    momentum per nucleon) in target rest system       *
10494 *         NTARG      index of target material (i.e. kind of nucleus)   *
10495 * This version dated 31.05.95 is revised by S. Roesler                 *
10496 ************************************************************************
10497
10498       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10499       SAVE
10500       PARAMETER ( LINP = 10 ,
10501      &            LOUT = 6 ,
10502      &            LDAT = 9 )
10503 CPH      SAVE
10504
10505       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
10506
10507       LOGICAL LSTART
10508       CHARACTER CNAME*80
10509
10510       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10511 * Glauber formalism: parameters
10512       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10513      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10514      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10515      &                NSITEB,NSTATB
10516 * Glauber formalism: cross sections
10517       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10518      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10519      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10520      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10521      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10522      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10523      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10524      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10525      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10526      &                BSLOPE,NEBINI,NQBINI
10527
10528       PARAMETER (NGLMAX=8000)
10529       DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
10530      &          GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
10531
10532       DATA LSTART /.TRUE./
10533
10534       IF (LSTART) THEN
10535 * read fit-parameters from file
10536          OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
10537          I = 0
10538     1    CONTINUE
10539          READ(47,'(A80)') CNAME
10540          IF (CNAME.EQ.'STOP') GOTO 2
10541          I = I+1
10542          READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
10543      &                 GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
10544      &                 GLAFIT(4,I),GLAFIT(5,I)
10545          IF (I+1.GT.NGLMAX) THEN
10546             WRITE(LOUT,1000)
10547  1000       FORMAT(1X,'PROFBI:    warning! array size exceeded - ',
10548      &             'program stopped')
10549             STOP
10550          ENDIF
10551          GOTO 1
10552     2    CONTINUE
10553          NGLPAR = I
10554          LSTART = .FALSE.
10555       ENDIF
10556
10557       NNA = NA
10558       NNB = NB
10559       IF (NA.GT.NB) THEN
10560          NNA = NB
10561          NNB = NA
10562       ENDIF
10563       IDXGLA = 0
10564       DO 3 J=1,NGLPAR
10565          IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
10566             IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
10567             DO 4 K=1,J-1
10568                IPOINT = J-K
10569                IF (J.EQ.NGLPAR) IPOINT = J+1-K
10570                IF ((NNA.GT.NGLIP(IPOINT)).OR.
10571      &             (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
10572                   IF (IPOINT.EQ.1) IPOINT = 0
10573                   NATMP = NGLIP(IPOINT+1)
10574                   IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
10575                      IDXGLA = IPOINT+1
10576                      GOTO 6
10577                   ELSE
10578                      J1BEG = IPOINT+1
10579                      J1END = J
10580 C                    IF (J.EQ.NGLPAR) THEN
10581 C                       J1BEG = IPOINT
10582 C                       J1END = J
10583 C                    ENDIF
10584                      DO 5 J1=J1BEG,J1END
10585                         IF (NGLIP(J1).EQ.NATMP) THEN
10586                            IF (PPN.LT.GLAPPN(J1)) THEN
10587                               IDXGLA = J1
10588                               GOTO 6
10589                            ENDIF
10590                         ELSE
10591                            IDXGLA = J1-1
10592                            GOTO 6
10593                         ENDIF
10594     5                CONTINUE
10595                      IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
10596      &                  IDXGLA = NGLPAR
10597                   ENDIF
10598                ENDIF
10599     4       CONTINUE
10600          ENDIF
10601     3 CONTINUE
10602
10603     6 CONTINUE
10604       IF (IDXGLA.EQ.0) THEN
10605          WRITE(LOUT,1001) NNA,NNB,PPN
10606  1001    FORMAT(1X,'PROFBI:   configuration (NA,NB,PPN = ',
10607      &          2I4,F6.0,') not found ')
10608          STOP
10609       ENDIF
10610
10611 * no interpolation yet available
10612       XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
10613
10614       BSITE(1,1,NTARG,1) = ZERO
10615       DO 10 I=2,NSITEB
10616          XX = DBLE(I)
10617          POLY  = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
10618      &           GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
10619      &           GLAFIT(5,IDXGLA)*XX**4
10620          IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
10621          BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
10622          IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
10623    10 CONTINUE
10624
10625       RETURN
10626       END
10627
10628 *$ CREATE DT_GLAUBE.FOR
10629 *COPY DT_GLAUBE
10630 *
10631 *===glaube=============================================================*
10632 *
10633       SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
10634
10635 ************************************************************************
10636 * Calculation of configuartion of interacting nucleons for one event.  *
10637 *    NB / NB    mass numbers of proj./target nuclei           (input)  *
10638 *    B          impact parameter                              (output) *
10639 *    INTT       total number of wounded nucleons                 "     *
10640 *    INTA / INTB number of wounded nucleons in proj. / target    "     *
10641 *    JS / JT(i) number of collisions proj. / target nucleon i is       *
10642 *                                                   involved  (output) *
10643 *    NIDX       index of projectile/target material            (input) *
10644 *               = -2 call within FLUKA transport calculation           *
10645 * This is an update of the original routine SHMAKO by J.Ranft/HJM      *
10646 * This version dated 22.03.96 is revised by S. Roesler                 *
10647 *                                                                      *
10648 * Last change 27.12.2006 by S. Roesler.                                *
10649 ************************************************************************
10650
10651       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10652       SAVE
10653       PARAMETER ( LINP = 10 ,
10654      &            LOUT = 6 ,
10655      &            LDAT = 9 )
10656       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
10657      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
10658
10659       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10660       PARAMETER ( MAXNCL = 260,
10661      &            MAXVQU = MAXNCL,
10662      &            MAXSQU = 20*MAXVQU,
10663      &            MAXINT = MAXVQU+MAXSQU)
10664 * Glauber formalism: parameters
10665       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10666      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10667      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10668      &                NSITEB,NSTATB
10669 * Glauber formalism: cross sections
10670       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10671      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10672      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10673      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10674      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10675      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10676      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10677      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10678      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10679      &                BSLOPE,NEBINI,NQBINI
10680 * Lorentz-parameters of the current interaction
10681       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10682      &                UMO,PPCM,EPROJ,PPROJ
10683 * properties of photon/lepton projectiles
10684       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10685 * Glauber formalism: collision properties
10686       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
10687      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
10688 * Glauber formalism: flags and parameters for statistics
10689       LOGICAL LPROD
10690       CHARACTER*8 CGLB
10691       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10692
10693       DIMENSION JS(MAXNCL),JT(MAXNCL)
10694
10695       NTARG = ABS(NIDX)
10696
10697 * get actual energy from /DTLTRA/
10698       ECMNOW = UMO
10699       Q2     = VIRT
10700 *
10701 * new patch for pre-initialized variable projectile/target/energy runs,
10702 * bypassed for use within FLUKA (Nidx=-2)
10703       IF (IOGLB.EQ.100) THEN
10704          IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
10705 *
10706 * variable energy run, interpolate profile function
10707       ELSE
10708          I1   = 1
10709          I2   = 1
10710          RATE = ONE
10711          IF (NEBINI.GT.1) THEN
10712             IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
10713                I1   = NEBINI
10714                I2   = NEBINI
10715                RATE = ONE
10716             ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
10717                DO 1 I=2,NEBINI
10718                   IF (ECMNOW.LT.ECMNN(I)) THEN
10719                      I1   = I-1
10720                      I2   = I
10721                      RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
10722                      GOTO 2
10723                   ENDIF
10724     1          CONTINUE
10725     2          CONTINUE
10726             ENDIF
10727          ENDIF
10728          J1   = 1
10729          J2   = 1
10730          RATQ = ONE
10731          IF (NQBINI.GT.1) THEN
10732             IF (Q2.GE.Q2G(NQBINI)) THEN
10733                J1   = NQBINI
10734                J2   = NQBINI
10735                RATQ = ONE
10736             ELSEIF (Q2.GT.Q2G(1)) THEN
10737                DO 3 I=2,NQBINI
10738                   IF (Q2.LT.Q2G(I)) THEN
10739                      J1   = I-1
10740                      J2   = I
10741                      RATQ = LOG10(     Q2/MAX(Q2G(J1),TINY14))/
10742      &                      LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
10743 C                    RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
10744                      GOTO 4
10745                   ENDIF
10746     3          CONTINUE
10747     4          CONTINUE
10748             ENDIF
10749          ENDIF
10750
10751          DO 5 I=1,KSITEB
10752             BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
10753      &         RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10754      &         RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10755      &         RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
10756      &                    BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
10757     5    CONTINUE
10758       ENDIF
10759
10760       CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
10761       IF (NIDX.LE.-1) THEN
10762          RPROJ = RASH(1)
10763          RTARG = RBSH(NTARG)
10764       ELSE
10765          RPROJ = RASH(NTARG)
10766          RTARG = RBSH(1)
10767       ENDIF
10768
10769       RETURN
10770       END
10771
10772 *$ CREATE DT_DIAGR.FOR
10773 *COPY DT_DIAGR
10774 *
10775 *===diagr==============================================================*
10776 *
10777       SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
10778      &                                                         NIDX)
10779
10780 ************************************************************************
10781 * Based on the original version by Shmakov et al.                      *
10782 * This version dated 21.04.95 is revised by S. Roesler                 *
10783 ************************************************************************
10784
10785       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10786       SAVE
10787       PARAMETER ( LINP = 10 ,
10788      &            LOUT = 6 ,
10789      &            LDAT = 9 )
10790       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10791       PARAMETER (TWOPI  = 6.283185307179586454D+00,
10792      &           PI     = TWOPI/TWO,
10793      &           GEV2MB = 0.38938D0,
10794      &           GEV2FM = 0.1972D0,
10795      &           ALPHEM = ONE/137.0D0,
10796 * proton mass
10797      &           AMP    = 0.938D0,
10798      &           AMP2   = AMP**2,
10799 * rho0 mass
10800      &           AMRHO0 = 0.77D0)
10801
10802       COMPLEX*16 C,CA,CI
10803       PARAMETER ( MAXNCL = 260,
10804      &            MAXVQU = MAXNCL,
10805      &            MAXSQU = 20*MAXVQU,
10806      &            MAXINT = MAXVQU+MAXSQU)
10807 * particle properties (BAMJET index convention)
10808       CHARACTER*8  ANAME
10809       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
10810      &                IICH(210),IIBAR(210),K1(210),K2(210)
10811       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10812 * emulsion treatment
10813       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
10814      &                NCOMPO,IEMUL
10815 * Glauber formalism: parameters
10816       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10817      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10818      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10819      &                NSITEB,NSTATB
10820 * Glauber formalism: cross sections
10821       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10822      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10823      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10824      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10825      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10826      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10827      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10828      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10829      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10830      &                BSLOPE,NEBINI,NQBINI
10831 * VDM parameter for photon-nucleus interactions
10832       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
10833 * nucleon-nucleon event-generator
10834       CHARACTER*8 CMODEL
10835       LOGICAL LPHOIN
10836       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10837 **PHOJET105a
10838 C     COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10839 **PHOJET112
10840 C  obsolete cut-off information
10841       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
10842       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10843 **
10844 * coordinates of nucleons
10845       COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
10846 * interface between Glauber formalism and DPM
10847       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
10848      &                INTER1(MAXINT),INTER2(MAXINT)
10849 * statistics: Glauber-formalism
10850       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
10851 * n-n cross section fluctuations
10852       PARAMETER (NBINS = 1000)
10853       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
10854
10855       DIMENSION JS(MAXNCL),JT(MAXNCL),
10856      &          JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
10857      &          JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
10858       DIMENSION NWA(0:210),NWB(0:210)
10859
10860       LOGICAL LFIRST
10861       DATA LFIRST /.TRUE./
10862
10863       DATA NTARGO,ICNT /0,0/
10864
10865       NTARG = ABS(NIDX)
10866
10867       IF (LFIRST) THEN
10868          LFIRST = .FALSE.
10869          IF (NCOMPO.EQ.0) THEN
10870             NCALL  = 0
10871             NWAMAX = NA
10872             NWBMAX = NB
10873             DO 17 I=0,210
10874                NWA(I) = 0
10875                NWB(I) = 0
10876    17       CONTINUE
10877          ENDIF
10878       ENDIF
10879       IF (NTARG.EQ.-1) THEN
10880          IF (NCOMPO.EQ.0) THEN
10881             WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
10882             WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
10883      &                                NCALL,NWAMAX,NWBMAX
10884             DO 18 I=1,MAX(NWAMAX,NWBMAX)
10885                WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
10886      &                          I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
10887      &                            NWB(I),DBLE(NWB(I))/DBLE(NCALL)
10888    18       CONTINUE
10889          ENDIF
10890          RETURN
10891       ENDIF
10892
10893       DCOH   = 1.0D10
10894       IPNT   = 0
10895
10896       SQ2  = Q2
10897       IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
10898       S   = ECMNOW**2
10899       X   = SQ2/(S+SQ2-AMP2)
10900       XNU = (S+SQ2-AMP2)/(TWO*AMP)
10901 * photon projectiles: recalculate photon-nucleon amplitude
10902       IF (IJPROJ.EQ.7) THEN
10903    15    CONTINUE
10904 *  VDM assumption: mass of V-meson
10905          AMV2   = DT_SAM2(SQ2,ECMNOW)
10906          AMV    = SQRT(AMV2)
10907          IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
10908 *  check for pointlike interaction
10909          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
10910 **sr 27.10.
10911 C        SIGSH  = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10912          SIGSH  = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10913 **
10914          ROSH   = 0.1D0
10915          BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
10916      &                   +0.25D0*LOG(S/(AMV2+SQ2)))
10917 *  coherence length
10918          IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
10919       ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
10920          IF (MCGENE.EQ.2) THEN
10921             ZERO1 = ZERO
10922             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
10923      &                                                BSLOPE,0)
10924          ELSE
10925             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
10926          ENDIF
10927          IF (ECMNOW.LE.3.0D0) THEN
10928             ROSH = -0.43D0
10929          ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
10930             ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
10931          ELSEIF (ECMNOW.GT.50.0D0) THEN
10932             ROSH = 0.1D0
10933          ENDIF
10934          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10935          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10936          IF (MCGENE.EQ.2) THEN
10937             ZERO1 = ZERO
10938             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
10939      &                                                  BDUM,0)
10940             SIGSH = SIGSH/10.0D0
10941          ELSE
10942 C           SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10943             DUMZER = ZERO
10944             CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10945             SIGSH = SIGSH/10.0D0
10946          ENDIF
10947       ELSE
10948          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
10949          ROSH   = 0.01D0
10950          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10951          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10952 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10953          DUMZER = ZERO
10954          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10955          SIGSH = SIGSH/10.0D0
10956       ENDIF
10957       GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
10958       GAM = GSH
10959       RCA = GAM*SIGSH/TWOPI
10960       FCA = -ROSH*RCA
10961       CA  = DCMPLX(RCA,FCA)
10962       CI  = DCMPLX(ONE,ZERO)
10963
10964    16 CONTINUE
10965 * impact parameter
10966       IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
10967
10968       NTRY = 0
10969     3 CONTINUE
10970       NTRY = NTRY+1
10971 * initializations
10972       JNT  = 0
10973       DO 1 I=1,NA
10974          JS(I) = 0
10975     1 CONTINUE
10976       DO 2 I=1,NB
10977          JT(I) = 0
10978     2 CONTINUE
10979       IF (IJPROJ.EQ.7) THEN
10980          DO 8 I=1,MAXNCL
10981             JS0(I) = 0
10982             JNT0(I)= 0
10983             DO 9 J=1,NB
10984                JT0(I,J) = 0
10985     9       CONTINUE
10986     8    CONTINUE
10987       ENDIF
10988
10989 * nucleon configuration
10990 C     IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
10991       IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
10992 C        CALL DT_CONUCL(PKOO,NA,RASH,2)
10993 C        CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
10994          IF (NIDX.LE.-1) THEN
10995             CALL DT_CONUCL(PKOO,NA,RASH(1),0)
10996             CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
10997          ELSE
10998             CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
10999             CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11000          ENDIF
11001          NTARGO = NTARG
11002       ENDIF
11003       ICNT = ICNT+1
11004
11005 * LEPTO: pick out one struck nucleon
11006       IF (MCGENE.EQ.3) THEN
11007          JNT     = 1
11008          JS(1)   = 1
11009          IDX     = INT(DT_RNDM(X)*NB)+1
11010          JT(IDX) = 1
11011          B       = ZERO
11012          GOTO 19
11013       ENDIF
11014
11015       DO 4 INA=1,NA
11016 * cross section fluctuations
11017          AFLUC = ONE
11018          IF (IFLUCT.EQ.1) THEN
11019             IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11020             AFLUC = FLUIXX(IFLUK)
11021          ENDIF
11022          KK1  = 1
11023          KINT = 1
11024          DO 5 INB=1,NB
11025 * photon-projectile: check for supression by coherence length
11026             IF (IJPROJ.EQ.7) THEN
11027                IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11028                   KK1  = INB
11029                   KINT = KINT+1
11030                ENDIF
11031             ENDIF
11032             QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11033             QQ2 =   TKOO(2,INB)-PKOO(2,INA)
11034             XY  = GAM*(QQ1*QQ1+QQ2*QQ2)
11035             IF (XY.LE.15.0D0) THEN
11036                C  = CI-CA*AFLUC*EXP(-XY)
11037                AR = DBLE(C)
11038                AI = DIMAG(C)
11039                P  = AR*AR+AI*AI
11040                IF (DT_RNDM(XY).GE.P) THEN
11041                   JNT = JNT+1
11042                   IF (IJPROJ.EQ.7) THEN
11043                      JNT0(KINT) = JNT0(KINT)+1
11044                      IF (JNT0(KINT).GT.MAXNCL) THEN
11045                         WRITE(LOUT,1001) MAXNCL
11046  1001                   FORMAT(1X,
11047      &                        'DIAGR:  no. of requested interactions',
11048      &                        ' exceeds array dimensions ',I4)
11049                         STOP
11050                      ENDIF
11051                      JS0(KINT)      = JS0(KINT)+1
11052                      JT0(KINT,INB)  = JT0(KINT,INB)+1
11053                      JI1(KINT,JNT0(KINT)) = INA
11054                      JI2(KINT,JNT0(KINT)) = INB
11055                   ELSE
11056                      IF (JNT.GT.MAXINT) THEN
11057                         WRITE(LOUT,1000) JNT, MAXINT
11058  1000                   FORMAT(1X,
11059      &                        'DIAGR:  no. of requested interactions ('
11060      &                        ,I4,') exceeds array dimensions (',I4,')')
11061                         STOP
11062                      ENDIF
11063                      JS(INA) = JS(INA)+1
11064                      JT(INB) = JT(INB)+1
11065                      INTER1(JNT) = INA
11066                      INTER2(JNT) = INB
11067                   ENDIF
11068                ENDIF
11069             ENDIF
11070     5    CONTINUE
11071     4 CONTINUE
11072
11073       IF (JNT.EQ.0) THEN
11074          IF (NTRY.LT.500) THEN
11075             GOTO 3
11076          ELSE
11077 C           WRITE(6,*) ' new impact parameter required (old= ',B,')'
11078             GOTO 16
11079          ENDIF
11080       ENDIF
11081
11082       IDIREC = 0
11083       IF (IJPROJ.EQ.7) THEN
11084          K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11085    10    CONTINUE
11086          IF (JNT0(K).EQ.0) THEN
11087             K = K+1
11088             IF (K.GT.KINT) K = 1
11089             GOTO 10
11090          ENDIF
11091 * supress Glauber-cascade by direct photon processes
11092          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11093          IF (IPNT.GT.0) THEN
11094             JNT   = 1
11095             JS(1) = 1
11096             DO 11 INB=1,NB
11097                JT(INB) = JT0(K,INB)
11098                IF (JT(INB).GT.0) GOTO 12
11099    11       CONTINUE
11100    12       CONTINUE
11101             INTER1(1) = 1
11102             INTER2(1) = INB
11103             IDIREC    = IPNT
11104          ELSE
11105             JNT   = JNT0(K)
11106             JS(1) = JS0(K)
11107             DO 13 INB=1,NB
11108                JT(INB) = JT0(K,INB)
11109    13       CONTINUE
11110             DO 14 I=1,JNT
11111                INTER1(I) = JI1(K,I)
11112                INTER2(I) = JI2(K,I)
11113    14       CONTINUE
11114          ENDIF
11115       ENDIF
11116
11117    19 CONTINUE
11118       INTA = 0
11119       INTB = 0
11120       DO 6 I=1,NA
11121         IF (JS(I).NE.0) INTA=INTA+1
11122     6 CONTINUE
11123       DO 7 I=1,NB
11124         IF (JT(I).NE.0) INTB=INTB+1
11125     7 CONTINUE
11126       ICWPG = INTA
11127       ICWTG = INTB
11128       ICIG  = JNT
11129       IPGLB = IPGLB+INTA
11130       ITGLB = ITGLB+INTB
11131       NGLB = NGLB+1
11132
11133       IF (NCOMPO.EQ.0) THEN
11134          NCALL = NCALL+1
11135          NWA(INTA) = NWA(INTA)+1
11136          NWB(INTB) = NWB(INTB)+1
11137       ENDIF
11138
11139       RETURN
11140       END
11141
11142 *$ CREATE DT_MODB.FOR
11143 *COPY DT_MODB
11144 *
11145 *===modb===============================================================*
11146 *
11147       SUBROUTINE DT_MODB(B,NIDX)
11148
11149 ************************************************************************
11150 * Sampling of impact parameter of collision.                           *
11151 *    B          impact parameter    (output)                           *
11152 *    NIDX       index of projectile/target material             (input)*
11153 * Based on the original version by Shmakov et al.                      *
11154 * This version dated 21.04.95 is revised by S. Roesler                 *
11155 *                                                                      *
11156 * Last change 27.12.2006 by S. Roesler.                                *
11157 ************************************************************************
11158
11159       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11160       SAVE
11161       PARAMETER ( LINP = 10 ,
11162      &            LOUT = 6 ,
11163      &            LDAT = 9 )
11164       PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11165
11166       LOGICAL LEFT,LFIRST
11167
11168 * central particle production, impact parameter biasing
11169       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11170       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11171 * Glauber formalism: parameters
11172       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11173      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11174      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11175      &                NSITEB,NSTATB
11176 * Glauber formalism: cross sections
11177       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11178      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11179      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11180      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11181      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11182      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11183      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11184      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11185      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11186      &                BSLOPE,NEBINI,NQBINI
11187
11188       DATA LFIRST /.TRUE./
11189
11190       NTARG = ABS(NIDX)
11191       IF (NIDX.LE.-1) THEN
11192          RA = RASH(1)
11193          RB = RBSH(NTARG)
11194       ELSE
11195          RA = RASH(NTARG)
11196          RB = RBSH(1)
11197       ENDIF
11198
11199       IF (ICENTR.EQ.2) THEN
11200          IF (RA.EQ.RB) THEN
11201             BB = DT_RNDM(B)*(0.3D0*RA)**2
11202             B  = SQRT(BB)
11203          ELSEIF(RA.LT.RB)THEN
11204             BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11205             B  = SQRT(BB)
11206          ELSEIF(RA.GT.RB)THEN
11207             BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11208             B  = SQRT(BB)
11209          ENDIF
11210       ELSE
11211     9    CONTINUE
11212          Y  = DT_RNDM(BB)
11213          I0 = 1
11214          I2 = NSITEB
11215    10    CONTINUE
11216          I1 = (I0+I2)/2
11217          LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11218      &          *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11219          IF (LEFT) GOTO 20
11220          I0 = I1
11221          GOTO 30
11222    20    CONTINUE
11223          I2 = I1
11224    30    CONTINUE
11225          IF (I2-I0-2) 40,50,60
11226    40    CONTINUE
11227          I1 = I2+1
11228          IF (I1.GT.NSITEB) I1 = I0-1
11229          GOTO 70
11230    50    CONTINUE
11231          I1 = I0+1
11232          GOTO 70
11233    60    CONTINUE
11234          GOTO 10
11235    70    CONTINUE
11236          X0 = DBLE(I0-1)*BSTEP(NTARG)
11237          X1 = DBLE(I1-1)*BSTEP(NTARG)
11238          X2 = DBLE(I2-1)*BSTEP(NTARG)
11239          Y0 = BSITE(0,1,NTARG,I0)
11240          Y1 = BSITE(0,1,NTARG,I1)
11241          Y2 = BSITE(0,1,NTARG,I2)
11242    80    CONTINUE
11243          B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11244      &       X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11245      &       X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11246 **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11247          B = B+0.5D0*BSTEP(NTARG)
11248          IF (B.LT.ZERO) B = X1
11249          IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11250          IF (ICENTR.LT.0) THEN
11251             IF (LFIRST) THEN
11252                LFIRST = .FALSE.
11253                IF (ICENTR.LE.-100) THEN
11254                   BIMIN  = 0.0D0
11255                ELSE
11256                   XSFRAC = 0.0D0
11257                ENDIF
11258                CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11259                WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11260      &                          BIMIN,BIMAX,XSFRAC*100.0D0,
11261      &                          XSFRAC*XSPRO(1,1,NTARG)
11262  10000         FORMAT(/,1X,'DT_MODB:      Biasing in impact parameter',
11263      &                /,15X,'---------------------------'/,/,4X,
11264      &                'average radii of proj / targ :',F10.3,' fm /',
11265      &                F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11266      &                F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11267      &                F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11268      &                ' cross section :',F10.3,' %',/,5X,
11269      &                'corresponding cross section :',F10.3,' mb',/)
11270             ENDIF
11271             IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11272                B = BIMIN
11273             ELSE
11274                IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11275             ENDIF
11276          ENDIF
11277       ENDIF
11278
11279       RETURN
11280       END
11281
11282 *$ CREATE DT_SHFAST.FOR
11283 *COPY DT_SHFAST
11284 *
11285 *===shfast=============================================================*
11286 *
11287       SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11288
11289       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11290       SAVE
11291       PARAMETER ( LINP = 10 ,
11292      &            LOUT = 6 ,
11293      &            LDAT = 9 )
11294       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11295      &           ONE=1.0D0,TWO=2.0D0)
11296
11297       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11298 * Glauber formalism: parameters
11299       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11300      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11301      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11302      &                NSITEB,NSTATB
11303 * properties of interacting particles
11304       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11305 * Glauber formalism: cross sections
11306       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11307      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11308      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11309      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11310      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11311      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11312      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11313      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11314      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11315      &                BSLOPE,NEBINI,NQBINI
11316
11317       IBACK = 0
11318
11319       IF (MODE.EQ.2) THEN
11320          OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11321          WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11322  1000    FORMAT(1X,8I5,E15.5)
11323          WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11324  1001    FORMAT(1X,4E15.5)
11325          WRITE(47,1002) SIGSH,ROSH,GSH
11326  1002    FORMAT(1X,3E15.5)
11327          DO 10 I=1,100
11328             WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11329    10    CONTINUE
11330          WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11331  1003    FORMAT(1X,2I10,3E15.5)
11332          CLOSE(47)
11333       ELSE
11334          OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11335          READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11336          IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11337      &       (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11338      &       .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11339      &       (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11340             READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11341             READ(47,1002) SIGSH,ROSH,GSH
11342             DO 11 I=1,100
11343                READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11344    11       CONTINUE
11345             READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11346          ELSE
11347             IBACK = 1
11348          ENDIF
11349          CLOSE(47)
11350       ENDIF
11351
11352       RETURN
11353       END
11354
11355 *$ CREATE DT_POILIK.FOR
11356 *COPY DT_POILIK
11357 *
11358 *===poilik=============================================================*
11359 *
11360       SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11361
11362       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11363       SAVE
11364
11365       PARAMETER ( LINP = 10 ,
11366      &            LOUT = 6 ,
11367      &            LDAT = 9 )
11368       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11369       PARAMETER (NE = 8)
11370
11371 **PHOJET105a
11372 C     CHARACTER*8 MDLNA
11373 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11374 C     PARAMETER (IEETAB=10)
11375 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11376 **PHOJET110
11377 C  model switches and parameters
11378       CHARACTER*8 MDLNA
11379       INTEGER ISWMDL,IPAMDL
11380       DOUBLE PRECISION PARMDL
11381       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11382 C  energy-interpolation table
11383       INTEGER IEETA2
11384       PARAMETER ( IEETA2 = 20 )
11385       INTEGER ISIMAX
11386       DOUBLE PRECISION SIGTAB,SIGECM
11387       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11388 **
11389 * VDM parameter for photon-nucleus interactions
11390       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11391 **sr 22.7.97
11392       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11393 * Glauber formalism: cross sections
11394       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11395      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11396      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11397      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11398      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11399      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11400      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11401      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11402      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11403      &                BSLOPE,NEBINI,NQBINI
11404 **
11405
11406       DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
11407
11408       IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
11409
11410 * load cross sections from interpolation table
11411       IP = 1
11412       IF(ECM.LE.SIGECM(IP,1)) THEN
11413         I1 = 1
11414         I2 = 1
11415       ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
11416         DO 50 I=2,ISIMAX
11417           IF(ECM.LE.SIGECM(IP,I)) GOTO 200
11418   50    CONTINUE
11419  200    CONTINUE
11420         I1 = I-1
11421         I2 = I
11422       ELSE
11423         WRITE(LOUT,'(/1X,A,2E12.3)')
11424      &    'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
11425         I1 = ISIMAX
11426         I2 = ISIMAX
11427       ENDIF
11428       FAC2 = ZERO
11429       IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
11430      &                     /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
11431       FAC1 = ONE-FAC2
11432
11433       SIGANO = DT_SANO(ECM)
11434
11435 * cross section dependence on photon virtuality
11436       FSUP1 = ZERO
11437       DO  150 I=1,3
11438          FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
11439      &                             /(ONE+VIRT/PARMDL(30+I))**2
11440  150  CONTINUE
11441       FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
11442       FAC1  = FAC1*FSUP1
11443       FAC2  = FAC2*FSUP1
11444       FSUP2 = ONE
11445
11446       ECMOLD = ECM
11447       Q2OLD  = VIRT
11448
11449     3 CONTINUE
11450
11451 C     SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
11452       CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
11453       IF (ISHAD(1).EQ.1) THEN
11454          SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
11455       ELSE
11456          SIGDIR = ZERO
11457       ENDIF
11458       SIGANO = FSUP1*FSUP2*SIGANO
11459       SIGTOT = SIGTOT-SIGDIR-SIGANO
11460       SIGDIR = SIGDIR/(FSUP1*FSUP2)
11461       SIGANO = SIGANO/(FSUP1*FSUP2)
11462       SIGTOT = SIGTOT+SIGDIR+SIGANO
11463
11464       RR = DT_RNDM(SIGTOT)
11465       IF (RR.LT.SIGDIR/SIGTOT) THEN
11466          IPNT = 1
11467       ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
11468      &        (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
11469          IPNT = 2
11470       ELSE
11471          IPNT = 0
11472       ENDIF
11473       RPNT = (SIGDIR+SIGANO)/SIGTOT
11474 C     WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
11475 C     WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
11476 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
11477 C     WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
11478       IF (MODE.EQ.1) RETURN
11479
11480 **sr 22.7.97
11481       K1   = 1
11482       K2   = 1
11483       RATE = ZERO
11484       IF (ECM.GE.ECMNN(NEBINI)) THEN
11485          K1   = NEBINI
11486          K2   = NEBINI
11487          RATE = ONE
11488       ELSEIF (ECM.GT.ECMNN(1)) THEN
11489          DO 10 I=2,NEBINI
11490             IF (ECM.LT.ECMNN(I)) THEN
11491                K1   = I-1
11492                K2   = I
11493                RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
11494                GOTO 11
11495             ENDIF
11496    10    CONTINUE
11497    11    CONTINUE
11498       ENDIF
11499       J1   = 1
11500       J2   = 1
11501       RATQ = ZERO
11502       IF (NQBINI.GT.1) THEN
11503          IF (VIRT.GE.Q2G(NQBINI)) THEN
11504             J1   = NQBINI
11505             J2   = NQBINI
11506             RATQ = ONE
11507          ELSEIF (VIRT.GT.Q2G(1)) THEN
11508             DO 12 I=2,NQBINI
11509                IF (VIRT.LT.Q2G(I)) THEN
11510                   J1   = I-1
11511                   J2   = I
11512                   RATQ = LOG10(   VIRT/MAX(Q2G(J1),TINY14))/
11513      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11514                   GOTO 13
11515                ENDIF
11516    12       CONTINUE
11517    13       CONTINUE
11518          ENDIF
11519       ENDIF
11520       SGA = XSPRO(K1,J1,NTARG)+
11521      &      RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
11522      &      RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
11523      &      RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
11524      &                 XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
11525       SDI = DBLE(NB)*SIGDIR
11526       SAN = DBLE(NB)*SIGANO
11527       SPL = SDI+SAN
11528       RR = DT_RNDM(SPL)
11529       IF (RR.LT.SDI/SGA) THEN
11530          IPNT = 1
11531       ELSEIF ((RR.GE.SDI/SGA).AND.
11532      &        (RR.LT.SPL/SGA)) THEN
11533          IPNT = 2
11534       ELSE
11535          IPNT = 0
11536       ENDIF
11537       RPNT = SPL/SGA
11538 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
11539 **
11540
11541       RETURN
11542       END
11543
11544 *$ CREATE DT_GLBINI.FOR
11545 *COPY DT_GLBINI
11546 *
11547 *===glbini=============================================================*
11548 *
11549       SUBROUTINE DT_GLBINI(WHAT)
11550
11551 ************************************************************************
11552 * Pre-initialization of profile function                               *
11553 * This version dated 28.11.00 is written by S. Roesler.                *
11554 *                                                                      *
11555 * Last change 27.12.2006 by S. Roesler.                                *
11556 ************************************************************************
11557
11558       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11559       SAVE
11560
11561       PARAMETER ( LINP = 10 ,
11562      &            LOUT = 6 ,
11563      &            LDAT = 9 )
11564       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
11565
11566       LOGICAL LCMS
11567
11568 * particle properties (BAMJET index convention)
11569       CHARACTER*8  ANAME
11570       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11571      &                IICH(210),IIBAR(210),K1(210),K2(210)
11572 * properties of interacting particles
11573       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11574       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11575 * emulsion treatment
11576       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11577      &                NCOMPO,IEMUL
11578 * Glauber formalism: flags and parameters for statistics
11579       LOGICAL LPROD
11580       CHARACTER*8 CGLB
11581       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11582 * number of data sets other than protons and nuclei
11583 * at the moment = 2 (pions and kaons)
11584       PARAMETER (MAXOFF=2)
11585       DIMENSION IJPINI(5),IOFFST(25)
11586       DATA IJPINI / 13, 15,  0,  0,  0/
11587 * Glauber data-set to be used for hadron projectiles
11588 * (0=proton, 1=pion, 2=kaon)
11589       DATA (IOFFST(K),K=1,25) /
11590      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11591      &  0, 0, 1, 2, 2/
11592 * Acceptance interval for target nucleus mass
11593       PARAMETER (KBACC = 6)
11594 * flags for input different options
11595       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
11596       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
11597      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
11598
11599       PARAMETER (MAXMSS = 100)
11600       DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
11601       DIMENSION WHAT(6)
11602
11603       DATA JPEACH,JPSTEP / 18, 5 /
11604
11605 * temporary patch until fix has been implemented in phojet:
11606 *  maximum energy for pion projectile
11607       DATA ECMXPI / 100000.0D0 /
11608 *
11609 *--------------------------------------------------------------------------
11610 * general initializations
11611 *
11612 *  steps in projectile mass number for initialization
11613       IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
11614       IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
11615 *
11616 *  energy range and binning
11617       ELO  = ABS(WHAT(1))
11618       EHI  = ABS(WHAT(2))
11619       IF (ELO.GT.EHI) ELO = EHI
11620       NEBIN = MAX(INT(WHAT(3)),1)
11621       IF (ELO.EQ.EHI) NEBIN = 0
11622       LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
11623       IF (LCMS) THEN
11624          ECMINI = EHI
11625       ELSE
11626          ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
11627      &                 +2.0D0*AAM(IJTARG)*EHI)
11628       ENDIF
11629 *
11630 *  default arguments for Glauber-routine
11631       XI  = ZERO
11632       Q2I = ZERO
11633 *
11634 *  initialize nuclear parameters, etc.
11635       CALL DT_BERTTP
11636       CALL DT_INCINI
11637 *
11638 *  open Glauber-data output file
11639       IDX = INDEX(CGLB,' ')
11640       K   = 12
11641       IF (IDX.GT.1) K = IDX-1
11642       OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11643 *
11644 *--------------------------------------------------------------------------
11645 * Glauber-initialization for proton and nuclei projectiles
11646 *
11647 *  initialize phojet for proton-proton interactions
11648       ELAB = ZERO
11649       PLAB = ZERO
11650       CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11651       CALL DT_PHOINI
11652 *
11653 *  record projectile masses
11654       NASAV = 0
11655       NPROJ = MIN(IP,JPEACH)
11656       DO 10 KPROJ=1,NPROJ
11657          NASAV = NASAV+1
11658          IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11659          IASAV(NASAV) = KPROJ
11660    10 CONTINUE
11661       IF (IP.GT.JPEACH) THEN
11662          NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
11663          IF (NPROJ.EQ.0) THEN
11664             NASAV = NASAV+1
11665             IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11666             IASAV(NASAV) = IP
11667          ELSE
11668             DO 11 IPROJ=1,NPROJ
11669                KPROJ = JPEACH+IPROJ*JPSTEP
11670                NASAV = NASAV+1
11671                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11672                IASAV(NASAV) = KPROJ
11673    11       CONTINUE
11674             IF (KPROJ.LT.IP) THEN
11675                NASAV = NASAV+1
11676                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11677                IASAV(NASAV) = IP
11678             ENDIF
11679          ENDIF
11680       ENDIF
11681 *
11682 *  record target masses
11683       NBSAV = 0
11684       NTARG = 1
11685       IF (NCOMPO.GT.0) NTARG = NCOMPO
11686       DO 12 ITARG=1,NTARG
11687          NBSAV = NBSAV+1
11688          IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
11689          IF (NCOMPO.GT.0) THEN
11690             IBSAV(NBSAV) = IEMUMA(ITARG)
11691          ELSE
11692             IBSAV(NBSAV) = IT
11693          ENDIF
11694    12 CONTINUE
11695 *
11696 *  print masses
11697       WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
11698  1000 FORMAT(I4,A,1P,2E13.5)
11699       NLINES = DBLE(NASAV)/18.0D0
11700       IF (NLINES.GT.0) THEN
11701          DO 13 I=1,NLINES
11702             IF (I.EQ.1) THEN
11703                WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
11704             ELSE
11705                WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
11706             ENDIF
11707    13    CONTINUE
11708       ENDIF
11709       I0 = 18*NLINES+1
11710       IF (I0.LE.NASAV) THEN
11711          IF (I0.EQ.1) THEN
11712             WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
11713          ELSE
11714             WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
11715          ENDIF
11716       ENDIF
11717       NLINES = DBLE(NBSAV)/18.0D0
11718       IF (NLINES.GT.0) THEN
11719          DO 14 I=1,NLINES
11720             IF (I.EQ.1) THEN
11721                WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
11722             ELSE
11723                WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
11724             ENDIF
11725    14    CONTINUE
11726       ENDIF
11727       I0 = 18*NLINES+1
11728       IF (I0.LE.NBSAV) THEN
11729          IF (I0.EQ.1) THEN
11730             WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
11731          ELSE
11732             WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
11733          ENDIF
11734       ENDIF
11735 *
11736 *  calculate Glauber-data for each energy and mass combination
11737 *
11738 *   loop over energy bins
11739       ELO = LOG10(ELO)
11740       EHI = LOG10(EHI)
11741       DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
11742       DO 1 IE=1,NEBIN+1
11743          E = ELO+DBLE(IE-1)*DEBIN
11744          E = 10**E
11745          IF (LCMS) THEN
11746             E   = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
11747             ECM = E
11748          ELSE
11749             PLAB = ZERO
11750             ECM  = ZERO
11751             E    = MAX(AAM(IJPROJ)+0.1D0,E)
11752             CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11753          ENDIF
11754 *
11755 *   loop over projectile and target masses
11756          DO 2 ITARG=1,NBSAV
11757             DO 3 IPROJ=1,NASAV
11758                CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
11759      &                                       XI,Q2I,ECM,1,1,-1)
11760     3       CONTINUE
11761     2    CONTINUE
11762 *
11763     1 CONTINUE
11764 *
11765 *--------------------------------------------------------------------------
11766 * Glauber-initialization for pion, kaon, ... projectiles
11767 *
11768       DO 6 IJ=1,MAXOFF
11769 *
11770 *  initialize phojet for this interaction
11771          ELAB = ZERO
11772          PLAB = ZERO
11773          IJPROJ = IJPINI(IJ)
11774          IP     = 1
11775          IPZ    = 1
11776 *
11777 *   temporary patch until fix has been implemented in phojet:
11778          IF (ECMINI.GT.ECMXPI) THEN
11779             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
11780          ELSE
11781             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11782          ENDIF
11783          CALL DT_PHOINI
11784 *
11785 *  calculate Glauber-data for each energy and mass combination
11786 *
11787 *   loop over energy bins
11788          DO 4 IE=1,NEBIN+1
11789             E = ELO+DBLE(IE-1)*DEBIN
11790             E = 10**E
11791             IF (LCMS) THEN
11792                E   = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
11793                ECM = E
11794             ELSE
11795                PLAB = ZERO
11796                ECM  = ZERO
11797                E    = MAX(AAM(IJPROJ)+TINY14,E)
11798                CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11799             ENDIF
11800 *
11801 *   loop over projectile and target masses
11802             DO 5 ITARG=1,NBSAV
11803                CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
11804     5       CONTINUE
11805 *
11806     4    CONTINUE
11807 *
11808     6 CONTINUE
11809
11810 *--------------------------------------------------------------------------
11811 * close output unit(s), etc.
11812 *
11813       CLOSE(LDAT)
11814
11815       RETURN
11816       END
11817
11818 *$ CREATE DT_GLBSET.FOR
11819 *COPY DT_GLBSET
11820 *
11821 *===glbset=============================================================*
11822 *
11823       SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
11824 ************************************************************************
11825 * Interpolation of pre-initialized profile functions                   *
11826 * This version dated 28.11.00 is written by S. Roesler.                *
11827 ************************************************************************
11828
11829       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11830       SAVE
11831
11832       PARAMETER ( LINP = 10 ,
11833      &            LOUT = 6 ,
11834      &            LDAT = 9 )
11835       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
11836
11837       LOGICAL LCMS,LREAD,LFRST1,LFRST2
11838
11839 * particle properties (BAMJET index convention)
11840       CHARACTER*8  ANAME
11841       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11842      &                IICH(210),IIBAR(210),K1(210),K2(210)
11843 * Glauber formalism: flags and parameters for statistics
11844       LOGICAL LPROD
11845       CHARACTER*8 CGLB
11846       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11847       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11848 * Glauber formalism: parameters
11849       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11850      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11851      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11852      &                NSITEB,NSTATB
11853 * Glauber formalism: cross sections
11854       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11855      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11856      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11857      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11858      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11859      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11860      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11861      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11862      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11863      &                BSLOPE,NEBINI,NQBINI
11864 * number of data sets other than protons and nuclei
11865 * at the moment = 2 (pions and kaons)
11866       PARAMETER (MAXOFF=2)
11867       DIMENSION IJPINI(5),IOFFST(25)
11868       DATA IJPINI / 13, 15,  0,  0,  0/
11869 * Glauber data-set to be used for hadron projectiles
11870 * (0=proton, 1=pion, 2=kaon)
11871       DATA (IOFFST(K),K=1,25) /
11872      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11873      &  0, 0, 1, 2, 2/
11874 * Acceptance interval for target nucleus mass
11875       PARAMETER (KBACC = 6)
11876 * emulsion treatment
11877       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11878      &                NCOMPO,IEMUL
11879
11880       PARAMETER (MAXSET=5000,
11881      &           MAXBIN=100)
11882       DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
11883       DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
11884      &          BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
11885      &          IAIDX(10)
11886
11887       DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
11888 *
11889 * read data from file
11890 *
11891       IF (MODE.EQ.0) THEN
11892
11893          IF (LREAD) RETURN
11894
11895          DO 1 I=1,MAXSET
11896             DO 2 J=1,6
11897                XSIG(I,J) = ZERO
11898                XERR(I,J) = ZERO
11899     2       CONTINUE
11900             DO 3 J=1,KSITEB
11901                BPROFL(I,J) = ZERO
11902     3       CONTINUE
11903     1    CONTINUE
11904          DO 4 I=1,MAXBIN
11905             IABIN(I) = 0
11906             IBBIN(I) = 0
11907     4    CONTINUE
11908          DO 5 I=1,KSITEB
11909             BPRO0(I) = ZERO
11910             BPRO1(I) = ZERO
11911             BPRO(I)  = ZERO
11912     5    CONTINUE
11913
11914          IDX = INDEX(CGLB,' ')
11915          K   = 12
11916          IF (IDX.GT.1) K = IDX-1
11917          OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11918          WRITE(LOUT,1000) CGLB(1:K)//'.glb'
11919  1000    FORMAT(/,' GLBSET: impact parameter distributions read from ',
11920      &          'file ',A12,/)
11921 *
11922 *  read binning information
11923          READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
11924 *  return lower energy threshold to Fluka-interface
11925          ELAB = ELO
11926          LCMS = ELO.LT.ZERO
11927          WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
11928          IF (LCMS) THEN
11929             WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
11930          ELSE
11931             WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
11932          ENDIF
11933  1001    FORMAT(2X,A5,'  E_lo = ',1P,E9.3,'  E_hi = ',1P,E9.3,4X,
11934      &          'No. of bins:',I5,/)
11935          ELO  = LOG10(ABS(ELO))
11936          EHI  = LOG10(ABS(EHI))
11937          DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
11938          WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
11939          READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
11940          IF (NABIN.LT.18) THEN
11941             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
11942          ELSE
11943             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
11944          ENDIF
11945          IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
11946          IF (NABIN.GT.18) THEN
11947             NLINES = DBLE(NABIN-18)/18.0D0
11948             IF (NLINES.GT.0) THEN
11949                DO 7 I=1,NLINES
11950                   I0 = 18*(I+1)-17
11951                   READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11952                   WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11953     7          CONTINUE
11954             ENDIF
11955             I0 = 18*(NLINES+1)+1
11956             IF (I0.LE.NABIN) THEN
11957                READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11958                WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11959             ENDIF
11960          ENDIF
11961          WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
11962          READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
11963          IF (NBBIN.LT.18) THEN
11964             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
11965          ELSE
11966             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
11967          ENDIF
11968          IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
11969          IF (NBBIN.GT.18) THEN
11970             NLINES = DBLE(NBBIN-18)/18.0D0
11971             IF (NLINES.GT.0) THEN
11972                DO 8 I=1,NLINES
11973                   I0 = 18*(I+1)-17
11974                   READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
11975                   WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
11976     8          CONTINUE
11977             ENDIF
11978             I0 = 18*(NLINES+1)+1
11979             IF (I0.LE.NBBIN) THEN
11980                READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
11981                WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
11982             ENDIF
11983          ENDIF
11984 *  number of data sets to follow in the Glauber data file
11985 *   this variable is used for checks of consistency of projectile
11986 *   and target mass configurations given in header of Glauber data
11987 *   file and the data-sets which follow in this file
11988          NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
11989 *
11990 *  read profile function data
11991          NSET  = 0
11992          NAIDX = 0
11993          IPOLD = 0
11994    10    CONTINUE
11995          NSET = NSET+1
11996          IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
11997          READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
11998  1002    FORMAT(5I10,E15.5)
11999          IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12000             NAIDX = NAIDX+1
12001             IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12002             IAIDX(NAIDX) = IP
12003             IPOLD = IP
12004          ENDIF
12005          READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12006          READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12007          NLINES = INT(DBLE(ISITEB)/7.0D0)
12008          IF (NLINES.GT.0) THEN
12009             DO 11 I=1,NLINES
12010                READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12011    11       CONTINUE
12012          ENDIF
12013          I0 = 7*NLINES+1
12014          IF (I0.LE.ISITEB)
12015      &      READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12016          GOTO 10
12017   100    CONTINUE
12018          NSET = NSET-1
12019          IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12020          WRITE(LOUT,'(/,1X,A)')
12021      &   ' projectiles other than protons and nuclei: (particle index)'
12022          IF (NAIDX.GT.0) THEN
12023             WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12024          ELSE
12025             WRITE(LOUT,'(6X,A)') 'none'
12026          ENDIF
12027 *
12028          CLOSE(LDAT)
12029          WRITE(LOUT,*)
12030          LREAD = .TRUE.
12031
12032          IF (NCOMPO.EQ.0) THEN
12033             DO 12 J=1,NBBIN
12034                NCOMPO = NCOMPO+1
12035                IEMUMA(NCOMPO) = IBBIN(J)
12036                IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12037                EMUFRA(NCOMPO) = 1.0D0
12038    12       CONTINUE
12039             IEMUL = 1
12040          ENDIF
12041 *
12042 * calculate profile function for certain set of parameters
12043 *
12044       ELSE
12045
12046 c        write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12047 *
12048 * check for type of projectile and set index-offset to entry in
12049 * Glauber data array correspondingly
12050          IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12051          IF (IOFFST(IDPROJ).EQ.-1) THEN
12052             STOP ' GLBSET: no data for this projectile !'
12053          ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12054             IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12055          ELSE
12056             IDXOFF = 0
12057          ENDIF
12058 *
12059 * get energy bin and interpolation factor
12060          IF (LCMS) THEN
12061             E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12062          ELSE
12063             E = ELAB
12064          ENDIF
12065          E = LOG10(E)
12066          IF (E.LT.ELO) THEN
12067             IF (LFRST1) THEN
12068                WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12069                LFRST1 = .FALSE.
12070             ENDIF
12071             E = ELO
12072          ENDIF
12073          IF (E.GT.EHI) THEN
12074             IF (LFRST2) THEN
12075                WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12076                LFRST2 = .FALSE.
12077             ENDIF
12078             E = EHI
12079          ENDIF
12080          IE0  = (E-ELO)/DEBIN+1
12081          IE1  = IE0+1
12082          FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12083 *
12084 * get target nucleus index
12085          KB = 0
12086          NBACC = KBACC
12087          DO 20 I=1,NBBIN
12088             NBDIFF = ABS(NB-IBBIN(I))
12089             IF (NB.EQ.IBBIN(I)) THEN
12090                KB = I
12091                GOTO 21
12092             ELSEIF (NBDIFF.LE.NBACC) THEN
12093                KB = I
12094                NBACC = NBDIFF
12095             ENDIF
12096    20    CONTINUE
12097          IF (KB.NE.0) GOTO 21
12098          WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12099          STOP
12100    21    CONTINUE
12101 *
12102 * get projectile nucleus bin and interpolation factor
12103          KA0 = 0
12104          KA1 = 0
12105          FACNA = 0
12106          IF (IDXOFF.GT.0) THEN
12107             KA0 = 1
12108             KA1 = 1
12109             KABIN = 1
12110          ELSE
12111             IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12112             DO 22 I=1,NABIN
12113                IF (NA.EQ.IABIN(I)) THEN
12114                   KA0 = I
12115                   KA1 = I
12116                   GOTO 23
12117                ELSEIF (NA.LT.IABIN(I)) THEN
12118                   KA0 = I-1
12119                   KA1 = I
12120                   GOTO 23
12121                ENDIF
12122    22       CONTINUE
12123             WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12124             STOP
12125    23       CONTINUE
12126             IF (KA0.NE.KA1)
12127      &         FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12128             KABIN = NABIN
12129          ENDIF
12130 *
12131 * interpolate profile functions for interactions ka0-kb and ka1-kb
12132 * for energy E separately
12133          IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12134          IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12135          IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12136          IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12137          DO 30 I=1,ISITEB
12138             BPRO0(I) = BPROFL(IDX0,I)
12139      &                 +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12140             BPRO1(I) = BPROFL(IDY0,I)
12141      &                 +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12142    30    CONTINUE
12143          RADB  = DT_RNCLUS(NB)
12144          BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12145          BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12146 *
12147 * interpolate cross sections for energy E and projectile mass
12148          DO 31 I=1,6
12149             XS0   = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12150             XS1   = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12151             XS(I) = XS0+FACNA*(XS1-XS0)
12152             XE0   = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12153             XE1   = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12154             XE(I) = XE0+FACNA*(XE1-XE0)
12155    31    CONTINUE
12156 *
12157 * interpolate between ka0 and ka1
12158          RADA = DT_RNCLUS(NA)
12159          BMX  = 2.0D0*(RADA+RADB)
12160          BSTP = BMX/DBLE(ISITEB-1)
12161          BPRO(1) = ZERO
12162          DO 32 I=1,ISITEB-1
12163             B = DBLE(I)*BSTP
12164 *
12165 *   calculate values of profile functions at B
12166             IDX0 = B/BSTP0+1
12167             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12168             IDX1 = MIN(IDX0+1,ISITEB)
12169             FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12170             BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12171             IDX0 = B/BSTP1+1
12172             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12173             IDX1 = MIN(IDX0+1,ISITEB)
12174             FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12175             BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12176 *
12177             BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12178    32    CONTINUE
12179 *
12180 * fill common dtglam
12181          NSITEB   = ISITEB
12182          RASH(1)  = RADA
12183          RBSH(1)  = RADB
12184          BMAX(1)  = BMX
12185          BSTEP(1) = BSTP
12186          DO 33 I=1,KSITEB
12187             BSITE(0,1,1,I) = BPRO(I)
12188    33    CONTINUE
12189 *
12190 * fill common dtglxs
12191          XSTOT(1,1,1) = XS(1)
12192          XSELA(1,1,1) = XS(2)
12193          XSQEP(1,1,1) = XS(3)
12194          XSQET(1,1,1) = XS(4)
12195          XSQE2(1,1,1) = XS(5)
12196          XSPRO(1,1,1) = XS(6)
12197          XETOT(1,1,1) = XE(1)
12198          XEELA(1,1,1) = XE(2)
12199          XEQEP(1,1,1) = XE(3)
12200          XEQET(1,1,1) = XE(4)
12201          XEQE2(1,1,1) = XE(5)
12202          XEPRO(1,1,1) = XE(6)
12203
12204       ENDIF
12205
12206       RETURN
12207       END
12208
12209 *$ CREATE DT_XKSAMP.FOR
12210 *COPY DT_XKSAMP
12211 *
12212 *===xksamp=============================================================*
12213 *
12214       SUBROUTINE DT_XKSAMP(NN,ECM)
12215
12216 ************************************************************************
12217 * Sampling of parton x-values and chain system for one interaction.    *
12218 *                                   processed by S. Roesler, 9.8.95    *
12219 ************************************************************************
12220
12221       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12222       SAVE
12223       PARAMETER ( LINP = 10 ,
12224      &            LOUT = 6 ,
12225      &            LDAT = 9 )
12226       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12227 CPH      SAVE
12228
12229       PARAMETER (
12230 * lower cuts for (valence-sea/sea-valence) chain masses
12231 *   antiquark-quark (u/d-sea quark)    (s-sea quark)
12232      &               AMIU = 0.5D0,      AMIS = 0.8D0,
12233 *   quark-diquark   (u/d-sea quark)    (s-sea quark)
12234      &               AMAU = 2.6D0,      AMAS = 2.6D0,
12235 * maximum lower valence-x threshold
12236      &           XVMAX  = 0.98D0,
12237 * fraction of sea-diquarks sampled out of sea-partons
12238 **test
12239 C    &           FRCDIQ = 0.9D0,
12240 **
12241 *
12242      &           SQMA   = 0.7D0,
12243 *
12244 * maximum number of trials to generate x's for the required number
12245 * of sea quark pairs for a given hadron
12246      &           NSEATY = 12
12247 C    &           NSEATY = 3
12248      &          )
12249
12250       LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12251
12252       PARAMETER ( MAXNCL = 260,
12253      &            MAXVQU = MAXNCL,
12254      &            MAXSQU = 20*MAXVQU,
12255      &            MAXINT = MAXVQU+MAXSQU)
12256 * event history
12257       PARAMETER (NMXHKK=200000)
12258       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12259      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12260      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12261 * particle properties (BAMJET index convention)
12262       CHARACTER*8  ANAME
12263       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12264      &                IICH(210),IIBAR(210),K1(210),K2(210)
12265 * interface between Glauber formalism and DPM
12266       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12267      &                INTER1(MAXINT),INTER2(MAXINT)
12268 * properties of interacting particles
12269       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12270 * threshold values for x-sampling (DTUNUC 1.x)
12271       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12272      &                SSMIMQ,VVMTHR
12273 * x-values of partons (DTUNUC 1.x)
12274       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12275      &                XTVQ(MAXVQU),XTVD(MAXVQU),
12276      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
12277      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
12278 * flavors of partons (DTUNUC 1.x)
12279       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12280      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12281      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
12282      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12283      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
12284      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12285      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
12286 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12287       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12288      &                IXPV,IXPS,IXTV,IXTS,
12289      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
12290      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
12291      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
12292      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
12293      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
12294      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
12295      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
12296      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
12297 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12298       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12299      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12300 * auxiliary common for chain system storage (DTUNUC 1.x)
12301       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12302 * flags for input different options
12303       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12304       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12305      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12306 * various options for treatment of partons (DTUNUC 1.x)
12307 * (chain recombination, Cronin,..)
12308       LOGICAL LCO2CR,LINTPT
12309       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12310      &                LCO2CR,LINTPT
12311
12312       DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12313      &          INTLO(MAXINT)
12314
12315 * (1) initializations
12316 *-----------------------------------------------------------------------
12317
12318 **test
12319       IF (ECM.LT.4.5D0) THEN
12320 C        FRCDIQ = 0.6D0
12321          FRCDIQ = 0.4D0
12322       ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12323 C        FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12324          FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12325       ELSE
12326 C        FRCDIQ = 0.9D0
12327          FRCDIQ = 0.7D0
12328       ENDIF
12329 **
12330       DO 30 I=1,MAXSQU
12331          ZUOSP(I) = .FALSE.
12332          ZUOST(I) = .FALSE.
12333          IF (I.LE.MAXVQU) THEN
12334             ZUOVP(I) = .FALSE.
12335             ZUOVT(I) = .FALSE.
12336          ENDIF
12337    30 CONTINUE
12338
12339 * lower thresholds for x-selection
12340 *  sea-quarks       (default: CSEA=0.2)
12341       IF (ECM.LT.10.0D0) THEN
12342 **!!test
12343          XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12344 C        XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12345          NSEA  = NSEATY
12346 C        XSTHR = ONE/ECM**2
12347       ELSE
12348 **sr 30.3.98
12349 C        XSTHR = CSEA/ECM
12350          XSTHR = CSEA/ECM**2
12351 C        XSTHR = ONE/ECM**2
12352 **
12353          IF ((IP.GE.150).AND.(IT.GE.150))
12354      &      XSTHR = 2.5D0/(ECM*SQRT(ECM))
12355          NSEA  = NSEATY
12356       ENDIF
12357 *                   (default: SSMIMA=0.14) used for sea-diquarks (?)
12358       XSSTHR = SSMIMA/ECM
12359       BSQMA  = SQMA/ECM
12360 *  valence-quarks   (default: CVQ=1.0)
12361       XVTHR  = CVQ/ECM
12362 *  valence-diquarks (default: CDQ=2.0)
12363       XDTHR  = CDQ/ECM
12364
12365 * maximum-x for sea-quarks
12366       XVCUT  = XVTHR+XDTHR
12367       IF (XVCUT.GT.XVMAX) THEN
12368          XVCUT = XVMAX
12369          XVTHR = XVCUT/3.0D0
12370          XDTHR = XVCUT-XVTHR
12371       ENDIF
12372       XXSEAM = ONE-XVCUT
12373 **sr 18.4. test: DPMJET
12374 C     XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
12375 C    &            - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
12376 C    &             -0.01*(1.D0+1.5D0*DT_RNDM(V3))
12377 **
12378 * maximum number of sea-pairs allowed kinematically
12379 C     NSMAX  = INT(OHALF*XXSEAM/XSTHR)
12380       RNSMAX = OHALF*XXSEAM/XSTHR
12381       IF (RNSMAX.GT.10000.0D0) THEN
12382          NSMAX = 10000
12383       ELSE
12384          NSMAX = INT(OHALF*XXSEAM/XSTHR)
12385       ENDIF
12386 * check kinematical limit for valence-x thresholds
12387 * (should be obsolete now)
12388       IF (XVCUT.GT.XVMAX) THEN
12389          WRITE(LOUT,1000) XVCUT,ECM
12390  1000    FORMAT(' XKSAMP:    kin. limit for valence-x',
12391      &          '  thresholds not allowed (',2E9.3,')')
12392 C        XVTHR = XVMAX-XDTHR
12393 C        IF (XVTHR.LT.ZERO) STOP
12394          STOP
12395       ENDIF
12396
12397 * set eta for valence-x sampling (BETREJ)
12398 *   (UNON per default, UNOM used for projectile mesons only)
12399       IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
12400          UNOPRV = UNOM
12401       ELSE
12402          UNOPRV = UNON
12403       ENDIF
12404
12405 * (2) select parton x-values of interacting projectile nucleons
12406 *-----------------------------------------------------------------------
12407
12408       IXPV = 0
12409       IXPS = 0
12410
12411       DO 100 IPP=1,IP
12412 *   get interacting projectile nucleon as sampled by Glauber
12413          IF (JSSH(IPP).NE.0) THEN
12414             IXSTMP = IXPS
12415             IXVTMP = IXPV
12416    99       CONTINUE
12417             IXPS   = IXSTMP
12418             IXPV   = IXVTMP
12419 *     JIPP is the actual number of sea-pairs sampled for this nucleon
12420             JIPP   = MIN(JSSH(IPP)-1,NSMAX)
12421    41       CONTINUE
12422             XXSEA  = ZERO
12423             IF (JIPP.GT.0) THEN
12424                XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
12425 *???
12426                IF (XSTHR.GE.XSMAX) THEN
12427                   JIPP = JIPP-1
12428                   GOTO 41
12429                ENDIF
12430
12431 *>>>get x-values of sea-quark pairs
12432                NSCOUN = 0
12433                PLW = 0.5D0
12434    40          CONTINUE
12435 *     accumulator for sea x-values
12436                XXSEA  = ZERO
12437                NSCOUN = NSCOUN+1
12438                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12439                IF (NSCOUN.GT.NSEA) THEN
12440 *     decrease the number of interactions after NSEA trials
12441                   JIPP   = JIPP-1
12442                   NSCOUN = 0
12443                ENDIF
12444                DO 70 ISQ=1,JIPP
12445 *     sea-quarks
12446                   IF (IPSQ(IXPS+1).LE.2) THEN
12447 **sr 8.4.98 (1/sqrt(x))
12448 C                    XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12449 C                    XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12450                      XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12451 **
12452                   ELSE
12453                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12454                         XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12455                      ELSE
12456 **sr 8.4.98 (1/sqrt(x))
12457 C                       XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12458 C                       XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12459                         XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12460 **
12461                      ENDIF
12462                   ENDIF
12463 *     sea-antiquarks
12464                   IF (IPSAQ(IXPS+1).GE.-2) THEN
12465 **sr 8.4.98 (1/sqrt(x))
12466 C                    XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12467 C                    XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12468                      XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12469 **
12470                   ELSE
12471                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12472                         XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12473                      ELSE
12474 **sr 8.4.98 (1/sqrt(x))
12475 C                       XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12476 C                       XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12477                         XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12478 **
12479                      ENDIF
12480                   ENDIF
12481                   XXSEA = XXSEA+XPSQI+XPSAQI
12482 *     check for maximum allowed sea x-value
12483                   IF (XXSEA.GE.XXSEAM) THEN
12484                      IXPS = IXPS-ISQ+1
12485                      GOTO 40
12486                   ENDIF
12487 *     accept this sea-quark pair
12488                   IXPS         = IXPS+1
12489                   XPSQ(IXPS)   = XPSQI
12490                   XPSAQ(IXPS)  = XPSAQI
12491                   IFROSP(IXPS) = IPP
12492                   ZUOSP(IXPS)  = .TRUE.
12493    70          CONTINUE
12494             ENDIF
12495
12496 *>>>get x-values of valence partons
12497 *     valence quark
12498             IF (XVTHR.GT.0.05D0) THEN
12499                XVHI  = ONE-XXSEA-XDTHR
12500                XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
12501             ELSE
12502    90          CONTINUE
12503                XPVQI = DT_DBETAR(OHALF,UNOPRV)
12504                IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
12505      &                                                     GOTO 90
12506             ENDIF
12507 *     valence diquark
12508             XPVDI = ONE-XPVQI-XXSEA
12509 *       reject according to x**1.5
12510             XDTMP = XPVDI**1.5D0
12511             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
12512 *     accept these valence partons
12513             IXPV         = IXPV+1
12514             XPVQ(IXPV)   = XPVQI
12515             XPVD(IXPV)   = XPVDI
12516             IFROVP(IXPV) = IPP
12517             ITOVP(IPP)   = IXPV
12518             ZUOVP(IXPV)  = .TRUE.
12519
12520          ENDIF
12521   100 CONTINUE
12522
12523 * (3) select parton x-values of interacting target nucleons
12524 *-----------------------------------------------------------------------
12525
12526       IXTV = 0
12527       IXTS = 0
12528
12529       DO 170 ITT=1,IT
12530 *   get interacting target nucleon as sampled by Glauber
12531          IF (JTSH(ITT).NE.0) THEN
12532             IXSTMP = IXTS
12533             IXVTMP = IXTV
12534   169       CONTINUE
12535             IXTS   = IXSTMP
12536             IXTV   = IXVTMP
12537 *     JITT is the actual number of sea-pairs sampled for this nucleon
12538             JITT   = MIN(JTSH(ITT)-1,NSMAX)
12539   111       CONTINUE
12540             XXSEA  = ZERO
12541             IF (JITT.GT.0) THEN
12542                XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
12543 *???
12544                IF (XSTHR.GE.XSMAX) THEN
12545                   JITT = JITT-1
12546                   GOTO 111
12547                ENDIF
12548
12549 *>>>get x-values of sea-quark pairs
12550                NSCOUN = 0
12551                PLW = 0.5D0
12552   110          CONTINUE
12553 *     accumulator for sea x-values
12554                XXSEA  = ZERO
12555                NSCOUN = NSCOUN+1
12556                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12557                IF (NSCOUN.GT.NSEA)THEN
12558 *     decrease the number of interactions after NSEA trials
12559                   JITT   = JITT-1
12560                   NSCOUN = 0
12561                ENDIF
12562                DO 140 ISQ=1,JITT
12563 *     sea-quarks
12564                   IF (ITSQ(IXTS+1).LE.2) THEN
12565 **sr 8.4.98 (1/sqrt(x))
12566 C                    XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12567 C                    XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12568                      XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12569 **
12570                   ELSE
12571                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12572                         XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12573                      ELSE
12574 **sr 8.4.98 (1/sqrt(x))
12575 C                       XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12576 C                       XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12577                         XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12578 **
12579                      ENDIF
12580                   ENDIF
12581 *     sea-antiquarks
12582                   IF (ITSAQ(IXTS+1).GE.-2) THEN
12583 **sr 8.4.98 (1/sqrt(x))
12584 C                    XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12585 C                    XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12586                      XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12587 **
12588                   ELSE
12589                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12590                         XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12591                      ELSE
12592 **sr 8.4.98 (1/sqrt(x))
12593 C                       XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12594 C                       XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12595                         XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12596 **
12597                      ENDIF
12598                   ENDIF
12599                   XXSEA = XXSEA+XTSQI+XTSAQI
12600 *     check for maximum allowed sea x-value
12601                   IF (XXSEA.GE.XXSEAM) THEN
12602                      IXTS = IXTS-ISQ+1
12603                      GOTO 110
12604                   ENDIF
12605 *     accept this sea-quark pair
12606                   IXTS         = IXTS+1
12607                   XTSQ(IXTS)   = XTSQI
12608                   XTSAQ(IXTS)  = XTSAQI
12609                   IFROST(IXTS) = ITT
12610                   ZUOST(IXTS)  = .TRUE.
12611   140          CONTINUE
12612             ENDIF
12613
12614 *>>>get x-values of valence partons
12615 *     valence quark
12616             IF (XVTHR.GT.0.05D0) THEN
12617                XVHI  = ONE-XXSEA-XDTHR
12618                XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
12619             ELSE
12620   160          CONTINUE
12621                XTVQI = DT_DBETAR(OHALF,UNON)
12622                IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
12623      &                                                    GOTO 160
12624             ENDIF
12625 *     valence diquark
12626             XTVDI = ONE-XTVQI-XXSEA
12627 *       reject according to x**1.5
12628             XDTMP = XTVDI**1.5D0
12629             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
12630 *     accept these valence partons
12631             IXTV         = IXTV+1
12632             XTVQ(IXTV)   = XTVQI
12633             XTVD(IXTV)   = XTVDI
12634             IFROVT(IXTV) = ITT
12635             ITOVT(ITT)   = IXTV
12636             ZUOVT(IXTV)  = .TRUE.
12637
12638          ENDIF
12639   170 CONTINUE
12640
12641 * (4) get valence-valence chains
12642 *-----------------------------------------------------------------------
12643
12644       NVV = 0
12645       DO 240 I=1,NN
12646          INTLO(I) = .TRUE.
12647          IPVAL    = ITOVP(INTER1(I))
12648          ITVAL    = ITOVT(INTER2(I))
12649          IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
12650             INTLO(I)      = .FALSE.
12651             ZUOVP(IPVAL)  = .FALSE.
12652             ZUOVT(ITVAL)  = .FALSE.
12653             NVV           = NVV+1
12654             ISKPCH(8,NVV) = 0
12655             INTVV1(NVV)   = IPVAL
12656             INTVV2(NVV)   = ITVAL
12657          ENDIF
12658   240 CONTINUE
12659
12660 * (5) get sea-valence chains
12661 *-----------------------------------------------------------------------
12662
12663       NSV = 0
12664       NDV = 0
12665       PLW = 0.5D0
12666       DO 270 I=1,NN
12667          IF (INTLO(I)) THEN
12668             IPVAL = ITOVP(INTER1(I))
12669             ITVAL = ITOVT(INTER2(I))
12670             DO 250 J=1,IXPS
12671                IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
12672      &                                ZUOVT(ITVAL)) THEN
12673                   ZUOSP(J)     = .FALSE.
12674                   ZUOVT(ITVAL) = .FALSE.
12675                   INTLO(I)     = .FALSE.
12676                   IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
12677 *   sample sea-diquark pair
12678                      CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
12679                      IF (IREJ1.EQ.0) GOTO 260
12680                   ENDIF
12681                   NSV           = NSV+1
12682                   ISKPCH(4,NSV) = 0
12683                   INTSV1(NSV)   = J
12684                   INTSV2(NSV)   = ITVAL
12685
12686 *>>>correct chain kinematics according to minimum chain masses
12687 *     the actual chain masses
12688                   AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
12689                   AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
12690 *     get lower mass cuts
12691                   IF (IPSQ(J).EQ.3) THEN
12692 *       q being s-quark
12693                      AMCHK1 = AMAS
12694                      AMCHK2 = AMIS
12695                   ELSE
12696 *       q being u/d-quark
12697                      AMCHK1 = AMAU
12698                      AMCHK2 = AMIU
12699                   ENDIF
12700 *       q-qq chain
12701 *         chain mass above minimum - resampling of sea-q x-value
12702                   IF (AMSVQ1.GT.AMCHK1) THEN
12703                      XPSQTH      = AMCHK1/(XTVD(ITVAL)*ECM**2)
12704 **sr 8.4.98 (1/sqrt(x))
12705 C                    XPSQXX      = DT_SAMPEX(XPSQTH,XPSQ(J))
12706 C                    XPSQXX      = DT_SAMSQX(XPSQTH,XPSQ(J))
12707                      XPSQXX      = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
12708 **
12709                      XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
12710                      XPSQ(J)     = XPSQXX
12711 *         chain mass below minimum - reset sea-q x-value and correct
12712 *                                    diquark-x of the same nucleon
12713                   ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12714                      XPSQW       = AMCHK1/(XTVD(ITVAL)*ECM**2)
12715                      DXPSQ       = XPSQW-XPSQ(J)
12716                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12717                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12718                         XPSQ(J)     = XPSQW
12719                      ENDIF
12720                   ENDIF
12721 *       aq-q chain
12722 *         chain mass below minimum - reset sea-aq x-value and correct
12723 *                                    diquark-x of the same nucleon
12724                   IF (AMSVQ2.LT.AMCHK2) THEN
12725                      XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
12726                      DXPSQ = XPSQW-XPSAQ(J)
12727                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12728                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12729                         XPSAQ(J)    = XPSQW
12730                      ENDIF
12731                   ENDIF
12732 *>>>end of chain mass correction
12733
12734                   GOTO 260
12735                ENDIF
12736   250       CONTINUE
12737          ENDIF
12738   260    CONTINUE
12739   270 CONTINUE
12740
12741 * (6) get valence-sea chains
12742 *-----------------------------------------------------------------------
12743
12744       NVS = 0
12745       NVD = 0
12746       DO 300 I=1,NN
12747          IF (INTLO(I)) THEN
12748             IPVAL = ITOVP(INTER1(I))
12749             ITVAL = ITOVT(INTER2(I))
12750             DO 280 J=1,IXTS
12751                IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
12752      &                  (IFROST(J).EQ.INTER2(I))) THEN
12753                   ZUOST(J)     = .FALSE.
12754                   ZUOVP(IPVAL) = .FALSE.
12755                   INTLO(I)     = .FALSE.
12756                   IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
12757 *   sample sea-diquark pair
12758                      CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
12759                      IF (IREJ1.EQ.0) GOTO 290
12760                   ENDIF
12761                   NVS           = NVS + 1
12762                   ISKPCH(6,NVS) = 0
12763                   INTVS1(NVS)   = IPVAL
12764                   INTVS2(NVS)   = J
12765
12766 *>>>correct chain kinematics according to minimum chain masses
12767 *     the actual chain masses
12768                   AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
12769                   AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
12770 *     get lower mass cuts
12771                   IF (ITSQ(J).EQ.3) THEN
12772 *       q being s-quark
12773                      AMCHK1 = AMIS
12774                      AMCHK2 = AMAS
12775                   ELSE
12776 *       q being u/d-quark
12777                      AMCHK1 = AMIU
12778                      AMCHK2 = AMAU
12779                   ENDIF
12780 *       q-aq chain
12781 *         chain mass below minimum - reset sea-aq x-value and correct
12782 *                                    diquark-x of the same nucleon
12783                   IF (AMVSQ1.LT.AMCHK1) THEN
12784                      XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
12785                      DXTSQ = XTSQW-XTSAQ(J)
12786                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12787                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12788                         XTSAQ(J)    = XTSQW
12789                      ENDIF
12790                   ENDIF
12791 *       qq-q chain
12792 *         chain mass above minimum - resampling of sea-q x-value
12793                   IF (AMVSQ2.GT.AMCHK2) THEN
12794                      XTSQTH      = AMCHK2/(XPVD(IPVAL)*ECM**2)
12795 **sr 8.4.98 (1/sqrt(x))
12796 C                    XTSQXX      = DT_SAMPEX(XTSQTH,XTSQ(J))
12797 C                    XTSQXX      = DT_SAMSQX(XTSQTH,XTSQ(J))
12798                      XTSQXX      = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
12799 **
12800                      XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
12801                      XTSQ(J)     = XTSQXX
12802 *         chain mass below minimum - reset sea-q x-value and correct
12803 *                                    diquark-x of the same nucleon
12804                   ELSEIF (AMVSQ2.LT.AMCHK2) THEN
12805                      XTSQW       = AMCHK2/(XPVD(IPVAL)*ECM**2)
12806                      DXTSQ       = XTSQW-XTSQ(J)
12807                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12808                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12809                         XTSQ(J)     = XTSQW
12810                      ENDIF
12811                   ENDIF
12812 *>>>end of chain mass correction
12813
12814                   GOTO 290
12815                ENDIF
12816   280       CONTINUE
12817          ENDIF
12818   290    CONTINUE
12819   300 CONTINUE
12820
12821 * (7) get sea-sea chains
12822 *-----------------------------------------------------------------------
12823
12824       NSS = 0
12825       NDS = 0
12826       NSD = 0
12827       DO 420 I=1,NN
12828          IF (INTLO(I)) THEN
12829             IPVAL = ITOVP(INTER1(I))
12830             ITVAL = ITOVT(INTER2(I))
12831 *   loop over target partons not yet matched
12832             DO 400 J=1,IXTS
12833                IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
12834 *   loop over projectile partons not yet matched
12835                   DO 390 JJ=1,IXPS
12836                      IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
12837                         ZUOSP(JJ)     = .FALSE.
12838                         ZUOST(J)      = .FALSE.
12839                         INTLO(I)      = .FALSE.
12840                         NSS           = NSS+1
12841                         ISKPCH(1,NSS) = 0
12842                         INTSS1(NSS)   = JJ
12843                         INTSS2(NSS)   = J
12844
12845 *---->chain recombination option
12846                         VALFRA        = DBLE(NVV/(NVV+IXPS+IXTS))
12847                         IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
12848      &                                                             THEN
12849 *       sea-sea chains may recombine with valence-valence chains
12850 *       only if they have the same projectile or target nucleon
12851                            DO 4201 IVV=1,NVV
12852                               IF (ISKPCH(8,IVV).NE.99) THEN
12853                                  IXVPR = INTVV1(IVV)
12854                                  IXVTA = INTVV2(IVV)
12855                                  IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
12856      &                               (INTER2(I).EQ.IFROVT(IXVTA))) THEN
12857 *         recombination possible, drop old v-v and s-s chains
12858                                     ISKPCH(1,NSS) = 99
12859                                     ISKPCH(8,IVV) = 99
12860
12861 *         (a) assign new s-v chains
12862 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
12863                                     IF (LSEADI.AND.
12864      &                                  (DT_RNDM(VALFRA).GT.FRCDIQ))
12865      &                                                             THEN
12866 *           sample sea-diquark pair
12867                                        CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
12868      &                                                      IREJ1)
12869                                        IF (IREJ1.EQ.0) GOTO 4202
12870                                     ENDIF
12871                                     NSV           = NSV+1
12872                                     ISKPCH(4,NSV) = 0
12873                                     INTSV1(NSV)   = JJ
12874                                     INTSV2(NSV)   = IXVTA
12875 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12876 *           the actual chain masses
12877                                     AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
12878      &                                                     *ECM**2
12879                                     AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
12880      &                                                     *ECM**2
12881 *           get lower mass cuts
12882                                     IF (IPSQ(JJ).EQ.3) THEN
12883 *             q being s-quark
12884                                        AMCHK1 = AMAS
12885                                        AMCHK2 = AMIS
12886                                     ELSE
12887 *             q being u/d-quark
12888                                        AMCHK1 = AMAU
12889                                        AMCHK2 = AMIU
12890                                     ENDIF
12891 *           q-qq chain
12892 *             chain mass above minimum - resampling of sea-q x-value
12893                                     IF (AMSVQ1.GT.AMCHK1) THEN
12894                                        XPSQTH      =
12895      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
12896 **sr 8.4.98 (1/sqrt(x))
12897                                        XPSQXX      =
12898      &                                    DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
12899 C    &                                    DT_SAMSQX(XPSQTH,XPSQ(JJ))
12900 C    &                                    DT_SAMPEX(XPSQTH,XPSQ(JJ))
12901 **
12902                                        XPVD(IPVAL) =
12903      &                                    XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
12904                                        XPSQ(JJ)    = XPSQXX
12905 *             chain mass below minimum - reset sea-q x-value and correct
12906 *                                        diquark-x of the same nucleon
12907                                     ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12908                                        XPSQW =
12909      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
12910                                        DXPSQ = XPSQW-XPSQ(JJ)
12911                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12912      &                                                            THEN
12913                                           XPVD(IPVAL) =
12914      &                                       XPVD(IPVAL)-DXPSQ
12915                                           XPSQ(JJ)    = XPSQW
12916                                        ENDIF
12917                                     ENDIF
12918 *           aq-q chain
12919 *             chain mass below minimum - reset sea-aq x-value and correct
12920 *                                        diquark-x of the same nucleon
12921                                     IF (AMSVQ2.LT.AMCHK2) THEN
12922                                        XPSQW =
12923      &                                    AMCHK2/(XTVQ(IXVTA)*ECM**2)
12924                                        DXPSQ = XPSQW-XPSAQ(JJ)
12925                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12926      &                                                            THEN
12927                                           XPVD(IPVAL) =
12928      &                                       XPVD(IPVAL)-DXPSQ
12929                                           XPSAQ(JJ)   = XPSQW
12930                                        ENDIF
12931                                     ENDIF
12932 *>>>>>>>>>>>end of chain mass correction
12933  4202                               CONTINUE
12934
12935 *         (b) assign new v-s chains
12936 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
12937                                     IF (LSEADI.AND.(
12938      &                                  DT_RNDM(AMSVQ2).GT.FRCDIQ))
12939      &                                                             THEN
12940 *           sample sea-diquark pair
12941                                        CALL DT_SAMSDQ(ECM,IXVPR,J,1,
12942      &                                                      IREJ1)
12943                                        IF (IREJ1.EQ.0) GOTO 4203
12944                                     ENDIF
12945                                     NVS           = NVS+1
12946                                     ISKPCH(6,NVS) = 0
12947                                     INTVS1(NVS)   = IXVPR
12948                                     INTVS2(NVS)   = J
12949 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12950 *           the actual chain masses
12951                                     AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
12952                                     AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
12953 *           get lower mass cuts
12954                                     IF (ITSQ(J).EQ.3) THEN
12955 *             q being s-quark
12956                                        AMCHK1 = AMIS
12957                                        AMCHK2 = AMAS
12958                                     ELSE
12959 *             q being u/d-quark
12960                                        AMCHK1 = AMIU
12961                                        AMCHK2 = AMAU
12962                                     ENDIF
12963 *           q-aq chain
12964 *             chain mass below minimum - reset sea-aq x-value and correct
12965 *                                        diquark-x of the same nucleon
12966                                     IF (AMVSQ1.LT.AMCHK1) THEN
12967                                        XTSQW =
12968      &                                    AMCHK1/(XPVQ(IXVPR)*ECM**2)
12969                                        DXTSQ = XTSQW-XTSAQ(J)
12970                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
12971      &                                                            THEN
12972                                           XTVD(ITVAL) =
12973      &                                       XTVD(ITVAL)-DXTSQ
12974                                           XTSAQ(J)    = XTSQW
12975                                        ENDIF
12976                                     ENDIF
12977                                     IF (AMVSQ2.GT.AMCHK2) THEN
12978                                        XTSQTH      =
12979      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
12980 **sr 8.4.98 (1/sqrt(x))
12981                                        XTSQXX      =
12982      &                                    DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
12983 C    &                                    DT_SAMSQX(XTSQTH,XTSQ(J))
12984 C    &                                    DT_SAMPEX(XTSQTH,XTSQ(J))
12985 **
12986                                        XTVD(ITVAL) =
12987      &                                    XTVD(ITVAL)+XTSQ(J)-XTSQXX
12988                                        XTSQ(J)     = XTSQXX
12989                                     ELSEIF (AMVSQ2.LT.AMCHK2) THEN
12990                                        XTSQW =
12991      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
12992                                        DXTSQ = XTSQW-XTSQ(J)
12993                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
12994      &                                                            THEN
12995                                           XTVD(ITVAL) =
12996      &                                       XTVD(ITVAL)-DXTSQ
12997                                           XTSQ(J)     = XTSQW
12998                                        ENDIF
12999                                     ENDIF
13000 *>>>>>>>>>end of chain mass correction
13001  4203                               CONTINUE
13002 *       jump out of s-s chain loop
13003                                     GOTO 420
13004                                  ENDIF
13005                               ENDIF
13006  4201                      CONTINUE
13007                         ENDIF
13008 *---->end of chain recombination option
13009
13010 *     sample sea-diquark pair (projectile)
13011                         IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13012                            CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13013                            IF (IREJ1.EQ.0) THEN
13014                               ISKPCH(1,NSS) = 99
13015                               GOTO 410
13016                            ENDIF
13017                         ENDIF
13018 *     sample sea-diquark pair (target)
13019                         IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13020                            CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13021                            IF (IREJ1.EQ.0) THEN
13022                               ISKPCH(1,NSS) = 99
13023                               GOTO 410
13024                            ENDIF
13025                         ENDIF
13026 *>>>>>correct chain kinematics according to minimum chain masses
13027 *     the actual chain masses
13028                         SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13029                         SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13030 *     check for lower mass cuts
13031                         IF ((SSMA1Q.LT.SSMIMQ).OR.
13032      &                      (SSMA2Q.LT.SSMIMQ)) THEN
13033                            IPVAL = ITOVP(INTER1(I))
13034                            ITVAL = ITOVT(INTER2(I))
13035                            IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13036      &                         (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13037 *       maximum allowed x values for sea quarks
13038                               XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13039      &                                           1.2D0*XSSTHR
13040                               XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13041      &                                           1.2D0*XSSTHR
13042 *       resampling of x values not possible - skip sea-sea chains
13043                               IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13044      &                            (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13045 *       resampling of x for projectile sea quark pair
13046                               ICOUS = 0
13047   310                         CONTINUE
13048                               ICOUS = ICOUS+1
13049                               IF (XSSTHR.GT.0.05D0) THEN
13050                                  XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13051      &                                                         XSPMAX)
13052                                  XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13053      &                                                         XSPMAX)
13054                               ELSE
13055   320                            CONTINUE
13056                                  XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13057                                  IF ((XPSQI.LT.XSSTHR).OR.
13058      &                               (XPSQI.GT.XSPMAX))  GOTO 320
13059   330                            CONTINUE
13060                                  XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13061                                  IF ((XPSAQI.LT.XSSTHR).OR.
13062      &                               (XPSAQI.GT.XSPMAX)) GOTO 330
13063                               ENDIF
13064 *       final test of remaining x for projectile diquark
13065                               XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13066      &                                            +XPSQ(JJ)+XPSAQ(JJ)
13067                               IF (XPVDCO.LE.XDTHR) THEN
13068 *!!!
13069 C                                IF (ICOUS.LT.5) GOTO 310
13070                                  IF (ICOUS.LT.0.5D0) GOTO 310
13071                                  GOTO 380
13072                               ENDIF
13073 *       resampling of x for target sea quark pair
13074                               ICOUS = 0
13075   350                         CONTINUE
13076                               ICOUS = ICOUS+1
13077                               IF (XSSTHR.GT.0.05D0) THEN
13078                                  XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13079      &                                                         XSTMAX)
13080                                  XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13081      &                                                         XSTMAX)
13082                               ELSE
13083   360                            CONTINUE
13084                                  XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13085                                  IF ((XTSQI.LT.XSSTHR).OR.
13086      &                               (XTSQI.GT.XSTMAX))  GOTO 360
13087   370                            CONTINUE
13088                                  XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13089                                  IF ((XTSAQI.LT.XSSTHR).OR.
13090      &                               (XTSAQI.GT.XSTMAX)) GOTO 370
13091                               ENDIF
13092 *       final test of remaining x for target diquark
13093                               XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13094      &                                            +XTSQ(J)+XTSAQ(J)
13095                               IF (XTVDCO.LT.XDTHR) THEN
13096                                  IF (ICOUS.LT.5) GOTO 350
13097                                  GOTO 380
13098                               ENDIF
13099                               XPVD(IPVAL) = XPVDCO
13100                               XTVD(ITVAL) = XTVDCO
13101                               XPSQ(JJ)    = XPSQI
13102                               XPSAQ(JJ)   = XPSAQI
13103                               XTSQ(J)     = XTSQI
13104                               XTSAQ(J)    = XTSAQI
13105 *>>>>>end of chain mass correction
13106                               GOTO 410
13107                            ENDIF
13108 *     come here to discard s-s interaction
13109 *     resampling of x values not allowed or unsuccessful
13110   380                      CONTINUE
13111                            INTLO(I)  = .FALSE.
13112                            ZUOST(J)  = .TRUE.
13113                            ZUOSP(JJ) = .TRUE.
13114                            NSS       = NSS-1
13115                         ENDIF
13116 *   consider next s-s interaction
13117                         GOTO 410
13118                      ENDIF
13119   390             CONTINUE
13120                ENDIF
13121   400       CONTINUE
13122          ENDIF
13123   410    CONTINUE
13124   420 CONTINUE
13125
13126 * correct x-values of valence quarks for non-matching sea quarks
13127       DO 430 I=1,IXPS
13128          IF (ZUOSP(I)) THEN
13129             IPVAL       = ITOVP(IFROSP(I))
13130             XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13131             XPSQ(I)     = ZERO
13132             XPSAQ(I)    = ZERO
13133             ZUOSP(I)    = .FALSE.
13134          ENDIF
13135   430 CONTINUE
13136       DO 440 I=1,IXTS
13137          IF (ZUOST(I)) THEN
13138             ITVAL       = ITOVT(IFROST(I))
13139             XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13140             XTSQ(I)     = ZERO
13141             XTSAQ(I)    = ZERO
13142             ZUOST(I)    = .FALSE.
13143          ENDIF
13144   440 CONTINUE
13145       DO 450 I=1,IXPV
13146          IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13147   450 CONTINUE
13148       DO 460 I=1,IXTV
13149          IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13150   460 CONTINUE
13151
13152       RETURN
13153       END
13154
13155 *$ CREATE DT_SAMSDQ.FOR
13156 *COPY DT_SAMSDQ
13157 *
13158 *===samsdq=============================================================*
13159 *
13160       SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13161
13162 ************************************************************************
13163 * SAMpling of Sea-DiQuarks                                             *
13164 *              ECM        cm-energy of the nucleon-nucleon system      *
13165 *              IDX1,2     indices of x-values of the participating     *
13166 *                         partons (IDX2 is always the sea-q-pair to be *
13167 *                         changed to sea-qq-pair)                      *
13168 *              MODE       = 1  valence-q - sea-diq                     *
13169 *                         = 2  sea-diq   - valence-q                   *
13170 *                         = 3  sea-q     - sea-diq                     *
13171 *                         = 4  sea-diq   - sea-q                       *
13172 * Based on DIQVS, DIQSV, DIQSSD, DIQDSS.                               *
13173 * This version dated 17.10.95 is written by S. Roesler                 *
13174 ************************************************************************
13175
13176       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13177       SAVE
13178
13179       PARAMETER (ZERO=0.0D0)
13180
13181 * threshold values for x-sampling (DTUNUC 1.x)
13182       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13183      &                SSMIMQ,VVMTHR
13184 * various options for treatment of partons (DTUNUC 1.x)
13185 * (chain recombination, Cronin,..)
13186       LOGICAL LCO2CR,LINTPT
13187       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13188      &                LCO2CR,LINTPT
13189       PARAMETER ( MAXNCL = 260,
13190      &            MAXVQU = MAXNCL,
13191      &            MAXSQU = 20*MAXVQU,
13192      &            MAXINT = MAXVQU+MAXSQU)
13193 * x-values of partons (DTUNUC 1.x)
13194       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13195      &                XTVQ(MAXVQU),XTVD(MAXVQU),
13196      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
13197      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
13198 * flavors of partons (DTUNUC 1.x)
13199       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13200      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13201      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
13202      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13203      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
13204      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13205      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
13206 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13207       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13208      &                IXPV,IXPS,IXTV,IXTS,
13209      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
13210      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
13211      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
13212      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
13213      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
13214      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
13215      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
13216      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
13217 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13218       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13219      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13220 * auxiliary common for chain system storage (DTUNUC 1.x)
13221       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13222
13223       IREJ = 0
13224 *  threshold-x for valence diquarks
13225       XDTHR = CDQ/ECM
13226
13227       GOTO (1,2,3,4) MODE
13228
13229 *---------------------------------------------------------------------
13230 * proj. valence partons - targ. sea partons
13231 * get x-values and flavors for target sea-diquark pair
13232
13233     1 CONTINUE
13234       IDXVP = IDX1
13235       IDXST = IDX2
13236
13237 *  index of corr. val-diquark-x in target nucleon
13238       IDXVT = ITOVT(IFROST(IDXST))
13239 *  available x above diquark thresholds for valence- and sea-diquarks
13240       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13241
13242       IF (XXD.GE.ZERO) THEN
13243 *  x-values for the three diquarks of the target nucleon
13244          RR1    = DT_RNDM(XXD)
13245          RR2    = DT_RNDM(RR1)
13246          RR3    = DT_RNDM(RR2)
13247          SR123  = RR1+RR2+RR3
13248          XXTV   = XDTHR+RR1*XXD/SR123
13249          XXTSQ  = XDTHR+RR2*XXD/SR123
13250          XXTSAQ = XDTHR+RR3*XXD/SR123
13251       ELSE
13252          XXTV   = XTVD(IDXVT)
13253          XXTSQ  = XTSQ(IDXST)
13254          XXTSAQ = XTSAQ(IDXST)
13255       ENDIF
13256 *  flavor of the second quarks in the sea-diquark pair
13257       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13258       ITSAQ2(IDXST) = -ITSQ2(IDXST)
13259 *  check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13260       AM1    = XXTSQ *XPVQ(IDXVP)*ECM**2
13261       AM2    = XXTSAQ*XPVD(IDXVP)*ECM**2
13262       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13263 *    ss-asas pair
13264      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13265          IREJ = 1
13266          RETURN
13267       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13268 *    at least one strange quark
13269      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13270          IREJ = 1
13271          RETURN
13272       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13273          IREJ = 1
13274          RETURN
13275       ENDIF
13276 *  accept the new sea-diquark
13277       XTVD(IDXVT)   = XXTV
13278       XTSQ(IDXST)   = XXTSQ
13279       XTSAQ(IDXST)  = XXTSAQ
13280       NVD           = NVD+1
13281       INTVD1(NVD)   = IDXVP
13282       INTVD2(NVD)   = IDXST
13283       ISKPCH(7,NVD) = 0
13284       RETURN
13285
13286 *---------------------------------------------------------------------
13287 * proj. sea partons - targ. valence partons
13288 * get x-values and flavors for projectile sea-diquark pair
13289
13290     2 CONTINUE
13291       IDXSP = IDX2
13292       IDXVT = IDX1
13293
13294 *  index of corr. val-diquark-x in projectile nucleon
13295       IDXVP = ITOVP(IFROSP(IDXSP))
13296 *  available x above diquark thresholds for valence- and sea-diquarks
13297       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13298
13299       IF (XXD.GE.ZERO) THEN
13300 *  x-values for the three diquarks of the projectile nucleon
13301          RR1    = DT_RNDM(XXD)
13302          RR2    = DT_RNDM(RR1)
13303          RR3    = DT_RNDM(RR2)
13304          SR123  = RR1+RR2+RR3
13305          XXPV   = XDTHR+RR1*XXD/SR123
13306          XXPSQ  = XDTHR+RR2*XXD/SR123
13307          XXPSAQ = XDTHR+RR3*XXD/SR123
13308       ELSE
13309          XXPV   = XPVD(IDXVP)
13310          XXPSQ  = XPSQ(IDXSP)
13311          XXPSAQ = XPSAQ(IDXSP)
13312       ENDIF
13313 *  flavor of the second quarks in the sea-diquark pair
13314       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13315       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13316 *  check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13317       AM1    = XXPSQ *XTVQ(IDXVT)*ECM**2
13318       AM2    = XXPSAQ*XTVD(IDXVT)*ECM**2
13319       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13320 *    ss-asas pair
13321      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13322          IREJ = 1
13323          RETURN
13324       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13325 *    at least one strange quark
13326      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13327          IREJ = 1
13328          RETURN
13329       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13330          IREJ = 1
13331          RETURN
13332       ENDIF
13333 *  accept the new sea-diquark
13334       XPVD(IDXVP)   = XXPV
13335       XPSQ(IDXSP)   = XXPSQ
13336       XPSAQ(IDXSP)  = XXPSAQ
13337       NDV           = NDV+1
13338       INTDV1(NDV)   = IDXSP
13339       INTDV2(NDV)   = IDXVT
13340       ISKPCH(5,NDV) = 0
13341       RETURN
13342
13343 *---------------------------------------------------------------------
13344 * proj. sea partons - targ. sea partons
13345 * get x-values and flavors for target sea-diquark pair
13346
13347     3 CONTINUE
13348       IDXSP = IDX1
13349       IDXST = IDX2
13350
13351 *  index of corr. val-diquark-x in target nucleon
13352       IDXVT = ITOVT(IFROST(IDXST))
13353 *  available x above diquark thresholds for valence- and sea-diquarks
13354       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13355
13356       IF (XXD.GE.ZERO) THEN
13357 *  x-values for the three diquarks of the target nucleon
13358          RR1    = DT_RNDM(XXD)
13359          RR2    = DT_RNDM(RR1)
13360          RR3    = DT_RNDM(RR2)
13361          SR123  = RR1+RR2+RR3
13362          XXTV   = XDTHR+RR1*XXD/SR123
13363          XXTSQ  = XDTHR+RR2*XXD/SR123
13364          XXTSAQ = XDTHR+RR3*XXD/SR123
13365       ELSE
13366          XXTV   = XTVD(IDXVT)
13367          XXTSQ  = XTSQ(IDXST)
13368          XXTSAQ = XTSAQ(IDXST)
13369       ENDIF
13370 *  flavor of the second quarks in the sea-diquark pair
13371       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13372       ITSAQ2(IDXST) = -ITSQ2(IDXST)
13373 *  check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
13374       AM1    = XXTSQ *XPSQ(IDXSP)*ECM**2
13375       AM2    = XXTSAQ*XPSAQ(IDXSP)*ECM**2
13376       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13377 *    ss-asas pair
13378      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
13379          IREJ = 1
13380          RETURN
13381       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13382 *    at least one strange quark
13383      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
13384          IREJ = 1
13385          RETURN
13386       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13387          IREJ = 1
13388          RETURN
13389       ENDIF
13390 *  accept the new sea-diquark
13391       XTVD(IDXVT)   = XXTV
13392       XTSQ(IDXST)   = XXTSQ
13393       XTSAQ(IDXST)  = XXTSAQ
13394       NSD           = NSD+1
13395       INTSD1(NSD)   = IDXSP
13396       INTSD2(NSD)   = IDXST
13397       ISKPCH(3,NSD) = 0
13398       RETURN
13399
13400 *---------------------------------------------------------------------
13401 * proj. sea partons - targ. sea partons
13402 * get x-values and flavors for projectile sea-diquark pair
13403
13404     4 CONTINUE
13405       IDXSP = IDX2
13406       IDXST = IDX1
13407
13408 *  index of corr. val-diquark-x in projectile nucleon
13409       IDXVP = ITOVP(IFROSP(IDXSP))
13410 *  available x above diquark thresholds for valence- and sea-diquarks
13411       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13412
13413       IF (XXD.GE.ZERO) THEN
13414 *  x-values for the three diquarks of the projectile nucleon
13415          RR1    = DT_RNDM(XXD)
13416          RR2    = DT_RNDM(RR1)
13417          RR3    = DT_RNDM(RR2)
13418          SR123  = RR1+RR2+RR3
13419          XXPV   = XDTHR+RR1*XXD/SR123
13420          XXPSQ  = XDTHR+RR2*XXD/SR123
13421          XXPSAQ = XDTHR+RR3*XXD/SR123
13422       ELSE
13423          XXPV   = XPVD(IDXVP)
13424          XXPSQ  = XPSQ(IDXSP)
13425          XXPSAQ = XPSAQ(IDXSP)
13426       ENDIF
13427 *  flavor of the second quarks in the sea-diquark pair
13428       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13429       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13430 *  check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
13431       AM1    = XXPSQ *XTSQ(IDXST)*ECM**2
13432       AM2    = XXPSAQ*XTSAQ(IDXST)*ECM**2
13433       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13434 *    ss-asas pair
13435      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
13436          IREJ = 1
13437          RETURN
13438       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13439 *    at least one strange quark
13440      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
13441          IREJ = 1
13442          RETURN
13443       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13444          IREJ = 1
13445          RETURN
13446       ENDIF
13447 *  accept the new sea-diquark
13448       XPVD(IDXVP)   = XXPV
13449       XPSQ(IDXSP)   = XXPSQ
13450       XPSAQ(IDXSP)  = XXPSAQ
13451       NDS           = NDS+1
13452       INTDS1(NDS)   = IDXSP
13453       INTDS2(NDS)   = IDXST
13454       ISKPCH(2,NDS) = 0
13455       RETURN
13456       END
13457
13458 *$ CREATE DT_DIFEVT.FOR
13459 *COPY DT_DIFEVT
13460 *
13461 *===difevt=============================================================*
13462 *
13463       SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
13464      &                  IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
13465
13466 ************************************************************************
13467 * Interface to treatment of diffractive interactions.                  *
13468 *  (input)          IFP1/2        PDG-indizes of projectile partons    *
13469 *                                 (baryon: IFP2 - adiquark)            *
13470 *                   PP(4)         projectile 4-momentum                *
13471 *                   IFT1/2        PDG-indizes of target partons        *
13472 *                                 (baryon: IFT1 - adiquark)            *
13473 *                   PT(4)         target 4-momentum                    *
13474 *  (output)         JDIFF = 0     no diffraction                       *
13475 *                         = 1/-1  LMSD/LMDD                            *
13476 *                         = 2/-2  HMSD/HMDD                            *
13477 *                   NCSY          counter for two-chain systems        *
13478 *                                 dumped to DTEVT1                     *
13479 * This version dated 14.02.95 is written by S. Roesler                 *
13480 ************************************************************************
13481
13482       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13483       SAVE
13484       PARAMETER ( LINP = 10 ,
13485      &            LOUT = 6 ,
13486      &            LDAT = 9 )
13487       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
13488      &           OHALF=0.5D0)
13489
13490 * event history
13491       PARAMETER (NMXHKK=200000)
13492       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
13493      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
13494      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
13495 * extended event history
13496       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
13497      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
13498      &                IHIST(2,NMXHKK)
13499 * flags for diffractive interactions (DTUNUC 1.x)
13500       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
13501
13502       DIMENSION PP(4),PT(4)
13503
13504       LOGICAL LFIRST
13505       DATA LFIRST /.TRUE./
13506
13507       IREJ   = 0
13508       JDIFF  = 0
13509       IFLAGD = JDIFF
13510
13511 * cm. energy
13512       XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
13513      &          (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
13514 * identities of projectile hadron / target nucleon
13515       KPROJ = IDT_ICIHAD(IDHKK(MOP))
13516       KTARG = IDT_ICIHAD(IDHKK(MOT))
13517
13518 * single diffractive xsections
13519       CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
13520 * double diffractive xsections
13521 **!! no double diff yet
13522 C     CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
13523       DDTOT = 0.0D0
13524       DDHM  = 0.0D0
13525 **!!
13526 * total inelastic xsection
13527 C     SIGIN  = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
13528       DUMZER = ZERO
13529       CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
13530       SIGIN  = MAX(SIGTO-SIGEL,ZERO)
13531
13532 * fraction of diffractive processes
13533       FRADIF = (SDTOT+DDTOT)/SIGIN
13534
13535       IF (LFIRST) THEN
13536          WRITE(LOUT,1000) XM,SDTOT,SIGIN
13537  1000    FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
13538      &          F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
13539      &          F5.1,' mb',/)
13540          LFIRST = .FALSE.
13541       ENDIF
13542
13543       IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
13544      &    (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
13545 * diffractive interaction requested by x-section or by user
13546          FRASD  = SDTOT/(SDTOT+DDTOT)
13547          FRASDH = SDHM/SDTOT
13548 **sr needs to be specified!!
13549 C        FRADDH = DDHM/DDTOT
13550          FRADDH = 1.0D0
13551 **
13552          IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
13553 *   single diffraction
13554             KDIFF = 1
13555             IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
13556                KP = 2
13557                KT = 0
13558                IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
13559      &               ISINGD.NE.3) THEN
13560                   KP = 0
13561                   KT = 2
13562                ENDIF
13563             ELSE
13564                KP = 1
13565                KT = 0
13566                IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
13567      &               ISINGD.NE.3) THEN
13568                   KP = 0
13569                   KT = 1
13570                ENDIF
13571             ENDIF
13572          ELSE
13573 *   double diffraction
13574             KDIFF = -1
13575             IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
13576                KP = 2
13577                KT = 2
13578             ELSE
13579                KP = 1
13580                KT = 1
13581             ENDIF
13582          ENDIF
13583          CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13584      &               IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13585          IF (IREJ1.EQ.0) THEN
13586             IFLAGD = 2*KDIFF
13587             IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
13588          ELSE
13589             GOTO 9999
13590          ENDIF
13591       ENDIF
13592       JDIFF = IFLAGD
13593
13594       RETURN
13595
13596  9999 CONTINUE
13597       IREJ  = 1
13598       RETURN
13599       END
13600
13601 *$ CREATE DT_DIFFKI.FOR
13602 *COPY DT_DIFFKI
13603 *
13604 *===difkin=============================================================*
13605 *
13606       SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13607      &                  IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
13608
13609 ************************************************************************
13610 * Kinematics of diffractive nucleon-nucleon interaction.               *
13611 *          IFP1/2   PDG-indizes of projectile partons                  *
13612 *                   (baryon: IFP2 - adiquark)                          *
13613 *          PP(4)    projectile 4-momentum                              *
13614 *          IFT1/2   PDG-indizes of target partons                      *
13615 *                   (baryon: IFT1 - adiquark)                          *
13616 *          PT(4)    target 4-momentum                                  *
13617 *          KP   = 0 projectile quasi-elastically scattered             *
13618 *               = 1            excited to low-mass diff. state         *
13619 *               = 2            excited to high-mass diff. state        *
13620 *          KT   = 0 target     quasi-elastically scattered             *
13621 *               = 1            excited to low-mass diff. state         *
13622 *               = 2            excited to high-mass diff. state        *
13623 * This version dated 12.02.95 is written by S. Roesler                 *
13624 ************************************************************************
13625
13626       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13627       SAVE
13628       PARAMETER ( LINP = 10 ,
13629      &            LOUT = 6 ,
13630      &            LDAT = 9 )
13631       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
13632
13633       LOGICAL LSTART
13634
13635 * particle properties (BAMJET index convention)
13636       CHARACTER*8  ANAME
13637       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
13638      &                IICH(210),IIBAR(210),K1(210),K2(210)
13639 * flags for input different options
13640       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
13641       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
13642      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
13643 * rejection counter
13644       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
13645      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
13646      &                IREXCI(3),IRDIFF(2),IRINC
13647 * kinematics of diffractive interactions (DTUNUC 1.x)
13648       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13649      &                PPF(4),PTF(4),
13650      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13651      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13652
13653       DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
13654      &          PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
13655
13656       DATA LSTART /.TRUE./
13657
13658       IF (LSTART) THEN
13659          WRITE(LOUT,2000)
13660  2000    FORMAT(/,1X,'DIFEVT:  diffractive interactions treated ')
13661          LSTART = .FALSE.
13662       ENDIF
13663
13664       IREJ = 0
13665
13666 * initialize common /DTDIKI/
13667       CALL DT_DIFINI
13668 * store momenta of initial incoming particles for emc-check
13669       IF (LEMCCK) THEN
13670          CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
13671          CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
13672       ENDIF
13673
13674 * masses of initial particles
13675       XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
13676       XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
13677       IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
13678       XMP  = SQRT(XMP2)
13679       XMT  = SQRT(XMT2)
13680 * check quark-input (used to adjust coherence cond. for M-selection)
13681       IBP  = 0
13682       IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
13683       IBT  = 0
13684       IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
13685
13686 * parameter for Lorentz-transformation into nucleon-nucleon cms
13687       DO 3 K=1,4
13688          PITOT(K) = PP(K)+PT(K)
13689     3 CONTINUE
13690       XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
13691       IF (XMTOT2.LE.ZERO) THEN
13692          WRITE(LOUT,1000) XMTOT2
13693  1000    FORMAT(1X,'DIFEVT:   negative cm. energy!  ',
13694      &          'XMTOT2 = ',E12.3)
13695          GOTO 9999
13696       ENDIF
13697       XMTOT = SQRT(XMTOT2)
13698       DO 4 K=1,4
13699          BGTOT(K) = PITOT(K)/XMTOT
13700     4 CONTINUE
13701 * transformation of nucleons into cms
13702       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
13703      &            PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
13704       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
13705      &            PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
13706 * rotation angles
13707       COD = PP1(3)/PPTOT
13708 C     SID = SQRT((ONE-COD)*(ONE+COD))
13709       PPT = SQRT(PP1(1)**2+PP1(2)**2)
13710       SID = PPT/PPTOT
13711       COF = ONE
13712       SIF = ZERO
13713       IF(PPTOT*SID.GT.TINY10) THEN
13714          COF   = PP1(1)/(SID*PPTOT)
13715          SIF   = PP1(2)/(SID*PPTOT)
13716          ANORF = SQRT(COF*COF+SIF*SIF)
13717          COF   = COF/ANORF
13718          SIF   = SIF/ANORF
13719       ENDIF
13720 * check consistency
13721       DO 5 K=1,4
13722          DEV1(K) = ABS(PP1(K)+PT1(K))
13723     5 CONTINUE
13724       DEV1(4) = ABS(DEV1(4)-XMTOT)
13725       IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
13726      &    (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10))     THEN
13727          WRITE(LOUT,1001) DEV1
13728  1001    FORMAT(1X,'DIFEVT:   inconsitent Lorentz-transformation! ',
13729      &          /,8X,4E12.3)
13730          GOTO 9999
13731       ENDIF
13732
13733 * select x-fractions in high-mass diff. interactions
13734       IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
13735
13736 * select diffractive masses
13737 * - projectile
13738       IF (KP.EQ.1) THEN
13739          XMPF = DT_XMLMD(XMTOT)
13740          CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
13741          IF (IREJ1.GT.0) GOTO 9999
13742       ELSEIF (KP.EQ.2) THEN
13743          XMPF = DT_XMHMD(XMTOT,IBP,1)
13744       ELSE
13745          XMPF = XMP
13746       ENDIF
13747 * - target
13748       IF (KT.EQ.1) THEN
13749          XMTF = DT_XMLMD(XMTOT)
13750          CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
13751          IF (IREJ1.GT.0) GOTO 9999
13752       ELSEIF (KT.EQ.2) THEN
13753          XMTF = DT_XMHMD(XMTOT,IBT,2)
13754       ELSE
13755          XMTF = XMT
13756       ENDIF
13757
13758 * kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
13759       XMPF2 = XMPF**2
13760       XMTF2 = XMTF**2
13761       PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
13762       PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
13763
13764 * select momentum transfer (all t-values used here are <0)
13765 *   minimum absolute value to produce diffractive masses
13766       TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
13767       TT   = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
13768       IF (IREJ1.GT.0) GOTO 9999
13769
13770 * longitudinal momentum of excited/elastically scattered projectile
13771       PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
13772 * total transverse momentum due to t-selection
13773       PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
13774       IF (PPBLT2.LT.ZERO) THEN
13775          WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
13776  1002    FORMAT(1X,'DIFEVT:   inconsistent transverse momentum! ',
13777      &          E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
13778          GOTO 9999
13779       ENDIF
13780       CALL DT_DSFECF(SINPHI,COSPHI)
13781       PPBLT     = SQRT(PPBLT2)
13782       PPBLOB(1) = COSPHI*PPBLT
13783       PPBLOB(2) = SINPHI*PPBLT
13784
13785 * rotate excited/elastically scattered projectile into n-n cms.
13786       CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
13787      &                                                    XX,YY,ZZ)
13788       PPBLOB(1) = XX
13789       PPBLOB(2) = YY
13790       PPBLOB(3) = ZZ
13791
13792 * 4-momentum of excited/elastically scattered target and of exchanged
13793 * Pomeron
13794       DO 6 K=1,4
13795          IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
13796          PPOM1(K) = PP1(K)-PPBLOB(K)
13797     6 CONTINUE
13798       PTBLOB(4) = XMTOT-PPBLOB(4)
13799
13800 * Lorentz-transformation back into system of initial diff. collision
13801       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13802      &            PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
13803      &            PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
13804       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13805      &            PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
13806      &            PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
13807       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13808      &            PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
13809      &            PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
13810
13811 * store 4-momentum of elastically scattered particle (in single diff.
13812 * events)
13813       IF (KP.EQ.0) THEN
13814          DO 7 K=1,4
13815             PSC(K) = PPF(K)
13816     7    CONTINUE
13817       ELSEIF (KT.EQ.0) THEN
13818          DO 8 K=1,4
13819             PSC(K) = PTF(K)
13820     8    CONTINUE
13821       ENDIF
13822
13823 * check consistency of kinematical treatment so far
13824       IF (LEMCCK) THEN
13825          CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
13826          CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
13827          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
13828          IF (IREJ1.NE.0) GOTO 9999
13829       ENDIF
13830       DO 9 K=1,4
13831          DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
13832          DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
13833     9 CONTINUE
13834       IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
13835      &    (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
13836      &    (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
13837      &    (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5))     THEN
13838          WRITE(LOUT,1003) DEV1,DEV2
13839  1003    FORMAT(1X,'DIFEVT:   inconsitent kinematical treatment!  ',
13840      &          2(/,8X,4E12.3))
13841          GOTO 9999
13842       ENDIF
13843
13844 * kinematical treatment for low-mass diffraction
13845       CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
13846       IF (IREJ1.NE.0) GOTO 9999
13847
13848 * dump diffractive chains into DTEVT1
13849       CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13850       IF (IREJ1.NE.0) GOTO 9999
13851
13852       RETURN
13853
13854  9999 CONTINUE
13855       IRDIFF(1) = IRDIFF(1)+1
13856       IREJ      = 1
13857       RETURN
13858       END
13859
13860 *$ CREATE DT_XMHMD.FOR
13861 *COPY DT_XMHMD
13862 *
13863 *===xmhmd==============================================================*
13864 *
13865       DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
13866
13867 ************************************************************************
13868 * Diffractive mass in high mass single/double diffractive events.      *
13869 * This version dated 11.02.95 is written by S. Roesler                 *
13870 ************************************************************************
13871
13872       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13873       SAVE
13874       PARAMETER ( LINP = 10 ,
13875      &            LOUT = 6 ,
13876      &            LDAT = 9 )
13877       PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
13878
13879 * kinematics of diffractive interactions (DTUNUC 1.x)
13880       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13881      &                PPF(4),PTF(4),
13882      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13883      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13884
13885 C     DATA XCOLOW /0.05D0/
13886       DATA XCOLOW /0.15D0/
13887
13888       DT_XMHMD = ZERO
13889       XH = XPH(2)
13890       IF (MODE.EQ.2) XH = XTH(2)
13891
13892 * minimum Pomeron-x for high-mass diffraction
13893 * (adjusted to get a smooth transition between HM and LM component)
13894       R = DT_RNDM(XH)
13895       XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
13896       IF (ECM.LE.300.0D0) THEN
13897          RR     = (1.0D0-EXP(-((ECM/140.0D0)**4)))
13898          XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
13899       ENDIF
13900 * maximum Pomeron-x for high-mass diffraction
13901 * (coherence condition, adjusted to fit to experimental data)
13902       IF (IB.NE.0) THEN
13903 *   baryon-diffraction
13904          XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
13905       ELSE
13906 *   meson-diffraction
13907          XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
13908       ENDIF
13909 * check boundaries
13910       IF (XDIMIN.GE.XDIMAX) THEN
13911          XDIMIN = OHALF*XDIMAX
13912       ENDIF
13913
13914       KLOOP = 0
13915     1 CONTINUE
13916       KLOOP = KLOOP+1
13917       IF (KLOOP.GT.20) RETURN
13918 * sample Pomeron-x from 1/x-distribution (critical Pomeron)
13919       XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
13920 * corr. diffr. mass
13921       DT_XMHMD = ECM*SQRT(XDIFF)
13922       IF (DT_XMHMD.LT.2.5D0) GOTO 1
13923
13924       RETURN
13925       END
13926
13927 *$ CREATE DT_XMLMD.FOR
13928 *COPY DT_XMLMD
13929 *
13930 *===xmlmd==============================================================*
13931 *
13932       DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
13933
13934 ************************************************************************
13935 * Diffractive mass in high mass single/double diffractive events.      *
13936 * This version dated 11.02.95 is written by S. Roesler                 *
13937 ************************************************************************
13938
13939       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13940       SAVE
13941       PARAMETER ( LINP = 10 ,
13942      &            LOUT = 6 ,
13943      &            LDAT = 9 )
13944
13945 * minimum Pomeron-x for low-mass diffraction
13946 C     AMO = 1.5D0
13947       AMO = 2.0D0
13948 * maximum Pomeron-x for low-mass diffraction
13949 * (adjusted to get a smooth transition between HM and LM component)
13950       R   = DT_RNDM(AMO)
13951       SAM = 1.0D0
13952       IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
13953       R   = DT_RNDM(AMO)*SAM
13954       AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
13955       AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
13956
13957 * selection of diffractive mass
13958 * (adjusted to get a smooth transition between HM and LM component)
13959       R   = DT_RNDM(AMU)
13960       IF (ECM.LE.50.0D0) THEN
13961          DT_XMLMD = AMO*(AMU/AMO)**R
13962       ELSE
13963          A = 0.7D0
13964          IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
13965          DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
13966       ENDIF
13967
13968       RETURN
13969       END
13970
13971 *$ CREATE DT_TDIFF.FOR
13972 *COPY DT_TDIFF
13973 *
13974 *===tdiff==============================================================*
13975 *
13976       DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
13977
13978 ************************************************************************
13979 * t-selection for single/double diffractive interactions.              *
13980 *          ECM      cm. energy                                         *
13981 *          TMIN     minimum momentum transfer to produce diff. masses  *
13982 *          XM1/XM2  diffractively produced masses                      *
13983 *                   (for single diffraction XM2 is obsolete)           *
13984 *          K1/K2= 0 not excited                                        *
13985 *               = 1 low-mass excitation                                *
13986 *               = 2 high-mass excitation                               *
13987 * This version dated 11.02.95 is written by S. Roesler                 *
13988 ************************************************************************
13989
13990       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13991       SAVE
13992       PARAMETER ( LINP = 10 ,
13993      &            LOUT = 6 ,
13994      &            LDAT = 9 )
13995       PARAMETER (ZERO=0.0D0)
13996
13997       PARAMETER ( BTP0   = 3.7D0,
13998      &            ALPHAP = 0.24D0 )
13999
14000       IREJ   = 0
14001       NCLOOP = 0
14002       DT_TDIFF  = ZERO
14003
14004       IF (K1.GT.0) THEN
14005          XM1 = XM1I
14006          XM2 = XM2I
14007       ELSE
14008          XM1 = XM2I
14009       ENDIF
14010       XDI = (XM1/ECM)**2
14011       IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14012 * slope for single diffraction
14013          SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14014       ELSE
14015 * slope for double diffraction
14016          SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14017       ENDIF
14018
14019     1 CONTINUE
14020       NCLOOP = NCLOOP+1
14021       IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14022       Y = DT_RNDM(XDI)
14023       T = -LOG(1.0D0-Y)/SLOPE
14024       IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14025       DT_TDIFF = -ABS(T)
14026
14027       RETURN
14028
14029  9999 CONTINUE
14030       WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14031  1000 FORMAT(1X,'DT_TDIFF:   t-selection rejected!',/,
14032      &       1X,'ECM  = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14033      &       E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14034       IREJ = 1
14035       RETURN
14036       END
14037
14038 *$ CREATE DT_XVALHM.FOR
14039 *COPY DT_XVALHM
14040 *
14041 *===xvalhm=============================================================*
14042 *
14043       SUBROUTINE DT_XVALHM(KP,KT)
14044
14045 ************************************************************************
14046 * Sampling of parton x-values in high-mass diffractive interactions.   *
14047 * This version dated 12.02.95 is written by S. Roesler                 *
14048 ************************************************************************
14049
14050       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14051       SAVE
14052       PARAMETER ( LINP = 10 ,
14053      &            LOUT = 6 ,
14054      &            LDAT = 9 )
14055       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14056
14057 * kinematics of diffractive interactions (DTUNUC 1.x)
14058       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14059      &                PPF(4),PTF(4),
14060      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14061      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14062 * various options for treatment of partons (DTUNUC 1.x)
14063 * (chain recombination, Cronin,..)
14064       LOGICAL LCO2CR,LINTPT
14065       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14066      &                LCO2CR,LINTPT
14067
14068       DATA UNON,XVQTHR /2.0D0,0.8D0/
14069
14070       IF (KP.EQ.2) THEN
14071 * x-fractions of projectile valence partons
14072     1    CONTINUE
14073          XPH(1) = DT_DBETAR(OHALF,UNON)
14074          IF (XPH(1).GE.XVQTHR) GOTO 1
14075          XPH(2) = ONE-XPH(1)
14076 * x-fractions of Pomeron q-aq-pair
14077          XPOLO = TINY2
14078          XPOHI = ONE-TINY2
14079          XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14080          XPPO(2) = ONE-XPPO(1)
14081 * flavors of Pomeron q-aq-pair
14082          IFLAV    = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14083          IFPPO(1) = IFLAV
14084          IFPPO(2) = -IFLAV
14085          IF (DT_RNDM(UNON).GT.OHALF) THEN
14086             IFPPO(1) = -IFLAV
14087             IFPPO(2) = IFLAV
14088          ENDIF
14089       ENDIF
14090
14091       IF (KT.EQ.2) THEN
14092 * x-fractions of projectile target partons
14093     2    CONTINUE
14094          XTH(1) = DT_DBETAR(OHALF,UNON)
14095          IF (XTH(1).GE.XVQTHR) GOTO 2
14096          XTH(2) = ONE-XTH(1)
14097 * x-fractions of Pomeron q-aq-pair
14098          XPOLO = TINY2
14099          XPOHI = ONE-TINY2
14100          XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14101          XTPO(2) = ONE-XTPO(1)
14102 * flavors of Pomeron q-aq-pair
14103          IFLAV    = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14104          IFTPO(1) = IFLAV
14105          IFTPO(2) = -IFLAV
14106          IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14107             IFTPO(1) = -IFLAV
14108             IFTPO(2) = IFLAV
14109          ENDIF
14110       ENDIF
14111
14112       RETURN
14113       END
14114
14115 *$ CREATE DT_LM2RES.FOR
14116 *COPY DT_LM2RES
14117 *
14118 *===lm2res=============================================================*
14119 *
14120       SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14121
14122 ************************************************************************
14123 * Check low-mass diffractive excitation for resonance mass.            *
14124 *   (input)   IF1/2    PDG-indizes of valence partons                  *
14125 *   (in/out)  XM       diffractive mass requested/corrected            *
14126 *   (output)  IDR/IDXR id./BAMJET-index of resonance                   *
14127 * This version dated 12.02.95 is written by S. Roesler                 *
14128 ************************************************************************
14129
14130       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14131       SAVE
14132       PARAMETER ( LINP = 10 ,
14133      &            LOUT = 6 ,
14134      &            LDAT = 9 )
14135       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14136
14137 * kinematics of diffractive interactions (DTUNUC 1.x)
14138       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14139      &                PPF(4),PTF(4),
14140      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14141      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14142
14143       IREJ = 0
14144       IF1B = 0
14145       IF2B = 0
14146       XMI  = XM
14147
14148 * BAMJET indices of partons
14149       IF1A = IDT_IPDG2B(IF1,1,2)
14150       IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14151       IF2A = IDT_IPDG2B(IF2,1,2)
14152       IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14153
14154 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14155       IDCH = 2
14156       IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14157
14158 * check for resonance mass
14159       CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14160       IF (IREJ1.NE.0) GOTO 9999
14161
14162       XM = XMN
14163       RETURN
14164
14165  9999 CONTINUE
14166       IREJ = 1
14167       RETURN
14168       END
14169
14170 *$ CREATE DT_LMKINE.FOR
14171 *COPY DT_LMKINE
14172 *
14173 *===lmkine=============================================================*
14174 *
14175       SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14176
14177 ************************************************************************
14178 * Kinematical treatment of low-mass excitations.                       *
14179 * This version dated 12.02.95 is written by S. Roesler                 *
14180 ************************************************************************
14181
14182       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14183       SAVE
14184       PARAMETER ( LINP = 10 ,
14185      &            LOUT = 6 ,
14186      &            LDAT = 9 )
14187       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14188
14189 * flags for input different options
14190       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14191       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14192      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14193 * kinematics of diffractive interactions (DTUNUC 1.x)
14194       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14195      &                PPF(4),PTF(4),
14196      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14197      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14198
14199       DIMENSION P1(4),P2(4)
14200
14201       IREJ = 0
14202
14203       IF (KP.EQ.1) THEN
14204          PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14205          POE  = PPF(4)/PABS
14206          FAC1 = OHALF*(POE+ONE)
14207          FAC2 = -OHALF*(POE-ONE)
14208          DO 1 K=1,3
14209             PPLM1(K) = FAC1*PPF(K)
14210             PPLM2(K) = FAC2*PPF(K)
14211     1    CONTINUE
14212          PPLM1(4) = FAC1*PABS
14213          PPLM2(4) = -FAC2*PABS
14214          IF (IMSHL.EQ.1) THEN
14215             XM1 = PYMASS(IFP1)
14216             XM2 = PYMASS(IFP2)
14217             CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14218             IF (IREJ1.NE.0) GOTO 9999
14219             DO 2 K=1,4
14220                PPLM1(K) = P1(K)
14221                PPLM2(K) = P2(K)
14222     2       CONTINUE
14223          ENDIF
14224       ENDIF
14225
14226       IF (KT.EQ.1) THEN
14227          PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14228          POE  = PTF(4)/PABS
14229          FAC1 = OHALF*(POE+ONE)
14230          FAC2 = -OHALF*(POE-ONE)
14231          DO 3 K=1,3
14232             PTLM2(K) = FAC1*PTF(K)
14233             PTLM1(K) = FAC2*PTF(K)
14234     3    CONTINUE
14235          PTLM2(4) = FAC1*PABS
14236          PTLM1(4) = -FAC2*PABS
14237          IF (IMSHL.EQ.1) THEN
14238             XM1 = PYMASS(IFT1)
14239             XM2 = PYMASS(IFT2)
14240             CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14241             IF (IREJ1.NE.0) GOTO 9999
14242             DO 4 K=1,4
14243                PTLM1(K) = P1(K)
14244                PTLM2(K) = P2(K)
14245     4       CONTINUE
14246          ENDIF
14247       ENDIF
14248
14249       RETURN
14250
14251  9999 CONTINUE
14252       WRITE(LOUT,'(A)') 'LMKINE:   kinematical treatment rejected'
14253       IREJ = 1
14254       RETURN
14255       END
14256
14257 *$ CREATE DT_DIFINI.FOR
14258 *COPY DT_DIFINI
14259 *
14260 *===difini=============================================================*
14261 *
14262       SUBROUTINE DT_DIFINI
14263
14264 ************************************************************************
14265 * Initialization of common /DTDIKI/                                    *
14266 * This version dated 12.02.95 is written by S. Roesler                 *
14267 ************************************************************************
14268
14269       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14270       SAVE
14271       PARAMETER ( LINP = 10 ,
14272      &            LOUT = 6 ,
14273      &            LDAT = 9 )
14274       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14275
14276 * kinematics of diffractive interactions (DTUNUC 1.x)
14277       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14278      &                PPF(4),PTF(4),
14279      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14280      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14281
14282       DO 1 K=1,4
14283          PPOM(K)  = ZERO
14284          PSC(K)   = ZERO
14285          PPF(K)   = ZERO
14286          PTF(K)   = ZERO
14287          PPLM1(K) = ZERO
14288          PPLM2(K) = ZERO
14289          PTLM1(K) = ZERO
14290          PTLM2(K) = ZERO
14291     1 CONTINUE
14292       DO 2 K=1,2
14293          XPH(K)   = ZERO
14294          XPPO(K)  = ZERO
14295          XTH(K)   = ZERO
14296          XTPO(K)  = ZERO
14297          IFPPO(K) = 0
14298          IFTPO(K) = 0
14299     2 CONTINUE
14300       IDPR  = 0
14301       IDXPR = 0
14302       IDTR  = 0
14303       IDXTR = 0
14304
14305       RETURN
14306       END
14307
14308 *$ CREATE DT_DIFPUT.FOR
14309 *COPY DT_DIFPUT
14310 *
14311 *===difput=============================================================*
14312 *
14313       SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14314      &                                                          IREJ)
14315
14316 ************************************************************************
14317 * Dump diffractive chains into DTEVT1                                  *
14318 * This version dated 12.02.95 is written by S. Roesler                 *
14319 ************************************************************************
14320
14321       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14322       SAVE
14323       PARAMETER ( LINP = 10 ,
14324      &            LOUT = 6 ,
14325      &            LDAT = 9 )
14326       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14327
14328       LOGICAL LCHK
14329
14330 * kinematics of diffractive interactions (DTUNUC 1.x)
14331       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14332      &                PPF(4),PTF(4),
14333      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14334      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14335 * event history
14336       PARAMETER (NMXHKK=200000)
14337       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14338      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14339      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14340 * extended event history
14341       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14342      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14343      &                IHIST(2,NMXHKK)
14344 * rejection counter
14345       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14346      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14347      &                IREXCI(3),IRDIFF(2),IRINC
14348
14349       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
14350      &          P1(4),P2(4),P3(4),P4(4)
14351
14352       IREJ = 0
14353
14354       IF (KP.EQ.1) THEN
14355          DO 1 K=1,4
14356             PCH(K) = PPLM1(K)+PPLM2(K)
14357     1    CONTINUE
14358          ID1 = IFP1
14359          ID2 = IFP2
14360          IF (DT_RNDM(PT).GT.OHALF) THEN
14361             ID1 = IFP2
14362             ID2 = IFP1
14363          ENDIF
14364          CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
14365      &                                        PPLM1(4),0,0,0)
14366          CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
14367      &                                        PPLM2(4),0,0,0)
14368          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14369      &                                              IDPR,IDXPR,8)
14370       ELSEIF (KP.EQ.2) THEN
14371          DO 2 K=1,4
14372             PP1(K) = XPH(1)*PP(K)
14373             PP2(K) = XPH(2)*PP(K)
14374             PT1(K) = -XPPO(1)*PPOM(K)
14375             PT2(K) = -XPPO(2)*PPOM(K)
14376     2    CONTINUE
14377          CALL  DT_CHKCSY(IFP1,IFPPO(1),LCHK)
14378          XM1 = ZERO
14379          XM2 = ZERO
14380          IF (LCHK) THEN
14381             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14382             IF (IREJ1.NE.0) GOTO 9999
14383             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14384             IF (IREJ1.NE.0) GOTO 9999
14385             DO 3 K=1,4
14386                PP1(K) = P1(K)
14387                PT1(K) = P2(K)
14388                PP2(K) = P3(K)
14389                PT2(K) = P4(K)
14390     3       CONTINUE
14391             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14392      &                                                       0,0,8)
14393             CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14394      &                                             PT1(4),0,0,8)
14395             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14396      &                                                       0,0,8)
14397             CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14398      &                                             PT2(4),0,0,8)
14399          ELSE
14400             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14401             IF (IREJ1.NE.0) GOTO 9999
14402             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14403             IF (IREJ1.NE.0) GOTO 9999
14404             DO 4 K=1,4
14405                PP1(K) = P1(K)
14406                PT2(K) = P2(K)
14407                PP2(K) = P3(K)
14408                PT1(K) = P4(K)
14409     4       CONTINUE
14410             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14411      &                                                       0,0,8)
14412             CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14413      &                                                PT2(4),0,0,8)
14414             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14415      &                                                       0,0,8)
14416             CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14417      &                                                PT1(4),0,0,8)
14418          ENDIF
14419          NCSY = NCSY+1
14420       ELSE
14421          CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
14422      &                                                        0,0,0)
14423       ENDIF
14424
14425       IF (KT.EQ.1) THEN
14426          DO 5 K=1,4
14427             PCH(K) = PTLM1(K)+PTLM2(K)
14428     5    CONTINUE
14429          ID1 = IFT1
14430          ID2 = IFT2
14431          IF (DT_RNDM(PT).GT.OHALF) THEN
14432             ID1 = IFT2
14433             ID2 = IFT1
14434          ENDIF
14435          CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
14436      &                                              PTLM1(4),0,0,0)
14437          CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
14438      &                                              PTLM2(4),0,0,0)
14439          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14440      &                                              IDTR,IDXTR,8)
14441       ELSEIF (KT.EQ.2) THEN
14442          DO 6 K=1,4
14443             PP1(K) = XTPO(1)*PPOM(K)
14444             PP2(K) = XTPO(2)*PPOM(K)
14445             PT1(K) = XTH(2)*PT(K)
14446             PT2(K) = XTH(1)*PT(K)
14447     6    CONTINUE
14448          CALL  DT_CHKCSY(IFTPO(1),IFT1,LCHK)
14449          XM1 = ZERO
14450          XM2 = ZERO
14451          IF (LCHK) THEN
14452             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14453             IF (IREJ1.NE.0) GOTO 9999
14454             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14455             IF (IREJ1.NE.0) GOTO 9999
14456             DO 7 K=1,4
14457                PP1(K) = P1(K)
14458                PT1(K) = P2(K)
14459                PP2(K) = P3(K)
14460                PT2(K) = P4(K)
14461     7       CONTINUE
14462             CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14463      &                                                PP1(4),0,0,8)
14464             CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14465      &                                                       0,0,8)
14466             CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14467      &                                                PP2(4),0,0,8)
14468             CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14469      &                                                       0,0,8)
14470          ELSE
14471             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14472             IF (IREJ1.NE.0) GOTO 9999
14473             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14474             IF (IREJ1.NE.0) GOTO 9999
14475             DO 8 K=1,4
14476                PP1(K) = P1(K)
14477                PT2(K) = P2(K)
14478                PP2(K) = P3(K)
14479                PT1(K) = P4(K)
14480     8       CONTINUE
14481             CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14482      &                                                PP1(4),0,0,8)
14483             CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14484      &                                                       0,0,8)
14485             CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14486      &                                                PP2(4),0,0,8)
14487             CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14488      &                                                       0,0,8)
14489          ENDIF
14490          NCSY = NCSY+1
14491       ELSE
14492          CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
14493      &                                                        0,0,0)
14494       ENDIF
14495
14496       RETURN
14497
14498  9999 CONTINUE
14499       IRDIFF(2) = IRDIFF(2)+1
14500       IREJ      = 1
14501       RETURN
14502       END
14503
14504 *$ CREATE DT_EVTFRG.FOR
14505 *COPY DT_EVTFRG
14506 *
14507 *===evtfrg=============================================================*
14508 *
14509       SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
14510
14511 ************************************************************************
14512 * Hadronization of chains in DTEVT1.                                   *
14513 *                                                                      *
14514 * Input:                                                               *
14515 *   KMODE = 1   hadronization of PHOJET-chains (id=77xxx)              *
14516 *         = 2   hadronization of DTUNUC-chains (id=88xxx)              *
14517 *   NFRG  if KMODE = 1 : upper index of PHOJET-scatterings to be       *
14518 *                        hadronized with one PYEXEC call               *
14519 *         if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
14520 *                        with one PYEXEC call                          *
14521 * Output:                                                              *
14522 *   NPYMEM      number of entries in JETSET-common after hadronization *
14523 *   IREJ        rejection flag                                         *
14524 *                                                                      *
14525 * This version dated 17.09.00 is written by S. Roesler                 *
14526 ************************************************************************
14527
14528       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14529       SAVE
14530       PARAMETER ( LINP = 10 ,
14531      &            LOUT = 6 ,
14532      &            LDAT = 9 )
14533       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
14534       PARAMETER (ONE=1.0D0,ZERO=0.0D0)
14535
14536       LOGICAL LACCEP
14537
14538       PARAMETER (MXJOIN=200)
14539
14540 * event history
14541       PARAMETER (NMXHKK=200000)
14542       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14543      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14544      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14545 * extended event history
14546       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14547      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14548      &                IHIST(2,NMXHKK)
14549 * flags for input different options
14550       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14551       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14552      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14553 * statistics
14554       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
14555      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
14556      &                ICEVTG(8,0:30)
14557 * flags for diffractive interactions (DTUNUC 1.x)
14558       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14559 * nucleon-nucleon event-generator
14560       CHARACTER*8 CMODEL
14561       LOGICAL LPHOIN
14562       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
14563 * phojet
14564 C  model switches and parameters
14565       CHARACTER*8 MDLNA
14566       INTEGER ISWMDL,IPAMDL
14567       DOUBLE PRECISION PARMDL
14568       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14569 * jetset
14570       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14571       PARAMETER (MAXLND=4000)
14572       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
14573       INTEGER PYK
14574       DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
14575
14576       MODE = KMODE
14577       ISTSTG = 7
14578       IF (MODE.NE.1) ISTSTG = 8
14579       IREJ = 0
14580
14581       IP     = 0
14582       ISH    = 0
14583       INIEMC = 1
14584       NEND   = NHKK
14585       NACCEP = 0
14586       IFRG   = 0
14587       IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
14588       DO 10 I=NPOINT(3),NEND
14589 * sr 14.02.00: seems to be not necessary anymore, commented
14590 C        LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
14591 C    &            ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
14592          LACCEP = .TRUE.
14593 * pick up chains from dtevt1
14594          IDCHK = IDHKK(I)/10000
14595          IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
14596             IF (IDCHK.EQ.7) THEN
14597                IPJE = IDHKK(I)-IDCHK*10000
14598                IF (IPJE.NE.IFRG) THEN
14599                   IFRG = IPJE
14600                   IF (IFRG.GT.NFRG) GOTO 16
14601                ENDIF
14602             ELSE
14603                IPJE = 1
14604                IFRG = IFRG+1
14605                IF (IFRG.GT.NFRG) THEN
14606                   NFRG = -1
14607                   GOTO 16
14608                ENDIF
14609             ENDIF
14610 *   statistics counter
14611 c           IF (IDCH(I).LE.8)
14612 c    &         ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
14613 c           IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
14614 * special treatment for small chains already corrected to hadrons
14615             IF (IDRES(I).NE.0) THEN
14616                IF (IDRES(I).EQ.11) THEN
14617                   ID = IDXRES(I)
14618                ELSE
14619                   ID = IDT_IPDGHA(IDXRES(I))
14620                ENDIF
14621                IF (LEMCCK) THEN
14622                   CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
14623      &                              PHKK(4,I),INIEMC,IDUM,IDUM)
14624                   INIEMC = 2
14625                ENDIF
14626                IP = IP+1
14627                IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
14628                P(IP,1) = PHKK(1,I)
14629                P(IP,2) = PHKK(2,I)
14630                P(IP,3) = PHKK(3,I)
14631                P(IP,4) = PHKK(4,I)
14632                P(IP,5) = PHKK(5,I)
14633                K(IP,1) = 1
14634                K(IP,2) = ID
14635                K(IP,3) = 0
14636                K(IP,4) = 0
14637                K(IP,5) = 0
14638                IHIST(2,I) = 10000*IPJE+IP
14639                IF (IHIST(1,I).LE.-100) THEN
14640                   ISH = ISH+1
14641                   IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14642                   ISJOIN(ISH) = I
14643                ENDIF
14644                N = IP
14645                IHISMO(IP) = I
14646             ELSE
14647                IJ  = 0
14648                DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
14649                   IF (LEMCCK) THEN
14650                      CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
14651      &                                   PHKK(4,KK),INIEMC,IDUM,IDUM)
14652                      CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
14653                      INIEMC = 2
14654                   ENDIF
14655                   ID = IDHKK(KK)
14656                   IF (ID.EQ.0) ID = 21
14657 c                  PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
14658 c                  AM0  = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
14659 c                  AMRQ   = PYMASS(ID)
14660 c                  AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
14661 c                  IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
14662 c     &                (ABS(IDIFF).EQ.0)) THEN
14663 cC                    WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
14664 c                     DELTA      = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
14665 c                     PHKK(4,KK) = PHKK(4,KK)+DELTA
14666 c                     PTOT1      = PTOT-DELTA
14667 c                     PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
14668 c                     PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
14669 c                     PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
14670 c                     PHKK(5,KK) = AMRQ
14671 c                  ENDIF
14672                   IP = IP+1
14673                   IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
14674                   P(IP,1) = PHKK(1,KK)
14675                   P(IP,2) = PHKK(2,KK)
14676                   P(IP,3) = PHKK(3,KK)
14677                   P(IP,4) = PHKK(4,KK)
14678                   P(IP,5) = PHKK(5,KK)
14679                   K(IP,1) = 1
14680                   K(IP,2) = ID
14681                   K(IP,3) = 0
14682                   K(IP,4) = 0
14683                   K(IP,5) = 0
14684                   IHIST(2,KK) = 10000*IPJE+IP
14685                   IF (IHIST(1,KK).LE.-100) THEN
14686                      ISH = ISH+1
14687                      IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14688                      ISJOIN(ISH) = KK
14689                   ENDIF
14690                   IJ = IJ+1
14691                   IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
14692                   IJOIN(IJ)  = IP
14693                   IHISMO(IP) = I
14694    11          CONTINUE
14695                N = IP
14696 * join the two-parton system
14697                CALL PYJOIN(IJ,IJOIN)
14698             ENDIF
14699             IDHKK(I) = 99999
14700          ENDIF
14701    10 CONTINUE
14702    16 CONTINUE
14703       N = IP
14704
14705       IF (IP.GT.0) THEN
14706
14707 * final state parton shower
14708          DO 136 NPJE=1,IPJE
14709             IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
14710                IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
14711                   DO 130 K1=1,ISH
14712                      IF (ISJOIN(K1).EQ.0) GOTO 130
14713                      I = ISJOIN(K1)
14714                      IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
14715      &                                                       GOTO 130
14716                      IH1 = IHIST(2,I)/10000
14717                      IF (IH1.NE.NPJE) GOTO 130
14718                      IH1 = IHIST(2,I)-IH1*10000
14719                      DO 135 K2=K1+1,ISH
14720                         IF (ISJOIN(K2).EQ.0) GOTO 135
14721                         II = ISJOIN(K2)
14722                         IH2 = IHIST(2,II)/10000
14723                         IF (IH2.NE.NPJE) GOTO 135
14724                         IH2 = IHIST(2,II)-IH2*10000
14725                         IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
14726                            PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
14727                            PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
14728                            RQLUN = MIN(PT1,PT2)
14729                            CALL PYSHOW(IH1,IH2,RQLUN)
14730
14731                            ISJOIN(K1) = 0
14732                            ISJOIN(K2) = 0
14733                            GOTO 130
14734                         ENDIF
14735  135                 CONTINUE
14736  130              CONTINUE
14737                ENDIF
14738             ENDIF
14739  136     CONTINUE
14740
14741          CALL DT_INITJS(MODE)
14742 * hadronization
14743
14744          CALL PYEXEC
14745
14746          IF (MSTU(24).NE.0) THEN
14747             WRITE(LOUT,*) ' JETSET-reject at event',
14748      &                    NEVHKK,MSTU(24),KMODE
14749 C           CALL DT_EVTOUT(4)
14750
14751 C           CALL PYLIST(2)
14752
14753             GOTO 9999
14754          ENDIF
14755
14756 *   number of entries in LUJETS
14757
14758          NLINES = PYK(0,1)
14759
14760          NPYMEM = NLINES
14761
14762          DO 12 I=1,NLINES
14763             IFLG(I) = 0
14764    12    CONTINUE
14765
14766          DO 13 II=1,NLINES
14767
14768             IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
14769
14770 *  pick up mother resonance if possible and put it together with
14771 *  their decay-products into the common
14772                IDXMOR = K(II,3)
14773                IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
14774                   KFMOR = K(IDXMOR,2)
14775                   ISMOR = K(IDXMOR,1)
14776                ELSE
14777                   KFMOR = 91
14778                   ISMOR = 1
14779                ENDIF
14780                IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
14781      &             (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
14782                   ID = K(IDXMOR,2)
14783                   MO = IHISMO(PYK(IDXMOR,15))
14784                   PX = PYP(IDXMOR,1)
14785                   PY = PYP(IDXMOR,2)
14786                   PZ = PYP(IDXMOR,3)
14787                   PE = PYP(IDXMOR,4)
14788                   CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14789                   IFLG(IDXMOR) = 1
14790                   MO = NHKK
14791                   DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
14792                      IF (PYK(JDAUG,7).EQ.1) THEN
14793                         ID = PYK(JDAUG,8)
14794                         PX = PYP(JDAUG,1)
14795                         PY = PYP(JDAUG,2)
14796                         PZ = PYP(JDAUG,3)
14797                         PE = PYP(JDAUG,4)
14798                         CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14799                         IF (LEMCCK) THEN
14800                            PX = -PYP(JDAUG,1)
14801                            PY = -PYP(JDAUG,2)
14802                            PZ = -PYP(JDAUG,3)
14803                            PE = -PYP(JDAUG,4)
14804                            CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14805                         ENDIF
14806                         IFLG(JDAUG) = 1
14807                      ENDIF
14808    15             CONTINUE
14809                ELSE
14810 *  there was no mother resonance
14811                   MO = IHISMO(PYK(II,15))
14812                   ID = PYK(II,8)
14813                   PX = PYP(II,1)
14814                   PY = PYP(II,2)
14815                   PZ = PYP(II,3)
14816                   PE = PYP(II,4)
14817                   CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14818                   IF (LEMCCK) THEN
14819                      PX = -PYP(II,1)
14820                      PY = -PYP(II,2)
14821                      PZ = -PYP(II,3)
14822                      PE = -PYP(II,4)
14823                      CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14824                   ENDIF
14825                ENDIF
14826             ENDIF
14827    13    CONTINUE
14828          IF (LEMCCK) THEN
14829             CHKLEV = TINY1
14830             CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
14831 C           IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
14832          ENDIF
14833
14834 * global energy-momentum & flavor conservation check
14835 **sr 16.5. this check is skipped in case of phojet-treatment
14836          IF (MCGENE.EQ.1)
14837      &      CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
14838
14839 * update statistics-counter for diffraction
14840 c        IF (IFLAGD.NE.0) THEN
14841 c           ICDIFF(1) = ICDIFF(1)+1
14842 c           IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
14843 c           IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
14844 c           IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
14845 c           IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
14846 c        ENDIF
14847
14848       ENDIF
14849
14850       RETURN
14851
14852  9999 CONTINUE
14853       IREJ = 1
14854       RETURN
14855       END
14856
14857 *$ CREATE DT_DECAYS.FOR
14858 *COPY DT_DECAYS
14859 *
14860 *===decay==============================================================*
14861 *
14862       SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
14863
14864 ************************************************************************
14865 * Resonance-decay.                                                     *
14866 * This subroutine replaces DDECAY/DECHKK.                              *
14867 *             PIN(4)      4-momentum of resonance          (input)     *
14868 *             IDXIN       BAMJET-index of resonance        (input)     *
14869 *             POUT(20,4)  4-momenta of decay-products      (output)    *
14870 *             IDXOUT(20)  BAMJET-indices of decay-products (output)    *
14871 *             NSEC        number of secondaries            (output)    *
14872 * Adopted from the original version DECHKK.                            *
14873 * This version dated 09.01.95 is written by S. Roesler                 *
14874 ************************************************************************
14875
14876       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14877       SAVE
14878       PARAMETER ( LINP = 10 ,
14879      &            LOUT = 6 ,
14880      &            LDAT = 9 )
14881       PARAMETER (TINY17=1.0D-17)
14882
14883 * HADRIN: decay channel information
14884       PARAMETER (IDMAX9=602)
14885       CHARACTER*8 ZKNAME
14886       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
14887 * particle properties (BAMJET index convention)
14888       CHARACTER*8  ANAME
14889       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14890      &                IICH(210),IIBAR(210),K1(210),K2(210)
14891 * flags for input different options
14892       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14893       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14894      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14895
14896       DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
14897      &          EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
14898      &          CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
14899
14900 * ISTAB = 1 strong and weak decays
14901 *       = 2 strong decays only
14902 *       = 3 strong decays, weak decays for charmed particles and tau
14903 *           leptons only
14904       DATA ISTAB /2/
14905
14906       IREJ = 0
14907       NSEC = 0
14908 * put initial resonance to stack
14909       NSTK = 1
14910       IDXSTK(NSTK) = IDXIN
14911       DO 5 I=1,4
14912          PI(NSTK,I) = PIN(I)
14913     5 CONTINUE
14914
14915 * store initial configuration for energy-momentum cons. check
14916       IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
14917      &                                   PI(NSTK,4),1,IDUM,IDUM)
14918
14919   100 CONTINUE
14920 * get particle from stack
14921       IDXI = IDXSTK(NSTK)
14922 * skip stable particles
14923       IF (ISTAB.EQ.1) THEN
14924          IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
14925          IF ((IDXI.GE.  1).AND.(IDXI.LE.  7)) GOTO 10
14926       ELSEIF (ISTAB.EQ.2) THEN
14927          IF ((IDXI.GE.  1).AND.(IDXI.LE. 30)) GOTO 10
14928          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14929          IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
14930          IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
14931          IF ( IDXI.EQ.109)                    GOTO 10
14932          IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
14933       ELSEIF (ISTAB.EQ.3) THEN
14934          IF ((IDXI.GE.  1).AND.(IDXI.LE. 23)) GOTO 10
14935          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14936          IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
14937          IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
14938       ENDIF
14939
14940 * calculate direction cosines and Lorentz-parameter of decaying part.
14941       PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
14942       PTOT = MAX(PTOT,TINY17)
14943       DO 1 I=1,3
14944          DCOS(I) = PI(NSTK,I)/PTOT
14945     1 CONTINUE
14946       GAM  = PI(NSTK,4)/AAM(IDXI)
14947       BGAM = PTOT/AAM(IDXI)
14948
14949 * get decay-channel
14950       KCHAN = K1(IDXI)-1
14951     2 CONTINUE
14952       KCHAN = KCHAN+1
14953       IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
14954
14955 * identities of secondaries
14956       IDX(1) = NZK(KCHAN,1)
14957       IDX(2) = NZK(KCHAN,2)
14958       IF (IDX(2).LT.1) GOTO 9999
14959       IDX(3) = NZK(KCHAN,3)
14960
14961 * handle decay in rest system of decaying particle
14962       IF (IDX(3).EQ.0) THEN
14963 *   two-particle decay
14964          NDEC = 2
14965          CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
14966      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
14967      &               AAM(IDX(1)),AAM(IDX(2)))
14968       ELSE
14969 *   three-particle decay
14970          NDEC = 3
14971          CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
14972      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
14973      &               CODF(3),COFF(3),SIFF(3),
14974      &               AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
14975       ENDIF
14976       NSTK = NSTK-1
14977
14978 * transform decay products back
14979       DO 3 I=1,NDEC
14980          NSTK = NSTK+1
14981          CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
14982      &               CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
14983      &               PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
14984 * add particle to stack
14985          IDXSTK(NSTK) = IDX(I)
14986          DO 4 J=1,3
14987             PI(NSTK,J) = DCOSF(J)*PFF(I)
14988     4    CONTINUE
14989     3 CONTINUE
14990       GOTO 100
14991
14992    10 CONTINUE
14993 * stable particle, put to output-arrays
14994       NSEC = NSEC+1
14995       DO 6 I=1,4
14996          POUT(NSEC,I) = PI(NSTK,I)
14997     6 CONTINUE
14998       IDXOUT(NSEC) = IDXSTK(NSTK)
14999 * store secondaries for energy-momentum conservation check
15000       IF (LEMCCK)
15001      &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15002      &            -POUT(NSEC,4),2,IDUM,IDUM)
15003       NSTK = NSTK-1
15004       IF (NSTK.GT.0) GOTO 100
15005
15006 * check energy-momentum conservation
15007       IF (LEMCCK) THEN
15008          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15009          IF (IREJ1.NE.0) GOTO 9999
15010       ENDIF
15011
15012       RETURN
15013
15014  9999 CONTINUE
15015       IREJ = 1
15016       RETURN
15017       END
15018
15019 *$ CREATE DT_DECAY1.FOR
15020 *COPY DT_DECAY1
15021 *
15022 *===decay1=============================================================*
15023 *
15024       SUBROUTINE DT_DECAY1
15025
15026 ************************************************************************
15027 * Decay of resonances stored in DTEVT1.                                *
15028 * This version dated 20.01.95 is written by S. Roesler                 *
15029 ************************************************************************
15030
15031       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15032       SAVE
15033       PARAMETER ( LINP = 10 ,
15034      &            LOUT = 6 ,
15035      &            LDAT = 9 )
15036
15037 * event history
15038       PARAMETER (NMXHKK=200000)
15039       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15040      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15041      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15042 * extended event history
15043       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15044      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15045      &                IHIST(2,NMXHKK)
15046
15047       DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15048
15049       NEND = NHKK
15050 C     DO 1 I=NPOINT(5),NEND
15051       DO 1 I=NPOINT(4),NEND
15052          IF (ABS(ISTHKK(I)).EQ.1) THEN
15053             DO 2 K=1,4
15054                PIN(K) = PHKK(K,I)
15055     2       CONTINUE
15056             IDXIN = IDBAM(I)
15057             CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15058             IF (NSEC.GT.1) THEN
15059                DO 3 N=1,NSEC
15060                   IDHAD = IDT_IPDGHA(IDXOUT(N))
15061                   CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15062      &                               POUT(N,3),POUT(N,4),0,0,0)
15063     3          CONTINUE
15064             ENDIF
15065          ENDIF
15066     1 CONTINUE
15067
15068       RETURN
15069       END
15070
15071 *$ CREATE DT_DECPI0.FOR
15072 *COPY DT_DECPI0
15073 *
15074 *===decpi0=============================================================*
15075 *
15076       SUBROUTINE DT_DECPI0
15077
15078 ************************************************************************
15079 * Decay of pi0 handled with JETSET.                                    *
15080 * This version dated 18.02.96 is written by S. Roesler                 *
15081 ************************************************************************
15082
15083       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15084       SAVE
15085       PARAMETER ( LINP = 10 ,
15086      &            LOUT = 6 ,
15087      &            LDAT = 9 )
15088       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15089
15090 * event history
15091       PARAMETER (NMXHKK=200000)
15092       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15093      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15094      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15095 * extended event history
15096       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15097      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15098      &                IHIST(2,NMXHKK)
15099       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15100       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15101       PARAMETER (MAXLND=4000)
15102       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15103 * flags for input different options
15104       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15105       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15106      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15107
15108       INTEGER PYCOMP,PYK
15109
15110       DIMENSION IHISMO(NMXHKK),P1(4)
15111
15112       TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15113
15114       CALL DT_INITJS(2)
15115 * allow pi0 decay
15116       KC = PYCOMP(111)
15117       MDCY(KC,1) = 1
15118
15119       NN  = 0
15120       INI = 0
15121       DO 1 I=1,NHKK
15122          IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15123             IF (INI.EQ.0) THEN
15124                INI = 1
15125             ELSE
15126                INI = 2
15127             ENDIF
15128             IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15129      &                                    PHKK(4,I),INI,IDUM,IDUM)
15130             PT    = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15131             PTOT  = SQRT(PT**2+PHKK(3,I)**2)
15132             COSTH = PHKK(3,I)/(PTOT+TINY10)
15133             IF (COSTH.GT.ONE) THEN
15134                THETA = ZERO
15135             ELSEIF (COSTH.LT.-ONE) THEN
15136                THETA = TWOPI/2.0D0
15137             ELSE
15138                THETA = ACOS(COSTH)
15139             ENDIF
15140             PHI     = ASIN(PHKK(2,I)/(PT  +TINY10))
15141             IF (PHKK(1,I).LT.0.0D0)
15142      &         PHI  = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15143             ENER    = PHKK(4,I)
15144             NN      = NN+1
15145             KTEMP   = MSTU(10)
15146             MSTU(10)= 1
15147             P(NN,5) = PHKK(5,I)
15148             CALL PY1ENT(NN,111,ENER,THETA,PHI)
15149             MSTU(10)  = KTEMP
15150             IHISMO(NN)= I
15151          ENDIF
15152     1 CONTINUE
15153       IF (NN.GT.0) THEN
15154          CALL PYEXEC
15155          NLINES = PYK(0,1)
15156          DO 2 II=1,NLINES
15157             IF (PYK(II,7).EQ.1) THEN
15158                DO 3 KK=1,4
15159                   P1(KK) = PYP(II,KK)
15160     3          CONTINUE
15161                ID = PYK(II,8)
15162                MO = IHISMO(PYK(II,15))
15163                CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15164                IF (LEMCCK)
15165      &            CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15166      &                                            IDUM,IDUM)
15167 *sr: flag with neg. sign (for HELIOS p/A-W jobs)
15168                ISTHKK(MO) = -2
15169             ENDIF
15170     2    CONTINUE
15171          IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15172       ENDIF
15173       MDCY(KC,1) = 0
15174
15175       RETURN
15176       END
15177
15178 *$ CREATE DT_DTWOPD.FOR
15179 *COPY DT_DTWOPD
15180 *
15181 *===dtwopd=============================================================*
15182 *
15183       SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15184      &                                            COF2,SIF2,AM1,AM2)
15185
15186 ************************************************************************
15187 * Two-particle decay.                                                  *
15188 *  UMO                 cm-energy of the decaying system       (input)  *
15189 *  AM1/AM2             masses of the decay products           (input)  *
15190 *  ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15191 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15192 * Revised by S. Roesler, 20.11.95                                      *
15193 ************************************************************************
15194
15195       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15196       SAVE
15197       PARAMETER ( LINP = 10 ,
15198      &            LOUT = 6 ,
15199      &            LDAT = 9 )
15200       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15201
15202       IF (UMO.LT.(AM1+AM2)) THEN
15203          WRITE(LOUT,1000) UMO,AM1,AM2
15204  1000    FORMAT(1X,'DTWOPD:    inconsistent kinematics - UMO,AM1,AM2 ',
15205      &          3E12.3)
15206          STOP
15207       ENDIF
15208
15209       ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15210       ECM2 = UMO-ECM1
15211       PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15212       PCM2 = PCM1
15213       CALL DT_DSFECF(SIF1,COF1)
15214       COD1 = TWO*DT_RNDM(PCM2)-ONE
15215       COD2 = -COD1
15216       COF2 = -COF1
15217       SIF2 = -SIF1
15218
15219       RETURN
15220       END
15221
15222 *$ CREATE DT_DTHREP.FOR
15223 *COPY DT_DTHREP
15224 *
15225 *===dthrep=============================================================*
15226 *
15227       SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15228      &                  SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15229
15230 ************************************************************************
15231 * Three-particle decay.                                                *
15232 *  UMO                 cm-energy of the decaying system       (input)  *
15233 *  AM1/2/3             masses of the decay products           (input)  *
15234 *  ECM1/2/2,PCM1/2/3   cm-energies/momenta of the decay prod. (output) *
15235 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15236 *                                                                      *
15237 * Threpd89: slight revision by A. Ferrari                              *
15238 * Last change on   11-oct-93   by    Alfredo Ferrari, INFN - Milan     *
15239 * Revised by S. Roesler, 20.11.95                                      *
15240 ************************************************************************
15241
15242       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15243       SAVE
15244       PARAMETER ( LINP = 10 ,
15245      &            LOUT = 6 ,
15246      &            LDAT = 9 )
15247
15248       PARAMETER ( ANGLSQ = 2.5D-31 )
15249       PARAMETER ( AZRZRZ = 1.0D-30 )
15250       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
15251       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
15252       PARAMETER ( ONEONE = 1.D+00 )
15253       PARAMETER ( TWOTWO = 2.D+00 )
15254       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15255
15256       COMMON /HNGAMR/ REDU,AMO,AMM(15)
15257 * flags for input different options
15258       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15259       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15260      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15261
15262       DIMENSION F(5),XX(5)
15263       DATA EPS /AZRZRZ/
15264
15265       UMOO=UMO+UMO
15266 C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
15267 C***J. VON NEUMANN - RANDOM - SELECTION OF S2
15268 C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
15269       UUMO=UMO
15270       AAM1=AM1
15271       AAM2=AM2
15272       AAM3=AM3
15273       GU=(AM2+AM3)**2
15274       GO=(UMO-AM1)**2
15275 *     UFAK=1.0000000000001D0
15276 *     IF (GU.GT.GO) UFAK=0.9999999999999D0
15277       IF (GU.GT.GO) THEN
15278          UFAK=ONEMNS
15279       ELSE
15280          UFAK=ONEPLS
15281       END IF
15282       OFAK=2.D0-UFAK
15283       GU=GU*UFAK
15284       GO=GO*OFAK
15285       DS2=(GO-GU)/99.D0
15286       AM11=AM1*AM1
15287       AM22=AM2*AM2
15288       AM33=AM3*AM3
15289       UMO2=UMO*UMO
15290       RHO2=0.D0
15291       S22=GU
15292       DO 124 I=1,100
15293          S21=S22
15294          S22=GU+(I-1.D0)*DS2
15295          RHO1=RHO2
15296          RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
15297      *                                             (S22+EPS)
15298          IF(RHO2.LT.RHO1) GO TO 125
15299   124 CONTINUE
15300   125 S2SUP=(S22-S21)*.5D0+S21
15301       SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
15302      *                                           (S2SUP+EPS)
15303       SUPRHO=SUPRHO*1.05D0
15304       XO=S21-DS2
15305       IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
15306       IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
15307       XX(1)=XO
15308       XX(3)=S22
15309       X1=(XO+S22)*0.5D0
15310       XX(2)=X1
15311       F(3)=RHO2
15312       F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
15313       F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
15314       DO 126 I=1,16
15315          X4=(XX(1)+XX(2))*0.5D0
15316          X5=(XX(2)+XX(3))*0.5D0
15317          F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
15318      *                                               (X4+EPS)
15319          F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
15320      *                                               (X5+EPS)
15321          XX(4)=X4
15322          XX(5)=X5
15323          DO 128 II=1,5
15324             IA=II
15325             DO 128 III=IA,5
15326                IF (F (II).GE.F (III)) GO TO 128
15327                FH=F(II)
15328                F(II)=F(III)
15329                F(III)=FH
15330                FH=XX(II)
15331                XX(II)=XX(III)
15332                XX(III)=FH
15333 128      CONTINUE
15334          SUPRHO=F(1)
15335          S2SUP=XX(1)
15336          DO 129 II=1,3
15337             IA=II
15338             DO 129 III=IA,3
15339                IF (XX(II).GE.XX(III)) GO TO 129
15340                FH=F(II)
15341                F(II)=F(III)
15342                F(III)=FH
15343                FH=XX(II)
15344                XX(II)=XX(III)
15345                XX(III)=FH
15346 129      CONTINUE
15347 126   CONTINUE
15348       AM23=(AM2+AM3)**2
15349       ITH=0
15350       REDU=2.D0
15351     1 CONTINUE
15352       ITH=ITH+1
15353       IF (ITH.GT.200) REDU=-9.D0
15354       IF (ITH.GT.200) GO TO 400
15355       C=DT_RNDM(REDU)
15356 *     S2=AM23+C*((UMO-AM1)**2-AM23)
15357       S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
15358       Y=DT_RNDM(S2)
15359       Y=Y*SUPRHO
15360       RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
15361       IF(Y.GT.RHO) GO TO 1
15362 C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
15363       S1=DT_RNDM(S2)
15364       S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
15365      &RHO*.5D0
15366       S3=UMO2+AM11+AM22+AM33-S1-S2
15367       ECM1=(UMO2+AM11-S2)/UMOO
15368       ECM2=(UMO2+AM22-S3)/UMOO
15369       ECM3=(UMO2+AM33-S1)/UMOO
15370       PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
15371       PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
15372       PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
15373       CALL DT_DSFECF(SFE,CFE)
15374 C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
15375 C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
15376       PCM12 = PCM1 * PCM2
15377       IF ( PCM12 .LT. ANGLSQ ) GO TO 200
15378       COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
15379       GO TO 300
15380  200  CONTINUE
15381          UW=DT_RNDM(S1)
15382          COSTH=(UW-0.5D+00)*2.D+00
15383  300  CONTINUE
15384 *     IF(ABS(COSTH).GT.0.9999999999999999D0)
15385 *    &COSTH=SIGN(0.9999999999999999D0,COSTH)
15386       IF(ABS(COSTH).GT.ONEONE)
15387      &COSTH=SIGN(ONEONE,COSTH)
15388       IF (REDU.LT.1.D+00) RETURN
15389       COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
15390 *     IF(ABS(COSTH2).GT.0.9999999999999999D0)
15391 *    &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
15392       IF(ABS(COSTH2).GT.ONEONE)
15393      &COSTH2=SIGN(ONEONE,COSTH2)
15394       SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
15395       SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
15396       SINTH1=COSTH2*SINTH-COSTH*SINTH2
15397       COSTH1=COSTH*COSTH2+SINTH2*SINTH
15398 C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
15399 C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
15400 C***THE DIRECTION OF PARTICLE 3
15401 C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
15402       CX11=-COSTH1
15403       CY11=SINTH1*CFE
15404       CZ11=SINTH1*SFE
15405       CX22=-COSTH2
15406       CY22=-SINTH2*CFE
15407       CZ22=-SINTH2*SFE
15408       CALL DT_DSFECF(SIF3,COF3)
15409       COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
15410       SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
15411     2 FORMAT(5F20.15)
15412       COD1=CX11*COD3+CZ11*SID3
15413       CHLP=(ONEONE-COD1)*(ONEONE+COD1)
15414       IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
15415      &CX11,CZ11
15416       SID1=SQRT(CHLP)
15417       COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
15418       SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
15419       COD2=CX22*COD3+CZ22*SID3
15420       SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
15421       COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
15422       SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
15423  400  CONTINUE
15424 * === Energy conservation check: === *
15425       EOCHCK = UMO - ECM1 - ECM2 - ECM3
15426 *     SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
15427 *     SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
15428 *     SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
15429       PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
15430       PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
15431      &       + PCM3 * COF3 * SID3
15432       PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
15433      &       + PCM3 * SIF3 * SID3
15434       EOCMPR = 1.D-12 * UMO
15435       IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
15436      &     .GT. EOCMPR ) THEN
15437 **sr 5.5.95 output-unit changed
15438          IF (IOULEV(1).GT.0) THEN
15439             WRITE(LOUT,*)
15440      &      ' *** Threpd: energy/momentum conservation failure! ***',
15441      &      EOCHCK,PXCHCK,PYCHCK,PZCHCK
15442             WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
15443          ENDIF
15444 **
15445       END IF
15446       RETURN
15447       END
15448
15449 *$ CREATE DT_DBKLAS.FOR
15450 *COPY DT_DBKLAS
15451 *
15452 *===dbklas=============================================================*
15453 *
15454       SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
15455
15456       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15457       SAVE
15458       PARAMETER ( LINP = 10 ,
15459      &            LOUT = 6 ,
15460      &            LDAT = 9 )
15461
15462 * quark-content to particle index conversion (DTUNUC 1.x)
15463       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15464      &                IA08(6,21),IA10(6,21)
15465
15466       IF (I) 20,20,10
15467 * baryons
15468    10 CONTINUE
15469       CALL DT_INDEXD(J,K,IND)
15470       I8  = IB08(I,IND)
15471       I10 = IB10(I,IND)
15472       IF (I8.LE.0) I8 = I10
15473       RETURN
15474 * antibaryons
15475    20 CONTINUE
15476       II = IABS(I)
15477       JJ = IABS(J)
15478       KK = IABS(K)
15479       CALL DT_INDEXD(JJ,KK,IND)
15480       I8  = IA08(II,IND)
15481       I10 = IA10(II,IND)
15482       IF (I8.LE.0) I8 = I10
15483
15484       RETURN
15485       END
15486
15487 *$ CREATE DT_INDEXD.FOR
15488 *COPY DT_INDEXD
15489 *
15490 *===indexd=============================================================*
15491 *
15492       SUBROUTINE DT_INDEXD(KA,KB,IND)
15493
15494       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15495       SAVE
15496       PARAMETER ( LINP = 10 ,
15497      &            LOUT = 6 ,
15498      &            LDAT = 9 )
15499
15500       KP = KA*KB
15501       KS = KA+KB
15502       IF (KP.EQ.1) IND=1
15503       IF (KP.EQ.2) IND=2
15504       IF (KP.EQ.3) IND=3
15505       IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
15506       IF (KP.EQ.5) IND=5
15507       IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
15508       IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
15509       IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
15510       IF (KP.EQ.8)  IND=9
15511       IF (KP.EQ.10) IND=10
15512       IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
15513       IF (KP.EQ.9)  IND=12
15514       IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
15515       IF (KP.EQ.15) IND=14
15516       IF (KP.EQ.18) IND=15
15517       IF (KP.EQ.16) IND=16
15518       IF (KP.EQ.20) IND=17
15519       IF (KP.EQ.24) IND=18
15520       IF (KP.EQ.25) IND=19
15521       IF (KP.EQ.30) IND=20
15522       IF (KP.EQ.36) IND=21
15523
15524       RETURN
15525       END
15526
15527 *$ CREATE DT_DCHANT.FOR
15528 *COPY DT_DCHANT
15529 *
15530 *===dchant=============================================================*
15531 *
15532       SUBROUTINE DT_DCHANT
15533
15534       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15535       SAVE
15536       PARAMETER ( LINP = 10 ,
15537      &            LOUT = 6 ,
15538      &            LDAT = 9 )
15539       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15540
15541 * HADRIN: decay channel information
15542       PARAMETER (IDMAX9=602)
15543       CHARACTER*8 ZKNAME
15544       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15545 * particle properties (BAMJET index convention)
15546       CHARACTER*8  ANAME
15547       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15548      &                IICH(210),IIBAR(210),K1(210),K2(210)
15549
15550       DIMENSION HWT(IDMAX9)
15551
15552 * change of weights wt from absolut values into the sum of wt of a dec.
15553       DO 10 J=1,IDMAX9
15554          HWT(J) = ZERO
15555    10 CONTINUE
15556 C     DO 999 KKK=1,210
15557 C        WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
15558 C    &      ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
15559 C    &      K1(KKK),K2(KKK)
15560 C 999 CONTINUE
15561 C     STOP
15562       DO 30 I=1,210
15563          IK1 = K1(I)
15564          IK2 = K2(I)
15565          HV  = ZERO
15566          DO 20 J=IK1,IK2
15567             HV     = HV+WT(J)
15568             HWT(J) = HV
15569 **sr 13.1.95
15570             IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
15571  1000       FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
15572    20    CONTINUE
15573    30 CONTINUE
15574       DO 40 J=1,IDMAX9
15575          WT(J) = HWT(J)
15576    40 CONTINUE
15577
15578       RETURN
15579       END
15580
15581 *$ CREATE DT_DDATAR.FOR
15582 *COPY DT_DDATAR
15583 *
15584 *===ddatar=============================================================*
15585 *
15586       SUBROUTINE DT_DDATAR
15587
15588       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15589       SAVE
15590       PARAMETER ( LINP = 10 ,
15591      &            LOUT = 6 ,
15592      &            LDAT = 9 )
15593       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15594
15595 * quark-content to particle index conversion (DTUNUC 1.x)
15596       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15597      &                IA08(6,21),IA10(6,21)
15598
15599       DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
15600
15601       DATA IV/ 33, 34, 38,123,  0,  0, 32, 33, 39,124,
15602      &          0,  0, 36, 37, 96,127,  0,  0,126,125,
15603      &        128,129,14*0/
15604       DATA IP/ 23, 14, 16,116,  0,  0, 13, 23, 25,117,
15605      &          0,  0, 15, 24, 31,120,  0,  0,119,118,
15606      &        121,122,14*0/
15607       DATA IB/  0,  1, 21,140,  0,  0,  8, 22,137,  0,
15608      &          0, 97,138,  0,  0,146,  0,  0,  0,  0,
15609      &          0,  1,  8, 22,137,  0,  0,  0, 20,142,
15610      &          0,  0, 98,139,  0,  0,147,  0,  0,  0,
15611      &          0,  0, 21, 22, 97,138,  0,  0, 20, 98,
15612      &        139,  0,  0,  0,145,  0,  0,148,  0,  0,
15613      &          0,  0,  0,140,137,138,146,  0,  0,142,
15614      &        139,147,  0,  0,145,148,           50*0/
15615       DATA IBB/53, 54,104,161,  0,  0, 55,105,162,  0,
15616      &          0,107,164,  0,  0,167,  0,  0,  0,  0,
15617      &          0, 54, 55,105,162,  0,  0, 56,106,163,
15618      &          0,  0,108,165,  0,  0,168,  0,  0,  0,
15619      &          0,  0,104,105,107,164,  0,  0,106,108,
15620      &        165,  0,  0,109,166,  0,  0,169,  0,  0,
15621      &          0,  0,  0,161,162,164,167,  0,  0,163,
15622      &        165,168,  0,  0,166,169,  0,  0,170,47*0/
15623       DATA IA/  0,  2, 99,152,  0,  0,  9,100,149,  0,
15624      &          0,102,150,  0,  0,158,  0,  0,  0,  0,
15625      &          0,  2,  9,100,149,  0,  0,  0,101,154,
15626      &          0,  0,103,151,  0,  0,159,  0,  0,  0,
15627      &          0,  0, 99,100,102,150,  0,  0,101,103,
15628      &        151,  0,  0,  0,157,  0,  0,160,  0,  0,
15629      &          0,  0,  0,152,149,150,158,  0,  0,154,
15630      &        151,159,  0,  0,157,160,           50*0/
15631       DATA IAA/67, 68,110,171,  0,  0, 69,111,172,  0,
15632      &          0,113,174,  0,  0,177,  0,  0,  0,  0,
15633      &          0, 68, 69,111,172,  0,  0, 70,112,173,
15634      &          0,  0,114,175,  0,  0,178,  0,  0,  0,
15635      &          0,  0,110,111,113,174,  0,  0,112,114,
15636      &        175,  0,  0,115,176,  0,  0,179,  0,  0,
15637      &          0,  0,  0,171,172,174,177,  0,  0,173,
15638      &        175,178,  0,  0,176,179,  0,  0,180,47*0/
15639
15640       L=0
15641       DO 2 I=1,6
15642          DO 1 J=1,6
15643             L = L+1
15644             IMPS(I,J) = IP(L)
15645             IMVE(I,J) = IV(L)
15646     1    CONTINUE
15647     2 CONTINUE
15648       L=0
15649       DO 4 I=1,6
15650          DO 3 J=1,21
15651             L = L+1
15652             IB08(I,J) = IB(L)
15653             IB10(I,J) = IBB(L)
15654             IA08(I,J) = IA(L)
15655             IA10(I,J) = IAA(L)
15656     3    CONTINUE
15657     4 CONTINUE
15658 C     A1  = 0.88D0
15659 C     B1  = 3.0D0
15660 C     B2  = 3.0D0
15661 C     B3  = 8.0D0
15662 C     LT  = 0
15663 C     LB  = 0
15664 C     BET = 12.0D0
15665 C     AS  = 0.25D0
15666 C     B8  = 0.33D0
15667 C     AME = 0.95D0
15668 C     DIQ = 0.375D0
15669 C     ISU = 4
15670
15671       RETURN
15672       END
15673
15674 *$ CREATE DT_INITJS.FOR
15675 *COPY DT_INITJS
15676 *
15677 *===initjs=============================================================*
15678 *
15679       SUBROUTINE DT_INITJS(MODE)
15680
15681 ************************************************************************
15682 * Initialize JETSET paramters.                                         *
15683 *           MODE = 0 default settings                                  *
15684 *                = 1 PHOJET settings                                   *
15685 *                = 2 DTUNUC settings                                   *
15686 * This version dated 16.02.96 is written by S. Roesler                 *
15687 *                                                                      *
15688 * Last change 27.12.2006 by S. Roesler.                                *
15689 ************************************************************************
15690
15691       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15692       SAVE
15693       PARAMETER ( LINP = 10 ,
15694      &            LOUT = 6 ,
15695      &            LDAT = 9 )
15696       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15697
15698       LOGICAL LFIRST,LFIRDT,LFIRPH
15699
15700       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15701       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15702       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15703 * flags for particle decays
15704       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
15705      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
15706      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
15707 * flags for input different options
15708       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15709       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15710      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15711
15712       INTEGER PYCOMP
15713
15714       DIMENSION IDXSTA(40)
15715       DATA IDXSTA
15716 *          K0s   pi0  lam   alam  sig+  asig+ sig-  asig- tet0  atet0
15717      &  /  310,  111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
15718 *          tet- atet-  om-  aom-   D+    D-    D0    aD0   Ds+   aDs+
15719      &    3312,-3312, 3334,-3334,  411, -411,  421, -421,  431, -431,
15720 *          etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
15721      &     441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
15722 *         Ksic0 aKsic+aKsic0 sig0 asig0
15723      &    4132,-4232,-4132, 3212,-3212, 5*0/
15724
15725       DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
15726
15727       IF (LFIRST) THEN
15728 * save default settings
15729          PDEF1  = PARJ(1)
15730          PDEF2  = PARJ(2)
15731          PDEF3  = PARJ(3)
15732          PDEF5  = PARJ(5)
15733          PDEF6  = PARJ(6)
15734          PDEF7  = PARJ(7)
15735          PDEF18 = PARJ(18)
15736          PDEF19 = PARJ(19)
15737          PDEF21 = PARJ(21)
15738          PDEF42 = PARJ(42)
15739          MDEF12 = MSTJ(12)
15740 * LUJETS / PYJETS array-dimensions
15741          MSTU(4) = 4000
15742 * increase maximum number of JETSET-error prints
15743          MSTU(22) = 50000
15744 * prevent particles decaying
15745          DO 1 I=1,35
15746             IF (I.LT.34) THEN
15747                KC = PYCOMP(IDXSTA(I))
15748                IF (KC.GT.0) THEN
15749                   IF (I.EQ.2) THEN
15750 *  pi0 decay
15751 C                    MDCY(KC,1) = 1
15752                      MDCY(KC,1) = 0
15753 **cr mode
15754 C                 ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
15755 C   &                    (I.EQ.8).OR.(I.EQ.10)) THEN
15756 C                 ELSEIF (I.EQ.4) THEN
15757 C                    MDCY(KC,1) = 1
15758 **
15759                   ELSE
15760                      MDCY(KC,1) = 0
15761                   ENDIF
15762                ENDIF
15763             ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
15764                KC = PYCOMP(IDXSTA(I))
15765                IF (KC.GT.0) THEN
15766                   MDCY(KC,1) = 0
15767                ENDIF
15768             ENDIF
15769     1    CONTINUE
15770 *
15771 *
15772 * popcorn:
15773          IF (PDB.LE.ZERO) THEN
15774 *   no popcorn-mechanism
15775             MSTJ(12) = 1
15776          ELSE
15777             MSTJ(12) = 3
15778             PARJ(5)  = PDB
15779          ENDIF
15780 * set JETSET-parameter requested by input cards
15781          IF (NMSTU.GT.0) THEN
15782             DO 2 I=1,NMSTU
15783                MSTU(IMSTU(I)) = MSTUX(I)
15784     2       CONTINUE
15785          ENDIF
15786          IF (NMSTJ.GT.0) THEN
15787             DO 3 I=1,NMSTJ
15788                MSTJ(IMSTJ(I)) = MSTJX(I)
15789     3       CONTINUE
15790          ENDIF
15791          IF (NPARU.GT.0) THEN
15792             DO 4 I=1,NPARU
15793                PARU(IPARU(I)) = PARUX(I)
15794     4       CONTINUE
15795          ENDIF
15796          LFIRST = .FALSE.
15797       ENDIF
15798 *
15799 * PARJ(1)  suppression of qq-aqaq pair prod. compared to
15800 *          q-aq pair prod.                      (default: 0.1)
15801 * PARJ(2)  strangeness suppression               (default: 0.3)
15802 * PARJ(3)  extra suppression of strange diquarks (default: 0.4)
15803 * PARJ(6)  extra suppression of sas-pair shared by B and
15804 *          aB in BMaB                           (default: 0.5)
15805 * PARJ(7)  extra suppression of strange meson M in BMaB
15806 *          configuration                        (default: 0.5)
15807 * PARJ(18) spin 3/2 baryon suppression           (default: 1.0)
15808 * PARJ(21) width sigma in Gaussian p_x, p_y transverse
15809 *          momentum distrib. for prim. hadrons  (default: 0.35)
15810 * PARJ(42) b-parameter for symmetric Lund-fragmentation
15811 *          function                             (default: 0.9 GeV^-2)
15812 *
15813 * PHOJET settings
15814       IF (MODE.EQ.1) THEN
15815 *   JETSET default
15816 C        PARJ(1)  = PDEF1
15817 C        PARJ(2)  = PDEF2
15818 C        PARJ(3)  = PDEF3
15819 C        PARJ(6)  = PDEF6
15820 C        PARJ(7)  = PDEF7
15821 C        PARJ(18) = PDEF18
15822 C        PARJ(21) = PDEF21
15823 C        PARJ(42) = PDEF42
15824 **sr 18.11.98 parameter tuning
15825 C        PARJ(1)  = 0.092D0
15826 C        PARJ(2)  = 0.25D0
15827 C        PARJ(3)  = 0.45D0
15828 C        PARJ(19) = 0.3D0
15829 C        PARJ(21) = 0.45D0
15830 C        PARJ(42) = 1.0D0
15831 **sr 28.04.99 parameter tuning (May 99 minor modifications)
15832          PARJ(1)  = 0.085D0
15833          PARJ(2)  = 0.26D0
15834          PARJ(3)  = 0.8D0
15835          PARJ(11) = 0.38D0
15836          PARJ(18) = 0.3D0
15837          PARJ(19) = 0.4D0
15838          PARJ(21) = 0.36D0
15839          PARJ(41) = 0.3D0
15840          PARJ(42) = 0.86D0
15841          IF (NPARJ.GT.0) THEN
15842             DO 10 I=1,NPARJ
15843                IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
15844    10       CONTINUE
15845          ENDIF
15846          IF (LFIRPH) THEN
15847             WRITE(LOUT,'(1X,A)')
15848      &         'DT_INITJS: JETSET-parameter for PHOJET'
15849             CALL DT_JSPARA(0)
15850             LFIRPH = .FALSE.
15851          ENDIF
15852 * DTUNUC settings
15853       ELSEIF (MODE.EQ.2) THEN
15854          IF (IFRAG(2).EQ.1) THEN
15855 **sr parameters before 9.3.96
15856 C           PARJ(2)  = 0.27D0
15857 C           PARJ(3)  = 0.6D0
15858 C           PARJ(6)  = 0.75D0
15859 C           PARJ(7)  = 0.75D0
15860 C           PARJ(21) = 0.55D0
15861 C           PARJ(42) = 1.3D0
15862 **sr 18.11.98 parameter tuning
15863 C           PARJ(1)  = 0.05D0
15864 C           PARJ(2)  = 0.27D0
15865 C           PARJ(3)  = 0.4D0
15866 C           PARJ(19) = 0.2D0
15867 C           PARJ(21) = 0.45D0
15868 C           PARJ(42) = 1.0D0
15869 **sr 28.04.99 parameter tuning
15870             PARJ(1)  = 0.11D0
15871             PARJ(2)  = 0.36D0
15872             PARJ(3)  = 0.8D0
15873             PARJ(19) = 0.2D0
15874             PARJ(21) = 0.3D0
15875             PARJ(41) = 0.3D0
15876             PARJ(42) = 0.58D0
15877             IF (NPARJ.GT.0) THEN
15878                DO 20 I=1,NPARJ
15879                   IF (IPARJ(I).LT.0) THEN
15880                      IDX = ABS(IPARJ(I))
15881                      PARJ(IDX) = PARJX(I)
15882                   ENDIF
15883    20          CONTINUE
15884             ENDIF
15885             IF (LFIRDT) THEN
15886                WRITE(LOUT,'(1X,A)')
15887      &           'DT_INITJS: JETSET-parameter for DTUNUC'
15888                CALL DT_JSPARA(0)
15889                LFIRDT = .FALSE.
15890             ENDIF
15891          ELSEIF (IFRAG(2).EQ.2) THEN
15892             PARJ(1)  = 0.11D0
15893             PARJ(2)  = 0.27D0
15894             PARJ(3)  = 0.3D0
15895             PARJ(6)  = 0.35D0
15896             PARJ(7)  = 0.45D0
15897             PARJ(18) = 0.66D0
15898 C           PARJ(21) = 0.55D0
15899 C           PARJ(42) = 1.0D0
15900             PARJ(21) = 0.60D0
15901             PARJ(42) = 1.3D0
15902          ELSE
15903             PARJ(1)  = PDEF1
15904             PARJ(2)  = PDEF2
15905             PARJ(3)  = PDEF3
15906             PARJ(6)  = PDEF6
15907             PARJ(7)  = PDEF7
15908             PARJ(18) = PDEF18
15909             PARJ(21) = PDEF21
15910             PARJ(42) = PDEF42
15911          ENDIF
15912       ELSE
15913          PARJ(1)  = PDEF1
15914          PARJ(2)  = PDEF2
15915          PARJ(3)  = PDEF3
15916          PARJ(5)  = PDEF5
15917          PARJ(6)  = PDEF6
15918          PARJ(7)  = PDEF7
15919          PARJ(18) = PDEF18
15920          PARJ(19) = PDEF19
15921          PARJ(21) = PDEF21
15922          PARJ(42) = PDEF42
15923          MSTJ(12) = MDEF12
15924       ENDIF
15925
15926       RETURN
15927       END
15928
15929 *$ CREATE DT_JSPARA.FOR
15930 *COPY DT_JSPARA
15931 *
15932 *===jspara=============================================================*
15933 *
15934       SUBROUTINE DT_JSPARA(MODE)
15935
15936       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15937       SAVE
15938       PARAMETER ( LINP = 10 ,
15939      &            LOUT = 6 ,
15940      &            LDAT = 9 )
15941       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
15942      &           ONE=1.0D0,ZERO=0.0D0)
15943
15944       LOGICAL LFIRST
15945
15946       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15947
15948       DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
15949
15950       DATA LFIRST /.TRUE./
15951
15952 * save the default JETSET-parameter on the first call
15953       IF (LFIRST) THEN
15954          DO 1 I=1,200
15955             ISTU(I) = MSTU(I)
15956             QARU(I) = PARU(I)
15957             ISTJ(I) = MSTJ(I)
15958             QARJ(I) = PARJ(I)
15959     1    CONTINUE
15960          LFIRST = .FALSE.
15961       ENDIF
15962
15963       WRITE(LOUT,1000)
15964  1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
15965
15966 * compare the default JETSET-parameter with the present values
15967       DO 2 I=1,200
15968          IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
15969             WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
15970 C           ISTU(I) = MSTU(I)
15971          ENDIF
15972          DIFF = ABS(PARU(I)-QARU(I))
15973          IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
15974             WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
15975 C           QARU(I) = PARU(I)
15976          ENDIF
15977          IF (MSTJ(I).NE.ISTJ(I)) THEN
15978             WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
15979 C           ISTJ(I) = MSTJ(I)
15980          ENDIF
15981          DIFF = ABS(PARJ(I)-QARJ(I))
15982          IF (DIFF.GE.1.0D-5) THEN
15983             WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
15984 C           QARJ(I) = PARJ(I)
15985          ENDIF
15986     2 CONTINUE
15987  1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
15988  1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
15989
15990       RETURN
15991       END
15992
15993 *$ CREATE DT_FOZOCA.FOR
15994 *COPY DT_FOZOCA
15995 *
15996 *===fozoca=============================================================*
15997 *
15998       SUBROUTINE DT_FOZOCA(LFZC,IREJ)
15999
16000 ************************************************************************
16001 * This subroutine treats the complete FOrmation ZOne supressed intra-  *
16002 * nuclear CAscade.                                                     *
16003 *               LFZC = .true.  cascade has been treated                *
16004 *                    = .false. cascade skipped                         *
16005 * This is a completely revised version of the original FOZOKL.         *
16006 * This version dated 18.11.95 is written by S. Roesler                 *
16007 ************************************************************************
16008
16009       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16010       SAVE
16011       PARAMETER ( LINP = 10 ,
16012      &            LOUT = 6 ,
16013      &            LDAT = 9 )
16014       PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16015       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16016
16017       LOGICAL LSTART,LCAS,LFZC
16018
16019 * event history
16020       PARAMETER (NMXHKK=200000)
16021       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16022      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16023      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16024 * extended event history
16025       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16026      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16027      &                IHIST(2,NMXHKK)
16028 * rejection counter
16029       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16030      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16031      &                IREXCI(3),IRDIFF(2),IRINC
16032 * properties of interacting particles
16033       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16034 * Glauber formalism: collision properties
16035       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16036      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16037 * flags for input different options
16038       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16039       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16040      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16041 * final state after intranuclear cascade step
16042       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16043 * parameter for intranuclear cascade
16044       LOGICAL LPAULI
16045       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16046
16047       DIMENSION NCWOUN(2)
16048
16049       DATA LSTART /.TRUE./
16050
16051       LFZC = .TRUE.
16052       IREJ = 0
16053
16054 * skip cascade if hadron-hadron interaction or if supressed by user
16055       IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16056 * skip cascade if not all possible chains systems are hadronized
16057       DO 1 I=1,8
16058          IF (.NOT.LHADRO(I)) GOTO 9999
16059     1 CONTINUE
16060
16061       IF (LSTART) THEN
16062          WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16063  1000    FORMAT(/,1X,'FOZOCA:  intranuclear cascade treated for a ',
16064      &          'maximum of',I4,' generations',/,10X,'formation time ',
16065      &          'parameter:',F5.1,'  fm/c',9X,'modus:',I2)
16066          IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16067          IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16068  1001    FORMAT(10X,'p_t dependent formation zone',/)
16069  1002    FORMAT(10X,'constant formation zone',/)
16070          LSTART = .FALSE.
16071       ENDIF
16072
16073 * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16074 * which may interact with final state particles are stored in a seperate
16075 * array - here all proj./target nucleon-indices (just for simplicity)
16076       NOINC = 0
16077       DO 9 I=1,NPOINT(1)-1
16078          NOINC = NOINC+1
16079          IDXINC(NOINC) = I
16080     9 CONTINUE
16081
16082 * initialize Pauli-principle treatment (find wounded nucleons)
16083       NWOUND(1) = 0
16084       NWOUND(2) = 0
16085       NCWOUN(1) = 0
16086       NCWOUN(2) = 0
16087       DO 2 J=1,NPOINT(1)
16088          DO 3 I=1,2
16089             IF (ISTHKK(J).EQ.10+I) THEN
16090                NWOUND(I) = NWOUND(I)+1
16091                EWOUND(I,NWOUND(I)) = PHKK(4,J)
16092                IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16093             ENDIF
16094     3    CONTINUE
16095     2 CONTINUE
16096
16097 * modify nuclear potential for wounded nucleons
16098       IPRCL  = IP -NWOUND(1)
16099       IPZRCL = IPZ-NCWOUN(1)
16100       ITRCL  = IT -NWOUND(2)
16101       ITZRCL = ITZ-NCWOUN(2)
16102       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16103
16104       NSTART = NPOINT(4)
16105       NEND   = NHKK
16106
16107     7 CONTINUE
16108       DO 8 I=NSTART,NEND
16109
16110          IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16111 * select nucleus the cascade starts first (proj. - 1, target - -1)
16112             NCAS   = 1
16113 *   projectile/target with probab. 1/2
16114             IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16115                IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16116 *   in the nucleus with highest mass
16117             ELSEIF (INCMOD.EQ.2) THEN
16118                IF (IP.GT.IT) THEN
16119                   NCAS = -NCAS
16120                ELSEIF (IP.EQ.IT) THEN
16121                   IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16122                ENDIF
16123 * the nucleus the cascade starts first is requested to be the one
16124 * moving in the direction of the secondary
16125             ELSEIF (INCMOD.EQ.3) THEN
16126                NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
16127             ENDIF
16128 * check that the selected "nucleus" is not a hadron
16129             IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
16130      &          ((NCAS.EQ.-1).AND.(IT.LE.1)))    NCAS = -NCAS
16131
16132 * treat intranuclear cascade in the nucleus selected first
16133             LCAS = .FALSE.
16134             CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16135             IF (IREJ1.NE.0) GOTO 9998
16136 * treat intranuclear cascade in the other nucleus if this isn't a had.
16137             NCAS = -NCAS
16138             IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
16139      &          ((NCAS.EQ.-1).AND.(IT.GT.1)))    THEN
16140                IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16141                IF (IREJ1.NE.0) GOTO 9998
16142             ENDIF
16143
16144          ENDIF
16145
16146     8 CONTINUE
16147       NSTART = NEND+1
16148       NEND   = NHKK
16149       IF (NSTART.LE.NEND) GOTO 7
16150
16151       RETURN
16152
16153  9998 CONTINUE
16154 * reject this event
16155       IRINC = IRINC+1
16156       IREJ = 1
16157
16158  9999 CONTINUE
16159 * intranucl. cascade not treated because of interaction properties or
16160 * it is supressed by user or it was rejected or...
16161       LFZC = .FALSE.
16162 * reset flag characterizing direction of motion in n-n-cms
16163 **sr14-11-95
16164 C     DO 9990 I=NPOINT(5),NHKK
16165 C        IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
16166 C9990 CONTINUE
16167
16168       RETURN
16169       END
16170
16171 *$ CREATE DT_INUCAS.FOR
16172 *COPY DT_INUCAS
16173 *
16174 *===inucas=============================================================*
16175 *
16176       SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
16177
16178 ************************************************************************
16179 * Formation zone supressed IntraNUclear CAScade for one final state    *
16180 * particle.                                                            *
16181 *           IT, IP    mass numbers of target, projectile nuclei        *
16182 *           IDXCAS    index of final state particle in DTEVT1          *
16183 *           NCAS =  1 intranuclear cascade in projectile               *
16184 *                = -1 intranuclear cascade in target                   *
16185 * This version dated 18.11.95 is written by S. Roesler                 *
16186 ************************************************************************
16187
16188       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16189       SAVE
16190       PARAMETER ( LINP = 10 ,
16191      &            LOUT = 6 ,
16192      &            LDAT = 9 )
16193
16194       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
16195      &           OHALF=0.5D0,ONE=1.0D0)
16196       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16197       PARAMETER (TWOPI=6.283185307179586454D+00)
16198       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
16199
16200       LOGICAL LABSOR,LCAS
16201
16202 * event history
16203       PARAMETER (NMXHKK=200000)
16204       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16205      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16206      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16207 * extended event history
16208       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16209      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16210      &                IHIST(2,NMXHKK)
16211 * final state after inc step
16212       PARAMETER (MAXFSP=10)
16213       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
16214 * flags for input different options
16215       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16216       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16217      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16218 * particle properties (BAMJET index convention)
16219       CHARACTER*8  ANAME
16220       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16221      &                IICH(210),IIBAR(210),K1(210),K2(210)
16222 * Glauber formalism: collision properties
16223       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16224      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16225 * nuclear potential
16226       LOGICAL LFERMI
16227       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
16228      &                EBINDP(2),EBINDN(2),EPOT(2,210),
16229      &                ETACOU(2),ICOUL,LFERMI
16230 * parameter for intranuclear cascade
16231       LOGICAL LPAULI
16232       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16233 * final state after intranuclear cascade step
16234       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16235 * nucleon-nucleon event-generator
16236       CHARACTER*8 CMODEL
16237       LOGICAL LPHOIN
16238       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
16239 * statistics: residual nuclei
16240       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
16241      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
16242      &                NINCST(2,4),NINCEV(2),
16243      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
16244      &                NRESPB(2),NRESCH(2),NRESEV(4),
16245      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
16246      &                NEVAFI(2,2)
16247
16248       DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
16249      &          PCAS1(5),PNUC(5),BGTA(4),
16250      &          BGCAS(2),GACAS(2),BECAS(2),
16251      &          RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
16252
16253       DATA PDIF /0.545D0/
16254
16255       IREJ = 0
16256
16257 * update counter
16258       IF (NINCEV(1).NE.NEVHKK) THEN
16259          NINCEV(1) = NEVHKK
16260          NINCEV(2) = NINCEV(2)+1
16261       ENDIF
16262
16263 * "BAMJET-index" of this hadron
16264       IDCAS = IDBAM(IDXCAS)
16265       IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
16266
16267 * skip gammas, electrons, etc..
16268       IF (AAM(IDCAS).LT.TINY2) RETURN
16269
16270 * Lorentz-trsf. into projectile rest system
16271       IF (IP.GT.1) THEN
16272          CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16273      &               PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
16274      &               PCAS(1,4),IDCAS,-2)
16275          PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
16276          PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
16277          IF (PCAS(1,5).GT.ZERO) THEN
16278             PCAS(1,5) = SQRT(PCAS(1,5))
16279          ELSE
16280             PCAS(1,5) = AAM(IDCAS)
16281          ENDIF
16282          DO 20 K=1,3
16283             COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
16284    20    CONTINUE
16285 * Lorentz-parameters
16286 *   particle rest system --> projectile rest system
16287          BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
16288          GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
16289          BECAS(1) = BGCAS(1)/GACAS(1)
16290       ELSE
16291          DO 21 K=1,5
16292             PCAS(1,K) = ZERO
16293             IF (K.LE.3) COSCAS(1,K) = ZERO
16294    21    CONTINUE
16295          PTOCAS(1) = ZERO
16296          BGCAS(1)  = ZERO
16297          GACAS(1)  = ZERO
16298          BECAS(1)  = ZERO
16299       ENDIF
16300 * Lorentz-trsf. into target rest system
16301       IF (IT.GT.1) THEN
16302 * LEPTO: final state particles are already in target rest frame
16303 C        IF (MCGENE.EQ.3) THEN
16304 C           PCAS(2,1) = PHKK(1,IDXCAS)
16305 C           PCAS(2,2) = PHKK(2,IDXCAS)
16306 C           PCAS(2,3) = PHKK(3,IDXCAS)
16307 C           PCAS(2,4) = PHKK(4,IDXCAS)
16308 C        ELSE
16309             CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16310      &                  PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
16311      &                  PCAS(2,4),IDCAS,-3)
16312 C        ENDIF
16313          PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
16314          PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
16315          IF (PCAS(2,5).GT.ZERO) THEN
16316             PCAS(2,5) = SQRT(PCAS(2,5))
16317          ELSE
16318             PCAS(2,5) = AAM(IDCAS)
16319          ENDIF
16320          DO 22 K=1,3
16321             COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
16322    22    CONTINUE
16323 * Lorentz-parameters
16324 *   particle rest system --> target rest system
16325          BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
16326          GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
16327          BECAS(2) = BGCAS(2)/GACAS(2)
16328       ELSE
16329          DO 23 K=1,5
16330             PCAS(2,K) = ZERO
16331             IF (K.LE.3) COSCAS(2,K) = ZERO
16332    23    CONTINUE
16333          PTOCAS(2) = ZERO
16334          BGCAS(2)  = ZERO
16335          GACAS(2)  = ZERO
16336          BECAS(2)  = ZERO
16337       ENDIF
16338
16339 * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
16340 * potential (see CONUCL)
16341       RNUC(1)  = (RPROJ+4.605D0*PDIF)*FM2MM
16342       RNUC(2)  = (RTARG+4.605D0*PDIF)*FM2MM
16343 * impact parameter (the projectile moving along z)
16344       BIMPC(1) = ZERO
16345       BIMPC(2) = BIMPAC*FM2MM
16346
16347 * get position of initial hadron in projectile/target rest-syst.
16348       DO 3 K=1,4
16349          VTXCAS(1,K) = WHKK(K,IDXCAS)
16350          VTXCAS(2,K) = VHKK(K,IDXCAS)
16351     3 CONTINUE
16352
16353       ICAS = 1
16354       I2   = 2
16355       IF (NCAS.EQ.-1) THEN
16356          ICAS = 2
16357          I2   = 1
16358       ENDIF
16359
16360       IF (PTOCAS(ICAS).LT.TINY10) THEN
16361          WRITE(LOUT,1000) PTOCAS
16362  1000    FORMAT(1X,'INUCAS:   warning! zero momentum of initial',
16363      &          '  hadron ',/,20X,2E12.4)
16364          GOTO 9999
16365       ENDIF
16366
16367 * reset spectator flags
16368       NSPE = 0
16369       IDXSPE(1) = 0
16370       IDXSPE(2) = 0
16371       IDSPE(1)  = 0
16372       IDSPE(2)  = 0
16373
16374 * formation length (in fm)
16375 C     IF (LCAS) THEN
16376 C        DEL0 = ZERO
16377 C     ELSE
16378          DEL0 = TAUFOR*BGCAS(ICAS)
16379          IF (ITAUVE.EQ.1) THEN
16380             AMT  = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
16381             DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
16382          ENDIF
16383 C     ENDIF
16384 *   sample from exp(-del/del0)
16385       DEL1   = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
16386 * save formation time
16387       TAUSA1 = DEL1/BGCAS(ICAS)
16388       REL1   = TAUSA1*BGCAS(I2)
16389
16390       DEL    = DEL1
16391       TAUSAM = DEL/BGCAS(ICAS)
16392       REL    = TAUSAM*BGCAS(I2)
16393
16394 * special treatment for negative particles unable to escape
16395 * nuclear potential (implemented for ap, pi-, K- only)
16396       LABSOR = .FALSE.
16397       IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
16398 *   threshold energy = nuclear potential + Coulomb potential
16399 *   (nuclear potential for hadron-nucleus interactions only)
16400          ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
16401          IF (PCAS(ICAS,4).LT.ETHR) THEN
16402             DO 4 K=1,5
16403                PCAS1(K) = PCAS(ICAS,K)
16404     4       CONTINUE
16405 *   "absorb" negative particle in nucleus
16406             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
16407             IF (IREJ1.NE.0) GOTO 9999
16408             IF (NSPE.GE.1) LABSOR = .TRUE.
16409          ENDIF
16410       ENDIF
16411
16412 * if the initial particle has not been absorbed proceed with
16413 * "normal" cascade
16414       IF (.NOT.LABSOR) THEN
16415
16416 *   calculate coordinates of hadron at the end of the formation zone
16417 *   transport-time and -step in the rest system where this step is
16418 *   treated
16419          DSTEP  = DEL*FM2MM
16420          DTIME  = DSTEP/BECAS(ICAS)
16421          RSTEP  = REL*FM2MM
16422          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16423             RTIME = RSTEP/BECAS(I2)
16424          ELSE
16425             RTIME = ZERO
16426          ENDIF
16427 *   save step whithout considering the overlapping region
16428          DSTEP1 = DEL1*FM2MM
16429          DTIME1 = DSTEP1/BECAS(ICAS)
16430          RSTEP1 = REL1*FM2MM
16431          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16432             RTIME1 = RSTEP1/BECAS(I2)
16433          ELSE
16434             RTIME1 = ZERO
16435          ENDIF
16436 *   transport to the end of the formation zone in this system
16437          DO 5 K=1,3
16438             VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
16439             VTXCA1(I2,K)   = VTXCAS(I2,K)  +RSTEP1*COSCAS(I2,K)
16440             VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
16441             VTXCAS(I2,K)   = VTXCAS(I2,K)  +RSTEP*COSCAS(I2,K)
16442     5    CONTINUE
16443          VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
16444          VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME1
16445          VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16446          VTXCAS(I2,4)   = VTXCAS(I2,4)  +RTIME
16447
16448          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16449             XCAS   = VTXCAS(ICAS,1)
16450             YCAS   = VTXCAS(ICAS,2)
16451             XNCLTA = BIMPAC*FM2MM
16452             RNCLPR = (RPROJ+RNUCLE)*FM2MM
16453             RNCLTA = (RTARG+RNUCLE)*FM2MM
16454 C           RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
16455 C           RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
16456 C           RNCLPR = (RPROJ)*FM2MM
16457 C           RNCLTA = (RTARG)*FM2MM
16458             RCASPR = SQRT( XCAS**2        +YCAS**2)
16459             RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
16460             IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
16461                IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
16462             ENDIF
16463          ENDIF
16464
16465 *   check if particle is already outside of the corresp. nucleus
16466          RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
16467      &                VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
16468          IF (RDIST.GE.RNUC(ICAS)) THEN
16469 *   here: IDCH is the generation of the final state part. starting
16470 *   with zero for hadronization products
16471 *   flag particles of generation 0 being outside the nuclei after
16472 *   formation time (to be used for excitation energy calculation)
16473             IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
16474      &         NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
16475             GOTO 9997
16476          ENDIF
16477          DIST   = DLARGE
16478          DISTP  = DLARGE
16479          DISTN  = DLARGE
16480          IDXP   = 0
16481          IDXN   = 0
16482
16483 *   already here: skip particles being outside HADRIN "energy-window"
16484 *   to avoid wasting of time
16485          NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
16486          IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
16487             NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
16488 C           WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
16489 C1002       FORMAT(1X,'INUCAS:   warning! momentum of particle with ',
16490 C    &             'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
16491 C    &             E12.4,', above or below HADRIN-thresholds',I6)
16492             NSPE = 0
16493             GOTO 9997
16494          ENDIF
16495
16496          DO 7 IDXHKK=1,NOINC
16497             I = IDXINC(IDXHKK)
16498 *   scan DTEVT1 for unwounded or excited nucleons
16499             IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
16500                DO 8 K=1,3
16501                   IF (ICAS.EQ.1) THEN
16502                      VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
16503                   ELSEIF (ICAS.EQ.2) THEN
16504                      VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
16505                   ENDIF
16506     8          CONTINUE
16507                POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
16508      &                  VTXDST(2)*COSCAS(ICAS,2)+
16509      &                  VTXDST(3)*COSCAS(ICAS,3)
16510 *   check if nucleon is situated in forward direction
16511                IF (POSNUC.GT.ZERO) THEN
16512 *   distance between hadron and this nucleon
16513                   DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16514      &                          VTXDST(3)**2)
16515 *   impact parameter
16516                   BIMNU2 = DISTNU**2-POSNUC**2
16517                   IF (BIMNU2.LT.ZERO) THEN
16518                      WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
16519  1001                FORMAT(1X,'INUCAS:   warning! inconsistent impact',
16520      &                      '  parameter ',/,20X,3E12.4)
16521                      GOTO 7
16522                   ENDIF
16523                   BIMNU  = SQRT(BIMNU2)
16524 *   maximum impact parameter to have interaction
16525                   IDNUC  = IDT_ICIHAD(IDHKK(I))
16526                   IDNUC1 = IDT_MCHAD(IDNUC)
16527                   IDCAS1 = IDT_MCHAD(IDCAS)
16528                   DO 19 K=1,5
16529                      PCAS1(K) = PCAS(ICAS,K)
16530                      PNUC(K)  = PHKK(K,I)
16531    19             CONTINUE
16532 * Lorentz-parameter for trafo into rest-system of target
16533                   DO 18 K=1,4
16534                      BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
16535    18             CONTINUE
16536 * transformation of projectile into rest-system of target
16537                   CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
16538      &                        PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
16539      &                        PPTOT,PX,PY,PZ,PE)
16540 **
16541 C                 CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
16542 C                 CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
16543                   DUMZER = ZERO
16544                   CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
16545                   CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
16546                   IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
16547      &                (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
16548                   SIGIN = SIGTOT-SIGEL-SIGAB
16549 C                 SIGTOT = SIGIN+SIGEL+SIGAB
16550 **
16551                   BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
16552 *   check if interaction is possible
16553                   IF (BIMNU.LE.BIMMAX) THEN
16554 *   get nucleon with smallest distance and kind of interaction
16555 *   (elastic/inelastic)
16556                      IF (DISTNU.LT.DIST) THEN
16557                         DIST      = DISTNU
16558                         BINT      = BIMNU
16559                         IF (IDNUC.NE.IDSPE(1)) THEN
16560                            IDSPE(2)  = IDSPE(1)
16561                            IDXSPE(2) = IDXSPE(1)
16562                            IDSPE(1)  = IDNUC
16563                         ENDIF
16564                         IDXSPE(1) = I
16565                         NSPE      = 1
16566 **sr
16567                         SELA = SIGEL
16568                         SABS = SIGAB
16569                         STOT = SIGTOT
16570 C                       IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
16571 C                          SELA = SIGEL
16572 C                          STOT = SIGIN+SIGEL
16573 C                       ELSE
16574 C                          SELA = SIGEL+0.75D0*SIGIN
16575 C                          STOT = 0.25D0*SIGIN+SELA
16576 C                       ENDIF
16577 **
16578                      ENDIF
16579                   ENDIf
16580                ENDIF
16581                DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16582      &                       VTXDST(3)**2)
16583                IDNUC  = IDT_ICIHAD(IDHKK(I))
16584                IF (IDNUC.EQ.1) THEN
16585                   IF (DISTNU.LT.DISTP) THEN
16586                      DISTP = DISTNU
16587                      IDXP  = I
16588                      POSP  = POSNUC
16589                   ENDIF
16590                ELSEIF (IDNUC.EQ.8) THEN
16591                   IF (DISTNU.LT.DISTN) THEN
16592                      DISTN = DISTNU
16593                      IDXN  = I
16594                      POSN  = POSNUC
16595                   ENDIF
16596                ENDIF
16597             ENDIF
16598     7    CONTINUE
16599
16600 * there is no nucleon for a secondary interaction
16601          IF (NSPE.EQ.0) GOTO 9997
16602
16603 C        IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
16604 C    &      WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
16605          IF (IDXSPE(2).EQ.0) THEN
16606             IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
16607 C              DO 80 K=1,3
16608 C                 IF (ICAS.EQ.1) THEN
16609 C                    VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
16610 C                 ELSEIF (ICAS.EQ.2) THEN
16611 C                    VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
16612 C                 ENDIF
16613 C  80          CONTINUE
16614 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16615 C    &                       VTXDST(3)**2)
16616 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
16617                   IDXSPE(2) = IDXN
16618                   IDSPE(2)  = 8
16619 C              ELSE
16620 C                 STOT = STOT-SABS
16621 C                 SABS = ZERO
16622 C              ENDIF
16623             ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
16624 C              DO 81 K=1,3
16625 C                 IF (ICAS.EQ.1) THEN
16626 C                    VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
16627 C                 ELSEIF (ICAS.EQ.2) THEN
16628 C                    VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
16629 C                 ENDIF
16630 C  81          CONTINUE
16631 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16632 C    &                       VTXDST(3)**2)
16633 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
16634                   IDXSPE(2) = IDXP
16635                   IDSPE(2)  = 1
16636 C              ELSE
16637 C                 STOT = STOT-SABS
16638 C                 SABS = ZERO
16639 C              ENDIF
16640             ELSE
16641                STOT = STOT-SABS
16642                SABS = ZERO
16643             ENDIF
16644          ENDIF
16645          RR = DT_RNDM(DIST)
16646          IF (RR.LT.SELA/STOT) THEN
16647             IPROC = 2
16648          ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
16649             IPROC = 3
16650          ELSE
16651             IPROC = 1
16652          ENDIF
16653
16654          DO 9 K=1,5
16655             PCAS1(K) = PCAS(ICAS,K)
16656             PNUC(K)  = PHKK(K,IDXSPE(1))
16657     9    CONTINUE
16658          IF (IPROC.EQ.3) THEN
16659 * 2-nucleon absorption of pion
16660             NSPE = 2
16661             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
16662             IF (IREJ1.NE.0) GOTO 9999
16663             IF (NSPE.GE.1) LABSOR = .TRUE.
16664          ELSE
16665 * sample secondary interaction
16666             IDNUC = IDBAM(IDXSPE(1))
16667             CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
16668             IF (IREJ1.EQ.1) GOTO 9999
16669             IF (IREJ1.GT.1) GOTO 9998
16670          ENDIF
16671       ENDIF
16672
16673 * update arrays to include Pauli-principle
16674       DO 10 I=1,NSPE
16675          IF (NWOUND(ICAS).LE.299) THEN
16676             NWOUND(ICAS) = NWOUND(ICAS)+1
16677             EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
16678          ENDIF
16679    10 CONTINUE
16680
16681 * dump initial hadron for energy-momentum conservation check
16682       IF (LEMCCK)
16683      &   CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
16684      &               PCAS(ICAS,4),1,IDUM,IDUM)
16685
16686 * dump final state particles into DTEVT1
16687
16688 *   check if Pauli-principle is fulfilled
16689       NPAULI = 0
16690       NWTMP(1) = NWOUND(1)
16691       NWTMP(2) = NWOUND(2)
16692       DO 111 I=1,NFSP
16693          NPAULI = 0
16694          J1 = 2
16695          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16696      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
16697          DO 117 J=1,J1
16698             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
16699             IF (J.EQ.1) THEN
16700                IDX = ICAS
16701                PE  = PFSP(4,I)
16702             ELSE
16703                IDX  = I2
16704                MODE = 1
16705                IF (IDX.EQ.1) MODE = -1
16706                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
16707             ENDIF
16708 * first check if cascade step is forbidden due to Pauli-principle
16709 * (in case of absorpion this step is forced)
16710             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16711      &          (IDFSP(I).EQ.8))) THEN
16712 *   get nuclear potential barrier
16713                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16714                IF (IDFSP(I).EQ.1) THEN
16715                   POTLOW = POT-EBINDP(IDX)
16716                ELSE
16717                   POTLOW = POT-EBINDN(IDX)
16718                ENDIF
16719 *   final state particle not able to escape nucleus
16720                IF (PE.LE.POTLOW) THEN
16721 *     check if there are wounded nucleons
16722                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16723      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
16724                      NPAULI      = NPAULI+1
16725                      NWOUND(IDX) = NWOUND(IDX)-1
16726                   ELSE
16727 *     interaction prohibited by Pauli-principle
16728                      NWOUND(1) = NWTMP(1)
16729                      NWOUND(2) = NWTMP(2)
16730                      GOTO 9997
16731                   ENDIF
16732                ENDIF
16733             ENDIF
16734   117    CONTINUE
16735   111 CONTINUE
16736
16737       NPAULI = 0
16738       NWOUND(1) = NWTMP(1)
16739       NWOUND(2) = NWTMP(2)
16740
16741       DO 11 I=1,NFSP
16742
16743          IST = ISTHKK(IDXCAS)
16744
16745          NPAULI = 0
16746          J1 = 2
16747          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16748      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
16749          DO 17 J=1,J1
16750             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
16751             IDX = ICAS
16752             PE  = PFSP(4,I)
16753             IF (J.EQ.2) THEN
16754                IDX = I2
16755                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
16756             ENDIF
16757 * first check if cascade step is forbidden due to Pauli-principle
16758 * (in case of absorpion this step is forced)
16759             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16760      &          (IDFSP(I).EQ.8))) THEN
16761 *   get nuclear potential barrier
16762                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16763                IF (IDFSP(I).EQ.1) THEN
16764                   POTLOW = POT-EBINDP(IDX)
16765                ELSE
16766                   POTLOW = POT-EBINDN(IDX)
16767                ENDIF
16768 *   final state particle not able to escape nucleus
16769                IF (PE.LE.POTLOW) THEN
16770 *     check if there are wounded nucleons
16771                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16772      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
16773                      NWOUND(IDX) = NWOUND(IDX)-1
16774                      NPAULI = NPAULI+1
16775                      IST    = 14+IDX
16776                   ELSE
16777 *     interaction prohibited by Pauli-principle
16778                      NWOUND(1) = NWTMP(1)
16779                      NWOUND(2) = NWTMP(2)
16780                      GOTO 9997
16781                   ENDIF
16782 **sr
16783 c               ELSEIF (PE.LE.POT) THEN
16784 cC              ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
16785 cC                 NWOUND(IDX) = NWOUND(IDX)-1
16786 c**
16787 c                  NPAULI = NPAULI+1
16788 c                  IST    = 14+IDX
16789                ENDIF
16790             ENDIF
16791    17    CONTINUE
16792
16793 * dump final state particles for energy-momentum conservation check
16794          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
16795      &                           -PFSP(4,I),2,IDUM,IDUM)
16796
16797          PX = PFSP(1,I)
16798          PY = PFSP(2,I)
16799          PZ = PFSP(3,I)
16800          PE = PFSP(4,I)
16801          IF (ABS(IST).EQ.1) THEN
16802 * transform particles back into n-n cms
16803 * LEPTO: leave final state particles in target rest frame
16804 C           IF (MCGENE.EQ.3) THEN
16805 C              PFSP(1,I) = PX
16806 C              PFSP(2,I) = PY
16807 C              PFSP(3,I) = PZ
16808 C              PFSP(4,I) = PE
16809 C           ELSE
16810                IMODE = ICAS+1
16811                CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16812      &                     PFSP(4,I),IDFSP(I),IMODE)
16813 C           ENDIF
16814          ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
16815 * target cascade but fsp got stuck in proj. --> transform it into
16816 * proj. rest system
16817             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16818      &                  PFSP(4,I),IDFSP(I),-1)
16819          ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
16820 * proj. cascade but fsp got stuck in target --> transform it into
16821 * target rest system
16822             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16823      &                  PFSP(4,I),IDFSP(I),1)
16824          ENDIF
16825
16826 * dump final state particles into DTEVT1
16827          IGEN = IDCH(IDXCAS)+1
16828          ID   = IDT_IPDGHA(IDFSP(I))
16829          IXR  = 0
16830          IF (LABSOR) IXR = 99
16831          CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
16832      &               PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
16833
16834 * update the counter for particles which got stuck inside the nucleus
16835          IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
16836             NOINC = NOINC+1
16837             IDXINC(NOINC) = NHKK
16838          ENDIF
16839          IF (LABSOR) THEN
16840 *   in case of absorption the spatial treatment is an approximate
16841 *   solution anyway (the positions of the nucleons which "absorb" the
16842 *   cascade particle are not taken into consideration) therefore the
16843 *   particles are produced at the position of the cascade particle
16844             DO 12 K=1,4
16845                WHKK(K,NHKK) = WHKK(K,IDXCAS)
16846                VHKK(K,NHKK) = VHKK(K,IDXCAS)
16847    12       CONTINUE
16848          ELSE
16849 *   DDISTL - distance the cascade particle moves to the intera. point
16850 *   (the position where impact-parameter = distance to the interacting
16851 *   nucleon), DIST - distance to the interacting nucleon at the time of
16852 *   formation of the cascade particle, BINT - impact-parameter of this
16853 *   cascade-interaction
16854             DDISTL = SQRT(DIST**2-BINT**2)
16855             DTIME  = DDISTL/BECAS(ICAS)
16856             DTIMEL = DDISTL/BGCAS(ICAS)
16857             RDISTL = DTIMEL*BGCAS(I2)
16858             IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16859                RTIME = RDISTL/BECAS(I2)
16860             ELSE
16861                RTIME = ZERO
16862             ENDIF
16863 *   RDISTL, RTIME are this step and time in the rest system of the other
16864 *   nucleus
16865             DO 13 K=1,3
16866                VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
16867                VTXCA1(I2,K)   = VTXCAS(I2,K)  +COSCAS(I2,K)  *RDISTL
16868    13       CONTINUE
16869             VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16870             VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME
16871 *   position of particle production is half the impact-parameter to
16872 *   the interacting nucleon
16873             DO 14 K=1,3
16874                WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
16875                VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
16876    14       CONTINUE
16877 *   time of production of secondary = time of interaction
16878             WHKK(4,NHKK) = VTXCA1(1,4)
16879             VHKK(4,NHKK) = VTXCA1(2,4)
16880          ENDIF
16881
16882    11 CONTINUE
16883
16884 * modify status and position of cascade particle (the latter for
16885 * statistics reasons only)
16886       ISTHKK(IDXCAS) = 2
16887       IF (LABSOR) ISTHKK(IDXCAS) = 19
16888       IF (.NOT.LABSOR) THEN
16889          DO 15 K=1,4
16890             WHKK(K,IDXCAS) = VTXCA1(1,K)
16891             VHKK(K,IDXCAS) = VTXCA1(2,K)
16892    15    CONTINUE
16893       ENDIF
16894
16895       DO 16 I=1,NSPE
16896          IS = IDXSPE(I)
16897 * dump interacting nucleons for energy-momentum conservation check
16898          IF (LEMCCK)
16899      &      CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
16900      &                                                  2,IDUM,IDUM)
16901 * modify entry for interacting nucleons
16902          IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
16903          IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
16904          IF (I.GE.2) THEN
16905             JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
16906             JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
16907          ENDIF
16908    16 CONTINUE
16909
16910 * check energy-momentum conservation
16911       IF (LEMCCK) THEN
16912          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
16913          IF (IREJ1.NE.0) GOTO 9999
16914       ENDIF
16915
16916 * update counter
16917       IF (LABSOR) THEN
16918          NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
16919       ELSE
16920          IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
16921          IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
16922       ENDIF
16923
16924       RETURN
16925
16926  9997 CONTINUE
16927  9998 CONTINUE
16928 * transport-step but no cascade step due to configuration (i.e. there
16929 * is no nucleon for interaction etc.)
16930       IF (LCAS) THEN
16931          DO 100 K=1,4
16932 C           WHKK(K,IDXCAS) = VTXCAS(1,K)
16933 C           VHKK(K,IDXCAS) = VTXCAS(2,K)
16934             WHKK(K,IDXCAS) = VTXCA1(1,K)
16935             VHKK(K,IDXCAS) = VTXCA1(2,K)
16936   100    CONTINUE
16937       ENDIF
16938
16939 C9998 CONTINUE
16940 * no cascade-step because of configuration
16941 * (i.e. hadron outside nucleus etc.)
16942       LCAS = .TRUE.
16943       RETURN
16944
16945  9999 CONTINUE
16946 * rejection
16947       IREJ = 1
16948       RETURN
16949       END
16950
16951 *$ CREATE DT_ABSORP.FOR
16952 *COPY DT_ABSORP
16953 *
16954 *===absorp=============================================================*
16955 *
16956       SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
16957
16958 ************************************************************************
16959 * Two-nucleon absorption of antiprotons, pi-, and K-.                  *
16960 * Antiproton absorption is handled by HADRIN.                          *
16961 * The following channels for meson-absorption are considered:          *
16962 *          pi- + p + p ---> n + p                                      *
16963 *          pi- + p + n ---> n + n                                      *
16964 *          K-  + p + p ---> sigma+ + n / Lam + p / sigma0 + p          *
16965 *          K-  + p + n ---> sigma- + n / Lam + n / sigma0 + n          *
16966 *          K-  + p + p ---> sigma- + n                                 *
16967 *      IDCAS, PCAS   identity, momentum of particle to be absorbed     *
16968 *      NCAS =  1     intranuclear cascade in projectile                *
16969 *           = -1     intranuclear cascade in target                    *
16970 *      NSPE          number of spectator nucleons involved             *
16971 *      IDXSPE(2)     DTEVT1-indices of spectator nucleons involved     *
16972 * Revised version of the original STOPIK written by HJM and J. Ranft.  *
16973 * This version dated 24.02.95 is written by S. Roesler                 *
16974 ************************************************************************
16975
16976       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16977       SAVE
16978       PARAMETER ( LINP = 10 ,
16979      &            LOUT = 6 ,
16980      &            LDAT = 9 )
16981       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
16982      &           ONETHI=0.3333D0,TWOTHI=0.6666D0)
16983
16984 * event history
16985       PARAMETER (NMXHKK=200000)
16986       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16987      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16988      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16989 * extended event history
16990       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16991      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16992      &                IHIST(2,NMXHKK)
16993 * flags for input different options
16994       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16995       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16996      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16997 * final state after inc step
16998       PARAMETER (MAXFSP=10)
16999       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17000 * particle properties (BAMJET index convention)
17001       CHARACTER*8  ANAME
17002       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17003      &                IICH(210),IIBAR(210),K1(210),K2(210)
17004
17005       DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17006      &          PTOT3P(4),BG3P(4),
17007      &          ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17008
17009       IREJ = 0
17010       NFSP = 0
17011
17012 * skip particles others than ap, pi-, K- for mode=0
17013       IF ((MODE.EQ.0).AND.
17014      &    (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17015 * skip particles others than pions for mode=1
17016 * (2-nucleon absorption in intranuclear cascade)
17017       IF ((MODE.EQ.1).AND.
17018      &    (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17019
17020       NUCAS = NCAS
17021       IF (NUCAS.EQ.-1) NUCAS = 2
17022
17023       IF (MODE.EQ.0) THEN
17024 * scan spectator nucleons for nucleons being able to "absorb"
17025          NSPE      = 0
17026          IDXSPE(1) = 0
17027          IDXSPE(2) = 0
17028          DO 1 I=1,NHKK
17029             IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17030                NSPE         = NSPE+1
17031                IDXSPE(NSPE) = I
17032                IDSPE(NSPE)  = IDBAM(I)
17033                IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17034                IF (NSPE.EQ.2) THEN
17035                   IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17036      &                                  (IDSPE(2).EQ.8)) THEN
17037 *    there is no pi-+n+n channel
17038                      NSPE = 1
17039                      GOTO 1
17040                   ELSE
17041                      GOTO 2
17042                   ENDIF
17043                ENDIF
17044             ENDIF
17045     1    CONTINUE
17046
17047     2    CONTINUE
17048       ENDIF
17049 * transform excited projectile nucleons (status=15) into proj. rest s.
17050       DO 3 I=1,NSPE
17051          DO 4 K=1,5
17052             PSPE(I,K) = PHKK(K,IDXSPE(I))
17053     4    CONTINUE
17054     3 CONTINUE
17055
17056 * antiproton absorption
17057       IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17058          DO 5 K=1,5
17059             PSPE1(K) = PSPE(1,K)
17060     5    CONTINUE
17061          CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17062          IF (IREJ1.NE.0) GOTO 9999
17063
17064 * meson absorption
17065       ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17066      &                      .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17067          IF (IDCAS.EQ.14) THEN
17068 *   pi- absorption
17069             IDFSP(1) = 8
17070             IDFSP(2) = 8
17071             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17072          ELSEIF (IDCAS.EQ.13) THEN
17073 *   pi+ absorption
17074             IDFSP(1) = 1
17075             IDFSP(2) = 1
17076             IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17077          ELSEIF (IDCAS.EQ.23) THEN
17078 *   pi0 absorption
17079             IDFSP(1) = IDSPE(1)
17080             IDFSP(2) = IDSPE(2)
17081          ELSEIF (IDCAS.EQ.16) THEN
17082 *   K- absorption
17083             R = DT_RNDM(PCAS)
17084             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17085                IF (R.LT.ONETHI) THEN
17086                   IDFSP(1) = 21
17087                   IDFSP(2) = 8
17088                ELSEIF (R.LT.TWOTHI) THEN
17089                   IDFSP(1) = 17
17090                   IDFSP(2) = 1
17091                ELSE
17092                   IDFSP(1) = 22
17093                   IDFSP(2) = 1
17094                ENDIF
17095             ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17096                IDFSP(1) = 20
17097                IDFSP(2) = 8
17098             ELSE
17099                IF (R.LT.ONETHI) THEN
17100                   IDFSP(1) = 20
17101                   IDFSP(2) = 1
17102                ELSEIF (R.LT.TWOTHI) THEN
17103                   IDFSP(1) = 17
17104                   IDFSP(2) = 8
17105                ELSE
17106                   IDFSP(1) = 22
17107                   IDFSP(2) = 8
17108                ENDIF
17109             ENDIF
17110          ENDIF
17111 *   dump initial particles for energy-momentum cons. check
17112          IF (LEMCCK) THEN
17113             CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
17114             CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
17115      &                                                    IDUM,IDUM)
17116             CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
17117      &                                                    IDUM,IDUM)
17118          ENDIF
17119 *   get Lorentz-parameter of 3 particle initial state
17120          DO 6 K=1,4
17121             PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
17122     6    CONTINUE
17123          P3P  = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
17124          AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
17125          DO 7 K=1,4
17126             BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
17127     7    CONTINUE
17128 *   2-particle decay of the 3-particle compound system
17129          CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
17130      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
17131      &               AAM(IDFSP(1)),AAM(IDFSP(2)))
17132          DO 8 I=1,2
17133             SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
17134             PX  = PCMF(I)*COFF(I)*SDF
17135             PY  = PCMF(I)*SIFF(I)*SDF
17136             PZ  = PCMF(I)*CODF(I)
17137             CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
17138      &                  ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17139      &                  PFSP(4,I))
17140             PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
17141 *   check consistency of kinematics
17142             IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
17143                WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
17144  1001          FORMAT(1X,'ABSORP:   warning! inconsistent',
17145      &                ' tree-particle kinematics',/,20X,'id: ',I3,
17146      &                ' AAM = ',E10.4,' MFSP = ',E10.4)
17147             ENDIF
17148 *   dump final state particles for energy-momentum cons. check
17149             IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17150      &                              -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17151     8    CONTINUE
17152          NFSP = 2
17153          IF (LEMCCK) THEN
17154             CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
17155             IF (IREJ1.NE.0) THEN
17156                WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
17157      &                      AM3P
17158                GOTO 9999
17159             ENDIF
17160          ENDIF
17161       ELSE
17162          IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
17163  1000    FORMAT(1X,'ABSORP:   warning! absorption for particle ',I3,
17164      &          ' impossible',/,20X,'too few spectators (',I2,')')
17165          NSPE = 0
17166       ENDIF
17167
17168       RETURN
17169
17170  9999 CONTINUE
17171       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
17172       IREJ = 1
17173       RETURN
17174       END
17175
17176 *$ CREATE DT_HADRIN.FOR
17177 *COPY DT_HADRIN
17178 *
17179 *===hadrin=============================================================*
17180 *
17181       SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
17182
17183 ************************************************************************
17184 * Interface to the HADRIN-routines for inelastic and elastic           *
17185 * scattering.                                                          *
17186 *      IDPR,PPR(5)   identity, momentum of projectile                  *
17187 *      IDTA,PTA(5)   identity, momentum of target                      *
17188 *      MODE  = 1     inelastic interaction                             *
17189 *            = 2     elastic   interaction                             *
17190 * Revised version of the original FHAD.                                *
17191 * This version dated 27.10.95 is written by S. Roesler                 *
17192 ************************************************************************
17193
17194       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17195       SAVE
17196       PARAMETER ( LINP = 10 ,
17197      &            LOUT = 6 ,
17198      &            LDAT = 9 )
17199       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
17200      &           TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
17201
17202       LOGICAL LCORR,LMSSG
17203
17204 * flags for input different options
17205       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17206       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17207      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17208 * final state after inc step
17209       PARAMETER (MAXFSP=10)
17210       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17211 * particle properties (BAMJET index convention)
17212       CHARACTER*8  ANAME
17213       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17214      &                IICH(210),IIBAR(210),K1(210),K2(210)
17215 * output-common for DHADRI/ELHAIN
17216 * final state from HADRIN interaction
17217       PARAMETER (MAXFIN=10)
17218       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
17219      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
17220
17221       DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
17222      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
17223
17224       DATA LMSSG /.TRUE./
17225
17226       IREJ  = 0
17227       NFSP  = 0
17228       KCORR = 0
17229       IMCORR(1) = 0
17230       IMCORR(2) = 0
17231       LCORR = .FALSE.
17232
17233 *   dump initial particles for energy-momentum cons. check
17234       IF (LEMCCK) THEN
17235          CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
17236          CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
17237       ENDIF
17238
17239       AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
17240       AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
17241       IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
17242      &    (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
17243      &    (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
17244          IF (LMSSG.AND.(IOULEV(3).GT.0))
17245      &   WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
17246  1000    FORMAT(1X,'HADRIN:   warning! inconsistent projectile/target',
17247      &          ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
17248      &          E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
17249          LMSSG = .FALSE.
17250          LCORR = .TRUE.
17251       ENDIF
17252
17253 * convert initial state particles into particles which can be
17254 * handled by HADRIN
17255       IDHPR = IDPR
17256       IDHTA = IDTA
17257       IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
17258          IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
17259          DO 1 K=1,4
17260             P1IN(K) = PPR(K)
17261             P2IN(K) = PTA(K)
17262     1    CONTINUE
17263          XM1 = AAM(IDHPR)
17264          XM2 = AAM(IDHTA)
17265          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17266          IF (IREJ1.GT.0) THEN
17267             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
17268             GOTO 9999
17269          ENDIF
17270          DO 2 K=1,4
17271             PPR(K) = P1OUT(K)
17272             PTA(K) = P2OUT(K)
17273     2    CONTINUE
17274          PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
17275          PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
17276       ENDIF
17277
17278 * Lorentz-parameter for trafo into rest-system of target
17279       DO 3 K=1,4
17280          BGTA(K) = PTA(K)/PTA(5)
17281     3 CONTINUE
17282 * transformation of projectile into rest-system of target
17283       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
17284      &            PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
17285      &            PPR1(4))
17286
17287 * direction cosines of projectile in target rest system
17288       CX = PPR1(1)/PPRTO1
17289       CY = PPR1(2)/PPRTO1
17290       CZ = PPR1(3)/PPRTO1
17291
17292 * sample inelastic interaction
17293       IF (MODE.EQ.1) THEN
17294          CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
17295          IF (IRH.EQ.1) GOTO 9998
17296 * sample elastic interaction
17297       ELSEIF (MODE.EQ.2) THEN
17298          CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
17299          IF (IREJ1.NE.0) THEN
17300             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
17301             GOTO 9999
17302          ENDIF
17303          IF (IRH.EQ.1) GOTO 9998
17304       ELSE
17305          WRITE(LOUT,1001) MODE,INTHAD
17306  1001    FORMAT(1X,'HADRIN:   warning! inconsistent interaction mode',
17307      &          I4,' (INTHAD =',I4,')')
17308          GOTO 9999
17309       ENDIF
17310
17311 * transform final state particles back into Lab.
17312       DO 4 I=1,IRH
17313          NFSP = NFSP+1
17314          PX   = CXRH(I)*PLRH(I)
17315          PY   = CYRH(I)*PLRH(I)
17316          PZ   = CZRH(I)*PLRH(I)
17317          CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
17318      &               PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
17319      &               PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
17320          IDFSP(NFSP) = ITRH(I)
17321          AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
17322      &                                            PFSP(3,NFSP)**2
17323          IF (AMFSP2.LT.-TINY3) THEN
17324             WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
17325      &                       PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
17326  1002       FORMAT(1X,'HADRIN:   warning! final state particle (id = ',
17327      &             I2,') with negative mass^2',/,1X,5E12.4)
17328             GOTO 9999
17329          ELSE
17330             PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
17331             IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
17332                WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
17333      &                          PFSP(5,NFSP)
17334  1003          FORMAT(1X,'HADRIN:   warning! final state particle',
17335      &                ' (id = ',I2,') with inconsistent mass',/,1X,
17336      &                2E12.4)
17337                KCORR         = KCORR+1
17338                IF (KCORR.GT.2) GOTO 9999
17339                IMCORR(KCORR) = NFSP
17340             ENDIF
17341          ENDIF
17342 *   dump final state particles for energy-momentum cons. check
17343          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17344      &                           -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17345     4 CONTINUE
17346
17347 * transform momenta on mass shell in case of inconsistencies in
17348 * HADRIN
17349       IF (KCORR.GT.0) THEN
17350          IF (KCORR.EQ.2) THEN
17351             I1 = IMCORR(1)
17352             I2 = IMCORR(2)
17353          ELSE
17354             IF (IMCORR(1).EQ.1) THEN
17355                I1 = 1
17356                I2 = 2
17357             ELSE
17358                I1 = 1
17359                I2 = IMCORR(1)
17360             ENDIF
17361          ENDIF
17362          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
17363      &                           PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
17364          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
17365      &                           PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
17366          DO 5 K=1,4
17367             P1IN(K) = PFSP(K,I1)
17368             P2IN(K) = PFSP(K,I2)
17369     5    CONTINUE
17370          XM1 = AAM(IDFSP(I1))
17371          XM2 = AAM(IDFSP(I2))
17372          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17373          IF (IREJ1.GT.0) THEN
17374             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
17375 C           GOTO 9999
17376          ENDIF
17377          DO 6 K=1,4
17378             PFSP(K,I1) = P1OUT(K)
17379             PFSP(K,I2) = P2OUT(K)
17380     6    CONTINUE
17381          PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
17382      &                    -PFSP(2,I1)**2-PFSP(3,I1)**2)
17383          PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
17384      &                    -PFSP(2,I2)**2-PFSP(3,I2)**2)
17385 *   dump final state particles for energy-momentum cons. check
17386          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
17387      &                           -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
17388          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
17389      &                           -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
17390       ENDIF
17391
17392 * check energy-momentum conservation
17393       IF (LEMCCK) THEN
17394          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
17395          IF (IREJ1.NE.0) GOTO 9999
17396       ENDIF
17397
17398       RETURN
17399
17400  9998 CONTINUE
17401       IREJ = 2
17402       RETURN
17403
17404  9999 CONTINUE
17405       IREJ = 1
17406       RETURN
17407       END
17408
17409 *$ CREATE DT_HADCOL.FOR
17410 *COPY DT_HADCOL
17411 *
17412 *===hadcol=============================================================*
17413 *
17414       SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
17415
17416 ************************************************************************
17417 * Interface to the HADRIN-routines for inelastic and elastic           *
17418 * scattering. This subroutine samples hadron-nucleus interactions      *
17419 * below DPM-threshold.                                                 *
17420 *      IDPROJ        BAMJET-index of projectile hadron                 *
17421 *      PPN           projectile momentum in target rest frame          *
17422 *      IDXTAR        DTEVT1-index of target nucleon undergoing         *
17423 *                    interaction with projectile hadron                *
17424 * This subroutine replaces HADHAD.                                     *
17425 * This version dated 5.5.95 is written by S. Roesler                   *
17426 ************************************************************************
17427
17428       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17429       SAVE
17430       PARAMETER ( LINP = 10 ,
17431      &            LOUT = 6 ,
17432      &            LDAT = 9 )
17433       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
17434
17435       LOGICAL LSTART
17436
17437 * event history
17438       PARAMETER (NMXHKK=200000)
17439       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17440      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17441      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17442 * extended event history
17443       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17444      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17445      &                IHIST(2,NMXHKK)
17446 * nuclear potential
17447       LOGICAL LFERMI
17448       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17449      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17450      &                ETACOU(2),ICOUL,LFERMI
17451 * interface HADRIN-DPM
17452       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
17453 * parameter for intranuclear cascade
17454       LOGICAL LPAULI
17455       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17456 * final state after inc step
17457       PARAMETER (MAXFSP=10)
17458       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17459 * particle properties (BAMJET index convention)
17460       CHARACTER*8  ANAME
17461       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17462      &                IICH(210),IIBAR(210),K1(210),K2(210)
17463
17464       DIMENSION PPROJ(5),PNUC(5)
17465
17466       DATA LSTART /.TRUE./
17467
17468       IREJ   = 0
17469
17470       NPOINT(1) = NHKK+1
17471
17472       TAUSAV = TAUFOR
17473 **sr 6/9/01 commented
17474 C     TAUFOR = TAUFOR/2.0D0
17475 **
17476       IF (LSTART) THEN
17477          WRITE(LOUT,1000)
17478  1000    FORMAT(/,1X,'HADCOL:  Scattering handled by HADRIN')
17479          WRITE(LOUT,1001) TAUFOR
17480  1001    FORMAT(/,1X,'HADCOL:  Formation zone parameter set to ',
17481      &          F5.1,' fm/c')
17482          LSTART = .FALSE.
17483       ENDIF
17484
17485       IDNUC  = IDBAM(IDXTAR)
17486       IDNUC1 = IDT_MCHAD(IDNUC)
17487       IDPRO1 = IDT_MCHAD(IDPROJ)
17488
17489       IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
17490          IPROC = INTHAD
17491       ELSE
17492 **
17493 C        CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
17494 C        CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
17495          DUMZER = ZERO
17496          CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
17497          SIGIN = SIGTOT-SIGEL
17498 C        SIGTOT = SIGIN+SIGEL
17499 **
17500          IPROC  = 1
17501          IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
17502       ENDIF
17503
17504       PPROJ(1) = ZERO
17505       PPROJ(2) = ZERO
17506       PPROJ(3) = PPN
17507       PPROJ(5) = AAM(IDPROJ)
17508       PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
17509       DO 1 K=1,5
17510          PNUC(K)  = PHKK(K,IDXTAR)
17511     1 CONTINUE
17512
17513       ILOOP = 0
17514     2 CONTINUE
17515       ILOOP = ILOOP+1
17516       IF (ILOOP.GT.100) GOTO 9999
17517
17518       CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
17519       IF (IREJ1.EQ.1) GOTO 9999
17520
17521       IF (IREJ1.GT.1) THEN
17522 * no interaction possible
17523 *   require Pauli blocking
17524          IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
17525          IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
17526          IF ((IIBAR(IDPROJ).NE.1).AND.
17527      &       (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5)))              GOTO 2
17528 *   store incoming particle as final state particle
17529          CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
17530          CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
17531          NPOINT(4) = NHKK
17532       ELSE
17533 * require Pauli blocking for final state nucleons
17534          DO 4 I=1,NFSP
17535             IF ((IDFSP(I).EQ.1).AND.
17536      &          (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I))))       GOTO 2
17537             IF ((IDFSP(I).EQ.8).AND.
17538      &          (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I))))       GOTO 2
17539             IF ((IIBAR(IDFSP(I)).NE.1).AND.
17540      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
17541     4    CONTINUE
17542 * store final state particles
17543          DO 5 I=1,NFSP
17544             IST = 1
17545             IF ((IIBAR(IDFSP(I)).EQ.1).AND.
17546      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
17547             IDHAD = IDT_IPDGHA(IDFSP(I))
17548             CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
17549             CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
17550      &                                        PCMS,ECMS,0,0,0)
17551             IF (I.EQ.1) NPOINT(4) = NHKK
17552             VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
17553             VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
17554             VHKK(3,NHKK) = VHKK(3,IDXTAR)
17555             VHKK(4,NHKK) = VHKK(4,IDXTAR)
17556             WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
17557             WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
17558             WHKK(3,NHKK) = WHKK(3,1)
17559             WHKK(4,NHKK) = WHKK(4,1)
17560     5    CONTINUE
17561       ENDIF
17562       TAUFOR = TAUSAV
17563       RETURN
17564
17565  9999 CONTINUE
17566       IREJ = 1
17567       TAUFOR = TAUSAV
17568       RETURN
17569       END
17570
17571 *$ CREATE DT_GETEMU.FOR
17572 *COPY DT_GETEMU
17573 *
17574 *===getemu=============================================================*
17575 *
17576       SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
17577
17578 ************************************************************************
17579 * Sampling of emulsion component to be considered as target-nucleus.   *
17580 * This version dated 6.5.95   is written by S. Roesler.                *
17581 ************************************************************************
17582
17583       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17584       SAVE
17585       PARAMETER ( LINP = 10 ,
17586      &            LOUT = 6 ,
17587      &            LDAT = 9 )
17588       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
17589
17590       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
17591 * emulsion treatment
17592       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
17593      &                NCOMPO,IEMUL
17594 * Glauber formalism: flags and parameters for statistics
17595       LOGICAL LPROD
17596       CHARACTER*8 CGLB
17597       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
17598
17599       IF (MODE.EQ.0) THEN
17600          SUMFRA = ZERO
17601          RR = DT_RNDM(SUMFRA)
17602          IT  = 0
17603          ITZ = 0
17604          DO 1 ICOMP=1,NCOMPO
17605             SUMFRA = SUMFRA+EMUFRA(ICOMP)
17606             IF (SUMFRA.GT.RR) THEN
17607                IT    = IEMUMA(ICOMP)
17608                ITZ   = IEMUCH(ICOMP)
17609                KKMAT = ICOMP
17610                GOTO 2
17611             ENDIF
17612     1    CONTINUE
17613     2    CONTINUE
17614          IF (IT.LE.0) THEN
17615             WRITE(LOUT,'(1X,A,E12.3)')
17616      &       'Warning!  norm. failure within emulsion fractions',
17617      &       SUMFRA
17618             STOP
17619          ENDIF
17620       ELSEIF (MODE.EQ.1) THEN
17621          NDIFF = 10000
17622          DO 3 I=1,NCOMPO
17623             IDIFF = ABS(IT-IEMUMA(I))
17624             IF (IDIFF.LT.NDIFF) THEN
17625                KKMAT = I
17626                NDIFF = IDIFF
17627             ENDIF
17628     3    CONTINUE
17629       ELSE
17630          STOP 'DT_GETEMU'
17631       ENDIF
17632
17633 * bypass for variable projectile/target/energy runs: the correct
17634 * Glauber data will be always loaded on kkmat=1
17635       IF (IOGLB.EQ.100) THEN
17636          KKMAT = 1
17637       ENDIF
17638
17639       RETURN
17640       END
17641
17642 *$ CREATE DT_NCLPOT.FOR
17643 *COPY DT_NCLPOT
17644 *
17645 *===nclpot=============================================================*
17646 *
17647       SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
17648
17649 ************************************************************************
17650 * Calculation of Coulomb and nuclear potential for a given configurat. *
17651 *               IPZ, IP       charge/mass number of proj.              *
17652 *               ITZ, IT       charge/mass number of targ.              *
17653 *               AFERP,AFERT   factors modifying proj./target pot.      *
17654 *                             if =0, FERMOD is used                    *
17655 *               MODE = 0      calculation of binding energy            *
17656 *                    = 1      pre-calculated binding energy is used    *
17657 * This version dated 16.11.95  is written by S. Roesler.               *
17658 *                                                                      *
17659 * Last change 28.12.2006 by S. Roesler.                                *
17660 ************************************************************************
17661
17662       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17663       SAVE
17664       PARAMETER ( LINP = 10 ,
17665      &            LOUT = 6 ,
17666      &            LDAT = 9 )
17667       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
17668      &           TINY10=1.0D-10)
17669
17670       LOGICAL LSTART
17671
17672 * particle properties (BAMJET index convention)
17673       CHARACTER*8  ANAME
17674       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17675      &                IICH(210),IIBAR(210),K1(210),K2(210)
17676 * nuclear potential
17677       LOGICAL LFERMI
17678       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17679      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17680      &                ETACOU(2),ICOUL,LFERMI
17681
17682       DIMENSION IDXPOT(14)
17683 *                   ap   an  lam  alam sig- sig+ sig0 tet0 tet- asig-
17684       DATA IDXPOT /   2,   9,  17,  18,  20,  21,  22,  97,  98,  99,
17685 *                 asig0 asig+ atet0 atet+
17686      &              100, 101, 102, 103/
17687
17688       DATA AN     /0.4D0/
17689       DATA LSTART /.TRUE./
17690
17691       IF (MODE.EQ.0) THEN
17692          EBINDP(1) = ZERO
17693          EBINDN(1) = ZERO
17694          EBINDP(2) = ZERO
17695          EBINDN(2) = ZERO
17696       ENDIF
17697       AIP  = DBLE(IP)
17698       AIPZ = DBLE(IPZ)
17699       AIT  = DBLE(IT)
17700       AITZ = DBLE(ITZ)
17701
17702       FERMIP = AFERP
17703       IF (AFERP.LE.ZERO) FERMIP = FERMOD
17704       FERMIT = AFERT
17705       IF (AFERT.LE.ZERO) FERMIT = FERMOD
17706
17707 * Fermi momenta and binding energy for projectile
17708       IF ((IP.GT.1).AND.LFERMI) THEN
17709          IF (MODE.EQ.0) THEN
17710 C           EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
17711 C           EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
17712             BIP  = AIP -ONE
17713             BIPZ = AIPZ-ONE
17714             EBINDP(1) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIP,BIPZ)
17715      &                                            -DT_ENERGY(AIP,AIPZ))
17716             IF (AIP.LE.AIPZ) THEN
17717                EBINDN(1) = EBINDP(1)
17718                WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
17719             ELSE
17720                EBINDN(1) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17721      &                     +DT_ENERGY(BIP,AIPZ)-DT_ENERGY(AIP,AIPZ))
17722             ENDIF
17723          ENDIF
17724          PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
17725          PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
17726       ELSE
17727          PFERMP(1) = ZERO
17728          PFERMN(1) = ZERO
17729       ENDIF
17730 * effective nuclear potential for projectile
17731 C     EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
17732 C     EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
17733       EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
17734       EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
17735
17736 * Fermi momenta and binding energy for target
17737       IF ((IT.GT.1).AND.LFERMI) THEN
17738          IF (MODE.EQ.0) THEN
17739 C           EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
17740 C           EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
17741             BIT  = AIT -ONE
17742             BITZ = AITZ-ONE
17743
17744             EBINDP(2) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIT,BITZ)
17745      &                                            -DT_ENERGY(AIT,AITZ))
17746
17747             IF (AIT.LE.AITZ) THEN
17748                EBINDN(2) = EBINDP(2)
17749                WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
17750             ELSE
17751
17752                EBINDN(2) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17753      &                     +DT_ENERGY(BIT,AITZ)-DT_ENERGY(AIT,AITZ))
17754
17755             ENDIF
17756          ENDIF
17757          PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
17758          PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
17759       ELSE
17760          PFERMP(2) = ZERO
17761          PFERMN(2) = ZERO
17762       ENDIF
17763 * effective nuclear potential for target
17764 C     EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
17765 C     EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
17766       EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
17767       EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
17768
17769       DO 2 I=1,14
17770          EPOT(1,IDXPOT(I)) = EPOT(1,8)
17771          EPOT(2,IDXPOT(I)) = EPOT(2,8)
17772     2 CONTINUE
17773
17774 * Coulomb energy
17775       ETACOU(1) = ZERO
17776       ETACOU(2) = ZERO
17777       IF (ICOUL.EQ.1) THEN
17778          IF (IP.GT.1)
17779      &   ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
17780          IF (IT.GT.1)
17781      &   ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
17782       ENDIF
17783
17784       IF (LSTART) THEN
17785          WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
17786      &                    EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
17787      &                    EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
17788      &                    FERMOD,ETACOU
17789  1000    FORMAT(/,/,1X,'NCLPOT:    quantities for inclusion of nuclear'
17790      &           ,' effects',/,12X,'---------------------------',
17791      &           '----------------',/,/,38X,'projectile',
17792      &           '      target',/,/,1X,'Mass number / charge',
17793      &           17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy  -',
17794      &           ' proton   (GeV) ',2E14.4,/,17X,'- neutron  (GeV)'
17795      &          ,1X,2E14.4,/,1X,'Fermi-potential - proton   (GeV)',
17796      &           1X,2E14.4,/,17X,'- neutron  (GeV) ',2E14.4,/,/,
17797      &           1X,'Scale factor for Fermi-momentum    ',F4.2,/,
17798      &           /,1X,'Coulomb-energy ',2(E14.4,' GeV  '),/,/)
17799          LSTART = .FALSE.
17800       ENDIF
17801
17802       RETURN
17803       END
17804
17805 *$ CREATE DT_RESNCL.FOR
17806 *COPY DT_RESNCL
17807 *
17808 *===resncl=============================================================*
17809 *
17810       SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
17811
17812 ************************************************************************
17813 * Treatment of residual nuclei and nuclear effects.                    *
17814 *         MODE = 1     initializations                                 *
17815 *              = 2     treatment of final state                        *
17816 * This version dated 16.11.95 is written by S. Roesler.                *
17817 *                                                                      *
17818 * Last change 05.01.2007 by S. Roesler.                                *
17819 ************************************************************************
17820
17821       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17822       SAVE
17823       PARAMETER ( LINP = 10 ,
17824      &            LOUT = 6 ,
17825      &            LDAT = 9 )
17826       PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
17827      &           TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
17828      &           ONETHI=ONE/THREE)
17829       PARAMETER (AMUAMU = 0.93149432D0,
17830      &           FM2MM  = 1.0D-12,
17831      &           RNUCLE = 1.12D0)
17832       PARAMETER ( EMVGEV = 1.0                D-03 )
17833       PARAMETER ( AMUGEV = 0.93149432         D+00 )
17834       PARAMETER ( AMPRTN = 0.93827231         D+00 )
17835       PARAMETER ( AMNTRN = 0.93956563         D+00 )
17836       PARAMETER ( AMELCT = 0.51099906         D-03 )
17837       PARAMETER ( HLFHLF = 0.5D+00 )
17838       PARAMETER ( FERTHO = 14.33       D-09 )
17839       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
17840       PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
17841       PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
17842
17843 * event history
17844       PARAMETER (NMXHKK=200000)
17845       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17846      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17847      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17848 * extended event history
17849       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17850      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17851      &                IHIST(2,NMXHKK)
17852 * particle properties (BAMJET index convention)
17853       CHARACTER*8  ANAME
17854       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17855      &                IICH(210),IIBAR(210),K1(210),K2(210)
17856 * flags for input different options
17857       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17858       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17859      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17860 * nuclear potential
17861       LOGICAL LFERMI
17862       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17863      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17864      &                ETACOU(2),ICOUL,LFERMI
17865 * properties of interacting particles
17866       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
17867 * properties of photon/lepton projectiles
17868       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
17869 * Lorentz-parameters of the current interaction
17870       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
17871      &                UMO,PPCM,EPROJ,PPROJ
17872 * treatment of residual nuclei: wounded nucleons
17873       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
17874 * treatment of residual nuclei: 4-momenta
17875       LOGICAL LRCLPR,LRCLTA
17876       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
17877      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
17878
17879       DIMENSION PFSP(4),PSEC(4),PSEC0(4)
17880       DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
17881      &          IDXCOR(15000),IDXOTH(NMXHKK)
17882
17883       GOTO (1,2) MODE
17884
17885 *------- initializations
17886     1 CONTINUE
17887
17888 * initialize arrays for residual nuclei
17889       DO 10 K=1,5
17890          IF (K.LE.4) THEN
17891             PFSP(K)     = ZERO
17892          ENDIF
17893          PINIPR(K) = ZERO
17894          PINITA(K) = ZERO
17895          PRCLPR(K) = ZERO
17896          PRCLTA(K) = ZERO
17897          TRCLPR(K) = ZERO
17898          TRCLTA(K) = ZERO
17899    10 CONTINUE
17900       SCPOT = ONE
17901       NLOOP = 0
17902
17903 * correction of projectile 4-momentum for effective target pot.
17904 * and Coulomb-energy (in case of hadron-nucleus interaction only)
17905       IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
17906          EPNI = EPN
17907 *   Coulomb-energy:
17908 *     positively charged hadron - check energy for Coloumb pot.
17909          IF (IICH(IJPROJ).EQ.1) THEN
17910             THRESH = ETACOU(2)+AAM(IJPROJ)
17911             IF (EPNI.LE.THRESH) THEN
17912                WRITE(LOUT,1000)
17913  1000          FORMAT(/,1X,'KKINC:  WARNING!  projectile energy',
17914      &                ' below Coulomb threshold - event rejected',/)
17915                ISTHKK(1) = 1
17916                RETURN
17917             ENDIF
17918 *     negatively charged hadron - increase energy by Coulomb energy
17919          ELSEIF (IICH(IJPROJ).EQ.-1) THEN
17920             EPNI = EPNI+ETACOU(2)
17921          ENDIF
17922          IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
17923 *   Effective target potential
17924 *sr 6.6. binding energy only (to avoid negative exc. energies)
17925 C           EPNI = EPNI+EPOT(2,IJPROJ)
17926             EBIPOT = EBINDP(2)
17927             IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
17928      &         EBIPOT = EBINDN(2)
17929             EPNI = EPNI+ABS(EBIPOT)
17930 * re-initialization of DTLTRA
17931             DUM1 = ZERO
17932             DUM2 = ZERO
17933             CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
17934          ENDIF
17935       ENDIF
17936
17937 * projectile in n-n cms
17938       IF ((IP.LE.1).AND.(IT.GT.1)) THEN
17939          PMASS1 = AAM(IJPROJ)
17940 C* VDM assumption
17941 C         IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
17942          IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
17943          PMASS2 = AAM(1)
17944          PM1 = SIGN(PMASS1**2,PMASS1)
17945          PM2 = SIGN(PMASS2**2,PMASS2)
17946          PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
17947          PINIPR(5) = PMASS1
17948          IF (PMASS1.GT.ZERO) THEN
17949             PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
17950      &                      *(PINIPR(4)+PINIPR(5)))
17951          ELSE
17952             PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
17953          ENDIF
17954          AIT  = DBLE(IT)
17955          AITZ = DBLE(ITZ)
17956          PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
17957          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
17958       ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
17959          PMASS1 = AAM(1)
17960          PMASS2 = AAM(IJTARG)
17961          PM1 = SIGN(PMASS1**2,PMASS1)
17962          PM2 = SIGN(PMASS2**2,PMASS2)
17963          PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
17964          PINITA(5) = PMASS2
17965          PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
17966      &                    *(PINITA(4)+PINITA(5)))
17967          AIP  = DBLE(IP)
17968          AIPZ = DBLE(IPZ)
17969          PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
17970          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
17971       ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
17972          AIP  = DBLE(IP)
17973          AIPZ = DBLE(IPZ)
17974          PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
17975          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
17976          AIT  = DBLE(IT)
17977          AITZ = DBLE(ITZ)
17978          PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
17979          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
17980       ENDIF
17981
17982       RETURN
17983
17984 *------- treatment of final state
17985     2 CONTINUE
17986
17987       NLOOP = NLOOP+1
17988       IF (NLOOP.GT.1) SCPOT = 0.10D0
17989 C     WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
17990
17991       JPW  = NPW
17992       JPCW = NPCW
17993       JTW  = NTW
17994       JTCW = NTCW
17995       DO 40 K=1,4
17996          PFSP(K)   = ZERO
17997    40 CONTINUE
17998
17999       NOB = 0
18000       NOM = 0
18001       DO 900 I=NPOINT(4),NHKK
18002          IDXOTH(I) = -1
18003          IF (ISTHKK(I).EQ.1) THEN
18004             IF (IDBAM(I).EQ.7) GOTO 900
18005             IPOT = 0
18006             IOTHER = 0
18007 * particle moving into forward direction
18008             IF (PHKK(3,I).GE.ZERO) THEN
18009 *   most likely to be effected by projectile potential
18010                IPOT = 1
18011 *     there is no projectile nucleus, try target
18012                IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18013                   IPOT   = 2
18014                   IF (IP.GT.1) IOTHER = 1
18015 *       there is no target nucleus --> skip
18016                   IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18017                ENDIF
18018 * particle moving into backward direction
18019             ELSE
18020 *   most likely to be effected by target potential
18021                IPOT = 2
18022 *     there is no target nucleus, try projectile
18023                IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18024                   IPOT   = 1
18025                   IF (IT.GT.1) IOTHER = 1
18026 *       there is no projectile nucleus --> skip
18027                   IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18028                ENDIF
18029             ENDIF
18030             IFLG = -IPOT
18031 * nobam=3: particle is in overlap-region or neither inside proj. nor target
18032 *      =1: particle is not in overlap-region AND is inside target (2)
18033 *      =2: particle is not in overlap-region AND is inside projectile (1)
18034 * flag particles which are inside the nucleus ipot but not in its
18035 * overlap region
18036             IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
18037             IF (IDBAM(I).NE.0) THEN
18038 * baryons: keep all nucleons and all others where flag is set
18039                IF (IIBAR(IDBAM(I)).NE.0) THEN
18040                   IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
18041      &                                                              THEN
18042                      NOB = NOB+1
18043                      PMOMB(NOB) = PHKK(3,I)
18044                      IDXB(NOB)  = SIGN(10000000*IABS(IFLG)
18045      &                           +1000000*IOTHER+I,IFLG)
18046                   ENDIF
18047 * mesons: keep only those mesons where flag is set
18048                ELSE
18049                   IF (IFLG.GT.0) THEN
18050                      NOM = NOM+1
18051                      PMOMM(NOM) = PHKK(3,I)
18052                      IDXM(NOM)  = 10000000*IFLG+1000000*IOTHER+I
18053                   ENDIF
18054                ENDIF
18055             ENDIF
18056          ENDIF
18057   900 CONTINUE
18058 *
18059 * sort particles in the arrays according to increasing long. momentum
18060       CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
18061       CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
18062 *
18063 * shuffle indices into one and the same array according to the later
18064 * sequence of correction
18065       NCOR = 0
18066       IF (IT.GT.1) THEN
18067          DO 910 I=1,NOB
18068             IF (PMOMB(I).GT.ZERO) GOTO 911
18069             NCOR = NCOR+1
18070             IDXCOR(NCOR) = IDXB(I)
18071   910    CONTINUE
18072   911    CONTINUE
18073          IF (IP.GT.1) THEN
18074             DO 912 J=1,NOB
18075                I = NOB+1-J
18076                IF (PMOMB(I).LT.ZERO) GOTO 913
18077                NCOR = NCOR+1
18078                IDXCOR(NCOR) = IDXB(I)
18079   912       CONTINUE
18080   913       CONTINUE
18081          ELSE
18082             DO 914 I=1,NOB
18083                IF (PMOMB(I).GT.ZERO) THEN
18084                   NCOR = NCOR+1
18085                   IDXCOR(NCOR) = IDXB(I)
18086                ENDIF
18087   914       CONTINUE
18088          ENDIF
18089       ELSE
18090          DO 915 J=1,NOB
18091             I = NOB+1-J
18092             NCOR = NCOR+1
18093             IDXCOR(NCOR) = IDXB(I)
18094   915    CONTINUE
18095       ENDIF
18096       DO 925 I=1,NOM
18097          IF (PMOMM(I).GT.ZERO) GOTO 926
18098          NCOR = NCOR+1
18099          IDXCOR(NCOR) = IDXM(I)
18100   925 CONTINUE
18101   926 CONTINUE
18102       DO 927 J=1,NOM
18103          I = NOM+1-J
18104          IF (PMOMM(I).LT.ZERO) GOTO 928
18105          NCOR = NCOR+1
18106          IDXCOR(NCOR) = IDXM(I)
18107   927 CONTINUE
18108   928 CONTINUE
18109 *
18110 C      IF (NEVHKK.EQ.484) THEN
18111 C         WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
18112 C 9000    FORMAT(1X,'wounded nucleons (proj.-p,n  targ.-p,n)',/,4I10)
18113 C         WRITE(LOUT,9001) NOB,NOM,NCOR
18114 C 9001    FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
18115 C         WRITE(LOUT,'(/,A)') ' baryons '
18116 C         DO 950 I=1,NOB
18117 CC           J     = IABS(IDXB(I))
18118 CC           INDEX = J-IABS(J/10000000)*10000000
18119 C            IPOT   = IABS(IDXB(I))/10000000
18120 C            IOTHER = IABS(IDXB(I))/1000000-IPOT*10
18121 C            INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
18122 C            WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
18123 C  950    CONTINUE
18124 C         WRITE(LOUT,'(/,A)') ' mesons '
18125 C         DO 951 I=1,NOM
18126 CC           INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
18127 C            IPOT   = IABS(IDXM(I))/10000000
18128 C            IOTHER = IABS(IDXM(I))/1000000-IPOT*10
18129 C            INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
18130 C            WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
18131 C  951    CONTINUE
18132 C 9002    FORMAT(1X,4I14,E14.5)
18133 C         WRITE(LOUT,'(/,A)') ' all '
18134 C         DO 952 I=1,NCOR
18135 CC           J     = IABS(IDXCOR(I))
18136 CC           INDEX = J-IABS(J/10000000)*10000000
18137 CC            IPOT   = IABS(IDXCOR(I))/10000000
18138 C            IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
18139 C            INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
18140 C            WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
18141 C  952    CONTINUE
18142 C 9003    FORMAT(1X,4I14)
18143 C      ENDIF
18144 *
18145       DO 20 ICOR=1,NCOR
18146          IPOT   = IABS(IDXCOR(ICOR))/10000000
18147          IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
18148          I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
18149          IDXOTH(I) = 1
18150
18151          IDSEC  = IDBAM(I)
18152
18153 * reduction of particle momentum by corresponding nuclear potential
18154 * (this applies only if Fermi-momenta are requested)
18155
18156          IF (LFERMI) THEN
18157
18158 *   Lorentz-transformation into the rest system of the selected nucleus
18159             IMODE = -IPOT-1
18160             CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18161      &                  PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
18162             PSECO  = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
18163             AMSEC  = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
18164             JPMOD  = 0
18165
18166             CHKLEV = TINY3
18167             IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
18168             IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
18169             IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
18170                IF (IOULEV(3).GT.0)
18171      &            WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
18172  2000          FORMAT(1X,'RESNCL: inconsistent mass of particle',
18173      &                ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
18174      &                I4,'   AMSEC: ',E12.3,'  AAM(IDSEC): ',E12.3,/)
18175                GOTO 23
18176             ENDIF
18177
18178             DO 21 K=1,4
18179                PSEC0(K) = PSEC(K)
18180    21       CONTINUE
18181
18182 *   the correction for nuclear potential effects is applied to as many
18183 *   p/n as many nucleons were wounded; the momenta of other final state
18184 *   particles are corrected only if they materialize inside the corresp.
18185 *   nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
18186 *   = 3 part. outside proj. and targ., >=10 in overlapping region)
18187             IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
18188                IF (IPOT.EQ.1) THEN
18189                   IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
18190 *      this is most likely a wounded nucleon
18191 **test
18192 C                    RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
18193 C    &                           +(VHKK(2,IPW(JPW))/FM2MM)**2
18194 C    &                           +(VHKK(3,IPW(JPW))/FM2MM)**2)
18195 C                    RAD   = RNUCLE*DBLE(IP)**ONETHI
18196 C                    FDEN  = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
18197 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18198 **
18199                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18200                      JPW = JPW-1
18201                      JPMOD = 1
18202                   ELSE
18203 *      correct only if part. was materialized inside nucleus
18204 *      and if it is ouside the overlapping region
18205                      IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
18206                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18207                         JPMOD = 1
18208                      ENDIF
18209                   ENDIF
18210                ELSEIF (IPOT.EQ.2) THEN
18211                   IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
18212 *      this is most likely a wounded nucleon
18213 **test
18214 C                    RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
18215 C    &                           +(VHKK(2,ITW(JTW))/FM2MM)**2
18216 C    &                           +(VHKK(3,ITW(JTW))/FM2MM)**2)
18217 C                    RAD   = RNUCLE*DBLE(IT)**ONETHI
18218 C                    FDEN  = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
18219 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18220 **
18221                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18222                      JTW = JTW-1
18223                      JPMOD = 1
18224                   ELSE
18225 *      correct only if part. was materialized inside nucleus
18226                      IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
18227                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18228                         JPMOD = 1
18229                      ENDIF
18230                   ENDIF
18231                ENDIF
18232             ELSE
18233                IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
18234                   PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18235                   JPMOD = 1
18236                ENDIF
18237             ENDIF
18238
18239             IF (NLOOP.EQ.1) THEN
18240 * Coulomb energy correction:
18241 * the treatment of Coulomb potential correction is similar to the
18242 * one for nuclear potential
18243                IF (IDSEC.EQ.1) THEN
18244                   IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
18245                      JPCW = JPCW-1
18246                   ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
18247                      JTCW = JTCW-1
18248                   ELSE
18249                      IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18250                   ENDIF
18251                ELSE
18252                   IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18253                ENDIF
18254                IF (IICH(IDSEC).EQ.1) THEN
18255 *    pos. particles: check if they are able to escape Coulomb potential
18256                   IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
18257                      ISTHKK(I) = 14+IPOT
18258                      IF (ISTHKK(I).EQ.15) THEN
18259                         DO 26 K=1,4
18260                            PHKK(K,I) = PSEC0(K)
18261                            TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18262    26                CONTINUE
18263                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18264                         IF (IDSEC.EQ.1) NPCW = NPCW-1
18265                      ELSEIF (ISTHKK(I).EQ.16) THEN
18266                         DO 27 K=1,4
18267                            PHKK(K,I) = PSEC0(K)
18268                            TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18269    27                   CONTINUE
18270                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18271                         IF (IDSEC.EQ.1) NTCW = NTCW-1
18272                      ENDIF
18273                      GOTO 20
18274                   ENDIF
18275                ELSEIF (IICH(IDSEC).EQ.-1) THEN
18276 *    neg. particles: decrease energy by Coulomb-potential
18277                   PSEC(4) = PSEC(4)-ETACOU(IPOT)
18278                   JPMOD = 1
18279                ENDIF
18280             ENDIF
18281
18282    25       CONTINUE
18283
18284             IF (PSEC(4).LT.AMSEC) THEN
18285                IF (IOULEV(6).GT.0)
18286      &            WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
18287  2001          FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
18288      &                ' is not allowed to escape nucleus',/,
18289      &                8X,'id : ',I3,'   reduced energy: ',E15.4,
18290      &                '   mass: ',E12.3)
18291                ISTHKK(I) = 14+IPOT
18292                IF (ISTHKK(I).EQ.15) THEN
18293                   DO 28 K=1,4
18294                      PHKK(K,I) = PSEC0(K)
18295                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18296    28             CONTINUE
18297                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18298                   IF (IDSEC.EQ.1) NPCW = NPCW-1
18299                ELSEIF (ISTHKK(I).EQ.16) THEN
18300                   DO 29 K=1,4
18301                      PHKK(K,I) = PSEC0(K)
18302                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18303    29             CONTINUE
18304                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18305                   IF (IDSEC.EQ.1) NTCW = NTCW-1
18306                ENDIF
18307                GOTO 20
18308             ENDIF
18309
18310             IF (JPMOD.EQ.1) THEN
18311                PSECN  = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
18312 * 4-momentum after correction for nuclear potential
18313                DO 22 K=1,3
18314                   PSEC(K) = PSEC(K)*PSECN/PSECO
18315    22          CONTINUE
18316
18317 * store recoil momentum from particles escaping the nuclear potentials
18318                DO 30 K=1,4
18319                   IF (IPOT.EQ.1) THEN
18320                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
18321                   ELSEIF (IPOT.EQ.2) THEN
18322                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
18323                   ENDIF
18324    30          CONTINUE
18325
18326 * transform momentum back into n-n cms
18327                IMODE = IPOT+1
18328                CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
18329      &                     PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18330      &                     IDSEC,IMODE)
18331             ENDIF
18332
18333          ENDIF
18334
18335    23    CONTINUE
18336          DO 31 K=1,4
18337             PFSP(K) = PFSP(K)+PHKK(K,I)
18338    31    CONTINUE
18339
18340    20 CONTINUE
18341
18342       DO 33 I=NPOINT(4),NHKK
18343          IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
18344             PFSP(1) = PFSP(1)+PHKK(1,I)
18345             PFSP(2) = PFSP(2)+PHKK(2,I)
18346             PFSP(3) = PFSP(3)+PHKK(3,I)
18347             PFSP(4) = PFSP(4)+PHKK(4,I)
18348          ENDIF
18349    33 CONTINUE
18350
18351       DO 34 K=1,5
18352          PRCLPR(K) = TRCLPR(K)
18353          PRCLTA(K) = TRCLTA(K)
18354    34 CONTINUE
18355
18356       IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18357 * hadron-nucleus interactions: get residual momentum from energy-
18358 * momentum conservation
18359          DO 32 K=1,4
18360             PRCLPR(K) = ZERO
18361             PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
18362    32    CONTINUE
18363       ELSE
18364 * nucleus-hadron, nucleus-nucleus: get residual momentum from
18365 * accumulated recoil momenta of particles leaving the spectators
18366 *   transform accumulated recoil momenta of residual nuclei into
18367 *   n-n cms
18368          PZI = PRCLPR(3)
18369          PEI = PRCLPR(4)
18370          CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
18371          PZI = PRCLTA(3)
18372          PEI = PRCLTA(4)
18373          CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
18374 C        IF (IP.GT.1) THEN
18375             PRCLPR(3) = PRCLPR(3)+PINIPR(3)
18376             PRCLPR(4) = PRCLPR(4)+PINIPR(4)
18377 C        ENDIF
18378          IF (IT.GT.1) THEN
18379             PRCLTA(3) = PRCLTA(3)+PINITA(3)
18380             PRCLTA(4) = PRCLTA(4)+PINITA(4)
18381          ENDIF
18382       ENDIF
18383
18384 * check momenta of residual nuclei
18385       IF (LEMCCK) THEN
18386          CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
18387      &               1,IDUM,IDUM)
18388          CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
18389      &               2,IDUM,IDUM)
18390          CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
18391      &               2,IDUM,IDUM)
18392          CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
18393      &               2,IDUM,IDUM)
18394          CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
18395 **sr 19.12. changed to avoid output when used with phojet
18396 C        CHKLEV = TINY3
18397          CHKLEV = TINY1
18398          CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
18399 C        IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
18400 C    &      CALL DT_EVTOUT(4)
18401          IF (IREJ1.GT.0) RETURN
18402       ENDIF
18403
18404       RETURN
18405       END
18406
18407 *$ CREATE DT_SCN4BA.FOR
18408 *COPY DT_SCN4BA
18409 *
18410 *===scn4ba=============================================================*
18411 *
18412       SUBROUTINE DT_SCN4BA
18413
18414 ************************************************************************
18415 * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot.    *
18416 * This version dated 12.12.95 is written by S. Roesler.                *
18417 ************************************************************************
18418
18419       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18420       SAVE
18421       PARAMETER ( LINP = 10 ,
18422      &            LOUT = 6 ,
18423      &            LDAT = 9 )
18424       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18425      &           TINY10=1.0D-10)
18426
18427 * event history
18428       PARAMETER (NMXHKK=200000)
18429       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18430      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18431      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18432 * extended event history
18433       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18434      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18435      &                IHIST(2,NMXHKK)
18436 * particle properties (BAMJET index convention)
18437       CHARACTER*8  ANAME
18438       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18439      &                IICH(210),IIBAR(210),K1(210),K2(210)
18440 * properties of interacting particles
18441       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18442 * nuclear potential
18443       LOGICAL LFERMI
18444       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18445      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18446      &                ETACOU(2),ICOUL,LFERMI
18447 * treatment of residual nuclei: wounded nucleons
18448       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18449 * treatment of residual nuclei: 4-momenta
18450       LOGICAL LRCLPR,LRCLTA
18451       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18452      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18453
18454       DIMENSION PLAB(2,5),PCMS(4)
18455
18456       IREJ = 0
18457
18458 * get number of wounded nucleons
18459       NPW    = 0
18460       NPW0   = 0
18461       NPCW   = 0
18462       NPSTCK = 0
18463       NTW    = 0
18464       NTW0   = 0
18465       NTCW   = 0
18466       NTSTCK = 0
18467
18468       ISGLPR = 0
18469       ISGLTA = 0
18470       LRCLPR = .FALSE.
18471       LRCLTA = .FALSE.
18472
18473 C     DO 2 I=1,NHKK
18474       DO 2 I=1,NPOINT(1)
18475 * projectile nucleons wounded in primary interaction and in fzc
18476          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
18477             NPW      = NPW+1
18478             IPW(NPW) = I
18479             NPSTCK   = NPSTCK+1
18480             IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
18481             IF (ISTHKK(I).EQ.11)  NPW0 = NPW0+1
18482 C           IF (IP.GT.1) THEN
18483                DO 5 K=1,4
18484                   TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
18485     5          CONTINUE
18486 C           ENDIF
18487 * target nucleons wounded in primary interaction and in fzc
18488          ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
18489             NTW      = NTW+1
18490             ITW(NTW) = I
18491             NTSTCK   = NTSTCK+1
18492             IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
18493             IF (ISTHKK(I).EQ.12)  NTW0 = NTW0+1
18494             IF (IT.GT.1) THEN
18495                DO 6 K=1,4
18496                   TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
18497     6          CONTINUE
18498             ENDIF
18499          ELSEIF (ISTHKK(I).EQ.13) THEN
18500             ISGLPR = I
18501          ELSEIF (ISTHKK(I).EQ.14) THEN
18502             ISGLTA = I
18503          ENDIF
18504     2 CONTINUE
18505
18506       DO 11 I=NPOINT(4),NHKK
18507 * baryons which are unable to escape the nuclear potential of proj.
18508          IF (ISTHKK(I).EQ.15) THEN
18509             ISGLPR = I
18510             NPSTCK = NPSTCK-1
18511             IF (IIBAR(IDBAM(I)).NE.0) THEN
18512                NPW    = NPW-1
18513                IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
18514             ENDIF
18515             DO 7 K=1,4
18516                TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18517     7       CONTINUE
18518 * baryons which are unable to escape the nuclear potential of targ.
18519          ELSEIF (ISTHKK(I).EQ.16) THEN
18520             ISGLTA = I
18521             NTSTCK = NTSTCK-1
18522             IF (IIBAR(IDBAM(I)).NE.0) THEN
18523                NTW    = NTW-1
18524                IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
18525             ENDIF
18526             DO 8 K=1,4
18527                TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18528     8       CONTINUE
18529          ENDIF
18530    11 CONTINUE
18531
18532 * residual nuclei so far
18533       IRESP = IP-NPSTCK
18534       IREST = IT-NTSTCK
18535
18536 * ckeck for "residual nuclei" consisting of one nucleon only
18537 * treat it as final state particle
18538       IF (IRESP.EQ.1) THEN
18539          ID  = IDBAM(ISGLPR)
18540          IST = ISTHKK(ISGLPR)
18541          CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
18542      &               PHKK(3,ISGLPR),PHKK(4,ISGLPR),
18543      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
18544          IF (IST.EQ.13) THEN
18545             ISTHKK(ISGLPR) = 11
18546          ELSE
18547             ISTHKK(ISGLPR) = 2
18548          ENDIF
18549          CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
18550      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18551      &               IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
18552          NOBAM(NHKK)      = NOBAM(ISGLPR)
18553          JDAHKK(1,ISGLPR) = NHKK
18554          DO 21 K=1,4
18555             TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
18556    21    CONTINUE
18557       ENDIF
18558       IF (IREST.EQ.1) THEN
18559          ID  = IDBAM(ISGLTA)
18560          IST = ISTHKK(ISGLTA)
18561          CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
18562      &               PHKK(3,ISGLTA),PHKK(4,ISGLTA),
18563      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
18564          IF (IST.EQ.14) THEN
18565             ISTHKK(ISGLTA) = 12
18566          ELSE
18567             ISTHKK(ISGLTA) = 2
18568          ENDIF
18569          CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
18570      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18571      &               IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
18572          NOBAM(NHKK)      = NOBAM(ISGLTA)
18573          JDAHKK(1,ISGLTA) = NHKK
18574          DO 22 K=1,4
18575             TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
18576    22    CONTINUE
18577       ENDIF
18578
18579 * get nuclear potential corresp. to the residual nucleus
18580       IPRCL  = IP -NPW
18581       IPZRCL = IPZ-NPCW
18582       ITRCL  = IT -NTW
18583       ITZRCL = ITZ-NTCW
18584       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
18585
18586 * baryons unable to escape the nuclear potential are treated as
18587 * excited nucleons (ISTHKK=15,16)
18588       DO 3 I=NPOINT(4),NHKK
18589          IF (ISTHKK(I).EQ.1) THEN
18590             ID  = IDBAM(I)
18591             IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
18592 *   final state n and p not being outside of both nuclei are considered
18593                NPOTP = 1
18594                NPOTT = 1
18595                IF ( (IP.GT.1)      .AND.(IRESP.GT.1).AND.
18596      &              (NOBAM(I).NE.1).AND.(NPW.GT.0)        ) THEN
18597 *     Lorentz-trsf. into proj. rest sys. for those being inside proj.
18598                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18599      &                        PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
18600      &                        PLAB(1,4),ID,-2)
18601                   PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
18602                   PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
18603      &                                  (PLAB(1,4)+PLABT) ))
18604                   EKIN = PLAB(1,4)-PLAB(1,5)
18605                   IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
18606                   IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
18607                ENDIF
18608                IF ( (IT.GT.1)      .AND.(IREST.GT.1).AND.
18609      &              (NOBAM(I).NE.2).AND.(NTW.GT.0)        ) THEN
18610 *     Lorentz-trsf. into targ. rest sys. for those being inside targ.
18611                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18612      &                        PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
18613      &                        PLAB(2,4),ID,-3)
18614                   PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
18615                   PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
18616      &                                  (PLAB(2,4)+PLABT) ))
18617                   EKIN = PLAB(2,4)-PLAB(2,5)
18618                   IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
18619                   IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
18620                ENDIF
18621                IF (PHKK(3,I).GE.ZERO) THEN
18622                   ISTHKK(I) = NPOTT
18623                   IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
18624                ELSE
18625                   ISTHKK(I) = NPOTP
18626                   IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
18627                ENDIF
18628                IF (ISTHKK(I).NE.1) THEN
18629                   J = ISTHKK(I)-14
18630                   DO 4 K=1,5
18631                      PHKK(K,I) = PLAB(J,K)
18632     4             CONTINUE
18633                   IF (ISTHKK(I).EQ.15) THEN
18634                      NPW = NPW-1
18635                      IF (ID.EQ.1) NPCW = NPCW-1
18636                      DO 9 K=1,4
18637                         TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18638     9                CONTINUE
18639                   ELSEIF (ISTHKK(I).EQ.16) THEN
18640                      NTW = NTW-1
18641                      IF (ID.EQ.1) NTCW = NTCW-1
18642                      DO 10 K=1,4
18643                         TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18644    10                CONTINUE
18645                   ENDIF
18646                ENDIF
18647             ENDIF
18648          ENDIF
18649     3 CONTINUE
18650
18651 * again: get nuclear potential corresp. to the residual nucleus
18652       IPRCL  = IP -NPW
18653       IPZRCL = IPZ-NPCW
18654       ITRCL  = IT -NTW
18655       ITZRCL = ITZ-NTCW
18656 c      AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
18657 cC     AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
18658 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
18659 C     AFERP = 0.0D0
18660 c      AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
18661 cC     AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
18662 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
18663 C     AFERT = 0.0D0
18664 C     IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
18665 C     IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
18666 C     IF (AFERP.GT.0.85D0) AFERP = 0.85D0
18667 C     IF (AFERT.GT.0.85D0) AFERT = 0.85D0
18668       AFERP = FERMOD+0.1D0
18669       AFERT = FERMOD+0.1D0
18670
18671       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
18672
18673       RETURN
18674       END
18675
18676 *$ CREATE DT_FICONF.FOR
18677 *COPY DT_FICONF
18678 *
18679 *===ficonf=============================================================*
18680 *
18681       SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
18682
18683 ************************************************************************
18684 * Treatment of FInal CONFiguration including evaporation, fission and  *
18685 * Fermi-break-up (for light nuclei only).                              *
18686 * Adopted from the original routine FINALE and extended to residual    *
18687 * projectile nuclei.                                                   *
18688 * This version dated 12.12.95 is written by S. Roesler.                *
18689 *                                                                      *
18690 * Last change 27.12.2006 by S. Roesler.                                *
18691 ************************************************************************
18692
18693       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18694       SAVE
18695       PARAMETER ( LINP = 10 ,
18696      &            LOUT = 6 ,
18697      &            LDAT = 9 )
18698       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18699       PARAMETER (ANGLGB=5.0D-16)
18700       PARAMETER (AMUAMU=0.93149432D0,AMELEC=0.51099906D-3)
18701
18702 * event history
18703       PARAMETER (NMXHKK=200000)
18704       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18705      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18706      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18707 * extended event history
18708       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18709      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18710      &                IHIST(2,NMXHKK)
18711 * rejection counter
18712       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
18713      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
18714      &                IREXCI(3),IRDIFF(2),IRINC
18715 * central particle production, impact parameter biasing
18716       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
18717 * particle properties (BAMJET index convention)
18718       CHARACTER*8  ANAME
18719       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18720      &                IICH(210),IIBAR(210),K1(210),K2(210)
18721 * treatment of residual nuclei: 4-momenta
18722       LOGICAL LRCLPR,LRCLTA
18723       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18724      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18725 * treatment of residual nuclei: properties of residual nuclei
18726       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
18727      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
18728      &                NTOTFI(2),NPROFI(2)
18729 * statistics: residual nuclei
18730       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
18731      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
18732      &                NINCST(2,4),NINCEV(2),
18733      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
18734      &                NRESPB(2),NRESCH(2),NRESEV(4),
18735      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
18736      &                NEVAFI(2,2)
18737 * flags for input different options
18738       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18739       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18740      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18741 * (original name: FINUC)
18742       PARAMETER (MXP=999)
18743       COMMON /FKFINU/ CXR    (MXP), CYR    (MXP), CZR    (MXP),
18744      &                CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
18745      &                TKI    (MXP), PLR    (MXP), WEI    (MXP),
18746      &                TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
18747      &                KPART  (MXP)
18748 * (original name: RESNUC)
18749       LOGICAL LRNFSS, LFRAGM
18750       COMMON /FKRESN/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
18751      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
18752      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
18753      &                  PYRES,  PZRES, PTRES2,  KTARP,  KTARN, IGREYP,
18754      &                 IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
18755      &                  ICRES,  IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
18756      &                 IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
18757      &                  IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
18758      &                 LFRAGM
18759       COMMON /FKNDAT/ AV0WEL,     APFRMX,     AEFRMX,     AEFRMA,
18760      &                RDSNUC,     V0WELL (2), PFRMMX (2), EFRMMX (2),
18761      &                EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
18762      &                VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
18763      &                PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
18764      &                EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
18765      &                ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV    ,
18766      &                AMRCSQ    , ATO1O3    , ZTO1O3    , ELBNDE (0:100)
18767 * (original name: PAREVT)
18768       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
18769      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
18770       PARAMETER ( NALLWP = 39   )
18771       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
18772      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
18773      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
18774      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
18775 * event flag
18776       COMMON /DTEVNO/ NEVENT,ICASCA
18777
18778       DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
18779      &          PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
18780      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
18781
18782       DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
18783       LOGICAL LLCPOT
18784       DATA EXC,NEXC /520*ZERO,520*0/
18785       DATA EXPNUC /4.0D-3,4.0D-3/
18786
18787       IREJ   = 0
18788       LRCLPR = .FALSE.
18789       LRCLTA = .FALSE.
18790
18791 * skip residual nucleus treatment if not requested or in case
18792 * of central collisions
18793       IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
18794
18795       DO 1 K=1,2
18796          IDPAR(K) = 0
18797          IDXPAR(K)= 0
18798          NTOT(K)  = 0
18799          NTOTFI(K)= 0
18800          NPRO(K)  = 0
18801          NPROFI(K)= 0
18802          NN(K)    = 0
18803          NH(K)    = 0
18804          NHPOS(K) = 0
18805          NQ(K)    = 0
18806          EEXC(K)  = ZERO
18807          MO1(K)   = 0
18808          MO2(K)   = 0
18809          DO 2 I=1,4
18810             VRCL(K,I) = ZERO
18811             WRCL(K,I) = ZERO
18812     2    CONTINUE
18813     1 CONTINUE
18814       NFSP = 0
18815       INUC(1) = IP
18816       INUC(2) = IT
18817
18818       DO 3 I=1,NHKK
18819
18820 * number of final state particles
18821          IF (ABS(ISTHKK(I)).EQ.1) THEN
18822             NFSP  = NFSP+1
18823             IDFSP = IDBAM(I)
18824          ENDIF
18825
18826 * properties of remaining nucleon configurations
18827          KF = 0
18828          IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
18829          IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
18830          IF (KF.GT.0) THEN
18831             IF (MO1(KF).EQ.0) MO1(KF) = I
18832             MO2(KF)  = I
18833 *   position of residual nucleus = average position of nucleons
18834             DO 4 K=1,4
18835                VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
18836                WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
18837     4       CONTINUE
18838 *   total number of particles contributing to each residual nucleus
18839             NTOT(KF)  = NTOT(KF)+1
18840             IDTMP     = IDBAM(I)
18841             IDXTMP    = I
18842 *   total charge of residual nuclei
18843             NQ(KF) = NQ(KF)+IICH(IDTMP)
18844 *   number of protons
18845             IF (IDHKK(I).EQ.2212) THEN
18846                NPRO(KF) = NPRO(KF)+1
18847 *   number of neutrons
18848             ELSEIF (IDHKK(I).EQ.2112) THEN
18849                NN(KF) = NN(KF)+1
18850             ELSE
18851 *   number of baryons other than n, p
18852                IF (IIBAR(IDTMP).EQ.1) THEN
18853                   NH(KF) = NH(KF)+1
18854                   IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
18855                ELSE
18856 *   any other mesons (status set to 1)
18857 C                 WRITE(LOUT,1002) KF,IDTMP
18858 C1002             FORMAT(1X,'FICONF:   residual nucleus ',I2,
18859 C    &                   ' containing meson ',I4,', status set to 1')
18860                   ISTHKK(I) = 1
18861                   IDTMP     = IDPAR(KF)
18862                   IDXTMP    = IDXPAR(KF)
18863                   NTOT(KF)  = NTOT(KF)-1
18864                ENDIF
18865             ENDIF
18866             IDPAR(KF)  = IDTMP
18867             IDXPAR(KF) = IDXTMP
18868          ENDIF
18869     3 CONTINUE
18870
18871 * reject elastic events (def: one final state particle = projectile)
18872       IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
18873          IREXCI(3) = IREXCI(3)+1
18874          GOTO 9999
18875 C        RETURN
18876       ENDIF
18877
18878 * check if one nucleus disappeared..
18879 C     IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
18880 C        DO 5 K=1,4
18881 C           PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
18882 C           PRCLPR(K) = ZERO
18883 C   5    CONTINUE
18884 C     ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
18885 C        DO 6 K=1,4
18886 C           PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
18887 C           PRCLTA(K) = ZERO
18888 C   6    CONTINUE
18889 C     ENDIF
18890
18891       ICOR   = 0
18892       INORCL = 0
18893       DO 7 I=1,2
18894          DO 8 K=1,4
18895 * get the average of the nucleon positions
18896             VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
18897             WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
18898             IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
18899             IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
18900     8    CONTINUE
18901 * mass number and charge of residual nuclei
18902          AIF(I)  = DBLE(NTOT(I))
18903          AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
18904          IF (NTOT(I).GT.1) THEN
18905 * masses of residual nuclei in ground state
18906             AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*DT_ENERGY(AIF(I),AIZF(I))
18907 * masses of residual nuclei
18908             PTORCL   = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
18909             AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
18910             IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
18911 *
18912 *   M_res^2 < 0 : configuration not allowed
18913 *
18914 *      a) re-calculate E_exc with scaled nuclear potential
18915 *         (conditional jump to label 9998)
18916 *      b) or reject event if N_loop(max) is exceeded
18917 *         (conditional jump to label 9999)
18918 *
18919             IF (AMRCL(I).LE.ZERO) THEN
18920                IF (IOULEV(3).GT.0)
18921      &            WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
18922      &                             PRCL(I,4),NTOT
18923  1000          FORMAT(1X,'warning! negative excitation energy',/,
18924      &                I4,4E15.4,2I4)
18925                AMRCL(I) = ZERO
18926                EEXC(I)  = ZERO
18927                IF (NLOOP.LE.500) THEN
18928                   GOTO 9998
18929                ELSE
18930                   IREXCI(2) = IREXCI(2)+1
18931                   GOTO 9999
18932                ENDIF
18933 *
18934 *   0 < M_res < M_res0 : mass below ground-state mass
18935 *
18936 *      a) we had residual nuclei with mass N_tot and reasonable E_exc
18937 *         before- assign average E_exc of those configurations to this
18938 *         one ( Nexc(i,N_tot) > 0 )
18939 *      b) or (and this applies always if run in transport codes) go up
18940 *         one mass number and
18941 *           i) if mass now larger than proj/targ mass or if run in
18942 *              transport codes assign average E_exc per wounded nucleon
18943 *              x number of wounded nucleons (Inuc-Ntot)
18944 *          ii) or assign average E_exc of those configurations to this
18945 *              one ( Nexc(i,m) > 0 )
18946 *
18947             ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
18948      &                                                         THEN
18949                M = MIN(NTOT(I),260)
18950                IF (NEXC(I,M).GT.0) THEN
18951                   AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
18952                ELSE
18953    70             CONTINUE
18954                   M = M+1
18955 **sr corrected 27.12.06
18956 *                 IF (M.GE.INUC(I)) THEN
18957 *                    AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
18958                   IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
18959                      IF ( INUC (I) .GT. NTOT (I) ) THEN
18960                         AMRCL(I) = AMRCL0(I)
18961      &                         + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
18962                      ELSE
18963                         AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
18964                      END IF
18965 **
18966                   ELSE
18967                      IF (NEXC(I,M).GT.0) THEN
18968                         AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
18969                      ELSE
18970                         GOTO 70
18971                      ENDIF
18972                   ENDIF
18973                ENDIF
18974                EEXC(I)  = AMRCL(I)-AMRCL0(I)
18975                ICOR     = ICOR+I
18976 *
18977 *   M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
18978 *
18979 *      a) re-calculate E_exc with scaled nuclear potential
18980 *         (conditional jump to label 9998)
18981 *      b) or reject event if N_loop(max) is exceeded
18982 *         (conditional jump to label 9999)
18983 *
18984 *
18985             ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
18986                IF (IOULEV(3).GT.0)
18987      &            WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
18988  1004          FORMAT(1X,'warning! too high excitation energy',/,
18989      &                I4,1P,2E15.4,3I5)
18990                AMRCL(I) = ZERO
18991                EEXC(I)  = ZERO
18992                IF (NLOOP.LE.500) THEN
18993                   GOTO 9998
18994                ELSE
18995                   IREXCI(2) = IREXCI(2)+1
18996                   GOTO 9999
18997                ENDIF
18998 *
18999 *   Otherwise (reasonable E_exc) :
19000 *      E_exc = M_res - M_res0
19001 *      in addition: calculate and save E_exc per wounded nucleon as
19002 *                   well as E_exc in <E_exc> counter
19003 *
19004             ELSE
19005 * excitation energies of residual nuclei
19006                EEXC(I)   = AMRCL(I)-AMRCL0(I)
19007 **sr 27.12.06 new excitation energy correction by A.F.
19008 *
19009 * all parts with Ilcopt<3 commented since not used
19010 *
19011 * still to be done/decided:
19012 *   Increase Icor and put back both residual nuclei on mass shell
19013 *   with the exciting correction further below.
19014 *   For the moment the modification in the excitation energy is simply
19015 *   corrected by scaling the energy of the residual nucleus.
19016 *
19017                LLCPOT = .TRUE.
19018                ILCOPT = 3
19019                IF ( LLCPOT ) THEN
19020                   NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
19021                   IF ( ILCOPT .LE. 2 ) THEN
19022 C* Patch for Fermi momentum reduction correlated with impact parameter:
19023 C                     FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
19024 C                     DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
19025 C                     AKPRHO = ONE - DLKPRH
19026 C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
19027 C                     FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO  - ONE,
19028 C     &                              0.05D+00 )
19029 C*                    REDORI = 0.75D+00
19030 C*                    REDORI = ONE
19031 C                     REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19032                   ELSE
19033                      DLKPRH = ZERO
19034                      RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
19035 *  Take out roughly one/half of the skin:
19036                      RDCORE = RDCORE - 0.5D+00
19037                      FRCFLL = RDCORE**3
19038                      PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
19039                      PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
19040                      FRCFLL = ONE - PRSKIN
19041                      FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
19042                      REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19043                   END IF
19044                   IF ( NNCHIT .GT. 0 ) THEN
19045 C                     IF ( ILCOPT .EQ. 1 ) THEN
19046 C                        SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
19047 C                        DO 1220 NCH = 1, 10
19048 C                           ETAETA = ( ONE - SKINRH**INUC(I)
19049 C     &                            - DBLE(INUC(I))* ( ONE - FRCFLL )
19050 C     &                            * ( ONE - SKINRH ) )
19051 C     &                            / ( SKINRH**INUC(I) - DBLE (INUC(I))
19052 C     &                            * ( ONE - FRCFLL) * SKINRH )
19053 C                           SKINRH = SKINRH * ( ONE + ETAETA )
19054 C 1220                   CONTINUE
19055 C                        PRSKIN = SKINRH**(NNCHIT-1)
19056 C                     ELSE IF ( ILCOPT .EQ. 2 ) THEN
19057 C                        PRSKIN = ONE - FRCFLL
19058 C                     END IF
19059                      REDCTN = ZERO
19060                      DO 1230 NCH = 1, NNCHIT
19061                         IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
19062                            PRFRMI = (( ONE - 2.D+00 * DLKPRH )
19063      &                            * DT_RNDM(PRFRMI))**0.333333333333D+00
19064                         ELSE
19065                            PRFRMI = ( ONE - 2.D+00 * DLKPRH
19066      &                            * DT_RNDM(PRFRMI))**0.333333333333D+00
19067                         END IF
19068                         REDCTN = REDCTN + PRFRMI**2
19069  1230                CONTINUE
19070                      REDCTN = REDCTN / DBLE (NNCHIT)
19071                   ELSE
19072                      REDCTN = 0.5D+00
19073                   END IF
19074                   EEXC  (I) = EEXC   (I) * REDCTN / REDORI
19075                   AMRCL (I) = AMRCL0 (I) + EEXC (I)
19076                   PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
19077                END IF
19078 **
19079                IF (ICASCA.EQ.0) THEN
19080                   EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
19081                   M = MIN(NTOT(I),260)
19082                   EXC(I,M)  = EXC(I,M)+EEXC(I)
19083                   NEXC(I,M) = NEXC(I,M)+1
19084                ENDIF
19085             ENDIF
19086          ELSEIF (NTOT(I).EQ.1) THEN
19087             WRITE(LOUT,1003) I
19088  1003       FORMAT(1X,'FICONF:   warning! NTOT(I)=1? (I=',I3,')')
19089             GOTO 9999
19090          ELSE
19091             AMRCL0(I) = ZERO
19092             AMRCL(I)  = ZERO
19093             EEXC(I)   = ZERO
19094             INORCL    = INORCL+I
19095          ENDIF
19096     7 CONTINUE
19097
19098       PRCLPR(5) = AMRCL(1)
19099       PRCLTA(5) = AMRCL(2)
19100
19101       IF (ICOR.GT.0) THEN
19102          IF (INORCL.EQ.0) THEN
19103 * one or both residual nuclei consist of one nucleon only, transform
19104 * this nucleon on mass shell
19105             DO 9 K=1,4
19106                P1IN(K) = PRCL(1,K)
19107                P2IN(K) = PRCL(2,K)
19108     9       CONTINUE
19109             XM1 = AMRCL(1)
19110             XM2 = AMRCL(2)
19111             CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
19112             IF (IREJ1.GT.0) THEN
19113                WRITE(LOUT,*) 'ficonf-mashel rejection'
19114                GOTO 9999
19115             ENDIF
19116             DO 10 K=1,4
19117                PRCL(1,K) = P1OUT(K)
19118                PRCL(2,K) = P2OUT(K)
19119                PRCLPR(K) = P1OUT(K)
19120                PRCLTA(K) = P2OUT(K)
19121    10       CONTINUE
19122             PRCLPR(5) = AMRCL(1)
19123             PRCLTA(5) = AMRCL(2)
19124          ELSE
19125             IF (IOULEV(3).GT.0)
19126      &      WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
19127      &                       INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
19128      &                       AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
19129      &                       AMRCL(2),AMRCL(2)-AMRCL0(2)
19130  1001       FORMAT(1X,'FICONF:   warning! no residual nucleus for',
19131      &             ' correction',/,11X,'at event',I8,
19132      &             ',  nucleon config. 1:',2I4,' 2:',2I4,
19133      &             2(/,11X,3E12.3))
19134             IF (NLOOP.LE.500) THEN
19135                GOTO 9998
19136             ELSE
19137                IREXCI(1) = IREXCI(1)+1
19138             ENDIF
19139          ENDIF
19140       ENDIF
19141
19142 * update counter
19143 C     IF (NRESEV(1).NE.NEVHKK) THEN
19144 C        NRESEV(1) = NEVHKK
19145 C        NRESEV(2) = NRESEV(2)+1
19146 C     ENDIF
19147       NRESEV(2) = NRESEV(2)+1
19148       DO 15 I=1,2
19149          EXCDPM(I)   = EXCDPM(I)+EEXC(I)
19150          EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
19151          NRESTO(I) = NRESTO(I)+NTOT(I)
19152          NRESPR(I) = NRESPR(I)+NPRO(I)
19153          NRESNU(I) = NRESNU(I)+NN(I)
19154          NRESBA(I) = NRESBA(I)+NH(I)
19155          NRESPB(I) = NRESPB(I)+NHPOS(I)
19156          NRESCH(I) = NRESCH(I)+NQ(I)
19157    15 CONTINUE
19158
19159 * evaporation
19160       IF (LEVPRT) THEN
19161          DO 13 I=1,2
19162 * initialize evaporation counter
19163             EEXCFI(I) = ZERO
19164             IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
19165      &          (EEXC(I).GT.ZERO)) THEN
19166 * put residual nuclei into DTEVT1
19167                IDRCL = 80000
19168                JMASS = INT( AIF(I))
19169                JCHAR = INT(AIZF(I))
19170 *  the following patch is required to transmit the correct excitation
19171 *   energy to Eventd
19172                IF (ITRSPT.EQ.1) THEN
19173                   IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
19174      &                (IOULEV(3).GT.0))
19175      &               WRITE(LOUT,*)
19176      &                  ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
19177      &                              AMRCL(I),AMRCL0(I),EEXC(I)
19178                   PRCL0 = PRCL(I,4)
19179                   PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
19180      &                                                    +PRCL(I,3)**2)
19181                   IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
19182                      WRITE(LOUT,*)
19183      &                  ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
19184                   ENDIF
19185                ENDIF
19186                CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
19187      &              PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
19188 **sr 22.6.97
19189                NOBAM(NHKK) = I
19190 **
19191                DO 14 J=1,4
19192                   VHKK(J,NHKK) = VRCL(I,J)
19193                   WHKK(J,NHKK) = WRCL(I,J)
19194    14          CONTINUE
19195 *  interface to evaporation module - fill final residual nucleus into
19196 *  common FKRESN
19197 *   fill resnuc only if code is not used as event generator in Fluka
19198                IF (ITRSPT.NE.1) THEN
19199                   PXRES  = PRCL(I,1)
19200                   PYRES  = PRCL(I,2)
19201                   PZRES  = PRCL(I,3)
19202                   IBRES  = NPRO(I)+NN(I)+NH(I)
19203                   ICRES  = NPRO(I)+NHPOS(I)
19204                   ANOW   = DBLE(IBRES)
19205                   ZNOW   = DBLE(ICRES)
19206                   PTRES  = SQRT(PXRES**2+PYRES**2+PZRES**2)
19207 *   ground state mass of the residual nucleus (should be equal to AM0T)
19208                   AMMRES = AMRCL0(I)
19209                   AMNRES = AMMRES-ZNOW*AMELEC+ELBNDE(ICRES)
19210 *  common FKFINU
19211                   TV = ZERO
19212 *   kinetic energy of residual nucleus
19213                   TVRECL = PRCL(I,4)-AMRCL(I)
19214 *   excitation energy of residual nucleus
19215                   TVCMS  = EEXC(I)
19216                   PTOLD  = PTRES
19217                   PTRES  = SQRT(ABS(TVRECL*(TVRECL+
19218      &                          2.0D0*(AMMRES+TVCMS))))
19219                   IF (PTOLD.LT.ANGLGB) THEN
19220                      CALL DT_RACO(PXRES,PYRES,PZRES)
19221                      PTOLD = ONE
19222                   ENDIF
19223                   PXRES = PXRES*PTRES/PTOLD
19224                   PYRES = PYRES*PTRES/PTOLD
19225                   PZRES = PZRES*PTRES/PTOLD
19226 * zero counter of secondaries from evaporation
19227                   NP = 0
19228 * evaporation
19229                   WE = ONE
19230                   CALL DT_EVEVAP(WE)
19231 * put evaporated particles and residual nuclei to DTEVT1
19232                   MO = NHKK
19233                   CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
19234                ENDIF
19235                EEXCFI(I) = EXCITF
19236                EXCEVA(I) = EXCEVA(I)+EXCITF
19237             ENDIF
19238    13    CONTINUE
19239       ENDIF
19240
19241       RETURN
19242
19243 C9998 IREXCI(1) = IREXCI(1)+1
19244  9998 IREJ   = IREJ+1
19245  9999 CONTINUE
19246       LRCLPR = .TRUE.
19247       LRCLTA = .TRUE.
19248       IREJ   = IREJ+1
19249       RETURN
19250       END
19251
19252 *$ CREATE DT_EVA2HE.FOR
19253 *COPY DT_EVA2HE
19254 *                                                                      *
19255 *====eva2he============================================================*
19256 *                                                                      *
19257       SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
19258
19259 ************************************************************************
19260 * Interface between common's of evaporation module (FKFINU,FKFHVY)     *
19261 * and DTEVT1.                                                          *
19262 *    MO    DTEVT1-index of "mother" (residual) nucleus before evap.    *
19263 *    EEXCF exitation energy of residual nucleus after evaporation      *
19264 *    IRCL  = 1 projectile residual nucleus                             *
19265 *          = 2 target     residual nucleus                             *
19266 * This version dated 19.04.95 is written by S. Roesler.                *
19267 *                                                                      *
19268 * Last change 27.12.2006 by S. Roesler.                                *
19269 ************************************************************************
19270
19271       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19272       SAVE
19273       PARAMETER ( LINP = 10 ,
19274      &            LOUT = 6 ,
19275      &            LDAT = 9 )
19276       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
19277
19278 * event history
19279       PARAMETER (NMXHKK=200000)
19280       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19281      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19282      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19283 * Note: DTEVT2 - special use for heavy fragments !
19284 *       (IDRES(I) = mass number, IDXRES(I) = charge)
19285 * extended event history
19286       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19287      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19288      &                IHIST(2,NMXHKK)
19289 * particle properties (BAMJET index convention)
19290       CHARACTER*8  ANAME
19291       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19292      &                IICH(210),IIBAR(210),K1(210),K2(210)
19293 * flags for input different options
19294       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19295       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19296      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19297 * statistics: residual nuclei
19298       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19299      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19300      &                NINCST(2,4),NINCEV(2),
19301      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19302      &                NRESPB(2),NRESCH(2),NRESEV(4),
19303      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19304      &                NEVAFI(2,2)
19305 * treatment of residual nuclei: properties of residual nuclei
19306       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19307      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19308      &                NTOTFI(2),NPROFI(2)
19309 * (original name: FINUC)
19310       PARAMETER (MXP=999)
19311       COMMON /FKFINU/ CXR    (MXP), CYR    (MXP), CZR    (MXP),
19312      &                CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
19313      &                TKI    (MXP), PLR    (MXP), WEI    (MXP),
19314      &                TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
19315      &                KPART  (MXP)
19316 * (original name: FHEAVY,FHEAVC)
19317       PARAMETER ( MXHEAV = 100 )
19318       CHARACTER*8 ANHEAV
19319       COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19320      &                CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19321      &                PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19322      &                AMHEAV  ( 12 ) , AMNHEA  ( 12 ) ,
19323      &                KHEAVY (MXHEAV), ICHEAV  ( 12 ) ,
19324      &                IBHEAV  ( 12 ) , NPHEAV
19325       COMMON /FKFHVC/ ANHEAV  ( 12 )
19326 * (original name: RESNUC)
19327       LOGICAL LRNFSS, LFRAGM
19328       COMMON /FKRESN/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19329      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19330      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
19331      &                  PYRES,  PZRES, PTRES2,  KTARP,  KTARN, IGREYP,
19332      &                 IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
19333      &                  ICRES,  IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
19334      &                 IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
19335      &                  IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
19336      &                 LFRAGM
19337
19338       DIMENSION IPTOKP(39)
19339       DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
19340      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
19341      & 100, 101, 97, 102, 98, 103, 109, 115 /
19342
19343       IREJ = 0
19344
19345 * skip if evaporation package is not included
19346       IF (.NOT.LEVAPO) RETURN
19347
19348 * update counter
19349       IF (NRESEV(3).NE.NEVHKK) THEN
19350          NRESEV(3) = NEVHKK
19351          NRESEV(4) = NRESEV(4)+1
19352       ENDIF
19353
19354       IF (LEMCCK)
19355      &   CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
19356      &                                                   IDUM,IDUM)
19357 * mass number/charge of residual nucleus before evaporation
19358       IBTOT = IDRES(MO)
19359       IZTOT = IDXRES(MO)
19360
19361 * protons/neutrons/gammas
19362       DO 1 I=1,NP
19363          PX    = CXR(I)*PLR(I)
19364          PY    = CYR(I)*PLR(I)
19365          PZ    = CZR(I)*PLR(I)
19366          ID    = IPTOKP(KPART(I))
19367          IDPDG = IDT_IPDGHA(ID)
19368          AM    = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
19369      &           (2.0D0*MAX(TKI(I),TINY10))
19370          IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
19371             WRITE(LOUT,1000) ID,AM,AAM(ID)
19372  1000       FORMAT(1X,'EVA2HE:  inconsistent mass of evap. ',
19373      &             'particle',I3,2E10.3)
19374          ENDIF
19375          PE = TKI(I)+AM
19376          CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
19377          NOBAM(NHKK) = IRCL
19378          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19379          IBTOT = IBTOT-IIBAR(ID)
19380          IZTOT = IZTOT-IICH(ID)
19381     1 CONTINUE
19382
19383 * heavy fragments
19384       DO 2 I=1,NPHEAV
19385          PX     = CXHEAV(I)*PHEAVY(I)
19386          PY     = CYHEAV(I)*PHEAVY(I)
19387          PZ     = CZHEAV(I)*PHEAVY(I)
19388          IDHEAV = 80000
19389          AM     = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
19390      &            (2.0D0*MAX(TKHEAV(I),TINY10))
19391          PE     = TKHEAV(I)+AM
19392          CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
19393      &                  IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
19394          NOBAM(NHKK) = IRCL
19395          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19396          IBTOT = IBTOT-IBHEAV(KHEAVY(I))
19397          IZTOT = IZTOT-ICHEAV(KHEAVY(I))
19398     2 CONTINUE
19399
19400       IF (IBRES.GT.0) THEN
19401 * residual nucleus after evaporation
19402          IDNUC = 80000
19403          CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
19404      &                                        IBRES,ICRES,0)
19405          NOBAM(NHKK) = IRCL
19406       ENDIF
19407       EEXCF = TVCMS
19408       NTOTFI(IRCL) = IBRES
19409       NPROFI(IRCL) = ICRES
19410       IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
19411       IBTOT = IBTOT-IBRES
19412       IZTOT = IZTOT-ICRES
19413
19414 * count events with fission
19415       NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
19416       IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
19417
19418 * energy-momentum conservation check
19419       IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
19420 C     IF (IREJ.GT.0) THEN
19421 C        CALL DT_EVTOUT(4)
19422 C        WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
19423 C     ENDIF
19424 * baryon-number/charge conservation check
19425       IF (IBTOT+IZTOT.NE.0) THEN
19426          WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
19427  1001    FORMAT(1X,'EVA2HE:   baryon-number/charge conservation ',
19428      &          'failure at event ',I8,' :  IBTOT,IZTOT = ',2I3)
19429       ENDIF
19430
19431       RETURN
19432       END
19433
19434 *$ CREATE DT_EBIND.FOR
19435 *COPY DT_EBIND
19436 *
19437 *===ebind==============================================================*
19438 *
19439       DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
19440
19441 ************************************************************************
19442 * Binding energy for nuclei.                                           *
19443 * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972)                  *
19444 *                 IA        mass number                                *
19445 *                 IZ        atomic number                              *
19446 * This version dated 5.5.95   is updated by S. Roesler.                *
19447 ************************************************************************
19448
19449       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19450       SAVE
19451       PARAMETER ( LINP = 10 ,
19452      &            LOUT = 6 ,
19453      &            LDAT = 9 )
19454       PARAMETER (ZERO=0.0D0)
19455
19456       DATA       A1,       A2,        A3,        A4,      A5
19457      &     / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
19458
19459       IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
19460          WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0.  ',IA,IZ
19461          DT_EBIND = ZERO
19462          RETURN
19463       ENDIF
19464       AA = IA
19465       DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
19466      &        -A4*(IA-2*IZ)**2/AA
19467       IF (MOD(IA,2).EQ.1) THEN
19468          IA5 = 0
19469       ELSEIF (MOD(IZ,2).EQ.1) THEN
19470          IA5 = 1
19471       ELSE
19472          IA5 = -1
19473       ENDIF
19474       DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
19475
19476       RETURN
19477       END
19478
19479 **sr 30.6. routine replaced completely
19480 *$ CREATE DT_ENERGY.FOR
19481 *COPY DT_ENERGY
19482 *                                                                      *
19483 *=== energy ===========================================================*
19484 *                                                                      *
19485       DOUBLE PRECISION FUNCTION DT_ENERGY( A, Z )
19486
19487 C     INCLUDE '(DBLPRC)'
19488 * DBLPRC.ADD
19489       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19490       SAVE
19491 * (original name: GLOBAL)
19492       PARAMETER ( KALGNM = 2 )
19493       PARAMETER ( ANGLGB = 5.0D-16 )
19494       PARAMETER ( ANGLSQ = 2.5D-31 )
19495       PARAMETER ( AXCSSV = 0.2D+16 )
19496       PARAMETER ( ANDRFL = 1.0D-38 )
19497       PARAMETER ( AVRFLW = 1.0D+38 )
19498       PARAMETER ( AINFNT = 1.0D+30 )
19499       PARAMETER ( AZRZRZ = 1.0D-30 )
19500       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
19501       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
19502       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
19503       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
19504       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
19505       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
19506       PARAMETER ( CSNNRM = 2.0D-15 )
19507       PARAMETER ( DMXTRN = 1.0D+08 )
19508       PARAMETER ( ZERZER = 0.D+00 )
19509       PARAMETER ( ONEONE = 1.D+00 )
19510       PARAMETER ( TWOTWO = 2.D+00 )
19511       PARAMETER ( THRTHR = 3.D+00 )
19512       PARAMETER ( FOUFOU = 4.D+00 )
19513       PARAMETER ( FIVFIV = 5.D+00 )
19514       PARAMETER ( SIXSIX = 6.D+00 )
19515       PARAMETER ( SEVSEV = 7.D+00 )
19516       PARAMETER ( EIGEIG = 8.D+00 )
19517       PARAMETER ( ANINEN = 9.D+00 )
19518       PARAMETER ( TENTEN = 10.D+00 )
19519       PARAMETER ( HLFHLF = 0.5D+00 )
19520       PARAMETER ( ONETHI = ONEONE / THRTHR )
19521       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
19522       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
19523       PARAMETER ( THRTWO = THRTHR / TWOTWO )
19524       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
19525       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
19526       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
19527       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
19528       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
19529       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
19530       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
19531       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
19532       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
19533       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
19534       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
19535       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
19536       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
19537       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
19538       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
19539       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
19540       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
19541       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
19542       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
19543       PARAMETER ( CLIGHT = 2.99792458         D+10 )
19544       PARAMETER ( AVOGAD = 6.0221367          D+23 )
19545       PARAMETER ( BOLTZM = 1.380658           D-23 )
19546       PARAMETER ( AMELGR = 9.1093897          D-28 )
19547       PARAMETER ( PLCKBR = 1.05457266         D-27 )
19548       PARAMETER ( ELCCGS = 4.8032068          D-10 )
19549       PARAMETER ( ELCMKS = 1.60217733         D-19 )
19550       PARAMETER ( AMUGRM = 1.6605402          D-24 )
19551       PARAMETER ( AMMUMU = 0.113428913        D+00 )
19552       PARAMETER ( AMPRMU = 1.007276470        D+00 )
19553       PARAMETER ( AMNEMU = 1.008664904        D+00 )
19554       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
19555       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
19556       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
19557       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
19558       PARAMETER ( PLABRC = 0.197327053        D+00 )
19559       PARAMETER ( AMELCT = 0.51099906         D-03 )
19560       PARAMETER ( AMUGEV = 0.93149432         D+00 )
19561       PARAMETER ( AMMUON = 0.105658389        D+00 )
19562       PARAMETER ( AMPRTN = 0.93827231         D+00 )
19563       PARAMETER ( AMNTRN = 0.93956563         D+00 )
19564       PARAMETER ( AMDEUT = 1.87561339         D+00 )
19565       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19566      &                   * 1.D-09 )
19567       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
19568       PARAMETER ( BLTZMN = 8.617385           D-14 )
19569       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
19570       PARAMETER ( GFOHB3 = 1.16639            D-05 )
19571       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
19572       PARAMETER ( SIN2TW = 0.2319             D+00 )
19573       PARAMETER ( GEVMEV = 1.0                D+03 )
19574       PARAMETER ( EMVGEV = 1.0                D-03 )
19575       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
19576       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
19577       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
19578       LOGICAL LGBIAS, LGBANA
19579       COMMON /FKGLOB/ LGBIAS, LGBANA
19580 C     INCLUDE '(DIMPAR)'
19581 * DIMPAR.ADD
19582       PARAMETER ( MXXRGN = 5000 )
19583       PARAMETER ( MXXMDF = 82   )
19584       PARAMETER ( MXXMDE = 54   )
19585       PARAMETER ( MFSTCK = 1000 )
19586       PARAMETER ( MESTCK = 100  )
19587       PARAMETER ( NALLWP = 39   )
19588       PARAMETER ( NELEMX = 80   )
19589       PARAMETER ( MPDPDX = 8    )
19590       PARAMETER ( ICOMAX = 180  )
19591       PARAMETER ( NSTBIS = 304  )
19592       PARAMETER ( IDMAXP = 220  )
19593       PARAMETER ( IDMXDC = 640  )
19594       PARAMETER ( MKBMX1 = 1    )
19595       PARAMETER ( MKBMX2 = 1    )
19596 C     INCLUDE '(IOUNIT)'
19597 * IOUNIT.ADD
19598       PARAMETER ( LUNIN  =  5 )
19599       PARAMETER ( LUNOUT =  6 )
19600 **sr 19.5. set error output-unit from 15 to 6
19601       PARAMETER ( LUNERR = 6  )
19602       PARAMETER ( LUNBER = 14 )
19603       PARAMETER ( LUNECH =  8 )
19604       PARAMETER ( LUNFLU = 13 )
19605       PARAMETER ( LUNGEO = 16 )
19606       PARAMETER ( LUNPMF = 12 )
19607       PARAMETER ( LUNRAN =  2 )
19608       PARAMETER ( LUNXSC =  9 )
19609       PARAMETER ( LUNDET = 17 )
19610       PARAMETER ( LUNRAY = 10 )
19611       PARAMETER ( LUNRDB =  1 )
19612       PARAMETER ( LUNPGO =  7 )
19613       PARAMETER ( LUNPGS =  4 )
19614       PARAMETER ( LUNSCR =  3 )
19615 *
19616 *----------------------------------------------------------------------*
19617 *                                                                      *
19618 *     Revised version of the original routine from EVAP:               *
19619 *                                                                      *
19620 *     Created on   15 may 1990     by    Alfredo Ferrari & Paola Sala  *
19621 *                                                   Infn - Milan       *
19622 *                                                                      *
19623 *     Last change on 19-sep-95     by    Alfredo Ferrari               *
19624 *                                                                      *
19625 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
19626 *     !!!  It is supposed to be used with the updated atomic   !!!     *
19627 *     !!!                    mass data file                    !!!     *
19628 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
19629 *                                                                      *
19630 *----------------------------------------------------------------------*
19631 *
19632 *  Mass number below which "unknown" isotopes out of the Z-interval
19633 *  reported in the mass tabulations are completely unstable and made
19634 *  up by Z proton masses + N neutron masses:
19635       PARAMETER ( KAFREE =  4 )
19636 *  Mass number below which "unknown" isotopes out of the Z-interval
19637 *  reported in the mass tabulations are supposed to be particle unstable
19638       PARAMETER ( KAPUNS = 12 )
19639 *  Minimum energy required for particle unstable isotopes
19640       PARAMETER ( DEPUNS = 0.5D+00 )
19641 *
19642 * (original name: EVA0)
19643       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
19644      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
19645      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
19646      *                T (4,7), RMASS (297), ALPH (297), BET (297),
19647      *                APRIME (250), IA (6), IZ (6)
19648 * (original name: ISOTOP)
19649       PARAMETER ( NAMSMX = 270 )
19650       PARAMETER ( NZGVAX =  15 )
19651       PARAMETER ( NISMMX = 574 )
19652       COMMON /FKISOT/ WAPS   (NAMSMX,NZGVAX),  T12NUC (NAMSMX,NZGVAX),
19653      &                WAPISM (NISMMX), T12ISM (NISMMX),
19654      &                ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
19655      &                AMSSST (100)  , ISOMNM (NSTBIS), ISONDX (2,100),
19656      &                JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
19657      &                INWAPS (NAMSMX), JSPISM (NISMMX),
19658      &                JPTISM (NISMMX), IZWISM (NISMMX),
19659      &                INWISM (0:NAMSMX)
19660 *
19661 CPH      SAVE KA0, KZ0, IZ0
19662       DATA KA0, KZ0, IZ0 / -1, -1, -1 /
19663 *
19664       IFLAG = 1
19665       GO TO 10
19666 *======================================================================*
19667 *                                                                      *
19668 *     Entry ENergy - KNOWn                                             *
19669 *                                                                      *
19670 *======================================================================*
19671       ENTRY DT_ENKNOW ( A, Z, IZZ0 )
19672       IZZ0  =-1
19673       IFLAG = 2
19674    10 CONTINUE
19675 *
19676       KA0 = NINT ( A )
19677       KZ0 = NINT ( Z )
19678       N   = KA0 - KZ0
19679 *  +-------------------------------------------------------------------*
19680 *  |  Null residual nucleus:
19681       IF ( KA0 .EQ. 0 .AND. KZ0 .LE. 0 ) THEN
19682          IF ( IFLAG .EQ. 1 ) THEN
19683             DT_ENERGY = ZERZER
19684          ELSE
19685             DT_ENKNOW = ZERZER
19686             IZZ0   = -1
19687          END IF
19688          RETURN
19689 *  |
19690 *  +-------------------------------------------------------------------*
19691 *  |  Only protons:
19692       ELSE IF ( N .LE. 0 ) THEN
19693          IF ( N .LT. 0 ) THEN
19694             WRITE ( LUNOUT, * )
19695      &     ' DPMJET stopped in energy: mass number =< atomic number !!',
19696      &       KA0, KZ0
19697             WRITE ( LUNOUT, * )
19698      &     ' DPMJET stopped in energy: mass number =< atomic number !!',
19699      &       KA0, KZ0
19700                WRITE ( 77, * )
19701      &  ' ^^^DPMJET stopped in energy: mass number =< atomic number !!',
19702      &       KA0, KZ0
19703             STOP 'DT_ENERGY:KA0-KZ0'
19704          END IF
19705          IZ0    = -1
19706          IF ( IFLAG .EQ. 1 ) THEN
19707             DT_ENERGY = Z * WAPS ( 1, 2 )
19708          ELSE
19709             DT_ENKNOW = Z * WAPS ( 1, 2 )
19710             IZZ0   = -1
19711          END IF
19712          RETURN
19713 *  |
19714 *  +-------------------------------------------------------------------*
19715 *  |  Only neutrons:
19716       ELSE IF ( KZ0 .LE. 0 ) THEN
19717          IF ( KZ0 .LT. 0 ) THEN
19718             WRITE ( LUNOUT, * )
19719      &   ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19720             WRITE ( LUNOUT, * )
19721      &   ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19722             WRITE ( 77, * )
19723      &' ^^^DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19724             STOP 'DT_ENERGY:KZ0<0'
19725          END IF
19726          IZ0    = -1
19727          IF ( IFLAG .EQ. 1 ) THEN
19728             DT_ENERGY = A * WAPS ( 1, 1 )
19729          ELSE
19730             DT_ENKNOW = A * WAPS ( 1, 1 )
19731             IZZ0   = -1
19732          END IF
19733          RETURN
19734       END IF
19735 *  |
19736 *  +-------------------------------------------------------------------*
19737 *  +-------------------------------------------------------------------*
19738 *  |  No actual nucleus
19739 *  |
19740 *  +-------------------------------------------------------------------*
19741 *  +-------------------------------------------------------------------*
19742 *  |  A larger than maximum allowed:
19743       IF ( KA0 .GT. NAMSMX ) THEN
19744          IZ0    = -1
19745          IF ( IFLAG .EQ. 1 ) THEN
19746             DT_ENERGY = DT_ENRG( A, Z )
19747          ELSE
19748             DT_ENKNOW = DT_ENRG( A, Z )
19749             IZZ0   = -1
19750          END IF
19751          RETURN
19752       END IF
19753 *  |
19754 *  +-------------------------------------------------------------------*
19755       IZZ = INWAPS ( KA0 )
19756 *  +-------------------------------------------------------------------*
19757 *  |  Too much neutron rich with respect to the stability line:
19758       IF ( KZ0 .LT. IZZ ) THEN
19759 *  |  +----------------------------------------------------------------*
19760 *  |  |  Up to A=Kafree all "bound" masses are known, set it unbound:
19761          IF ( KA0 .LE. KAFREE ) THEN
19762             DT_ENERGY = AINFNT
19763 *  |  |
19764 *  |  +----------------------------------------------------------------*
19765 *  |  |  Up to Kapuns: be sure it is particle unstable
19766          ELSE IF ( KA0 .LE. KAPUNS ) THEN
19767 *  |  |  Exp. excess mass for A,IZZ
19768             ENEEXP = WAPS ( KA0, 1 )
19769 *  |  |  Cameron excess mass for A, IZZ
19770             ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19771 *  |  |  Cameron excess mass for A, Z
19772             DT_ENERGY = DT_ENRG( A, Z )
19773 *  |  |  Use just the difference according to Cameron!!!
19774             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19775             JZZ    = INWAPS ( KA0 - 1 )
19776             LZZ    = INWAPS ( KA0 - 2 )
19777 *  |  |  +-------------------------------------------------------------*
19778 *  |  |  |  Residual mass for n-decay known:
19779             IF ( KZ0 .GE. JZZ .AND. KZ0 .LE. JZZ + NZGVAX - 1 ) THEN
19780                IZ0    = KZ0 - JZZ + 1
19781                DT_ENERGY = MAX(DT_ENERGY,WAPS (KA0-1,IZ0) + WAPS (1,1)
19782      &                      + DEPUNS )
19783 *  |  |  |
19784 *  |  |  +-------------------------------------------------------------*
19785 *  |  |  |  Residual mass for 2n-decay known:
19786             ELSE IF ( KZ0 .GE. LZZ .AND. KZ0 .LE. LZZ + NZGVAX - 1 )THEN
19787                IZ0    = KZ0 - LZZ + 1
19788                DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19789      &                      ( WAPS (1,1) + DEPUNS ) )
19790 *  |  |  |
19791 *  |  |  +-------------------------------------------------------------*
19792 *  |  |  |  Set it unbound:
19793             ELSE
19794                DT_ENERGY = AINFNT
19795             END IF
19796 *  |  |  |
19797 *  |  |  +-------------------------------------------------------------*
19798 *  |  |
19799 *  |  +----------------------------------------------------------------*
19800 *  |  |  Proceed as usual:
19801          ELSE
19802 *  |  |  Exp. excess mass for A,IZZ
19803             ENEEXP = WAPS ( KA0, 1 )
19804 *  |  |  Cameron excess mass for A, IZZ
19805             ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19806 *  |  |  Cameron excess mass for A, Z
19807             DT_ENERGY = DT_ENRG( A, Z )
19808 *  |  |  Use just the difference according to Cameron!!!
19809             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19810          END IF
19811 *  |  |
19812 *  |  +----------------------------------------------------------------*
19813 *  |  Be sure not to have a positive energy state:
19814          DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19815          IZ0    = -1
19816          IF ( IFLAG .EQ. 2 ) THEN
19817             DT_ENKNOW = DT_ENERGY
19818             IZZ0   = -1
19819          END IF
19820          RETURN
19821 *  |
19822 *  +-------------------------------------------------------------------*
19823 *  |  Too much proton rich with respect to the stability line:
19824       ELSE IF ( KZ0 .GT. IZZ + NZGVAX - 1 ) THEN
19825 *  |  +----------------------------------------------------------------*
19826 *  |  |  Up to A=Kafree all "bound" masses are known, set it unbound:
19827          IF ( KA0 .LE. KAFREE ) THEN
19828             DT_ENERGY = AINFNT
19829 *  |  |
19830 *  |  +----------------------------------------------------------------*
19831 *  |  |  Up to Kapuns: be sure it is particle unstable
19832          ELSE IF ( KA0 .LE. KAPUNS ) THEN
19833 *  |  |  Exp. excess mass for A,IZZ+NZGVAX-1
19834             ENEEXP = WAPS ( KA0, NZGVAX )
19835 *  |  |  Cameron excess mass for A, IZZ+NZGVAX-1
19836             ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19837 *  |  |  Cameron excess mass for A, Z
19838             DT_ENERGY = DT_ENRG( A, Z )
19839 *  |  |  Use just the difference according to Cameron!!!
19840             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19841             JZZ    = INWAPS ( KA0 - 1 )
19842             LZZ    = INWAPS ( KA0 - 2 )
19843 *  |  |  +-------------------------------------------------------------*
19844 *  |  |  |  Residual mass for p-decay known:
19845             IF ( KZ0-1 .GE. JZZ .AND. KZ0-1 .LE. JZZ + NZGVAX - 1 ) THEN
19846                IZ0    = KZ0 - 1 - JZZ + 1
19847                DT_ENERGY = MAX (DT_ENERGY, WAPS (KA0-1,IZ0) + WAPS (1,2)
19848      &                      + DEPUNS )
19849 *  |  |  |
19850 *  |  |  +-------------------------------------------------------------*
19851 *  |  |  |  Residual mass for 2p-decay known:
19852             ELSE IF ( KZ0-2 .GE. LZZ .AND. KZ0-2 .LE. LZZ + NZGVAX - 1 )
19853      &         THEN
19854                IZ0    = KZ0 - 2 - LZZ + 1
19855                DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19856      &                      ( WAPS (1,2) + DEPUNS ) )
19857 *  |  |  |
19858 *  |  |  +-------------------------------------------------------------*
19859 *  |  |  |  Set it unbound:
19860             ELSE
19861                DT_ENERGY = AINFNT
19862             END IF
19863 *  |  |  |
19864 *  |  |  +-------------------------------------------------------------*
19865 *  |  |
19866 *  |  +----------------------------------------------------------------*
19867 *  |  |  Proceed as usual:
19868          ELSE
19869 *  |  |  Exp. excess mass for A,IZZ+NZGVAX-1
19870             ENEEXP = WAPS ( KA0, NZGVAX )
19871 *  |  |  Cameron excess mass for A, IZZ+NZGVAX-1
19872             ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19873 *  |  |  Cameron excess mass for A, Z
19874             DT_ENERGY = DT_ENRG( A, Z )
19875 *  |  |  Use just the difference according to Cameron!!!
19876             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19877          END IF
19878 *  |  |
19879 *  |  +----------------------------------------------------------------*
19880 *  |  Be sure not to have a positive energy state:
19881          DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19882          IZ0    = -1
19883          IF ( IFLAG .EQ. 2 ) THEN
19884             DT_ENKNOW = DT_ENERGY
19885             IZZ0   = -1
19886          END IF
19887          RETURN
19888 *  |
19889 *  +-------------------------------------------------------------------*
19890 *  |  Known isotope or anyway isotope "inside" the stability zone
19891       ELSE
19892          IZ0    = KZ0 - IZZ + 1
19893          DT_ENERGY = WAPS ( KA0, IZ0 )
19894          IF ( IFLAG .EQ. 2 ) IZZ0 = IZ0
19895 *  |  +----------------------------------------------------------------*
19896 *  |  |  Mass not known
19897          IF ( ABS (DT_ENERGY) .LT. ANGLGB .AND. (KA0 .NE. 12 .OR. KZ0
19898      &        .NE. 6) ) THEN
19899             IF ( IFLAG .EQ. 2 ) IZZ0 = -1
19900 *  |  |  +-------------------------------------------------------------*
19901 *  |  |  |  Set it unbound:
19902             IF ( KA0 .LE. KAFREE ) THEN
19903                DT_ENERGY = AINFNT
19904 *  |  |  |
19905 *  |  |  +-------------------------------------------------------------*
19906 *  |  |  |  Try to get a reasonable excess mass:
19907             ELSE
19908                JZ0 = -100
19909 *  |  |  |  +----------------------------------------------------------*
19910 *  |  |  |  |  Check the closest one known:
19911                DO 500 JZZ = 1, NZGVAX
19912                   IF ( ABS ( WAPS (KA0,JZZ) ) .GT. ANGLGB .AND.
19913      &                 ABS (JZZ-IZ0) .LT. ABS (JZ0-IZ0) ) JZ0 = JZZ
19914                   IF ( ABS (JZ0-IZ0) .EQ. 1 ) GO TO 550
19915   500          CONTINUE
19916 *  |  |  |  |
19917 *  |  |  |  +----------------------------------------------------------*
19918   550          CONTINUE
19919 *  |  |  |  Exp. excess mass for A,IZZ+JZ0-1
19920                ENEEXP = WAPS ( KA0, JZ0 )
19921 *  |  |  |  Cameron excess mass for A, IZZ+JZ0-1
19922                ENECA1 = DT_ENRG( A, DBLE (IZZ+JZ0-1) )
19923 *  |  |  |  Cameron excess mass for A, Z
19924                DT_ENERGY = DT_ENRG( A, Z )
19925 *  |  |  |  Use just the difference according to Cameron!!!
19926                DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19927                IZ0    = -1
19928             END IF
19929 *  |  |  |
19930 *  |  |  +-------------------------------------------------------------*
19931 *  |  |  Be sure not to have a positive energy state:
19932             DT_ENERGY = MIN(DT_ENERGY,(A-Z)*WAPS(1,1)+Z*WAPS (1,2) )
19933          END IF
19934 *  |  |
19935 *  |  +----------------------------------------------------------------*
19936          IF ( IFLAG .EQ. 2 ) DT_ENKNOW = DT_ENERGY
19937          RETURN
19938       END IF
19939 *  |
19940 *  +-------------------------------------------------------------------*
19941 *=== End of Function Energy ===========================================*
19942 *     RETURN
19943       END
19944 **
19945
19946 *$ CREATE DT_ENRG.FOR
19947 *COPY DT_ENRG
19948 *                                                                      *
19949 *=== enrg =============================================================*
19950 *                                                                      *
19951       DOUBLE PRECISION FUNCTION DT_ENRG(A,Z)
19952
19953       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19954       SAVE
19955
19956       PARAMETER ( ZERZER = 0.D+00 )
19957       PARAMETER ( ONEONE = 1.D+00 )
19958       PARAMETER ( LUNIN  = 5  )
19959       PARAMETER ( LUNOUT = 6  )
19960 *
19961 *----------------------------------------------------------------------*
19962 *                                                                      *
19963 *     Revised version of the original routine from EVAP:               *
19964 *                                                                      *
19965 *     Created on   15 may 1990     by    Alfredo Ferrari & Paola Sala  *
19966 *                                                   Infn - Milan       *
19967 *                                                                      *
19968 *     Last change on 01-oct-94     by    Alfredo Ferrari               *
19969 *                                                                      *
19970 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
19971 *     !!!  It is supposed to be used with the updated atomic   !!!     *
19972 *     !!!                    mass data file                    !!!     *
19973 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
19974 *                                                                      *
19975 *----------------------------------------------------------------------*
19976 *
19977       PARAMETER ( O16OLD = 931.145  D+00 )
19978       PARAMETER ( O16NEW = 931.19826D+00 )
19979       PARAMETER ( O16RAT = O16NEW / O16OLD )
19980       PARAMETER ( C12NEW = 931.49432D+00 )
19981       PARAMETER ( ADJUST = -8.322737768178909D-02 )
19982       PARAMETER ( AINFNT = 1.0D+30 )
19983 * (original name: EVA0)
19984       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
19985      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
19986      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
19987      *                T (4,7), RMASS (297), ALPH (297), BET (297),
19988      *                APRIME (250), IA (6), IZ (6)
19989       LOGICAL LFIRST
19990 CPH      SAVE LFIRST, EXHYDR, EXNEUT
19991       DATA LFIRST / .TRUE. /
19992 *
19993       IF ( LFIRST ) THEN
19994          LFIRST = .FALSE.
19995 **sr 30.6.
19996 C        EXHYDR = DT_ENERGY( ONEONE, ONEONE )
19997 C        EXNEUT = DT_ENERGY( ONEONE, ZERZER )
19998          EXHYDR = A
19999          EXNEUT = Z
20000          DT_ENRG   = -AINFNT
20001          RETURN
20002 **
20003       END IF
20004       IZ0 = NINT (Z)
20005       IF ( IZ0 .LE. 0 ) THEN
20006          DT_ENRG = A * EXNEUT
20007          RETURN
20008       END IF
20009       N   = NINT (A-Z)
20010       IF ( N .LE. 0 ) THEN
20011          DT_ENRG = Z * EXHYDR
20012          RETURN
20013       END IF
20014       AM2ZOA= (A-Z-Z)/A
20015       AM2ZOA=AM2ZOA*AM2ZOA
20016       A13 = RMASS(NINT(A))
20017 *     A13 = A**.3333333333333333D+00
20018       AM13 = 1.D+00/A13
20019       EV=-17.0354D+00*(1.D+00 -1.84619 D+00*AM2ZOA)*A
20020       ES= 25.8357D+00*(1.D+00 -1.712185D+00*AM2ZOA)*
20021      &    (1.D+00 -0.62025D+00*AM13*AM13)*
20022      &    (A13*A13 -.62025D+00)
20023       EC= 0.799D+00*Z*(Z-1.D+00)*AM13*(((1.5772D+00*AM13 +1.2273D+00)*
20024      &    AM13-1.5849D+00)*
20025      &    AM13*AM13 +1.D+00)
20026       EEX= -0.4323D+00*AM13*Z**1.3333333D+00*
20027      &   (((0.49597D+00*AM13 -0.14518D+00)*AM13 -0.57811D+00) * AM13
20028      &   + 1.D+00)
20029       DT_ENRG=8.367D+00*A-0.783D+00*Z +EV +ES +EC +EEX+CAM2(IZ0)+CAM3(N)
20030       DT_ENRG=(DT_ENRG + A * O16OLD ) * O16RAT - A * ( C12NEW - ADJUST )
20031       DT_ENRG  = MIN ( DT_ENRG, Z * EXHYDR + ( A - Z ) * EXNEUT )
20032       RETURN
20033 *=== End of function Enrg =============================================*
20034       END
20035
20036 *$ CREATE DT_INCINI.FOR
20037 *COPY DT_INCINI
20038 *                                                                      *
20039 *=== incini ===========================================================*
20040 *                                                                      *
20041       SUBROUTINE DT_INCINI
20042
20043       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20044       SAVE
20045
20046       PARAMETER ( ZERZER = 0.D+00 )
20047       PARAMETER ( ONEONE = 1.D+00 )
20048       PARAMETER ( TWOTWO = 2.D+00 )
20049       PARAMETER ( THRTHR = 3.D+00 )
20050       PARAMETER ( FOUFOU = 4.D+00 )
20051       PARAMETER ( EIGEIG = 8.D+00 )
20052       PARAMETER ( ANINEN = 9.D+00 )
20053       PARAMETER ( HLFHLF = 0.5D+00 )
20054       PARAMETER ( ONETHI = ONEONE / THRTHR )
20055       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20056       PARAMETER ( PLABRC = 0.197327053        D+00 )
20057       PARAMETER ( AMELCT = 0.51099906         D-03 )
20058       PARAMETER ( AMUGEV = 0.93149432         D+00 )
20059       PARAMETER ( AMPRTN = 0.93827231         D+00 )
20060       PARAMETER ( AMNTRN = 0.93956563         D+00 )
20061       PARAMETER ( AMDEUT = 1.87561339         D+00 )
20062       PARAMETER ( EMVGEV = 1.0                D-03 )
20063
20064       PARAMETER ( LUNOUT = 6  )
20065 *
20066 *----------------------------------------------------------------------*
20067 *                                                                      *
20068 *     Created on  10  june  1990   by    Alfredo Ferrari & Paola Sala  *
20069 *                                                   Infn - Milan       *
20070 *                                                                      *
20071 *     Last change on 02-may-95     by    Alfredo Ferrari               *
20072 *                                                                      *
20073 *                                                                      *
20074 *----------------------------------------------------------------------*
20075 *
20076 * (original name: FHEAVY,FHEAVC)
20077       PARAMETER ( MXHEAV = 100 )
20078       CHARACTER*8 ANHEAV
20079       COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20080      &                CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20081      &                PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20082      &                AMHEAV  ( 12 ) , AMNHEA  ( 12 ) ,
20083      &                KHEAVY (MXHEAV), ICHEAV  ( 12 ) ,
20084      &                IBHEAV  ( 12 ) , NPHEAV
20085       COMMON /FKFHVC/ ANHEAV  ( 12 )
20086 * (original name: INPFLG)
20087       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20088 * (original name: FRBKCM)
20089       PARAMETER ( MXFFBK =     6 )
20090       PARAMETER ( MXZFBK =     9 )
20091       PARAMETER ( MXNFBK =    10 )
20092       PARAMETER ( MXAFBK =    16 )
20093       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20094       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20095       PARAMETER ( NXAFBK = MXAFBK + 1 )
20096       PARAMETER ( MXPSST =   300 )
20097       PARAMETER ( MXPSFB = 41000 )
20098       LOGICAL LFRMBK, LNCMSS
20099       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20100      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20101      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20102      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
20103      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20104      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20105      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20106      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20107      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
20108 * (original name: NUCDAT)
20109       PARAMETER ( AMUAMU = AMUGEV )
20110       PARAMETER ( AMPROT = AMPRTN )
20111       PARAMETER ( AMNEUT = AMNTRN )
20112       PARAMETER ( AMELEC = AMELCT )
20113       PARAMETER ( R0NUCL = 1.12        D+00 )
20114       PARAMETER ( RCCOUL = 1.7         D+00 )
20115       PARAMETER ( FERTHO = 14.33       D-09 )
20116       PARAMETER ( EXPEBN = 2.39        D+00 )
20117       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
20118       PARAMETER ( AMUC12 = AMUGEV - HLFHLF * AMELCT + BEXC12 / 12.D+00 )
20119       PARAMETER ( AMHYDR = AMPRTN + AMELCT  )
20120       PARAMETER ( AMHTON = AMHYDR - AMNTRN  )
20121       PARAMETER ( AMNTOU = AMNTRN - AMUC12  )
20122       PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
20123       PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
20124       PARAMETER ( GAMMIN = 1.0D-06 )
20125       PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
20126       PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
20127       COMMON /FKNDAT/ AV0WEL,     APFRMX,     AEFRMX,     AEFRMA,
20128      &                RDSNUC,     V0WELL (2), PFRMMX (2), EFRMMX (2),
20129      &                EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
20130      &                VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
20131      &                PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
20132      &                EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
20133      &                ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV    ,
20134      &                AMRCSQ    , ATO1O3    , ZTO1O3    , ELBNDE (0:100)
20135 * (original name: PAREVT)
20136       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20137      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20138       PARAMETER ( NALLWP = 39   )
20139       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20140      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20141      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20142      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20143 * (original name: NUCOLD)
20144       COMMON /FKNOLD/ HELP (2), HHLP (2), FTVTH (2), FINCX (2),
20145      &                EKPOLD (2), BBOLD, ZZOLD, SQROLD, ASEASQ,
20146      &                FSPRED, FEX0RD
20147 *
20148       BBOLD  = - 1.D+10
20149       ZZOLD  = - 1.D+10
20150       SQROLD = - 1.D+10
20151       APFRMX = PLABRC * ( ANINEN * PIPIPI / EIGEIG )**ONETHI / R0NUCL
20152       AMNUCL (1) = AMPROT
20153       AMNUCL (2) = AMNEUT
20154       AMNUSQ (1) = AMPROT * AMPROT
20155       AMNUSQ (2) = AMNEUT * AMNEUT
20156       AMNHLP = HLFHLF * ( AMNUCL (1) + AMNUCL (2) )
20157       ASQHLP = AMNHLP**2
20158 *     ASQHLP = HLFHLF * ( AMNUSQ (1) + AMNUSQ (2) )
20159       AEFRMX = SQRT ( ASQHLP + APFRMX**2 ) - AMNHLP
20160       AEFRMA = 0.3D+00 * APFRMX**2 / AMNHLP * ( ONEONE - APFRMX**2 /
20161      &         ( 5.6D+00 * ASQHLP ) )
20162       AV0WEL = AEFRMX + EBNDAV
20163       EBNDNG (1) = EBNDAV
20164       EBNDNG (2) = EBNDAV
20165       AEXC12 = EMVGEV * DT_ENERGY( 12.D+00, 6.D+00 )
20166       CEXC12 = EMVGEV * DT_ENRG( 12.D+00, 6.D+00 )
20167       AMMC12 = 12.D+00 * AMUGEV + AEXC12
20168       AMNC12 = AMMC12 - 6.D+00 * AMELCT + FERTHO * 6.D+00**EXPEBN
20169       AEXO16 = EMVGEV * DT_ENERGY( 16.D+00, 8.D+00 )
20170       CEXO16 = EMVGEV * DT_ENRG( 16.D+00, 8.D+00 )
20171       AMMO16 = 16.D+00 * AMUGEV + AEXO16
20172       AMNO16 = AMMO16 - 8.D+00 * AMELCT + FERTHO * 8.D+00**EXPEBN
20173       AEXS28 = EMVGEV * DT_ENERGY( 28.D+00, 14.D+00 )
20174       CEXS28 = EMVGEV * DT_ENRG( 28.D+00, 14.D+00 )
20175       AMMS28 = 28.D+00 * AMUGEV + AEXS28
20176       AMNS28 = AMMS28 - 14.D+00 * AMELCT + FERTHO * 14.D+00**EXPEBN
20177       AEXC40 = EMVGEV * DT_ENERGY( 40.D+00, 20.D+00 )
20178       CEXC40 = EMVGEV * DT_ENRG( 40.D+00, 20.D+00 )
20179       AMMC40 = 40.D+00 * AMUGEV + AEXC40
20180       AMNC40 = AMMC40 - 20.D+00 * AMELCT + FERTHO * 20.D+00**EXPEBN
20181       AEXF56 = EMVGEV * DT_ENERGY( 56.D+00, 26.D+00 )
20182       CEXF56 = EMVGEV * DT_ENRG( 56.D+00, 26.D+00 )
20183       AMMF56 = 56.D+00 * AMUGEV + AEXF56
20184       AMNF56 = AMMF56 - 26.D+00 * AMELCT + FERTHO * 26.D+00**EXPEBN
20185       AEX107 = EMVGEV * DT_ENERGY( 107.D+00, 47.D+00 )
20186       CEX107 = EMVGEV * DT_ENRG( 107.D+00, 47.D+00 )
20187       AMM107 = 107.D+00 * AMUGEV + AEX107
20188       AMN107 = AMM107 - 47.D+00 * AMELCT + FERTHO * 47.D+00**EXPEBN
20189       AEX132 = EMVGEV * DT_ENERGY( 132.D+00, 54.D+00 )
20190       CEX132 = EMVGEV * DT_ENRG( 132.D+00, 54.D+00 )
20191       AMM132 = 132.D+00 * AMUGEV + AEX132
20192       AMN132 = AMM132 - 54.D+00 * AMELCT + FERTHO * 54.D+00**EXPEBN
20193       AEX181 = EMVGEV * DT_ENERGY( 181.D+00, 73.D+00 )
20194       CEX181 = EMVGEV * DT_ENRG( 181.D+00, 73.D+00 )
20195       AMM181 = 181.D+00 * AMUGEV + AEX181
20196       AMN181 = AMM181 - 73.D+00 * AMELCT + FERTHO * 73.D+00**EXPEBN
20197       AEX208 = EMVGEV * DT_ENERGY( 208.D+00, 82.D+00 )
20198       CEX208 = EMVGEV * DT_ENRG( 208.D+00, 82.D+00 )
20199       AMM208 = 208.D+00 * AMUGEV + AEX208
20200       AMN208 = AMM208 - 82.D+00 * AMELCT + FERTHO * 82.D+00**EXPEBN
20201       AEX238 = EMVGEV * DT_ENERGY( 238.D+00, 92.D+00 )
20202       CEX238 = EMVGEV * DT_ENRG( 238.D+00, 92.D+00 )
20203       AMM238 = 238.D+00 * AMUGEV + AEX238
20204       AMN238 = AMM238 - 92.D+00 * AMELCT + FERTHO * 92.D+00**EXPEBN
20205
20206       AMHEAV (1) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ZERZER )
20207       AMHEAV (2) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ONEONE )
20208       AMHEAV (3) = TWOTWO * AMUGEV
20209      &             + EMVGEV * DT_ENERGY( TWOTWO, ONEONE )
20210       AMHEAV (4) = THRTHR * AMUGEV
20211      &             + EMVGEV * DT_ENERGY( THRTHR, ONEONE )
20212       AMHEAV (5) = THRTHR * AMUGEV
20213      &             + EMVGEV * DT_ENERGY( THRTHR, TWOTWO )
20214       AMHEAV (6) = FOUFOU * AMUGEV
20215      &             + EMVGEV * DT_ENERGY( FOUFOU, TWOTWO )
20216       ELBNDE (0) = ZERZER
20217       ELBNDE (1) = 13.6D-09
20218       DO 2000 IZ = 2, 100
20219          ELBNDE ( IZ ) = FERTHO * DBLE ( IZ )**EXPEBN
20220 2000  CONTINUE
20221       AMNHEA (1) = AMHEAV (1) + ELBNDE (0)
20222       AMNHEA (2) = AMHEAV (2) - AMELCT + ELBNDE (1)
20223       AMNHEA (3) = AMHEAV (3) - AMELCT + ELBNDE (1)
20224       AMNHEA (4) = AMHEAV (4) - AMELCT + ELBNDE (1)
20225       AMNHEA (5) = AMHEAV (5) - TWOTWO * AMELCT + ELBNDE (2)
20226       AMNHEA (6) = AMHEAV (6) - TWOTWO * AMELCT + ELBNDE (2)
20227       IF ( LEVPRT ) THEN
20228          WRITE ( LUNOUT, * )' **** Evaporation from residual nucleus',
20229      &                      ' activated **** '
20230          IF ( LDEEXG ) WRITE ( LUNOUT, * )' **** Deexcitation gamma',
20231      &                      ' production activated **** '
20232 **sr 18.5.95
20233 * commented, since obsolete
20234 C        IF ( LHEAVY ) WRITE ( LUNOUT, * )' **** Evaporated "heavies"',
20235 C    &                      ' transport activated **** '
20236          IF ( IFISS .GT. 0 )
20237      &                 WRITE ( LUNOUT, * )' **** High Energy fission ',
20238      &                      ' requested & activated **** '
20239          IF ( LFRMBK )
20240      &                 WRITE ( LUNOUT, * )' **** Fermi Break Up ',
20241      &                      ' requested & activated **** '
20242          IF ( LFRMBK ) CALL DT_FRBKIN(.FALSE.,.FALSE.)
20243       ELSE
20244          LDEEXG = .FALSE.
20245          LHEAVY = .FALSE.
20246          LFRMBK = .FALSE.
20247          IFISS  = 0
20248       END IF
20249       RETURN
20250 *=== End of subroutine incini =========================================*
20251       END
20252
20253 *$ CREATE DT_STALIN.FOR
20254 *COPY DT_STALIN
20255 *                                                                      *
20256 *=== stalin ===========================================================*
20257 *                                                                      *
20258       SUBROUTINE DT_STALIN
20259
20260       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20261       SAVE
20262       PARAMETER ( ANGLGB = 5.0D-16 )
20263       PARAMETER ( ZERZER = 0.D+00 )
20264       PARAMETER ( ONEONE = 1.D+00 )
20265       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20266       PARAMETER ( AMUGEV = 0.93149432         D+00 )
20267       PARAMETER ( EMVGEV = 1.0                D-03 )
20268       PARAMETER ( NSTBIS = 304  )
20269       PARAMETER ( LUNIN  = 5  )
20270       PARAMETER ( LUNOUT = 6  )
20271 *
20272 *----------------------------------------------------------------------*
20273 *                                                                      *
20274 *     STAbility LINe calculation:                                      *
20275 *                                                                      *
20276 *     Created on 04 december 1992  by    Alfredo Ferrari & Paola Sala  *
20277 *                                                   Infn - Milan       *
20278 *                                                                      *
20279 *     Last change on 04-dec-92     by    Alfredo Ferrari               *
20280 *                                                                      *
20281 *                                                                      *
20282 *----------------------------------------------------------------------*
20283 *
20284 * (original name: ISOTOP)
20285       PARAMETER ( NAMSMX = 270 )
20286       PARAMETER ( NZGVAX =  15 )
20287       PARAMETER ( NISMMX = 574 )
20288       COMMON /FKISOT/ WAPS   (NAMSMX,NZGVAX),  T12NUC (NAMSMX,NZGVAX),
20289      &                WAPISM (NISMMX), T12ISM (NISMMX),
20290      &                ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20291      &                AMSSST (100)  , ISOMNM (NSTBIS), ISONDX (2,100),
20292      &                JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20293      &                INWAPS (NAMSMX), JSPISM (NISMMX),
20294      &                JPTISM (NISMMX), IZWISM (NISMMX),
20295      &                INWISM (0:NAMSMX)
20296 *
20297       DIMENSION ZNORM (260)
20298 *  +-------------------------------------------------------------------*
20299 *  |
20300       DO 1000 IZ=1,100
20301          DO 500 J=1,2
20302             ASTLIN (J,IZ) = ZERZER
20303   500    CONTINUE
20304  1000 CONTINUE
20305 *  |
20306 *  +-------------------------------------------------------------------*
20307 *  +-------------------------------------------------------------------*
20308 *  |
20309       DO 2000 IA=1,260
20310          ZNORM (IA) = ZERZER
20311          DO 1500 J=1,2
20312             ZSTLIN (J,IA) = ZERZER
20313  1500    CONTINUE
20314  2000 CONTINUE
20315 *  |
20316 *  +-------------------------------------------------------------------*
20317 *  +-------------------------------------------------------------------*
20318 *  |  Loop on the Atomic Number
20319       DO 3000 IZ=1,100
20320          AMSSST (IZ) = ZERZER
20321          ANORM       = ONEONE
20322          ZTAR        = IZ
20323 *  |  +----------------------------------------------------------------*
20324 *  |  |    Loop on the stable isotopes
20325          DO 2500 IS = ISONDX (1,IZ), ISONDX (2,IZ)
20326             IA = ISOMNM (IS)
20327             ASTLIN (1,IZ) = ASTLIN (1,IZ) + ABUISO (IS) * IA
20328             ASTLIN (2,IZ) = ASTLIN (2,IZ) + ABUISO (IS) * IA**2
20329             ZNORM    (IA) = ZNORM (IA) + ABUISO (IS)
20330             ZSTLIN (1,IA) = ZSTLIN (1,IA) + ABUISO (IS) * IZ
20331             ZSTLIN (2,IA) = ZSTLIN (2,IA) + ABUISO (IS) * IZ**2
20332             AHELP  = IA
20333             IF ( AHELP .LE. 1.00001D+00 ) THEN
20334                ANORM = ONEONE / ( ONEONE - ABUISO (IS) )
20335                GO TO 2500
20336             END IF
20337             AMSSST (IZ) = ABUISO (IS) * ( AHELP * AMUGEV
20338      &                  + EMVGEV * DT_ENERGY(AHELP,ZTAR) ) + AMSSST (IZ)
20339  2500    CONTINUE
20340 *  |  |
20341 *  |  +----------------------------------------------------------------*
20342          AMSSST (IZ) = ANORM * AMSSST (IZ) / AMUGEV
20343 *  |  Normalize and print A_stab versus Z data:
20344          ASTLIN (2,IZ) = MAX ( SQRT (ASTLIN(2,IZ)-ASTLIN(1,IZ)**2),
20345      &                         0.5D+00 )
20346 *        WRITE (LUNOUT,*)'  Z:',IZ,' A_stab:',SNGL(ASTLIN(1,IZ)),
20347 *    &                   '  Sigma_st',SNGL(ASTLIN(2,IZ))
20348  3000 CONTINUE
20349 *  |
20350 *  +-------------------------------------------------------------------*
20351 *  +-------------------------------------------------------------------*
20352 *  |  Normalize and print Z_stab versus A data:
20353       DO 4000 IA=1,260
20354          ZSTLIN (1,IA) = ZSTLIN (1,IA) / MAX ( ZNORM (IA), 1.D-10 )
20355          ZSTLIN (2,IA) = ZSTLIN (2,IA) / MAX ( ZNORM (IA), 1.D-10 )
20356          ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ZSTLIN (1,IA)**2 )
20357          IF ( ZNORM (IA) .GT. ANGLGB )
20358 **sr 2.11. avoid underflows at Pentium
20359      &      ZSTLIN (2,IA) =
20360      &               MAX ( SQRT ( ABS(ZSTLIN(2,IA)-ZSTLIN(1,IA)**2) ),
20361 C    &      ZSTLIN (2,IA) = MAX ( SQRT (ZSTLIN(2,IA)-ZSTLIN(1,IA)**2),
20362      &                            0.3D+00 )
20363  4000 CONTINUE
20364 *  |
20365 *  +-------------------------------------------------------------------*
20366 *  +-------------------------------------------------------------------*
20367 *  |  Normalize and print Z_stab versus A data:
20368       DO 5000 IA=1,260
20369          IF ( ZNORM (IA) .LE. ANGLGB ) THEN
20370             DO 4200 JA = IA-1,1,-1
20371                IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20372                   IA1 = JA
20373                   GO TO 4300
20374                END IF
20375  4200       CONTINUE
20376  4300       CONTINUE
20377             DO 4400 JA = IA+1,260
20378                IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20379                   IA2 = JA
20380                   GO TO 4500
20381                END IF
20382  4400       CONTINUE
20383             IA2 = IA1
20384             IA1 = IA1 - 1
20385  4500       CONTINUE
20386             ZSTLIN (1,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20387      &                    * ( ZSTLIN (1,IA2) - ZSTLIN (1,IA1) )
20388      &                    + ZSTLIN (1,IA1)
20389             ZSTLIN (2,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20390      &                    * ( ZSTLIN (2,IA2) - ZSTLIN (2,IA1) )
20391      &                    + ZSTLIN (2,IA1)
20392          END IF
20393          IZ = MIN ( 100, NINT (ZSTLIN(1,IA)) )
20394          ATOZ = IZ / ASTLIN (1,IZ)
20395          ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ATOZ * ASTLIN (2,IZ) )
20396 *        WRITE (LUNOUT,*)'  A:',IA,' Z_stab:',SNGL(ZSTLIN(1,IA)),
20397 *    &                   '  Sigma_st',SNGL(ZSTLIN(2,IA))
20398  5000 CONTINUE
20399 *  |
20400 *  +-------------------------------------------------------------------*
20401       RETURN
20402       END
20403
20404 *$ CREATE DT_BERTTP.FOR
20405 *COPY DT_BERTTP
20406 *
20407 *=== berttp ===========================================================*
20408 *                                                                      *
20409       SUBROUTINE DT_BERTTP
20410
20411       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20412       SAVE
20413
20414       PARAMETER ( CSNNRM = 2.0D-15 )
20415       PARAMETER ( ZERZER = 0.D+00 )
20416       PARAMETER ( ONEONE = 1.D+00 )
20417       PARAMETER ( THRTHR = 3.D+00 )
20418       PARAMETER ( SIXSIX = 6.D+00 )
20419       PARAMETER ( ONETHI = ONEONE / THRTHR )
20420       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20421       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
20422       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
20423       PARAMETER ( EMVGEV = 1.0                D-03 )
20424
20425       PARAMETER ( NSTBIS = 304  )
20426
20427       PARAMETER ( LUNIN  = 5  )
20428       PARAMETER ( LUNOUT = 6  )
20429 **sr 19.5. set error output-unit from 15 to 6
20430       PARAMETER ( LUNERR = 6  )
20431 C---------------------------------------------------------------------
20432 C SUBNAME = DT_BERTTP --- READ BERTINI DATA
20433 C---------------------------------------------------------------------
20434 C     ---------------------------------- I-N-C DATA
20435 C     COMMON R8(2127),R4(64),CRSC(600,4),R8B(336),CS(29849)
20436 C     REAL*8 R8,R8B,CRSC,CS
20437 C     REAL*4 R4
20438 C     --------------------------------- EVAPORATION DATA
20439 * (original name: COOKCM)
20440       PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
20441       LOGICAL LDEFOZ, LDEFON
20442       PARAMETER ( INCOOK = 150, IZCOOK = 98 )
20443       COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
20444      &                SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
20445      &                PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
20446 * (original name: EVA0)
20447       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
20448      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
20449      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
20450      *                T (4,7), RMASS (297), ALPH (297), BET (297),
20451      *                APRIME (250), IA (6), IZ (6)
20452 * (original name: FRBKCM)
20453       PARAMETER ( MXFFBK =     6 )
20454       PARAMETER ( MXZFBK =     9 )
20455       PARAMETER ( MXNFBK =    10 )
20456       PARAMETER ( MXAFBK =    16 )
20457       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20458       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20459       PARAMETER ( NXAFBK = MXAFBK + 1 )
20460       PARAMETER ( MXPSST =   300 )
20461       PARAMETER ( MXPSFB = 41000 )
20462       LOGICAL LFRMBK, LNCMSS
20463       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20464      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20465      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20466      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
20467      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20468      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20469      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20470      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20471      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
20472 * (original name: HETTP)
20473       COMMON /FKHETP/  NHSTP,NBERTP,IOSUB,INSRS
20474 * (original name: INPFLG)
20475       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20476 * (original name: ISOTOP)
20477       PARAMETER ( NAMSMX = 270 )
20478       PARAMETER ( NZGVAX =  15 )
20479       PARAMETER ( NISMMX = 574 )
20480       COMMON /FKISOT/ WAPS   (NAMSMX,NZGVAX),  T12NUC (NAMSMX,NZGVAX),
20481      &                WAPISM (NISMMX), T12ISM (NISMMX),
20482      &                ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20483      &                AMSSST (100)  , ISOMNM (NSTBIS), ISONDX (2,100),
20484      &                JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20485      &                INWAPS (NAMSMX), JSPISM (NISMMX),
20486      &                JPTISM (NISMMX), IZWISM (NISMMX),
20487      &                INWISM (0:NAMSMX)
20488 * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
20489       PARAMETER ( PI     = PIPIPI )
20490       PARAMETER ( PISQ   = PIPISQ )
20491       PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
20492       PARAMETER ( RZNUCL = 1.12        D+00 )
20493       PARAMETER ( RMSPRO = 0.8         D+00 )
20494       PARAMETER ( R0PROT = RMSPRO / SQRT12  )
20495       PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
20496      &          / R0PROT )
20497       PARAMETER ( RLLE04 = RZNUCL )
20498       PARAMETER ( RLLE16 = RZNUCL )
20499       PARAMETER ( RLGT16 = RZNUCL )
20500       PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
20501       PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
20502       PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
20503       PARAMETER ( SKLE04 = 1.4D+00 )
20504       PARAMETER ( SKLE16 = 1.9D+00 )
20505       PARAMETER ( SKGT16 = 2.4D+00 )
20506       PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
20507       PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
20508       PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
20509       PARAMETER ( ALPHA0 = 0.1D+00 )
20510       PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
20511       PARAMETER ( GAMSK0 = 0.9D+00 )
20512       PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
20513       PARAMETER ( POTME0 = 0.6666666666666667D+00 )
20514       PARAMETER ( POTBA0 = 1.D+00 )
20515       PARAMETER ( PNFRAT = 1.533D+00 )
20516       PARAMETER ( RADPIM = 0.035D+00 )
20517       PARAMETER ( RDPMHL = 14.D+00   )
20518       PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
20519       PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
20520       PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
20521       PARAMETER ( AP0PFS = 0.5D+00 )
20522       PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
20523       PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
20524       PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
20525       PARAMETER ( MXSCIN = 50     )
20526       LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
20527      &        LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
20528       COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
20529      &                RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
20530      &                SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
20531      &                CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
20532      &                PFRTAB (2:260)
20533       COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
20534      &                ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
20535      &                RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
20536      &                YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
20537      &                RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
20538      &                PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
20539      &                PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
20540      &                BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
20541      &                YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
20542      &                XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
20543      &                SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
20544      &                R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
20545      &                PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
20546      &                EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
20547      &                PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
20548      &                EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
20549      &                PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
20550      &                BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
20551       COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
20552      &                RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
20553      &                EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
20554      &                BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
20555      &                WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
20556      &                POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
20557      &                BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
20558      &                SIGPAB (3), SIGNAB (3), HHLP   (2), FORTOT (2),
20559      &                FPNBLC, DPNBLC, FFTFLG, IFTFLG,
20560      &                IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
20561      &                KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
20562      &                NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
20563      &                IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
20564      &                LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
20565       COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
20566       COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
20567      &                YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
20568      &                AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
20569      &                NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
20570      &                NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
20571      &                ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
20572      &                LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
20573      &                LNCDCY, LNUSCT
20574       DIMENSION AWSTAB (2:260), SIGMAB (3)
20575       EQUIVALENCE ( DEFPRO, DEFNUC (1) )
20576       EQUIVALENCE ( DEFNEU, DEFNUC (2) )
20577       EQUIVALENCE ( RHOIPP, RHONCP (1) )
20578       EQUIVALENCE ( RHOINP, RHONCP (2) )
20579       EQUIVALENCE ( RHOIP2, RHONC2 (1) )
20580       EQUIVALENCE ( RHOIN2, RHONC2 (2) )
20581       EQUIVALENCE ( RHOIP3, RHONC3 (1) )
20582       EQUIVALENCE ( RHOIN3, RHONC3 (2) )
20583       EQUIVALENCE ( RHOIPT, RHONCT (1) )
20584       EQUIVALENCE ( RHOINT, RHONCT (2) )
20585       EQUIVALENCE ( OMALHL, SK3PAR )
20586       EQUIVALENCE ( ALPHAL, HABPAR )
20587       EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
20588       EQUIVALENCE ( SIGMPE, SIGMPR (1) )
20589       EQUIVALENCE ( SIGMPC, SIGMPR (2) )
20590       EQUIVALENCE ( SIGMPI, SIGMPR (3) )
20591       EQUIVALENCE ( SIGMPA, SIGMPR (4) )
20592       EQUIVALENCE ( SIGMNE, SIGMNU (1) )
20593       EQUIVALENCE ( SIGMNC, SIGMNU (2) )
20594       EQUIVALENCE ( SIGMNI, SIGMNU (3) )
20595       EQUIVALENCE ( SIGMNA, SIGMNU (4) )
20596       EQUIVALENCE ( SIGMA2, SIGPAB (1) )
20597       EQUIVALENCE ( SIGMA3, SIGPAB (2) )
20598       EQUIVALENCE ( SIGMAS, SIGPAB (3) )
20599       EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
20600 * (original name: NUCLEV)
20601       LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
20602       COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
20603      &                DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
20604      &                CUMRAD (0:160,2), RUSNUC (2),
20605      &                ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
20606      &                NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
20607      &                NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
20608      &                JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
20609      &                MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
20610      &                NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
20611      &                LFLVSL, LRLVSL, LEQSBL
20612       DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
20613      &          MGSSPR (19) , MGSSNE (25)
20614       EQUIVALENCE ( RUSNUC (1), RUSPRO )
20615       EQUIVALENCE ( RUSNUC (2), RUSNEU )
20616       EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
20617       EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
20618       EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
20619       EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
20620       EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
20621       EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
20622       EQUIVALENCE ( NTANUC (1), NTAPRO )
20623       EQUIVALENCE ( NTANUC (2), NTANEU )
20624       EQUIVALENCE ( NAVNUC (1), NAVPRO )
20625       EQUIVALENCE ( NAVNUC (2), NAVNEU )
20626       EQUIVALENCE ( NLSNUC (1), NLSPRO )
20627       EQUIVALENCE ( NLSNUC (2), NLSNEU )
20628       EQUIVALENCE ( NCONUC (1), NCOPRO )
20629       EQUIVALENCE ( NCONUC (2), NCONEU )
20630       EQUIVALENCE ( NSKNUC (1), NSKPRO )
20631       EQUIVALENCE ( NSKNUC (2), NSKNEU )
20632       EQUIVALENCE ( NHANUC (1), NHAPRO )
20633       EQUIVALENCE ( NHANUC (2), NHANEU )
20634       EQUIVALENCE ( NUSNUC (1), NUSPRO )
20635       EQUIVALENCE ( NUSNUC (2), NUSNEU )
20636       EQUIVALENCE ( NACNUC (1), NACPRO )
20637       EQUIVALENCE ( NACNUC (2), NACNEU )
20638       EQUIVALENCE ( JMXNUC (1), JMXPRO )
20639       EQUIVALENCE ( JMXNUC (2), JMXNEU )
20640       EQUIVALENCE ( MAGNUC (1), MAGPRO )
20641       EQUIVALENCE ( MAGNUC (2), MAGNEU )
20642 * (original name: PAREVT)
20643       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20644      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20645       PARAMETER ( NALLWP = 39   )
20646       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20647      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20648      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20649      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20650 * (original name: XSEPAR)
20651       COMMON /FKXSEP/ AANXSE (100), BBNXSE (100), CCNXSE (100),
20652      &                DDNXSE (100), EENXSE (100), ZZNXSE (100),
20653      &                EMNXSE (100), XMNXSE (100),
20654      &                AAPXSE (100), BBPXSE (100), CCPXSE (100),
20655      &                DDPXSE (100), EEPXSE (100), FFPXSE (100),
20656      &                ZZPXSE (100), EMPXSE (100), XMPXSE (100)
20657
20658 C---------------------------------------------------------------------
20659 **sr 17.5.95
20660 * modified for use in DPMJET
20661 C     WRITE( LUNOUT,'(A,I2)')
20662 C    & ' *** Reading evaporation and nuclear data from unit: ', NBERTP
20663 C     REWIND NBERTP
20664       IF (LEVPRT) WRITE(LUNOUT,1000)
20665  1000 FORMAT(/,1X,'BERTTP:',4X,'Initialization of evaporation module',
20666      &       /,12X,'------------------------------------',/)
20667       NBERNW = 23
20668       OPEN (UNIT=NBERNW,FILE='dpmjet.dat',STATUS='UNKNOWN')
20669
20670 **sr 17.5.
20671 *!!!! changed to be able to read the ASCII !!!!
20672 **
20673 C A. Ferrari: first of all read isotopic data
20674       READ (NBERNW,*) ISONDX
20675       READ (NBERNW,*) ISOMNM
20676       READ (NBERNW,*) ABUISO
20677 C     READ (NBERTP) ISONDX
20678 C     READ (NBERTP) ISOMNM
20679 C     READ (NBERTP) ABUISO
20680       DO 1 I=1,4
20681 C        READ  (NBERTP) (CRSC(J,I),J=1,600)
20682 C A. Ferrari: commented also the dummy read to save disk space
20683 C        READ  (NBERTP)
20684     1 CONTINUE
20685 C     READ  (NBERTP) CS
20686 C A. Ferrari: commented also the dummy read to save disk space
20687 C     READ  (NBERTP)
20688 C---------------------------------------------------------------------
20689       READ (NBERNW,*) (P0(I),P1(I),P2(I),I=1,1001)
20690       READ (NBERNW,*) IA,IZ
20691       DO 2 I=1,6
20692          FLA(I)=IA(I)
20693          FLZ(I)=IZ(I)
20694     2 CONTINUE
20695       READ (NBERNW,*) RHO,OMEGA
20696       READ (NBERNW,*) EXMASS
20697       READ (NBERNW,*) CAM2
20698       READ (NBERNW,*) CAM3
20699       READ (NBERNW,*) CAM4
20700       READ (NBERNW,*) CAM5
20701       READ (NBERNW,*) ((T(I,J),J=1,7),I=1,3)
20702       DO 3 I=1,7
20703          T(4,I) = ZERZER
20704     3 CONTINUE
20705       READ (NBERNW,*) RMASS
20706       READ (NBERNW,*) ALPH
20707       READ (NBERNW,*) BET
20708       READ (NBERNW,*) INWAPS
20709       READ (NBERNW,*) WAPS
20710       READ (NBERNW,*) T12NUC
20711       READ (NBERNW,*) JSPNUC
20712       READ (NBERNW,*) JPTNUC
20713       READ (NBERNW,*) INWISM
20714       READ (NBERNW,*) IZWISM
20715       READ (NBERNW,*) WAPISM
20716       READ (NBERNW,*) T12ISM
20717       READ (NBERNW,*) JSPISM
20718       READ (NBERNW,*) JPTISM
20719       READ (NBERNW,*) APRIME
20720       IF (LEVPRT)
20721      &WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20722       READ (NBERNW,*) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20723       IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20724      &     ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20725          WRITE (LUNOUT,*)
20726      &         ' *** Inconsistent Nuclear Geometry data on file ***'
20727          STOP
20728       END IF
20729       READ (NBERNW,*) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20730      &              EKATAB, PFATAB, PFRTAB
20731       READ (NBERNW,*) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20732      &              EMNXSE, XMNXSE
20733       READ (NBERNW,*) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20734      &              ZZPXSE, EMPXSE, XMPXSE
20735 *  Data about Fermi-breakup:
20736       READ (NBERNW,*) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20737       IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20738      &     MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20739          WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20740      &                   ' in the Nuclear Data file ***'
20741          STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20742       END IF
20743       READ (NBERNW,*) IFRBKN
20744       READ (NBERNW,*) IFRBKZ
20745       READ (NBERNW,*) IFBKSP
20746       READ (NBERNW,*) IFBKST
20747       READ (NBERNW,*) EEXFBK
20748
20749       CLOSE (UNIT=NBERNW)
20750
20751 C     READ (NBERTP) (P0(I),P1(I),P2(I),I=1,1001)
20752 C     READ (NBERTP) IA,IZ
20753 C     DO 2 I=1,6
20754 C        FLA(I)=IA(I)
20755 C        FLZ(I)=IZ(I)
20756 C   2 CONTINUE
20757 C     READ (NBERTP) RHO,OMEGA
20758 C     READ (NBERTP) EXMASS
20759 C     READ (NBERTP) CAM2
20760 C     READ (NBERTP) CAM3
20761 C     READ (NBERTP) CAM4
20762 C     READ (NBERTP) CAM5
20763 C     READ (NBERTP) ((T(I,J),J=1,7),I=1,3)
20764 C     DO 3 I=1,7
20765 C        T(4,I) = ZERZER
20766 C   3 CONTINUE
20767 C     READ (NBERTP) RMASS
20768 C     READ (NBERTP) ALPH
20769 C     READ (NBERTP) BET
20770 C     READ (NBERTP) INWAPS
20771 C     READ (NBERTP) WAPS
20772 C     READ (NBERTP) T12NUC
20773 C     READ (NBERTP) JSPNUC
20774 C     READ (NBERTP) JPTNUC
20775 C     READ (NBERTP) INWISM
20776 C     READ (NBERTP) IZWISM
20777 C     READ (NBERTP) WAPISM
20778 C     READ (NBERTP) T12ISM
20779 C     READ (NBERTP) JSPISM
20780 C     READ (NBERTP) JPTISM
20781 C     READ (NBERTP) APRIME
20782 C     WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20783 C     READ (NBERTP) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20784 C     IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20785 C    &     ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20786 C        WRITE (LUNOUT,*)
20787 C    &         ' *** Inconsistent Nuclear Geometry data on file ***'
20788 C        STOP
20789 C     END IF
20790 C     READ (NBERTP) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20791 C    &              EKATAB, PFATAB, PFRTAB
20792 C     READ (NBERTP) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20793 C    &              EMNXSE, XMNXSE
20794 C     READ (NBERTP) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20795 C    &              ZZPXSE, EMPXSE, XMPXSE
20796 *  Data about Fermi-breakup:
20797 C     READ (NBERTP) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20798 C     IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20799 C    &     MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20800 C        WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20801 C    &                   ' in the Nuclear Data file ***'
20802 C        STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20803 C     END IF
20804 C     READ (NBERTP) IFRBKN
20805 C     READ (NBERTP) IFRBKZ
20806 C     READ (NBERTP) IFBKSP
20807 C     READ (NBERTP) IFBKST
20808 C     READ (NBERTP) EEXFBK
20809 C     CLOSE (UNIT=NBERTP)
20810       DO 100 JZ = 1, 130
20811          SHENUC ( JZ, 1 ) = EMVGEV * ( CAM2 (JZ) + CAM4 (JZ) )
20812   100 CONTINUE
20813       DO 200 JA = 1, 200
20814          SHENUC ( JA, 2 ) = EMVGEV * ( CAM3 (JA) + CAM5 (JA) )
20815   200 CONTINUE
20816       CALL DT_STALIN
20817       IF ( ILVMOD .LE. 0 ) THEN
20818          ILVMOD = IB0
20819       ELSE
20820          IB0 = ILVMOD
20821       END IF
20822       IF ( LLVMOD ) THEN
20823          DO 300 JZ = 1, IZCOOK
20824             CAM4 (JZ) = PZCOOK (JZ)
20825   300    CONTINUE
20826          DO 400 JN = 1, INCOOK
20827             CAM5 (JN) = PNCOOK (JZ)
20828   400    CONTINUE
20829       END IF
20830 **sr
20831       IF (LEVPRT) THEN
20832          WRITE (LUNOUT,*)
20833          IF ( ILVMOD .EQ. 1 ) THEN
20834             WRITE (LUNOUT,*)
20835      &   ' **** Standard EVAP T=0 level density used ****'
20836          ELSE IF ( ILVMOD .EQ. 2 ) THEN
20837             WRITE (LUNOUT,*)
20838      &   ' **** Gilbert & Cameron T=0 N,Z-dep. level density used ****'
20839          ELSE IF ( ILVMOD .EQ. 3 ) THEN
20840             WRITE (LUNOUT,*)
20841      &      ' **** Julich A-dependent level density used ****'
20842          ELSE IF ( ILVMOD .EQ. 4 ) THEN
20843             WRITE (LUNOUT,*)
20844      &   ' **** Brancazio & Cameron T=0 N,Z-dep. level density used',
20845      &                                                          ' ****'
20846          ELSE
20847             WRITE (LUNOUT,*)
20848      &   ' **** Unknown T=0 level density option requested ****'
20849             STOP 'BERTTP-ILVMOD'
20850          END IF
20851          IF ( JLVMOD .LE. 0 ) THEN
20852             GAMIGN = ZERZER
20853             WRITE (LUNOUT,*)
20854      &   ' **** No Excitation en. dependence for level densities ****'
20855          ELSE IF ( JLVMOD .EQ. 1 ) THEN
20856             WRITE (LUNOUT,*)
20857      &   ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20858             WRITE (LUNOUT,*)
20859      &   ' **** with Ignyatuk (1975, 1st) set of parameters for T=oo',
20860      &                                                        ' ****'
20861             GAMIGN = 0.054D+00
20862             BETIGN = -6.3 D-05
20863             ALPIGN = 0.154D+00
20864             POWIGN = ZERZER
20865          ELSE IF ( JLVMOD .EQ. 2 ) THEN
20866             WRITE (LUNOUT,*)
20867      &   ' ****   Ignyatuk (1975, 1st) level density en. dep. used ****'
20868             WRITE (LUNOUT,*)
20869      &   ' **** with UNKNOWN set of parameters for T=oo ****'
20870             STOP 'BERTTP-JLVMOD'
20871          ELSE IF ( JLVMOD .EQ. 3 ) THEN
20872             WRITE (LUNOUT,*)
20873      &   ' ****   Ignyatuk (1975, 1st) level density en. dep. used ****'
20874             WRITE (LUNOUT,*)
20875      &   ' **** with UNKNOWN set of parameters for T=oo ****'
20876             STOP 'BERTTP-JLVMOD'
20877          ELSE IF ( JLVMOD .EQ. 4 ) THEN
20878             WRITE (LUNOUT,*)
20879      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20880             WRITE (LUNOUT,*)
20881      &   ' **** with Ignyatuk (1975, 2nd) set of parameters for T=oo',
20882      &                                                        ' ****'
20883             GAMIGN = 0.054D+00
20884             BETIGN = 0.162D+00
20885             ALPIGN = 0.114D+00
20886             POWIGN = -ONETHI
20887          ELSE IF ( JLVMOD .EQ. 5 ) THEN
20888             WRITE (LUNOUT,*)
20889      &   ' ****  Ignyatuk (1975, 2nd) level density en. dep. used  ****'
20890             WRITE (LUNOUT,*)
20891      &   ' **** with Iljinov & Mebel 1st set of parameters for T=oo****'
20892             GAMIGN = 0.051D+00
20893             BETIGN = 0.098D+00
20894             ALPIGN = 0.114D+00
20895             POWIGN = -ONETHI
20896          ELSE IF ( JLVMOD .EQ. 6 ) THEN
20897             WRITE (LUNOUT,*)
20898      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20899             WRITE (LUNOUT,*)
20900      &   ' **** with Iljinov & Mebel 2nd set of parameters for T=oo****'
20901             GAMIGN = -0.46D+00
20902             BETIGN = 0.107D+00
20903             ALPIGN = 0.111D+00
20904             POWIGN = -ONETHI
20905          ELSE IF ( JLVMOD .EQ. 7 ) THEN
20906             WRITE (LUNOUT,*)
20907      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20908             WRITE (LUNOUT,*)
20909      &   ' **** with Iljinov & Mebel 3rd set of parameters for T=oo****'
20910             GAMIGN = 0.059D+00
20911             BETIGN = 0.257D+00
20912             ALPIGN = 0.072D+00
20913             POWIGN = -ONETHI
20914          ELSE IF ( JLVMOD .EQ. 8 ) THEN
20915             WRITE (LUNOUT,*)
20916      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20917             WRITE (LUNOUT,*)
20918      &   ' **** with Iljinov & Mebel 4th set of parameters for T=oo****'
20919             GAMIGN = -0.37D+00
20920             BETIGN = 0.229D+00
20921             ALPIGN = 0.077D+00
20922             POWIGN = -ONETHI
20923          ELSE
20924             WRITE (LUNOUT,*)
20925      &   ' **** Unknown T=oo level density option requested ****'
20926             STOP 'BERTTP-JLVMOD'
20927          END IF
20928          IF ( LLVMOD ) THEN
20929             WRITE (LUNOUT,*)
20930      &      ' **** Cook''s modified pairing energy used ****'
20931          ELSE
20932             WRITE (LUNOUT,*)
20933      &      ' **** Original Gilbert/Cameron pairing energy used ****'
20934          END IF
20935       ENDIF
20936 **
20937
20938       ILVMOD = IB0
20939       DO 500 JZ = 1, 130
20940          PAENUC ( JZ, 1 ) = EMVGEV * CAM4 (JZ)
20941   500 CONTINUE
20942       DO 600 JA = 1, 200
20943          PAENUC ( JA, 2 ) = EMVGEV * CAM5 (JA)
20944   600 CONTINUE
20945       RETURN
20946       END
20947
20948 *$ CREATE DT_EVEVAP.FOR
20949 *COPY DT_EVEVAP
20950 *
20951 *====evevap============================================================*
20952 *
20953       SUBROUTINE DT_EVEVAP(WE)
20954
20955       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20956       SAVE
20957       PARAMETER ( LINP = 10 ,
20958      &            LOUT = 6 ,
20959      &            LDAT = 9 )
20960
20961 * flags for input different options
20962       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
20963       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
20964      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
20965
20966       LEVAPO = .FALSE.
20967
20968       RETURN
20969       END
20970
20971 *$ CREATE DT_FRBKIN.FOR
20972 *COPY DT_FRBKIN
20973 *
20974 *====frbkin============================================================*
20975 *
20976       SUBROUTINE DT_FRBKIN(LDUM1,LDUM2)
20977
20978       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20979       SAVE
20980       PARAMETER ( LINP = 10 ,
20981      &            LOUT = 6 ,
20982      &            LDAT = 9 )
20983
20984       LOGICAL LDUM1,LDUM2
20985
20986       RETURN
20987       END
20988
20989 *$ CREATE DT_EXPLOD.FOR
20990 *COPY DT_EXPLOD
20991 *
20992 *=== explod ===========================================================*
20993 *
20994       SUBROUTINE DT_EXPLOD( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
20995      &                    PYEXPL, PZEXPL )
20996
20997       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20998       SAVE
20999
21000       DIMENSION PXEXPL (NPEXPL), PYEXPL (NPEXPL), PZEXPL (NPEXPL),
21001      &          ETEXPL (NPEXPL), AMEXPL (NPEXPL)
21002
21003       RETURN
21004       END
21005
21006 ************************************************************************
21007 *                                                                      *
21008 *  DPMJET 3.0:   cross section routines                                *
21009 *                                                                      *
21010 ************************************************************************
21011 *
21012 *
21013 *     SUBROUTINE DT_SHNDIF
21014 *         diffractive cross sections (all energies)
21015 *     SUBROUTINE DT_PHOXS
21016 *         total and inel. cross sections from PHOJET interpol. tables
21017 *     SUBROUTINE DT_XSHN
21018 *         total and el. cross sections for all energies
21019 *     SUBROUTINE DT_SIHNAB
21020 *         pion 2-nucleon absorption cross sections
21021 *     SUBROUTINE DT_SIGEMU
21022 *         cross section for target "compounds"
21023 *     SUBROUTINE DT_SIGGA
21024 *         photon nucleus cross sections
21025 *     SUBROUTINE DT_SIGGAT
21026 *         photon nucleus cross sections from tables
21027 *     SUBROUTINE DT_SANO
21028 *         anomalous hard photon-nucleon cross sections from tables
21029 *     SUBROUTINE DT_SIGGP
21030 *         photon nucleon cross sections
21031 *     SUBROUTINE DT_SIGVEL
21032 *         quasi-elastic vector meson prod. cross sections
21033 *     DOUBLE PRECISION FUNCTION DT_SIGVP
21034 *         sigma_VN(tilde)
21035 *     DOUBLE PRECISION FUNCTION DT_RRM2
21036 *     DOUBLE PRECISION FUNCTION DT_RM2
21037 *     DOUBLE PRECISION FUNCTION DT_SAM2
21038 *     SUBROUTINE DT_CKMT
21039 *     SUBROUTINE DT_CKMTX
21040 *     SUBROUTINE DT_PDF0
21041 *     SUBROUTINE DT_CKMTQ0
21042 *     SUBROUTINE DT_CKMTDE
21043 *     SUBROUTINE DT_CKMTPR
21044 *     FUNCTION DT_CKMTFF
21045 *
21046 *     SUBROUTINE DT_FLUINI
21047 *         total nucleon cross section fluctuation treatment
21048 *
21049 *     SUBROUTINE DT_SIGTBL
21050 *         pre-tabulation of low-energy elastic x-sec. using SIHNEL
21051 *     SUBROUTINE DT_XSTABL
21052 *         service routines
21053 *
21054 *
21055 *$ CREATE DT_SHNDIF.FOR
21056 *COPY DT_SHNDIF
21057 *
21058 *===shndif===============================================================*
21059 *
21060       SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
21061
21062 **********************************************************************
21063 *   Single diffractive hadron-nucleon cross sections                 *
21064 *                                              S.Roesler 14/1/93     *
21065 *                                                                    *
21066 *   The cross sections are calculated from extrapolated single       *
21067 *   diffractive antiproton-proton cross sections (DTUJET92) using    *
21068 *   scaling relations between total and single diffractive cross     *
21069 *   sections.                                                        *
21070 **********************************************************************
21071
21072       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21073       SAVE
21074       PARAMETER (ZERO=0.0D0)
21075
21076 * particle properties (BAMJET index convention)
21077       CHARACTER*8  ANAME
21078       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21079      &                IICH(210),IIBAR(210),K1(210),K2(210)
21080 *
21081       CSD1   =   4.201483727D0
21082       CSD4   = -0.4763103556D-02
21083       CSD5   =  0.4324148297D0
21084 *
21085       CHMSD1 =  0.8519297242D0
21086       CHMSD4 = -0.1443076599D-01
21087       CHMSD5 =  0.4014954567D0
21088 *
21089       EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
21090       PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
21091 *
21092       SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21093       SHMSD  = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
21094       FRAC   = SHMSD/SDIAPP
21095 *
21096       GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
21097      &     999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
21098      &      10, 10, 20, 20, 20) KPROJ
21099 *
21100    10 CONTINUE
21101 *---------------------------- p - p , n - p , sigma0+- - p ,
21102 *                             Lambda - p
21103       CSD1   =  6.004476070D0
21104       CSD4   = -0.1257784606D-03
21105       CSD5   =  0.2447335720D0
21106       SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21107       SIGDIH = FRAC*SIGDIF
21108       RETURN
21109 *
21110    20 CONTINUE
21111 *
21112       KPSCAL = 2
21113       KTSCAL = 1
21114 C     F      = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
21115       DUMZER = ZERO
21116       CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
21117       F      = SDIAPP/SIGTO
21118       KT     = 1
21119 C     SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
21120       CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
21121       SIGDIF = SIGTO*F
21122       SIGDIH = FRAC*SIGDIF
21123       RETURN
21124 *
21125   999 CONTINUE
21126 *-------------------------- leptons..
21127       SIGDIF = 1.D-10
21128       SIGDIH = 1.D-10
21129       RETURN
21130       END
21131
21132 *$ CREATE DT_PHOXS.FOR
21133 *COPY DT_PHOXS
21134 *
21135 *===phoxs================================================================*
21136 *
21137       SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
21138
21139 ************************************************************************
21140 * Total/inelastic proton-nucleon cross sections taken from PHOJET-     *
21141 * interpolation tables.                                                *
21142 * This version dated 05.11.97 is written by S. Roesler                 *
21143 ************************************************************************
21144
21145       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21146       SAVE
21147
21148       PARAMETER ( LINP = 10 ,
21149      &            LOUT = 6 ,
21150      &            LDAT = 9 )
21151       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21152       PARAMETER (TWOPI  = 6.283185307179586454D+00,
21153      &           PI     = TWOPI/TWO,
21154      &           GEV2MB = 0.38938D0)
21155
21156       LOGICAL LFIRST
21157       DATA LFIRST /.TRUE./
21158
21159 * nucleon-nucleon event-generator
21160       CHARACTER*8 CMODEL
21161       LOGICAL LPHOIN
21162       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21163 * particle properties (BAMJET index convention)
21164       CHARACTER*8  ANAME
21165       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21166      &                IICH(210),IIBAR(210),K1(210),K2(210)
21167
21168 **PHOJET105a
21169 C     PARAMETER (IEETAB=10)
21170 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21171 **PHOJET110
21172 C  energy-interpolation table
21173       INTEGER IEETA2
21174       PARAMETER ( IEETA2 = 20 )
21175       INTEGER ISIMAX
21176       DOUBLE PRECISION SIGTAB,SIGECM
21177       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21178 **
21179
21180       IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
21181          WRITE(LOUT,*) MCGENE
21182  1000    FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
21183          STOP
21184       ENDIF
21185
21186       IF (ECM.LE.ZERO) THEN
21187          EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
21188          ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
21189       ENDIF
21190
21191       IF (MODE.EQ.1) THEN
21192 * DL
21193          DELDL = 0.0808D0
21194          EPSDL = -0.4525D0
21195          S     = ECM*ECM
21196          STOT  = 21.7D0*S**DELDL+56.08D0*S**EPSDL
21197          ALPHAP= 0.25D0
21198          BEL   = 8.5D0+2.D0*ALPHAP*LOG(S)
21199          SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
21200          SINE  = STOT-SIGEL
21201          SDIF1 = ZERO
21202       ELSE
21203 * Phojet
21204          IP = 1
21205          IF(ECM.LE.SIGECM(IP,1)) THEN
21206            I1 = 1
21207            I2 = 1
21208          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21209            DO 1 I=2,ISIMAX
21210               IF (ECM.LE.SIGECM(IP,I)) GOTO 2
21211     1      CONTINUE
21212     2      CONTINUE
21213            I1 = I-1
21214            I2 = I
21215          ELSE
21216            IF (LFIRST) THEN
21217               WRITE(LOUT,'(/1X,A,2E12.3)')
21218      &          'PHOXS: warning! energy above initialization limit (',
21219      &          ECM,SIGECM(IP,ISIMAX)
21220              LFIRST = .FALSE.
21221            ENDIF
21222            I1 = ISIMAX
21223            I2 = ISIMAX
21224          ENDIF
21225          FAC2 = ZERO
21226          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21227      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21228          FAC1  = ONE-FAC2
21229          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21230          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21231          SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
21232      &           FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
21233          BEL   = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
21234       ENDIF
21235
21236       RETURN
21237       END
21238
21239 *$ CREATE DT_XSHN.FOR
21240 *COPY DT_XSHN
21241 *
21242 *===xshn===============================================================*
21243 *
21244       SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
21245
21246 ************************************************************************
21247 * Total and elastic hadron-nucleon cross section.                      *
21248 * Below 500GeV cross sections are based on the '98 data compilation    *
21249 * of the PDG. At higher energies PHOJET results are used (patched to   *
21250 * the low energy data at 500GeV).                                      *
21251 *     IP      projectile index (BAMJET numbering scheme)               *
21252 *             (should be in the range 1..25)                           *
21253 *     IT      target index (BAMJET numbering scheme)                   *
21254 *             (1 = proton, 8 = neutron)                                *
21255 *     PL      laboratory momentum                                      *
21256 *     ECM     cm. energy (ignored if PL>0)                             *
21257 *     STOT    total cross section                                      *
21258 *     SELA    elastic cross section                                    *
21259 * Last change: 24.4.99 by S. Roesler                                   *
21260 ************************************************************************
21261
21262       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21263       SAVE
21264
21265       PARAMETER ( LINP = 10 ,
21266      &            LOUT = 6 ,
21267      &            LDAT = 9 )
21268       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
21269
21270       PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
21271      &           PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
21272       PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
21273
21274       LOGICAL LFIRST
21275 * particle properties (BAMJET index convention)
21276       CHARACTER*8  ANAME
21277       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21278      &                IICH(210),IIBAR(210),K1(210),K2(210)
21279 * nucleon-nucleon event-generator
21280       CHARACTER*8 CMODEL
21281       LOGICAL LPHOIN
21282       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21283 **PHOJET105a
21284 C     PARAMETER (IEETAB=10)
21285 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21286 **PHOJET110
21287 C  energy-interpolation table
21288       INTEGER IEETA2
21289       PARAMETER ( IEETA2 = 20 )
21290       INTEGER ISIMAX
21291       DOUBLE PRECISION SIGTAB,SIGECM
21292       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21293
21294       DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
21295       DIMENSION IDXDAT(25,2)
21296 *
21297       DATA APL /
21298      &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
21299      &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
21300      &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
21301      &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
21302      & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
21303      & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
21304      & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
21305 *
21306 * total cross sections:
21307 * p p
21308       DATA (ASIGTO(1,K),K=1,NPOINT) /
21309      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21310      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21311      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
21312      & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
21313      & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
21314      & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
21315      & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
21316 * pbar p
21317       DATA (ASIGTO(2,K),K=1,NPOINT) /
21318      & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
21319      & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
21320      & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
21321      & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
21322      & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
21323      & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
21324      & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
21325 * n p
21326       DATA (ASIGTO(3,K),K=1,NPOINT) /
21327      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21328      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21329      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21330      & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
21331      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21332      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21333      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21334 * pi+ p
21335       DATA (ASIGTO(4,K),K=1,NPOINT) /
21336      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21337      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21338      & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
21339      & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
21340      & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
21341      & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
21342      & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
21343 * pi- p
21344       DATA (ASIGTO(5,K),K=1,NPOINT) /
21345      & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
21346      & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
21347      & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
21348      & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
21349      & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
21350      & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
21351      & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
21352 * K+ p
21353       DATA (ASIGTO(6,K),K=1,NPOINT) /
21354      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21355      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21356      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
21357      & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
21358      & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
21359      & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
21360      & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
21361 * K- p
21362       DATA (ASIGTO(7,K),K=1,NPOINT) /
21363      & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
21364      & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
21365      & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
21366      & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
21367      & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
21368      & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
21369      & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21370 * K+ n
21371       DATA (ASIGTO(8,K),K=1,NPOINT) /
21372      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21373      & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21374      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21375      & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21376      & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21377      & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21378      & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21379 * K- n
21380       DATA (ASIGTO(9,K),K=1,NPOINT) /
21381      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21382      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21383      & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21384      & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21385      & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21386      & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21387      & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21388 * Lambda p
21389       DATA (ASIGTO(10,K),K=1,NPOINT) /
21390      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21391      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21392      & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21393      & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21394      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21395      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21396      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21397 *
21398 * elastic cross sections:
21399 * p p
21400       DATA (ASIGEL(1,K),K=1,NPOINT) /
21401      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21402      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21403      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21404      & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21405      & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21406      & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21407      & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21408 * pbar p
21409       DATA (ASIGEL(2,K),K=1,NPOINT) /
21410      & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21411      & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21412      & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21413      & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21414      & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21415      & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21416      & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21417 * n p
21418       DATA (ASIGEL(3,K),K=1,NPOINT) /
21419      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21420      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21421      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21422      & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21423      & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21424      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21425      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21426 * pi+ p
21427       DATA (ASIGEL(4,K),K=1,NPOINT) /
21428      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21429      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21430      & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21431      & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21432      & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21433      & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21434      & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21435 * pi- p
21436       DATA (ASIGEL(5,K),K=1,NPOINT) /
21437      & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21438      & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21439      & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21440      & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21441      & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21442      & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21443      & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21444 * K+ p
21445       DATA (ASIGEL(6,K),K=1,NPOINT) /
21446      & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21447      & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21448      & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21449      & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21450      & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21451      & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21452      & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21453 * K- p
21454       DATA (ASIGEL(7,K),K=1,NPOINT) /
21455      & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21456      & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21457      & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21458      & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21459      & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21460      & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21461      & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21462 * K+ n
21463       DATA (ASIGEL(8,K),K=1,NPOINT) /
21464      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21465      & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21466      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21467      & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21468      & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21469      & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21470      & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21471 * K- n
21472       DATA (ASIGEL(9,K),K=1,NPOINT) /
21473      & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21474      & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21475      & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21476      & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21477      & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21478      & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21479      & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21480 * Lambda p
21481       DATA (ASIGEL(10,K),K=1,NPOINT) /
21482      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21483      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21484      & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21485      & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21486      & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21487      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21488      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21489
21490       DATA (IDXDAT(K,1),K=1,25) /
21491      &  1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21492      &  1, 3,45, 8, 9/
21493       DATA (IDXDAT(K,2),K=1,25) /
21494      &  3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21495      &  3, 1,45, 6, 7/
21496
21497       DATA LFIRST /.TRUE./
21498
21499       IF (LFIRST) THEN
21500          APLABL = LOG10(PLABLO)
21501          APLABH = LOG10(PLABHI)
21502          APTHRE = LOG10(PTHRE)
21503          ADP1   = (APTHRE-APLABL)/DBLE(NPOIN1)
21504          ADP2   = (APLABH-APTHRE)/DBLE(NPOIN2)
21505          DUM0   = ZERO
21506          PHOPLA = PLABHI
21507          PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21508          ECMS   = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21509          IF (MCGENE.EQ.2) THEN
21510             IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21511                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21512             ELSE
21513                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21514             ENDIF
21515          ELSE
21516             CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21517          ENDIF
21518          PHOSEL = PHOSTO-PHOSIN
21519          APHOST = LOG10(PHOSTO)
21520          APHOSE = LOG10(PHOSEL)
21521          LFIRST = .FALSE.
21522       ENDIF
21523       STOT = ZERO
21524       SELA = ZERO
21525       PLAB = PL
21526       ECMS = ECM
21527       IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21528          WRITE(LOUT,1000) IP,IT
21529  1000    FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21530      &          'proj/target',2I4)
21531          STOP
21532       ENDIF
21533
21534       IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21535          ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21536          PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21537       ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21538          WRITE(LOUT,1001) PLAB,ECMS
21539  1001    FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21540          STOP
21541       ENDIF
21542
21543 * index of spectrum
21544       IDXP = IP
21545       IF (IP.GT.25) THEN
21546          IF (AAM(IP).GT.ZERO) THEN
21547             IF (ABS(IIBAR(IP)).GT.0) THEN
21548                IDXP = 1
21549             ELSE
21550                IDXP = 13
21551             ENDIF
21552          ELSE
21553             IDXP = 7
21554          ENDIF
21555       ENDIF
21556       IDXT = 1
21557       IF (IT.EQ.8) IDXT = 2
21558       IDXS = IDXDAT(IDXP,IDXT)
21559       IF (IDXS.EQ.0) RETURN
21560
21561 * compute momentum bin indices
21562       IF (PLAB.LT.PLABLO) THEN
21563          IDX0 = 1
21564          IDX1 = 1
21565       ELSEIF (PLAB.GE.PLABHI) THEN
21566          IDX0 = NPOINT
21567          IDX1 = NPOINT
21568       ELSE
21569          APLAB = LOG10(PLAB)
21570          IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21571             IDX0 = INT((APLAB-APLABL)/ADP1)+1
21572          ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21573             IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21574          ENDIF
21575          IDX1 = IDX0+1
21576       ENDIF
21577
21578 * interpolate cross section
21579       IF (IDXS.GT.10) THEN
21580          IDXS1 = IDXS/10
21581          IDXS2 = IDXS-10*IDXS1
21582          IF (IDX0.EQ.IDX1) THEN
21583             IF (IDX0.EQ.1) THEN
21584                ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21585                ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21586             ELSE
21587                DUM0   = ZERO
21588                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21589                PHOSEL = PHOSTO-PHOSIN
21590                ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21591                ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21592                ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21593                ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21594                ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
21595                ASELA  = 0.5D0*(ASELA1+ASELA2)
21596             ENDIF
21597          ELSE
21598             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21599             ASTOT1 = ASIGTO(IDXS1,IDX0)+
21600      &               FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21601             ASTOT2 = ASIGTO(IDXS2,IDX0)+
21602      &               FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21603             ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
21604             ASELA1 = ASIGEL(IDXS1,IDX0)+
21605      &               FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21606             ASELA2 = ASIGEL(IDXS2,IDX0)+
21607      &               FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21608             ASELA  = 0.5D0*(ASELA1+ASELA2)
21609          ENDIF
21610       ELSE
21611          IF (IDX0.EQ.IDX1) THEN
21612             IF (IDX0.EQ.1) THEN
21613                ASTOT = ASIGTO(IDXS,IDX0)
21614                ASELA = ASIGEL(IDXS,IDX0)
21615             ELSE
21616                DUM0   = ZERO
21617                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21618                PHOSEL = PHOSTO-PHOSIN
21619                ASTOT  = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21620                ASELA  = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21621             ENDIF
21622          ELSE
21623             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21624             ASTOT = ASIGTO(IDXS,IDX0)+
21625      &              FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21626             ASELA = ASIGEL(IDXS,IDX0)+
21627      &              FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21628          ENDIF
21629       ENDIF
21630       STOT = 10.0D0**ASTOT
21631       SELA = 10.0D0**ASELA
21632
21633       RETURN
21634       END
21635
21636 *$ CREATE DT_SIHNAB.FOR
21637 *COPY DT_SIHNAB
21638 *
21639 *===sihnab===============================================================*
21640 *
21641       SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21642
21643 **********************************************************************
21644 * Pion 2-nucleon absorption cross sections.                          *
21645 * (sigma_tot for pi+ d --> p p, pi- d --> n n                        *
21646 *  taken from Ritchie PRC 28 (1983) 926 )                            *
21647 * This version dated 18.05.96 is written by S. Roesler               *
21648 **********************************************************************
21649
21650       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21651       SAVE
21652       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21653       PARAMETER (AMPR = 938.0D0,
21654      &           AMPI = 140.0D0,
21655      &           AMDE = TWO*AMPR,
21656      &           A    = -1.2D0,
21657      &           B    = 3.5D0,
21658      &           C    = 7.4D0,
21659      &           D    = 5600.0D0,
21660      &           ER   = 2136.0D0)
21661
21662       SIGABS = ZERO
21663       IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21664      &                   .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21665       PTOT = PLAB*1.0D3
21666       EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21667       IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21668       ECM  = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21669       SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21670 * approximate 3N-abs., I=1-abs. etc.
21671       SIGABS = SIGABS/0.40D0
21672 * pi0-absorption (rough approximation!!)
21673       IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21674
21675       RETURN
21676       END
21677
21678 *$ CREATE DT_SIGEMU.FOR
21679 *COPY DT_SIGEMU
21680 *
21681 *===sigemu=============================================================*
21682 *
21683       SUBROUTINE DT_SIGEMU
21684
21685 ************************************************************************
21686 * Combined cross section for target compounds.                         *
21687 * This version dated 6.4.98   is written by S. Roesler                 *
21688 ************************************************************************
21689
21690       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21691       SAVE
21692       PARAMETER ( LINP = 10 ,
21693      &            LOUT = 6 ,
21694      &            LDAT = 9 )
21695       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21696      &           OHALF=0.5D0,ONE=1.0D0)
21697
21698       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21699 * Glauber formalism: cross sections
21700       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21701      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21702      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21703      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21704      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21705      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21706      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21707      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21708      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21709      &                BSLOPE,NEBINI,NQBINI
21710 * emulsion treatment
21711       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21712      &                NCOMPO,IEMUL
21713 * nucleon-nucleon event-generator
21714       CHARACTER*8 CMODEL
21715       LOGICAL LPHOIN
21716       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21717
21718       IF (MCGENE.NE.4) THEN
21719          WRITE(LOUT,'(A)') ' DT_SIGEMU:    Combined cross sections'
21720          WRITE(LOUT,'(15X,A)') '-----------------------'
21721       ENDIF
21722       DO 1 IE=1,NEBINI
21723          DO 2 IQ=1,NQBINI
21724             SIGTOT = ZERO
21725             SIGELA = ZERO
21726             SIGQEP = ZERO
21727             SIGQET = ZERO
21728             SIGQE2 = ZERO
21729             SIGPRO = ZERO
21730             SIGDEL = ZERO
21731             SIGDQE = ZERO
21732             ERRTOT = ZERO
21733             ERRELA = ZERO
21734             ERRQEP = ZERO
21735             ERRQET = ZERO
21736             ERRQE2 = ZERO
21737             ERRPRO = ZERO
21738             ERRDEL = ZERO
21739             ERRDQE = ZERO
21740             IF (NCOMPO.GT.0) THEN
21741                DO 3 IC=1,NCOMPO
21742                   SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21743                   SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21744                   SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21745                   SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21746                   SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21747                   SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21748                   SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21749                   SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21750                   ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21751                   ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21752                   ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21753                   ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21754                   ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21755                   ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21756                   ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21757                   ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21758     3          CONTINUE
21759                ERRTOT = SQRT(ERRTOT)
21760                ERRELA = SQRT(ERRELA)
21761                ERRQEP = SQRT(ERRQEP)
21762                ERRQET = SQRT(ERRQET)
21763                ERRQE2 = SQRT(ERRQE2)
21764                ERRPRO = SQRT(ERRPRO)
21765                ERRDEL = SQRT(ERRDEL)
21766                ERRDQE = SQRT(ERRDQE)
21767             ELSE
21768                SIGTOT = XSTOT(IE,IQ,1)
21769                SIGELA = XSELA(IE,IQ,1)
21770                SIGQEP = XSQEP(IE,IQ,1)
21771                SIGQET = XSQET(IE,IQ,1)
21772                SIGQE2 = XSQE2(IE,IQ,1)
21773                SIGPRO = XSPRO(IE,IQ,1)
21774                SIGDEL = XSDEL(IE,IQ,1)
21775                SIGDQE = XSDQE(IE,IQ,1)
21776                ERRTOT = XETOT(IE,IQ,1)
21777                ERRELA = XEELA(IE,IQ,1)
21778                ERRQEP = XEQEP(IE,IQ,1)
21779                ERRQET = XEQET(IE,IQ,1)
21780                ERRQE2 = XEQE2(IE,IQ,1)
21781                ERRPRO = XEPRO(IE,IQ,1)
21782                ERRDEL = XEDEL(IE,IQ,1)
21783                ERRDQE = XEDQE(IE,IQ,1)
21784             ENDIF
21785             IF (MCGENE.NE.4) THEN
21786                WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21787  1000         FORMAT(/,1X,'E_cm =',F9.1,' GeV  Q^2 =',F6.1,' GeV^2 :',/)
21788                WRITE(LOUT,1001) SIGTOT,ERRTOT
21789  1001          FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21790                WRITE(LOUT,1002) SIGELA,ERRELA
21791  1002          FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21792                WRITE(LOUT,1003) SIGQEP,ERRQEP
21793  1003          FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21794      &                F11.5,' mb')
21795                WRITE(LOUT,1004) SIGQET,ERRQET
21796  1004          FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21797      &                F11.5,' mb')
21798                WRITE(LOUT,1005) SIGQE2,ERRQE2
21799  1005          FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21800      &                ' +-',F11.5,' mb')
21801                WRITE(LOUT,1006) SIGPRO,ERRPRO
21802  1006          FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21803                WRITE(LOUT,1007) SIGDEL,ERRDEL
21804  1007          FORMAT(1X,'diff-el   ',27X,F10.4,' +-',F11.5,' mb')
21805                WRITE(LOUT,1008) SIGDQE,ERRDQE
21806  1008          FORMAT(1X,'diff-qel  ',27X,F10.4,' +-',F11.5,' mb')
21807             ENDIF
21808
21809     2    CONTINUE
21810     1 CONTINUE
21811
21812       RETURN
21813       END
21814
21815 *$ CREATE DT_SIGGA.FOR
21816 *COPY DT_SIGGA
21817 *
21818 *===sigga==============================================================*
21819 *
21820       SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21821
21822 ************************************************************************
21823 * Total/inelastic photon-nucleus cross sections.                       *
21824 *     !!!! Overwrites SHMAKI-initialization. Do not use it during      *
21825 *          production runs !!!!                                        *
21826 * This version dated 27.03.96 is written by S. Roesler                 *
21827 ************************************************************************
21828
21829       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21830       SAVE
21831       PARAMETER ( LINP = 10 ,
21832      &            LOUT = 6 ,
21833      &            LDAT = 9 )
21834       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21835      &           OHALF=0.5D0,ONE=1.0D0)
21836       PARAMETER (AMPROT = 0.938D0)
21837
21838       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21839 * Glauber formalism: cross sections
21840       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21841      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21842      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21843      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21844      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21845      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21846      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21847      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21848      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21849      &                BSLOPE,NEBINI,NQBINI
21850
21851       NT  = NTI
21852       X   = XI
21853       Q2  = Q2I
21854       ECM = ECMI
21855       XNU = XNUI
21856       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21857      &   ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21858       CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21859       STOT  = XSTOT(1,1,1)
21860       ETOT  = XETOT(1,1,1)
21861       SIN   = XSPRO(1,1,1)
21862       EIN   = XEPRO(1,1,1)
21863
21864       RETURN
21865       END
21866
21867 *$ CREATE DT_SIGGAT.FOR
21868 *COPY DT_SIGGAT
21869 *
21870 *===siggat=============================================================*
21871 *
21872       SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21873
21874 ************************************************************************
21875 * Total/inelastic photon-nucleus cross sections.                       *
21876 * Uses pre-tabulated cross section.                                    *
21877 * This version dated 29.07.96 is written by S. Roesler                 *
21878 ************************************************************************
21879
21880       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21881       SAVE
21882       PARAMETER ( LINP = 10 ,
21883      &            LOUT = 6 ,
21884      &            LDAT = 9 )
21885       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21886      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21887
21888       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21889 * Glauber formalism: cross sections
21890       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21891      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21892      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21893      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21894      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21895      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21896      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21897      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21898      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21899      &                BSLOPE,NEBINI,NQBINI
21900
21901       NTARG = ABS(NT)
21902       I1   = 1
21903       I2   = 1
21904       RATE = ONE
21905       IF (NEBINI.GT.1) THEN
21906          IF (ECMI.GE.ECMNN(NEBINI)) THEN
21907             I1   = NEBINI
21908             I2   = NEBINI
21909             RATE = ONE
21910          ELSEIF (ECMI.GT.ECMNN(1)) THEN
21911             DO 1 I=2,NEBINI
21912                IF (ECMI.LT.ECMNN(I)) THEN
21913                   I1   = I-1
21914                   I2   = I
21915                   RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21916                   GOTO 2
21917                ENDIF
21918     1       CONTINUE
21919     2       CONTINUE
21920          ENDIF
21921       ENDIF
21922       J1   = 1
21923       J2   = 1
21924       RATQ = ONE
21925       IF (NQBINI.GT.1) THEN
21926          IF (Q2I.GE.Q2G(NQBINI)) THEN
21927             J1   = NQBINI
21928             J2   = NQBINI
21929             RATQ = ONE
21930          ELSEIF (Q2I.GT.Q2G(1)) THEN
21931             DO 3 I=2,NQBINI
21932                IF (Q2I.LT.Q2G(I)) THEN
21933                   J1   = I-1
21934                   J2   = I
21935                   RATQ = LOG10(    Q2I/MAX(Q2G(J1),TINY14))/
21936      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21937 C                 RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21938                   GOTO 4
21939                ENDIF
21940     3       CONTINUE
21941     4       CONTINUE
21942          ENDIF
21943       ENDIF
21944
21945       STOT = XSTOT(I1,J1,NTARG)+
21946      &   RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21947      &   RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21948      &   RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21949      &              XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21950
21951       RETURN
21952       END
21953
21954 *$ CREATE DT_SANO.FOR
21955 *COPY DT_SANO
21956 *
21957 *===sigano=============================================================*
21958 *
21959       DOUBLE PRECISION FUNCTION DT_SANO(ECM)
21960
21961 ************************************************************************
21962 * This version dated 31.07.96 is written by S. Roesler                 *
21963 ************************************************************************
21964
21965       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21966       SAVE
21967       PARAMETER ( LINP = 10 ,
21968      &            LOUT = 6 ,
21969      &            LDAT = 9 )
21970       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21971      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21972       PARAMETER (NE = 8)
21973
21974 * VDM parameter for photon-nucleus interactions
21975       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21976 * properties of interacting particles
21977       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
21978
21979       DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
21980       DATA ECMANO /
21981      &             0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
21982      &             0.100D+04,0.200D+04,0.500D+04
21983      &            /
21984 * fixed cut (3 GeV/c)
21985       DATA FRAANO /
21986      &             0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
21987      &             0.062D+00,0.054D+00,0.042D+00
21988      &            /
21989       DATA SIGHRD /
21990      &           4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
21991      &           3.3086D-01,7.6255D-01,2.1319D+00
21992      &            /
21993 * running cut (based on obsolete Phojet-caluclations, bugs..)
21994 C     DATA FRAANO /
21995 C    &             0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
21996 C    &             0.167E+00,0.150E+00,0.131E+00
21997 C    &            /
21998 C     DATA SIGHRD /
21999 C    &           6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
22000 C    &           2.5736E-01,4.5593E-01,8.2550E-01
22001 C    &            /
22002
22003       DT_SANO = ZERO
22004       IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
22005       J1   = 0
22006       J2   = 0
22007       RATE = ONE
22008       IF (ECM.GE.ECMANO(NE)) THEN
22009          J1 = NE
22010          J2 = NE
22011       ELSEIF (ECM.GT.ECMANO(1)) THEN
22012          DO 1 IE=2,NE
22013             IF (ECM.LT.ECMANO(IE)) THEN
22014                J1   = IE-1
22015                J2   = IE
22016                RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
22017                GOTO 2
22018             ENDIF
22019     1    CONTINUE
22020     2    CONTINUE
22021       ENDIF
22022       IF ((J1.GT.0).AND.(J2.GT.0)) THEN
22023          AFRA1  = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
22024          AFRA2  = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
22025          DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
22026       ENDIF
22027
22028       RETURN
22029       END
22030
22031 *$ CREATE DT_SIGGP.FOR
22032 *COPY DT_SIGGP
22033 *
22034 *===siggp==============================================================*
22035 *
22036       SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
22037
22038 ************************************************************************
22039 * Total/inelastic photon-nucleon cross sections.                       *
22040 * This version dated 30.04.96 is written by S. Roesler                 *
22041 ************************************************************************
22042
22043       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22044       SAVE
22045       PARAMETER ( LINP = 10 ,
22046      &            LOUT = 6 ,
22047      &            LDAT = 9 )
22048       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22049       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
22050      &           PI     = TWOPI/TWO,
22051      &           GEV2MB = 0.38938D0,
22052      &           ALPHEM = ONE/137.0D0)
22053
22054 * particle properties (BAMJET index convention)
22055       CHARACTER*8  ANAME
22056       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22057      &                IICH(210),IIBAR(210),K1(210),K2(210)
22058 * VDM parameter for photon-nucleus interactions
22059       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22060
22061 **PHOJET105a
22062 C     CHARACTER*8 MDLNA
22063 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
22064 C     PARAMETER (IEETAB=10)
22065 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
22066 **PHOJET110
22067 C  model switches and parameters
22068       CHARACTER*8 MDLNA
22069       INTEGER ISWMDL,IPAMDL
22070       DOUBLE PRECISION PARMDL
22071       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
22072 C  energy-interpolation table
22073       INTEGER IEETA2
22074       PARAMETER ( IEETA2 = 20 )
22075       INTEGER ISIMAX
22076       DOUBLE PRECISION SIGTAB,SIGECM
22077       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
22078 **
22079
22080 C     PARAMETER (NPOINT=80)
22081       PARAMETER (NPOINT=16)
22082       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22083
22084       STOT = ZERO
22085       SINE = ZERO
22086       SDIR = ZERO
22087
22088       W2 = ECMI**2
22089       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22090      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22091       Q2 = Q2I
22092       X  = XI
22093 * photoprod.
22094       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22095          Q2 = 0.0001D0
22096          X  = Q2/(W2+Q2-AAM(1)**2)
22097 * DIS
22098       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22099          X  = Q2/(W2+Q2-AAM(1)**2)
22100       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22101          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22102       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22103          W2 = Q2*(ONE-X)/X+AAM(1)**2
22104       ELSE
22105          WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
22106          STOP
22107       ENDIF
22108       ECM = SQRT(W2)
22109
22110       IF (MODEGA.EQ.1) THEN
22111          SCALE = SQRT(Q2)
22112          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22113      &                                                       IDPDF)
22114 C        W = SQRT(W2)
22115 C        ALLMF2 = PHO_ALLM97(Q2,W)
22116 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22117          STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22118          SINE = ZERO
22119          SDIR = ZERO
22120       ELSEIF (MODEGA.EQ.2) THEN
22121          IF (INTRGE(1).EQ.1) THEN
22122             AMLO2 = (3.0D0*AAM(13))**2
22123          ELSEIF (INTRGE(1).EQ.2) THEN
22124             AMLO2 = AAM(33)**2
22125          ELSE
22126             AMLO2 = AAM(96)**2
22127          ENDIF
22128          IF (INTRGE(2).EQ.1) THEN
22129             AMHI2 = W2/TWO
22130          ELSEIF (INTRGE(2).EQ.2) THEN
22131             AMHI2 = W2/4.0D0
22132          ELSE
22133             AMHI2 = W2
22134          ENDIF
22135          AMHI20 = (ECM-AAM(1))**2
22136          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22137          XAMLO  = LOG( AMLO2+Q2 )
22138          XAMHI  = LOG( AMHI2+Q2 )
22139 **PHOJET105a
22140 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22141 **PHOJET112
22142          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22143 **
22144          SUM  = ZERO
22145          DO 1 J=1,NPOINT
22146             AM2 = EXP(ABSZX(J))-Q2
22147             IF (AM2.LT.16.0D0) THEN
22148                R = TWO
22149             ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
22150                R = 10.0D0/3.0D0
22151             ELSE
22152                R = 11.0D0/3.0D0
22153             ENDIF
22154 C           FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22155             FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22156      &            * (ONE+EPSPOL*Q2/AM2)
22157             SUM = SUM+WEIGHT(J)*FAC
22158     1    CONTINUE
22159          SINE = SUM
22160          SDIR = DT_SIGVP(X,Q2)
22161          STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
22162          SDIR = SDIR/(0.588D0+RL2+Q2)
22163 C        STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
22164       ELSEIF (MODEGA.EQ.3) THEN
22165          CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
22166       ELSEIF (MODEGA.EQ.4) THEN
22167 *  load cross sections from PHOJET interpolation table
22168          IP = 1
22169          IF(ECM.LE.SIGECM(IP,1)) THEN
22170            I1 = 1
22171            I2 = 1
22172          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
22173            DO 2 I=2,ISIMAX
22174               IF (ECM.LE.SIGECM(IP,I)) GOTO 3
22175     2      CONTINUE
22176     3      CONTINUE
22177            I1 = I-1
22178            I2 = I
22179          ELSE
22180            WRITE(LOUT,'(/1X,A,2E12.3)')
22181      &       'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
22182            I1 = ISIMAX
22183            I2 = ISIMAX
22184          ENDIF
22185          FAC2 = ZERO
22186          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
22187      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
22188          FAC1 = ONE-FAC2
22189 *  cross section dependence on photon virtuality
22190          FSUP1 = ZERO
22191          DO 4 I=1,3
22192             FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
22193      &                                /(1.D0+Q2/PARMDL(30+I))**2
22194     4    CONTINUE
22195          FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
22196          FAC1  = FAC1*FSUP1
22197          FAC2  = FAC2*FSUP1
22198          FSUP2 = 1.0D0
22199          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
22200          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
22201          SDIR  = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
22202 **re:
22203          STOT  = STOT-SDIR
22204 **
22205          SDIR  = SDIR/(FSUP1*FSUP2)
22206 **re:
22207          STOT  = STOT+SDIR
22208 **
22209       ENDIF
22210
22211       RETURN
22212       END
22213
22214 *$ CREATE DT_SIGVEL.FOR
22215 *COPY DT_SIGVEL
22216 *
22217 *===sigvel=============================================================*
22218 *
22219       SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
22220
22221 ************************************************************************
22222 * Cross section for elastic vector meson production                    *
22223 * This version dated 10.05.96 is written by S. Roesler                 *
22224 ************************************************************************
22225
22226       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22227       SAVE
22228       PARAMETER ( LINP = 10 ,
22229      &            LOUT = 6 ,
22230      &            LDAT = 9 )
22231       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22232       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
22233      &           PI     = TWOPI/TWO,
22234      &           GEV2MB = 0.38938D0,
22235      &           ALPHEM = ONE/137.0D0)
22236
22237 * particle properties (BAMJET index convention)
22238       CHARACTER*8  ANAME
22239       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22240      &                IICH(210),IIBAR(210),K1(210),K2(210)
22241 * VDM parameter for photon-nucleus interactions
22242       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22243
22244       W2 = ECMI**2
22245       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22246      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22247       Q2 = Q2I
22248       X  = XI
22249 * photoprod.
22250       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22251          Q2 = 0.0001D0
22252          X  = Q2/(W2+Q2-AAM(1)**2)
22253 * DIS
22254       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22255          X  = Q2/(W2+Q2-AAM(1)**2)
22256       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22257          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22258       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22259          W2 = Q2*(ONE-X)/X+AAM(1)**2
22260       ELSE
22261          WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
22262          STOP
22263       ENDIF
22264       ECM = SQRT(W2)
22265
22266       AMV  = AAM(IDXV)
22267       AMV2 = AMV**2
22268
22269       BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
22270      &        +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
22271       ROSH   = 0.1D0
22272       STOVP  = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
22273       SELVP  = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
22274
22275       IF (IDXV.EQ.33) THEN
22276          COUPL = 0.00365D0
22277       ELSE
22278          STOP
22279       ENDIF
22280       SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
22281       SIG2 = SELVP
22282       SVEL  = COUPL * (AMV2/(AMV2+Q2))**2
22283      &              * (ONE+EPSPOL*Q2/AMV2) * SELVP
22284
22285       RETURN
22286       END
22287
22288 *$ CREATE DT_SIGVP.FOR
22289 *COPY DT_SIGVP
22290 *
22291 *===sigvp==============================================================*
22292 *
22293       DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
22294
22295 ************************************************************************
22296 * sigma_Vp                                                             *
22297 ************************************************************************
22298
22299       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22300       SAVE
22301
22302       PARAMETER ( LINP = 10 ,
22303      &            LOUT = 6 ,
22304      &            LDAT = 9 )
22305       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22306       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22307      &           PI    = TWOPI/TWO,
22308      &           GEV2MB = 0.38938D0,
22309      &           AMPROT = 0.938D0,
22310      &           ALPHEM = ONE/137.0D0)
22311 * VDM parameter for photon-nucleus interactions
22312       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22313
22314       X  = XI
22315       Q2 = Q2I
22316       IF (XI.LE.ZERO)  X  = 0.0001D0
22317       IF (Q2I.LE.ZERO) Q2 = 0.0001D0
22318
22319       ECM    = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
22320
22321       SCALE = SQRT(Q2)
22322       IF (MODEGA.EQ.1) THEN
22323          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22324      &                                                       IDPDF)
22325 C        W = ECM
22326 C        ALLMF2 = PHO_ALLM97(Q2,W)
22327 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22328 C        STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22329 C        DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
22330          DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
22331       ELSEIF (MODEGA.EQ.4) THEN
22332          CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
22333 C        F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
22334          DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
22335       ELSE
22336          STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
22337       ENDIF
22338
22339       RETURN
22340
22341       END
22342
22343 *$ CREATE DT_RRM2.FOR
22344 *COPY DT_RRM2
22345 *
22346 *===RRM2===============================================================*
22347 *
22348       DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22349
22350       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22351       SAVE
22352       PARAMETER ( LINP = 10 ,
22353      &            LOUT = 6 ,
22354      &            LDAT = 9 )
22355       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22356       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22357      &           PI    = TWOPI/TWO,
22358      &           GEV2MB = 0.38938D0)
22359
22360 * particle properties (BAMJET index convention)
22361       CHARACTER*8  ANAME
22362       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22363      &                IICH(210),IIBAR(210),K1(210),K2(210)
22364 * VDM parameter for photon-nucleus interactions
22365       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22366
22367       S   = Q2*(ONE-X)/X+AAM(1)**2
22368       ECM = SQRT(S)
22369
22370       IF (INTRGE(1).EQ.1) THEN
22371          AMLO2 = (3.0D0*AAM(13))**2
22372       ELSEIF (INTRGE(1).EQ.2) THEN
22373          AMLO2 = AAM(33)**2
22374       ELSE
22375          AMLO2 = AAM(96)**2
22376       ENDIF
22377       IF (INTRGE(2).EQ.1) THEN
22378          AMHI2 = S/TWO
22379       ELSEIF (INTRGE(2).EQ.2) THEN
22380          AMHI2 = S/4.0D0
22381       ELSE
22382          AMHI2 = S
22383       ENDIF
22384       AMHI20 = (ECM-AAM(1))**2
22385       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22386
22387       AM1C2 = 16.0D0
22388       AM2C2 = 121.0D0
22389       IF (AMHI2.LE.AM1C2) THEN
22390          DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22391       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22392          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22393      &          10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22394       ELSE
22395          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22396      &          10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22397      &          11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22398       ENDIF
22399
22400       RETURN
22401       END
22402
22403 *$ CREATE DT_RM2.FOR
22404 *COPY DT_RM2
22405 *
22406 *===RM2================================================================*
22407 *
22408       DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22409
22410       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22411       SAVE
22412       PARAMETER ( LINP = 10 ,
22413      &            LOUT = 6 ,
22414      &            LDAT = 9 )
22415       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22416       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22417      &           PI    = TWOPI/TWO,
22418      &           GEV2MB = 0.38938D0)
22419 * VDM parameter for photon-nucleus interactions
22420       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22421
22422       IF (RL2.LE.ZERO) THEN
22423          DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22424      &        (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22425      &         +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22426       ELSE
22427          TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22428          TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22429          DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22430      &       -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22431      &       +EPSPOL*(
22432      &         -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22433      &       -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22434       ENDIF
22435
22436       RETURN
22437       END
22438
22439 *$ CREATE DT_SAM2.FOR
22440 *COPY DT_SAM2
22441 *
22442 *===SAM2===============================================================*
22443 *
22444       DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22445
22446       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22447       SAVE
22448       PARAMETER ( LINP = 10 ,
22449      &            LOUT = 6 ,
22450      &            LDAT = 9 )
22451       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22452      &           TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22453       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22454      &           PI    = TWOPI/TWO,
22455      &           GEV2MB = 0.38938D0)
22456
22457 * particle properties (BAMJET index convention)
22458       CHARACTER*8  ANAME
22459       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22460      &                IICH(210),IIBAR(210),K1(210),K2(210)
22461 * VDM parameter for photon-nucleus interactions
22462       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22463
22464       S = ECM**2
22465       IF (INTRGE(1).EQ.1) THEN
22466          AMLO2 = (3.0D0*AAM(13))**2
22467       ELSEIF (INTRGE(1).EQ.2) THEN
22468          AMLO2 = AAM(33)**2
22469       ELSE
22470          AMLO2 = AAM(96)**2
22471       ENDIF
22472       IF (INTRGE(2).EQ.1) THEN
22473          AMHI2 = S/TWO
22474       ELSEIF (INTRGE(2).EQ.2) THEN
22475          AMHI2 = S/4.0D0
22476       ELSE
22477          AMHI2 = S
22478       ENDIF
22479       AMHI20 = (ECM-AAM(1))**2
22480       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22481
22482       AM1C2 = 16.0D0
22483       AM2C2 = 121.0D0
22484       YLO   = LOG(AMLO2+Q2)
22485       YC1   = LOG(AM1C2+Q2)
22486       YC2   = LOG(AM2C2+Q2)
22487       YHI   = LOG(AMHI2+Q2)
22488       IF (AMHI2.LE.AM1C2) THEN
22489          FACHI = TWO
22490       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22491          FACHI = TENTRD
22492       ELSE
22493          FACHI = ELVTRD
22494       ENDIF
22495
22496     1 CONTINUE
22497       YSAM2  = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22498       IF (YSAM2.LE.YC1) THEN
22499          FAC = TWO
22500       ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22501          FAC = TENTRD
22502       ELSE
22503          FAC = ELVTRD
22504       ENDIF
22505       WEIGMX = FACHI*(ONE-Q2*EXP(  -YHI))
22506       XSAM2  = FAC  *(ONE-Q2*EXP(-YSAM2))
22507       IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22508
22509       DT_SAM2   = EXP(YSAM2)-Q2
22510
22511       RETURN
22512       END
22513
22514 *$ CREATE DT_CKMT.FOR
22515 *COPY DT_CKMT
22516 *
22517 *===ckmt===============================================================*
22518 *
22519       SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22520      &                F2,IPAR)
22521
22522 ************************************************************************
22523 * This version dated 31.01.96 is written by S. Roesler                 *
22524 ************************************************************************
22525
22526       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22527       SAVE
22528       PARAMETER ( LINP = 10 ,
22529      &            LOUT = 6 ,
22530      &            LDAT = 9 )
22531       PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22532
22533       PARAMETER (Q02 = 2.0D0,
22534      &           DQ2 = 10.05D0,
22535      &           Q12 = Q02+DQ2)
22536
22537       DIMENSION PD(-6:6),SEA(3),VAL(2)
22538
22539       CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22540       CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22541       ADQ2 = LOG10(Q12)-LOG10(Q02)
22542       F2P  = (F2Q1-F2Q0)/ADQ2
22543       CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22544       CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22545       F2PP = (F2PQ1-F2PQ0)/ADQ2
22546       FX   = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22547
22548       Q2     = MAX(SCALE**2.0D0,TINY10)
22549       SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22550       IF (Q2.LT.Q02) THEN
22551          CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22552          UPV  = VAL(1)
22553          DNV  = VAL(2)
22554          USEA = SEA(1)
22555          DSEA = SEA(2)
22556          STR  = SEA(3)
22557          CHM  = 0.0D0
22558          BOT  = 0.0D0
22559          TOP  = 0.0D0
22560          GL   = GLU
22561       ELSE
22562          CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22563          F2 = F2*SMOOTH
22564          UPV  = PD(2)-PD(3)
22565          DNV  = PD(1)-PD(3)
22566          USEA = PD(3)
22567          DSEA = PD(3)
22568          STR  = PD(3)
22569          CHM  = PD(4)
22570          BOT  = PD(5)
22571          TOP  = PD(6)
22572          GL   = PD(0)
22573 C        UPV  = UPV*SMOOTH
22574 C        DNV  = DNV*SMOOTH
22575 C        USEA = USEA*SMOOTH
22576 C        DSEA = DSEA*SMOOTH
22577 C        STR  = STR*SMOOTH
22578 C        CHM  = CHM*SMOOTH
22579 C        GL   = GL*SMOOTH
22580       ENDIF
22581
22582       RETURN
22583       END
22584 C
22585
22586 *$ CREATE DT_CKMTX.FOR
22587 *COPY DT_CKMTX
22588       SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22589 C**********************************************************************
22590 C
22591 C     PDF based on Regge theory, evolved with .... by ....
22592 C
22593 C     input: IPAR     2212   proton (not installed)
22594 C                       45   Pomeron
22595 C                      100   Deuteron
22596 C
22597 C     output: PD(-6:6) x*f(x)  parton distribution functions
22598 C            (PDFLIB convention: d = PD(1), u = PD(2) )
22599 C
22600 C**********************************************************************
22601
22602       SAVE
22603       DOUBLE PRECISION  X,SCALE2,PD(-6:6),CDN,CUP,F2
22604       PARAMETER ( LINP = 10 ,
22605      &            LOUT = 6 ,
22606      &            LDAT = 9 )
22607       DIMENSION QQ(7)
22608 C
22609       Q2=SNGL(SCALE2)
22610       Q1S=Q2
22611       XX=SNGL(X)
22612 C  QCD lambda for evolution
22613       OWLAM = 0.23D0
22614       OWLAM2=OWLAM**2
22615 C  Q0**2 for evolution
22616       Q02 = 2.D0
22617 C
22618 C
22619 C  the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22620 C                        q(6)=x*charm, q(7)=x*gluon
22621 C
22622       SB=0.
22623       IF(Q2-Q02) 1,1,2
22624     2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22625     1 CONTINUE
22626       IF(IPAR.EQ.2212) THEN
22627         CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22628         CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22629         CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22630         CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22631         CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22632         CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22633         CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22634 C     ELSEIF (IPAR.EQ.45) THEN
22635 C       CALL CKMTPO(1,0,XX,SB,QQ(1))
22636 C       CALL CKMTPO(2,0,XX,SB,QQ(2))
22637 C       CALL CKMTPO(3,0,XX,SB,QQ(3))
22638 C       CALL CKMTPO(4,0,XX,SB,QQ(4))
22639 C       CALL CKMTPO(5,0,XX,SB,QQ(5))
22640 C       CALL CKMTPO(8,0,XX,SB,QQ(6))
22641 C       CALL CKMTPO(7,0,XX,SB,QQ(7))
22642       ELSEIF (IPAR.EQ.100) THEN
22643         CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22644         CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22645         CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22646         CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22647         CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22648         CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22649         CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22650       ELSE
22651         WRITE(LOUT,'(1X,A,I4,A)')
22652      &     'CKMTX:   IPAR =',IPAR,' not implemented!'
22653         STOP
22654       ENDIF
22655 C
22656       PD(-6) = 0.D0
22657       PD(-5) = 0.D0
22658       PD(-4) = DBLE(QQ(6))
22659       PD(-3) = DBLE(QQ(3))
22660       PD(-2) = DBLE(QQ(4))
22661       PD(-1) = DBLE(QQ(5))
22662       PD(0)  = DBLE(QQ(7))
22663       PD(1)  = DBLE(QQ(2))
22664       PD(2)  = DBLE(QQ(1))
22665       PD(3)  = DBLE(QQ(3))
22666       PD(4)  = DBLE(QQ(6))
22667       PD(5)  = 0.D0
22668       PD(6)  = 0.D0
22669       IF(IPAR.EQ.45) THEN
22670         CDN = (PD(1)-PD(-1))/2.D0
22671         CUP = (PD(2)-PD(-2))/2.D0
22672         PD(-1) = PD(-1) + CDN
22673         PD(-2) = PD(-2) + CUP
22674         PD(1) = PD(-1)
22675         PD(2) = PD(-2)
22676       ENDIF
22677       F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22678      &     1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22679      &     1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22680       END
22681 C
22682
22683 *$ CREATE DT_PDF0.FOR
22684 *COPY DT_PDF0
22685 *
22686 *===pdf0===============================================================*
22687 *
22688       SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22689
22690 ************************************************************************
22691 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
22692 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
22693 *                   IPAR  = 2212   proton                              *
22694 *                         =  100   deuteron                            *
22695 * This version dated 31.01.96 is written by S. Roesler                 *
22696 ************************************************************************
22697
22698       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22699       SAVE
22700       PARAMETER ( LINP = 10 ,
22701      &            LOUT = 6 ,
22702      &            LDAT = 9 )
22703       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22704
22705       PARAMETER (
22706      &              AA     = 0.1502D0,
22707      &              BBDEU  = 1.2D0,
22708      &              BUD    = 0.754D0,
22709      &              BDD    = 0.4495D0,
22710      &              BUP    = 1.2064D0,
22711      &              BDP    = 0.1798D0,
22712      &              DELTA0 = 0.07684D0,
22713      &              D      = 1.117D0,
22714      &              C      = 3.5489D0,
22715      &              A      = 0.2631D0,
22716      &              B      = 0.6452D0,
22717      &              ALPHAR = 0.415D0,
22718      &              E      = 0.1D0
22719      &          )
22720
22721       PARAMETER (NPOINT=16)
22722 C     DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22723       DIMENSION SEA(3),VAL(2)
22724
22725       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22726       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
22727 * proton, deuteron
22728       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22729          CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22730          SEA(1) = 0.75D0*SEA0
22731          SEA(2) = SEA(1)
22732          SEA(3) = SEA(1)
22733          VAL(1) = 9.0D0/4.0D0*VALU0
22734          VAL(2) = 9.0D0*VALD0
22735          GLU0   = SEA(1)/(1.0D0-X)
22736          F2     = SEA0+VALU0+VALD0
22737          F2PDF  = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22738      &            1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22739      &            1.0D0/9.0D0*(2.0D0*SEA(3))
22740          IF (ABS(F2-F2PDF).GT.TINY9) THEN
22741             WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22742             STOP
22743          ENDIF
22744 **PHOJET105a
22745 C        CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22746 **PHOJET112
22747 C        CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22748 **
22749 C        SUMQ = ZERO
22750 C        SUMG = ZERO
22751 C        DO 1 J=1,NPOINT
22752 C           CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22753 C           VALU0 = 9.0D0/4.0D0*VALU0
22754 C           VALD0 = 9.0D0*VALD0
22755 C           SEA0  = 0.75D0*SEA0
22756 C           SUMQ  = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22757 C           SUMG  = SUMG+ (SEA0/(1.0D0-ABSZX(J)))  *WEIGHT(J)
22758 C   1    CONTINUE
22759 C        GLU = GLU0*(1.0D0-SUMQ)/SUMG
22760       ELSE
22761          WRITE(LOUT,'(1X,A,I4,A)')
22762      &      'PDF0:   IPAR =',IPAR,' not implemented!'
22763          STOP
22764       ENDIF
22765
22766       RETURN
22767       END
22768
22769 *$ CREATE DT_CKMTQ0.FOR
22770 *COPY DT_CKMTQ0
22771 *
22772 *===ckmtq0=============================================================*
22773 *
22774       SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22775
22776 ************************************************************************
22777 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
22778 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
22779 *                   IPAR  = 2212   proton                              *
22780 *                         =  100   deuteron                            *
22781 * This version dated 31.01.96 is written by S. Roesler                 *
22782 ************************************************************************
22783
22784       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22785       SAVE
22786       PARAMETER ( LINP = 10 ,
22787      &            LOUT = 6 ,
22788      &            LDAT = 9 )
22789       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22790
22791       PARAMETER (
22792      &              AA     = 0.1502D0,
22793      &              BBDEU  = 1.2D0,
22794      &              BUD    = 0.754D0,
22795      &              BDD    = 0.4495D0,
22796      &              BUP    = 1.2064D0,
22797      &              BDP    = 0.1798D0,
22798      &              DELTA0 = 0.07684D0,
22799      &              D      = 1.117D0,
22800      &              C      = 3.5489D0,
22801      &              A      = 0.2631D0,
22802      &              B      = 0.6452D0,
22803      &              ALPHAR = 0.415D0,
22804      &              E      = 0.1D0
22805      &          )
22806
22807       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22808       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
22809 * proton, deuteron
22810       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22811          IF (IPAR.EQ.2212) THEN
22812             BU = BUP
22813             BD = BDP
22814          ELSE
22815             BU = BUD
22816             BD = BDD
22817          ENDIF
22818          SEA0  = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22819      &          (Q2/(Q2+A))**(1.0D0+DELTA)
22820          VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22821      &           (Q2/(Q2+B))**(ALPHAR)
22822          VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22823      &           (Q2/(Q2+B))**(ALPHAR)
22824       ELSE
22825          WRITE(LOUT,'(1X,A,I4,A)')
22826      &      'CKMTQ0: IPAR =',IPAR,' not implemented!'
22827          STOP
22828       ENDIF
22829       RETURN
22830       END
22831 C
22832 C
22833
22834 *$ CREATE DT_CKMTDE.FOR
22835 *COPY DT_CKMTDE
22836       SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22837 C
22838 C**********************************************************************
22839 C    Deuteron - PDFs
22840 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22841 C    ANS = PDF(I)
22842 C    This version by S. Roesler, 30.01.96
22843 C**********************************************************************
22844
22845       SAVE
22846       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22847       EQUIVALENCE (GF(1,1,1),DL(1))
22848       DATA DELTA/.13/
22849 C
22850       DATA (DL(K),K=    1,   85) /
22851      &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22852      &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22853      &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22854      &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22855      &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22856      &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22857      &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22858      &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22859      &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22860      &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22861      &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22862      &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22863      &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22864      &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22865      &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22866      &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22867      &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22868       DATA (DL(K),K=   86,  170) /
22869      &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22870      &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22871      &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22872      &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22873      &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22874      &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22875      &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
22876      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22877      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22878      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22879      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22880      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22881      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22882      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22883      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22884      &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22885      &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22886       DATA (DL(K),K=  171,  255) /
22887      &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22888      &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22889      &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22890      &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22891      &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22892      &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22893      &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22894      &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22895      &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22896      &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22897      &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22898      &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22899      &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22900      &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22901      &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22902      &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22903      &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22904       DATA (DL(K),K=  256,  340) /
22905      &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22906      &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22907      &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22908      &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22909      &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
22910      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22911      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22912      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22913      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22914      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22915      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22916      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22917      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22918      &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22919      &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22920      &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22921      &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22922       DATA (DL(K),K=  341,  425) /
22923      &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22924      &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22925      &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22926      &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22927      &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22928      &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22929      &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22930      &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22931      &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22932      &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22933      &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22934      &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22935      &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22936      &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22937      &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22938      &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22939      &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22940       DATA (DL(K),K=  426,  510) /
22941      &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22942      &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22943      &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
22944      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22945      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22946      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22947      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22948      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22949      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22950      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22951      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22952      &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22953      &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22954      &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22955      &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22956      &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22957      &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22958       DATA (DL(K),K=  511,  595) /
22959      &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
22960      &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
22961      &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
22962      &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
22963      &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
22964      &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
22965      &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
22966      &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
22967      &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
22968      &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
22969      &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
22970      &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
22971      &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
22972      &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
22973      &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
22974      &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
22975      &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
22976       DATA (DL(K),K=  596,  680) /
22977      &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
22978      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22979      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22980      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22981      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22982      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22983      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22984      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22985      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22986      &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
22987      &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
22988      &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
22989      &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
22990      &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
22991      &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
22992      &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
22993      &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
22994       DATA (DL(K),K=  681,  765) /
22995      &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
22996      &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
22997      &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
22998      &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
22999      &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
23000      &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
23001      &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
23002      &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
23003      &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
23004      &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
23005      &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
23006      &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
23007      &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
23008      &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
23009      &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
23010      &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
23011      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23012       DATA (DL(K),K=  766,  850) /
23013      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23014      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23015      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23016      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23017      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23018      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23019      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23020      &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23021      &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
23022      &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
23023      &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
23024      &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
23025      &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
23026      &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
23027      &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
23028      &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
23029      &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
23030       DATA (DL(K),K=  851,  935) /
23031      &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
23032      &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
23033      &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
23034      &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
23035      &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
23036      &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
23037      &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
23038      &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
23039      &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
23040      &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
23041      &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
23042      &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
23043      &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
23044      &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
23045      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23046      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23047      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23048       DATA (DL(K),K=  936, 1020) /
23049      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23050      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23051      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23052      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23053      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23054      &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23055      &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
23056      &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
23057      &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
23058      &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
23059      &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
23060      &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
23061      &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
23062      &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
23063      &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
23064      &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
23065      &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
23066       DATA (DL(K),K= 1021, 1105) /
23067      &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
23068      &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
23069      &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
23070      &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
23071      &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
23072      &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
23073      &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
23074      &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
23075      &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
23076      &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
23077      &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
23078      &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
23079      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23080      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23081      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23082      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23083      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23084       DATA (DL(K),K= 1106, 1190) /
23085      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23086      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23087      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23088      &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23089      &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
23090      &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
23091      &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
23092      &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
23093      &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
23094      &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
23095      &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
23096      &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
23097      &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
23098      &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
23099      &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
23100      &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
23101      &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
23102       DATA (DL(K),K= 1191, 1275) /
23103      &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
23104      &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
23105      &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
23106      &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
23107      &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
23108      &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
23109      &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
23110      &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
23111      &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
23112      &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
23113      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23114      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23115      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23116      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23117      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23118      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23119      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23120       DATA (DL(K),K= 1276, 1360) /
23121      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23122      &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23123      &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
23124      &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
23125      &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
23126      &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
23127      &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
23128      &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
23129      &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
23130      &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
23131      &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
23132      &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
23133      &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
23134      &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
23135      &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
23136      &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
23137      &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
23138       DATA (DL(K),K= 1361, 1445) /
23139      &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
23140      &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
23141      &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
23142      &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
23143      &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
23144      &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
23145      &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
23146      &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
23147      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23148      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23149      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23150      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23151      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23152      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23153      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23154      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23155      &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23156       DATA (DL(K),K= 1446, 1530) /
23157      &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
23158      &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
23159      &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
23160      &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
23161      &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
23162      &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
23163      &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
23164      &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
23165      &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
23166      &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
23167      &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
23168      &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
23169      &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
23170      &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
23171      &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
23172      &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
23173      &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
23174       DATA (DL(K),K= 1531, 1615) /
23175      &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
23176      &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
23177      &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
23178      &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
23179      &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
23180      &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
23181      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23182      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23183      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23184      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23185      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23186      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23187      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23188      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23189      &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23190      &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
23191      &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
23192       DATA (DL(K),K= 1616, 1700) /
23193      &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
23194      &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
23195      &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
23196      &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
23197      &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
23198      &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
23199      &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
23200      &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
23201      &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
23202      &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
23203      &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
23204      &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
23205      &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
23206      &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
23207      &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
23208      &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
23209      &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
23210       DATA (DL(K),K= 1701, 1785) /
23211      &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
23212      &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
23213      &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
23214      &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
23215      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23216      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23217      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23218      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23219      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23220      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23221      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23222      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23223      &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23224      &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
23225      &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
23226      &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
23227      &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
23228       DATA (DL(K),K= 1786, 1870) /
23229      &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
23230      &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
23231      &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
23232      &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
23233      &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
23234      &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
23235      &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
23236      &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
23237      &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
23238      &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
23239      &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
23240      &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
23241      &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
23242      &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
23243      &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
23244      &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
23245      &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
23246       DATA (DL(K),K= 1871, 1955) /
23247      &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
23248      &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
23249      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23250      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23251      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23252      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23253      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23254      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23255      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23256      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23257      &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23258      &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
23259      &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
23260      &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
23261      &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
23262      &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
23263      &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
23264       DATA (DL(K),K= 1956, 2040) /
23265      &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
23266      &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
23267      &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
23268      &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
23269      &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
23270      &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
23271      &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
23272      &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
23273      &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
23274      &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
23275      &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
23276      &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
23277      &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
23278      &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
23279      &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
23280      &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
23281      &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
23282       DATA (DL(K),K= 2041, 2125) /
23283      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23284      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23285      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23286      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23287      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23288      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23289      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23290      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23291      &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23292      &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
23293      &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
23294      &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
23295      &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
23296      &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
23297      &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
23298      &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
23299      &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
23300       DATA (DL(K),K= 2126, 2210) /
23301      &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
23302      &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
23303      &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
23304      &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
23305      &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
23306      &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
23307      &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
23308      &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
23309      &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
23310      &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
23311      &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
23312      &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
23313      &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
23314      &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
23315      &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
23316      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23317      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23318       DATA (DL(K),K= 2211, 2295) /
23319      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23320      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23321      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23322      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23323      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23324      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23325      &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23326      &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23327      &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23328      &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23329      &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23330      &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23331      &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23332      &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23333      &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23334      &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23335      &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23336       DATA (DL(K),K= 2296, 2380) /
23337      &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23338      &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23339      &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23340      &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23341      &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23342      &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23343      &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23344      &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23345      &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23346      &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23347      &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23348      &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23349      &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
23350      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23351      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23352      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23353      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23354       DATA (DL(K),K= 2381, 2465) /
23355      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23356      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23357      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23358      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23359      &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23360      &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23361      &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23362      &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23363      &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23364      &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23365      &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23366      &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23367      &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23368      &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23369      &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23370      &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23371      &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23372       DATA (DL(K),K= 2466, 2550) /
23373      &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23374      &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23375      &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23376      &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23377      &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23378      &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23379      &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23380      &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23381      &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23382      &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23383      &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
23384      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23385      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23386      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23387      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23388      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23389      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23390       DATA (DL(K),K= 2551, 2635) /
23391      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23392      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23393      &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23394      &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23395      &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23396      &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23397      &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23398      &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23399      &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23400      &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23401      &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23402      &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23403      &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23404      &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23405      &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23406      &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23407      &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23408       DATA (DL(K),K= 2636, 2720) /
23409      &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23410      &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23411      &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23412      &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23413      &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23414      &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23415      &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23416      &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23417      &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
23418      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23419      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23420      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23421      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23422      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23423      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23424      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23425      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23426       DATA (DL(K),K= 2721, 2805) /
23427      &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23428      &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23429      &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23430      &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23431      &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23432      &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23433      &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23434      &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23435      &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23436      &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23437      &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23438      &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23439      &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23440      &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23441      &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23442      &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23443      &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23444       DATA (DL(K),K= 2806, 2890) /
23445      &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23446      &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23447      &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23448      &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23449      &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23450      &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23451      &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
23452      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23453      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23454      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23455      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23456      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23457      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23458      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23459      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23460      &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23461      &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23462       DATA (DL(K),K= 2891, 2975) /
23463      &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23464      &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23465      &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23466      &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23467      &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23468      &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23469      &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23470      &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23471      &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23472      &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23473      &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23474      &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23475      &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23476      &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23477      &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23478      &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23479      &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23480       DATA (DL(K),K= 2976, 3060) /
23481      &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23482      &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23483      &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23484      &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23485      &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
23486      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23487      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23488      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23489      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23490      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23491      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23492      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23493      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23494      &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23495      &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23496      &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23497      &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23498       DATA (DL(K),K= 3061, 3145) /
23499      &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23500      &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23501      &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23502      &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23503      &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23504      &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23505      &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23506      &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23507      &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23508      &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23509      &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23510      &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23511      &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23512      &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23513      &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23514      &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23515      &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23516       DATA (DL(K),K= 3146, 3230) /
23517      &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23518      &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23519      &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
23520      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23521      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23522      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23523      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23524      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23525      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23526      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23527      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23528      &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23529      &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23530      &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23531      &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23532      &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23533      &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23534       DATA (DL(K),K= 3231, 3315) /
23535      &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23536      &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23537      &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23538      &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23539      &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23540      &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23541      &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23542      &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23543      &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23544      &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23545      &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23546      &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23547      &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23548      &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23549      &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23550      &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23551      &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23552       DATA (DL(K),K= 3316, 3400) /
23553      &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
23554      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23555      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23556      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23557      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23558      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23559      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23560      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23561      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23562      &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23563      &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23564      &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23565      &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23566      &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23567      &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23568      &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23569      &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23570       DATA (DL(K),K= 3401, 3485) /
23571      &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23572      &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23573      &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23574      &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23575      &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23576      &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23577      &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23578      &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23579      &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23580      &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23581      &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23582      &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23583      &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23584      &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23585      &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23586      &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23587      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23588       DATA (DL(K),K= 3486, 3570) /
23589      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23590      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23591      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23592      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23593      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23594      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23595      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23596      &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23597      &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23598      &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23599      &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23600      &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23601      &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23602      &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23603      &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23604      &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23605      &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23606       DATA (DL(K),K= 3571, 3655) /
23607      &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23608      &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23609      &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23610      &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23611      &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23612      &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23613      &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23614      &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23615      &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23616      &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23617      &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23618      &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23619      &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23620      &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
23621      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23622      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23623      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23624       DATA (DL(K),K= 3656, 3740) /
23625      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23626      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23627      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23628      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23629      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23630      &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23631      &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23632      &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23633      &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23634      &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23635      &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23636      &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23637      &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23638      &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23639      &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23640      &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23641      &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23642       DATA (DL(K),K= 3741, 3825) /
23643      &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23644      &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23645      &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23646      &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23647      &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23648      &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23649      &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23650      &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23651      &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23652      &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23653      &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23654      &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
23655      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23656      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23657      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23658      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23659      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23660       DATA (DL(K),K= 3826, 3910) /
23661      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23662      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23663      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23664      &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23665      &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23666      &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23667      &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23668      &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23669      &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23670      &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23671      &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23672      &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23673      &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23674      &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23675      &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23676      &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23677      &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23678       DATA (DL(K),K= 3911, 3995) /
23679      &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23680      &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23681      &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23682      &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23683      &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23684      &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23685      &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23686      &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23687      &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23688      &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
23689      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23690      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23691      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23692      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23693      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23694      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23695      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23696       DATA (DL(K),K= 3996, 4000) /
23697      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23698 C
23699       ANS = 0.
23700       IF (X.GT.0.9985) RETURN
23701       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23702 C
23703       IS  = S/DELTA+1
23704       IS1 = IS+1
23705       DO 1 L=1,25
23706          KL    = L+NDRV*25
23707          F1(L) = GF(I,IS,KL)
23708          F2(L) = GF(I,IS1,KL)
23709     1 CONTINUE
23710       A1 = DT_CKMTFF(X,F1)
23711       A2 = DT_CKMTFF(X,F2)
23712 C      A1=ALOG(A1)
23713 C      A2=ALOG(A2)
23714       S1  = (IS-1)*DELTA
23715       S2  = S1+DELTA
23716       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23717 C      ANS=EXP(ANS)
23718       RETURN
23719       END
23720 C
23721 C
23722
23723 *$ CREATE DT_CKMTPR.FOR
23724 *COPY DT_CKMTPR
23725       SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23726 C
23727 C**********************************************************************
23728 C    Proton   - PDFs
23729 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23730 C    ANS = PDF(I)
23731 C    This version by S. Roesler, 31.01.96
23732 C**********************************************************************
23733
23734       SAVE
23735       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23736       EQUIVALENCE (GF(1,1,1),DL(1))
23737       DATA DELTA/.10/
23738 C
23739       DATA (DL(K),K=    1,   85) /
23740      &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23741      &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23742      &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23743      &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23744      &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23745      &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23746      &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23747      &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23748      &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23749      &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23750      &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23751      &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23752      &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23753      &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23754      &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23755      &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23756      &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23757       DATA (DL(K),K=   86,  170) /
23758      &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23759      &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23760      &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23761      &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23762      &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23763      &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23764      &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23765      &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23766      &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23767      &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23768      &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23769      &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23770      &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23771      &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23772      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23773      &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23774      &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23775       DATA (DL(K),K=  171,  255) /
23776      &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23777      &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23778      &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23779      &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23780      &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23781      &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23782      &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23783      &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23784      &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23785      &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23786      &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23787      &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23788      &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23789      &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23790      &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23791      &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23792      &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23793       DATA (DL(K),K=  256,  340) /
23794      &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23795      &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23796      &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23797      &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23798      &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23799      &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23800      &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23801      &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23802      &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23803      &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23804      &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23805      &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23806      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23807      &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23808      &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23809      &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23810      &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23811       DATA (DL(K),K=  341,  425) /
23812      &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23813      &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23814      &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23815      &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23816      &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23817      &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23818      &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23819      &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23820      &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23821      &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23822      &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23823      &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23824      &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23825      &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23826      &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23827      &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23828      &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23829       DATA (DL(K),K=  426,  510) /
23830      &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23831      &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23832      &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23833      &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23834      &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23835      &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23836      &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23837      &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23838      &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23839      &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23840      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23841      &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23842      &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23843      &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23844      &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23845      &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23846      &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23847       DATA (DL(K),K=  511,  595) /
23848      &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23849      &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23850      &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23851      &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23852      &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23853      &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23854      &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23855      &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23856      &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23857      &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23858      &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23859      &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23860      &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23861      &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23862      &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23863      &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23864      &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23865       DATA (DL(K),K=  596,  680) /
23866      &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23867      &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23868      &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23869      &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23870      &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23871      &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23872      &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23873      &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23874      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23875      &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23876      &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23877      &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23878      &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23879      &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23880      &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23881      &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23882      &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23883       DATA (DL(K),K=  681,  765) /
23884      &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23885      &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23886      &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23887      &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23888      &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23889      &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23890      &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23891      &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23892      &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23893      &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23894      &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23895      &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23896      &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23897      &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23898      &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23899      &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23900      &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23901       DATA (DL(K),K=  766,  850) /
23902      &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23903      &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23904      &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23905      &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23906      &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23907      &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23908      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23909      &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23910      &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23911      &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23912      &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23913      &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23914      &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23915      &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23916      &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23917      &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23918      &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23919       DATA (DL(K),K=  851,  935) /
23920      &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23921      &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23922      &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23923      &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23924      &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23925      &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23926      &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23927      &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23928      &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23929      &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23930      &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23931      &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23932      &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23933      &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23934      &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23935      &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23936      &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23937       DATA (DL(K),K=  936, 1020) /
23938      &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23939      &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23940      &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23941      &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23942      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23943      &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23944      &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23945      &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23946      &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23947      &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23948      &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23949      &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23950      &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23951      &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23952      &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23953      &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23954      &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23955       DATA (DL(K),K= 1021, 1105) /
23956      &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23957      &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23958      &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23959      &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
23960      &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
23961      &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
23962      &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
23963      &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
23964      &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
23965      &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
23966      &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
23967      &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
23968      &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
23969      &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
23970      &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
23971      &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
23972      &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
23973       DATA (DL(K),K= 1106, 1190) /
23974      &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
23975      &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23976      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23977      &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23978      &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
23979      &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
23980      &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
23981      &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
23982      &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
23983      &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
23984      &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
23985      &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
23986      &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
23987      &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
23988      &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
23989      &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
23990      &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
23991       DATA (DL(K),K= 1191, 1275) /
23992      &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
23993      &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
23994      &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
23995      &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
23996      &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
23997      &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
23998      &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
23999      &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
24000      &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
24001      &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
24002      &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
24003      &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
24004      &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
24005      &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
24006      &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
24007      &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
24008      &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
24009       DATA (DL(K),K= 1276, 1360) /
24010      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24011      &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
24012      &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
24013      &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
24014      &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
24015      &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
24016      &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
24017      &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
24018      &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
24019      &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
24020      &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
24021      &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
24022      &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
24023      &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
24024      &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
24025      &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
24026      &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
24027       DATA (DL(K),K= 1361, 1445) /
24028      &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
24029      &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
24030      &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
24031      &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
24032      &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
24033      &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
24034      &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
24035      &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
24036      &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
24037      &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
24038      &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
24039      &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
24040      &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
24041      &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
24042      &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
24043      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24044      &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
24045       DATA (DL(K),K= 1446, 1530) /
24046      &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
24047      &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
24048      &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
24049      &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
24050      &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
24051      &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
24052      &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
24053      &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
24054      &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
24055      &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
24056      &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
24057      &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
24058      &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
24059      &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
24060      &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
24061      &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
24062      &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
24063       DATA (DL(K),K= 1531, 1615) /
24064      &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
24065      &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
24066      &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
24067      &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
24068      &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
24069      &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
24070      &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
24071      &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
24072      &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
24073      &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
24074      &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
24075      &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
24076      &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24077      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24078      &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
24079      &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
24080      &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
24081       DATA (DL(K),K= 1616, 1700) /
24082      &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
24083      &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
24084      &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
24085      &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
24086      &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
24087      &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
24088      &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
24089      &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
24090      &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
24091      &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
24092      &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
24093      &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
24094      &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
24095      &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
24096      &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
24097      &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
24098      &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
24099       DATA (DL(K),K= 1701, 1785) /
24100      &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
24101      &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
24102      &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
24103      &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
24104      &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
24105      &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
24106      &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
24107      &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
24108      &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
24109      &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
24110      &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24111      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24112      &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
24113      &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
24114      &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
24115      &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
24116      &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
24117       DATA (DL(K),K= 1786, 1870) /
24118      &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
24119      &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
24120      &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
24121      &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
24122      &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
24123      &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
24124      &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
24125      &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
24126      &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
24127      &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
24128      &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
24129      &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
24130      &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
24131      &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
24132      &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
24133      &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
24134      &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
24135       DATA (DL(K),K= 1871, 1955) /
24136      &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
24137      &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
24138      &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
24139      &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
24140      &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
24141      &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
24142      &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
24143      &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
24144      &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24145      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24146      &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
24147      &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
24148      &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
24149      &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
24150      &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
24151      &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
24152      &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
24153       DATA (DL(K),K= 1956, 2040) /
24154      &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
24155      &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
24156      &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
24157      &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
24158      &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
24159      &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
24160      &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
24161      &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
24162      &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
24163      &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
24164      &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
24165      &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
24166      &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
24167      &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
24168      &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
24169      &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
24170      &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
24171       DATA (DL(K),K= 2041, 2125) /
24172      &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
24173      &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
24174      &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
24175      &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
24176      &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
24177      &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
24178      &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24179      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24180      &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
24181      &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
24182      &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
24183      &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
24184      &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
24185      &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
24186      &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
24187      &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
24188      &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
24189       DATA (DL(K),K= 2126, 2210) /
24190      &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
24191      &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
24192      &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
24193      &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
24194      &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
24195      &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
24196      &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
24197      &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
24198      &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
24199      &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
24200      &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
24201      &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
24202      &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
24203      &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
24204      &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
24205      &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
24206      &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
24207       DATA (DL(K),K= 2211, 2295) /
24208      &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
24209      &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
24210      &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
24211      &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
24212      &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24213      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24214      &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
24215      &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
24216      &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
24217      &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
24218      &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
24219      &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
24220      &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
24221      &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
24222      &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
24223      &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
24224      &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
24225       DATA (DL(K),K= 2296, 2380) /
24226      &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
24227      &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
24228      &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
24229      &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
24230      &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
24231      &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
24232      &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
24233      &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
24234      &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
24235      &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
24236      &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
24237      &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
24238      &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
24239      &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
24240      &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
24241      &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
24242      &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
24243       DATA (DL(K),K= 2381, 2465) /
24244      &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
24245      &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
24246      &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24247      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24248      &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
24249      &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
24250      &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
24251      &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
24252      &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
24253      &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
24254      &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
24255      &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
24256      &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
24257      &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
24258      &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
24259      &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
24260      &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
24261       DATA (DL(K),K= 2466, 2550) /
24262      &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
24263      &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
24264      &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
24265      &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
24266      &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
24267      &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
24268      &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
24269      &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
24270      &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
24271      &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
24272      &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
24273      &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
24274      &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
24275      &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
24276      &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
24277      &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
24278      &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
24279       DATA (DL(K),K= 2551, 2635) /
24280      &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24281      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24282      &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
24283      &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
24284      &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
24285      &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
24286      &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
24287      &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
24288      &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
24289      &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
24290      &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
24291      &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
24292      &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
24293      &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
24294      &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
24295      &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
24296      &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
24297       DATA (DL(K),K= 2636, 2720) /
24298      &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
24299      &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
24300      &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
24301      &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
24302      &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
24303      &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
24304      &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
24305      &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
24306      &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
24307      &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
24308      &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
24309      &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
24310      &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
24311      &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
24312      &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
24313      &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24314      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24315       DATA (DL(K),K= 2721, 2805) /
24316      &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
24317      &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
24318      &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
24319      &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
24320      &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24321      &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24322      &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24323      &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24324      &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24325      &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24326      &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24327      &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24328      &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24329      &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24330      &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24331      &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24332      &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24333       DATA (DL(K),K= 2806, 2890) /
24334      &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24335      &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24336      &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24337      &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24338      &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24339      &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24340      &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24341      &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24342      &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24343      &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24344      &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24345      &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24346      &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24347      &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24348      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24349      &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24350      &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24351       DATA (DL(K),K= 2891, 2975) /
24352      &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24353      &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24354      &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24355      &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24356      &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24357      &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24358      &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24359      &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24360      &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24361      &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24362      &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24363      &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24364      &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24365      &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24366      &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24367      &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24368      &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24369       DATA (DL(K),K= 2976, 3060) /
24370      &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24371      &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24372      &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24373      &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24374      &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24375      &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24376      &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24377      &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24378      &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24379      &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24380      &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24381      &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24382      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24383      &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24384      &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24385      &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24386      &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24387       DATA (DL(K),K= 3061, 3145) /
24388      &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24389      &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24390      &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24391      &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24392      &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24393      &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24394      &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24395      &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24396      &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24397      &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24398      &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24399      &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24400      &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24401      &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24402      &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24403      &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24404      &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24405       DATA (DL(K),K= 3146, 3230) /
24406      &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24407      &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24408      &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24409      &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24410      &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24411      &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24412      &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24413      &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24414      &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24415      &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24416      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24417      &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24418      &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24419      &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24420      &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24421      &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24422      &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24423       DATA (DL(K),K= 3231, 3315) /
24424      &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24425      &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24426      &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24427      &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24428      &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24429      &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24430      &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24431      &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24432      &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24433      &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24434      &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24435      &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24436      &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24437      &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24438      &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24439      &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24440      &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24441       DATA (DL(K),K= 3316, 3400) /
24442      &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24443      &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24444      &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24445      &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24446      &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24447      &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24448      &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24449      &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24450      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24451      &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24452      &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24453      &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24454      &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24455      &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24456      &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24457      &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24458      &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24459       DATA (DL(K),K= 3401, 3485) /
24460      &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24461      &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24462      &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24463      &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24464      &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24465      &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24466      &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24467      &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24468      &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24469      &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24470      &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24471      &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24472      &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24473      &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24474      &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24475      &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24476      &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24477       DATA (DL(K),K= 3486, 3570) /
24478      &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24479      &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24480      &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24481      &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24482      &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24483      &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24484      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24485      &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24486      &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24487      &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24488      &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24489      &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24490      &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24491      &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24492      &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24493      &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24494      &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24495       DATA (DL(K),K= 3571, 3655) /
24496      &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24497      &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24498      &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24499      &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24500      &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24501      &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24502      &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24503      &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24504      &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24505      &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24506      &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24507      &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24508      &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24509      &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24510      &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24511      &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24512      &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24513       DATA (DL(K),K= 3656, 3740) /
24514      &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24515      &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24516      &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24517      &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24518      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24519      &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24520      &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24521      &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24522      &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24523      &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24524      &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24525      &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24526      &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24527      &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24528      &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24529      &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24530      &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24531       DATA (DL(K),K= 3741, 3825) /
24532      &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24533      &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24534      &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24535      &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24536      &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24537      &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24538      &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24539      &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24540      &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24541      &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24542      &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24543      &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24544      &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24545      &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24546      &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24547      &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24548      &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24549       DATA (DL(K),K= 3826, 3910) /
24550      &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24551      &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24552      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24553      &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24554      &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24555      &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24556      &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24557      &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24558      &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24559      &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24560      &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24561      &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24562      &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24563      &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24564      &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24565      &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24566      &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24567       DATA (DL(K),K= 3911, 3995) /
24568      &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24569      &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24570      &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24571      &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24572      &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24573      &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24574      &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24575      &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24576      &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24577      &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24578      &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24579      &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24580      &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24581      &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24582      &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24583      &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24584      &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24585       DATA (DL(K),K= 3996, 4000) /
24586      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24587 C
24588       ANS = 0.
24589       IF (X.GT.0.9985) RETURN
24590       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24591 C
24592       IS  = S/DELTA+1
24593       IS1 = IS+1
24594       DO 1 L=1,25
24595          KL    = L+NDRV*25
24596          F1(L) = GF(I,IS,KL)
24597          F2(L) = GF(I,IS1,KL)
24598     1 CONTINUE
24599       A1 = DT_CKMTFF(X,F1)
24600       A2 = DT_CKMTFF(X,F2)
24601 C      A1=ALOG(A1)
24602 C      A2=ALOG(A2)
24603       S1  = (IS-1)*DELTA
24604       S2  = S1+DELTA
24605       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24606 C      ANS=EXP(ANS)
24607       RETURN
24608       END
24609 C
24610
24611 *$ CREATE DT_CKMTFF.FOR
24612 *COPY DT_CKMTFF
24613       FUNCTION DT_CKMTFF(X,FVL)
24614 C**********************************************************************
24615 C
24616 C     LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24617 C     FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24618 C     NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24619 C     IN MAIN ROUTINE.
24620 C
24621 C**********************************************************************
24622
24623       SAVE
24624       DIMENSION FVL(25),XGRID(25)
24625       DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24626      *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24627 C
24628       DT_CKMTFF=0.
24629       DO 1 I=1,NX
24630       IF(X.LT.XGRID(I)) GO TO 2
24631     1 CONTINUE
24632     2 I=I-1
24633       IF(I.EQ.0) THEN
24634          I=I+1
24635       ELSE IF(I.GT.23) THEN
24636          I=23
24637       ENDIF
24638       J=I+1
24639       K=J+1
24640       AXI=LOG(XGRID(I))
24641       BXI=LOG(1.-XGRID(I))
24642       AXJ=LOG(XGRID(J))
24643       BXJ=LOG(1.-XGRID(J))
24644       AXK=LOG(XGRID(K))
24645       BXK=LOG(1.-XGRID(K))
24646       FI=LOG(ABS(FVL(I)) +1.E-15)
24647       FJ=LOG(ABS(FVL(J)) +1.E-16)
24648       FK=LOG(ABS(FVL(K)) +1.E-17)
24649       DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24650       ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24651      $ BXI))/DET
24652       ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24653       BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24654       IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24655      1RETURN
24656 C      IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24657 C         WRITE(6,2001) X,FVL
24658 C 2001    FORMAT(8E12.4)
24659 C         WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24660 C      ENDIF
24661       DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24662       RETURN
24663       END
24664
24665 *$ CREATE DT_FLUINI.FOR
24666 *COPY DT_FLUINI
24667 *
24668 *===fluini=============================================================*
24669 *
24670       SUBROUTINE DT_FLUINI
24671
24672 ************************************************************************
24673 * Initialisation of the nucleon-nucleon cross section fluctuation      *
24674 * treatment. The original version by J. Ranft.                         *
24675 * This version dated 21.04.95 is revised by S. Roesler.                *
24676 ************************************************************************
24677
24678       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24679       SAVE
24680       PARAMETER ( LINP = 10 ,
24681      &            LOUT = 6 ,
24682      &            LDAT = 9 )
24683       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24684
24685       PARAMETER ( A     = 0.1D0,
24686      &            B     = 0.893D0,
24687      &            OM    = 1.1D0,
24688      &            N     = 6,
24689      &            DX    = 0.003D0)
24690
24691 * n-n cross section fluctuations
24692       PARAMETER (NBINS = 1000)
24693       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24694       DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24695
24696       WRITE(LOUT,1000)
24697  1000 FORMAT(/,1X,'FLUINI:  hadronic cross section fluctuations ',
24698      &       'treated')
24699
24700       FLUSU  = ZERO
24701       FLUSUU = ZERO
24702
24703       DO 1 I=1,NBINS
24704          X        = DBLE(I)*DX
24705          FLUIX(I) = X
24706          FLUS     = ((X-B)/(OM*B))**N
24707          IF (FLUS.LE.20.0D0) THEN
24708             FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24709          ELSE
24710             FLUSI(I) = ZERO
24711          ENDIF
24712          FLUSU = FLUSU+FLUSI(I)
24713     1 CONTINUE
24714       DO 2 I=1,NBINS
24715          FLUSUU   = FLUSUU+FLUSI(I)/FLUSU
24716          FLUSI(I) = FLUSUU
24717     2 CONTINUE
24718
24719 C     WRITE(LOUT,1001)
24720 C1001 FORMAT(1X,'FLUCTUATIONS')
24721 C     CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24722
24723       DO 3 I=1,NBINS
24724          AF = DBLE(I)*0.001D0
24725          DO 4 J=1,NBINS
24726             IF (AF.LE.FLUSI(J)) THEN
24727                FLUIXX(I) = FLUIX(J)
24728                GOTO 5
24729             ENDIF
24730     4    CONTINUE
24731     5    CONTINUE
24732     3 CONTINUE
24733       FLUIXX(1)     = FLUIX(1)
24734       FLUIXX(NBINS) = FLUIX(NBINS)
24735
24736       RETURN
24737       END
24738
24739 *$ CREATE DT_SIGTBL.FOR
24740 *COPY DT_SIGTBL
24741 *
24742 *===sigtab=============================================================*
24743 *
24744       SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24745
24746 ************************************************************************
24747 * This version dated 18.11.95 is written by S. Roesler                 *
24748 ************************************************************************
24749
24750       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24751       SAVE
24752       PARAMETER ( LINP = 10 ,
24753      &            LOUT = 6 ,
24754      &            LDAT = 9 )
24755
24756       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24757      &           OHALF=0.5D0,ONE=1.0D0)
24758       PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24759
24760       LOGICAL LINIT
24761
24762 * particle properties (BAMJET index convention)
24763       CHARACTER*8  ANAME
24764       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24765      &                IICH(210),IIBAR(210),K1(210),K2(210)
24766
24767       DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24768       DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24769      &             0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24770      &             0, 0, 5/
24771       DATA LINIT /.FALSE./
24772
24773 * precalculation and tabulation of elastic cross sections
24774       IF (ABS(MODE).EQ.1) THEN
24775          IF (MODE.EQ.1)
24776      &      OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24777          PLABLX = LOG10(PLO)
24778          PLABHX = LOG10(PHI)
24779          DPLAB  = (PLABHX-PLABLX)/DBLE(NBINS)
24780          DO 1 I=1,NBINS+1
24781             PLAB = PLABLX+DBLE(I-1)*DPLAB
24782             PLAB = 10**PLAB
24783             DO 2 IPROJ=1,23
24784                IDX = IDSIG(IPROJ)
24785                IF (IDX.GT.0) THEN
24786 C                 CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24787 C                 CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24788                   DUMZER = ZERO
24789                   CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24790                   CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24791                ENDIF
24792     2       CONTINUE
24793             IF (MODE.EQ.1) THEN
24794                WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24795      &                                (SIGEN(IDX,I),IDX=1,5)
24796  1000          FORMAT(F5.1,10F7.2)
24797             ENDIF
24798     1    CONTINUE
24799          IF (MODE.EQ.1) CLOSE(LDAT)
24800          LINIT = .TRUE.
24801       ELSE
24802          SIGE = -ONE
24803          IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24804      &                           .AND.(PTOT.LE.PHI) ) THEN
24805             IDX = IDSIG(JP)
24806             IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24807                PLABX = LOG10(PTOT)
24808                IF (PLABX.LE.PLABLX) THEN
24809                   I1 = 1
24810                   I2 = 1
24811                ELSEIF (PLABX.GE.PLABHX) THEN
24812                   I1 = NBINS+1
24813                   I2 = NBINS+1
24814                ELSE
24815                   I1 = INT((PLABX-PLABLX)/DPLAB)+1
24816                   I2 = I1+1
24817                ENDIF
24818                PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24819                PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24820                PBIN   = PLAB2X-PLAB1X
24821                IF (PBIN.GT.TINY10) THEN
24822                   RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24823                ELSE
24824                   RATX = ZERO
24825                ENDIF
24826                IF (JT.EQ.1) THEN
24827                   SIG1 = SIGEP(IDX,I1)
24828                   SIG2 = SIGEP(IDX,I2)
24829                ELSE
24830                   SIG1 = SIGEN(IDX,I1)
24831                   SIG2 = SIGEN(IDX,I2)
24832                ENDIF
24833                SIGE = SIG1+RATX*(SIG2-SIG1)
24834             ENDIF
24835          ENDIF
24836       ENDIF
24837
24838       RETURN
24839       END
24840
24841 *$ CREATE DT_XSTABL.FOR
24842 *COPY DT_XSTABL
24843 *
24844 *===xstabl=============================================================*
24845 *
24846       SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24847
24848       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24849       SAVE
24850       PARAMETER ( LINP = 10 ,
24851      &            LOUT = 6 ,
24852      &            LDAT = 9 )
24853       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24854      &           OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24855       LOGICAL LLAB,LELOG,LQLOG
24856
24857 * particle properties (BAMJET index convention)
24858       CHARACTER*8  ANAME
24859       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24860      &                IICH(210),IIBAR(210),K1(210),K2(210)
24861 * properties of interacting particles
24862       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24863       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24864 * Glauber formalism: cross sections
24865       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24866      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24867      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24868      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24869      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24870      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24871      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24872      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24873      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24874      &                BSLOPE,NEBINI,NQBINI
24875 * emulsion treatment
24876       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24877      &                NCOMPO,IEMUL
24878
24879       DIMENSION WHAT(6)
24880
24881       LLAB   = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24882       ELO    = ABS(WHAT(1))
24883       EHI    = ABS(WHAT(2))
24884       IF (ELO.GT.EHI) ELO = EHI
24885       LELOG  = WHAT(3).LT.ZERO
24886       NEBINS = MAX(INT(ABS(WHAT(3))),1)
24887       DEBINS = (EHI-ELO)/DBLE(NEBINS)
24888       IF (LELOG) THEN
24889          AELO   = LOG10(ELO)
24890          AEHI   = LOG10(EHI)
24891          ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24892       ENDIF
24893       Q2LO   = WHAT(4)
24894       Q2HI   = WHAT(5)
24895       IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24896       LQLOG  = WHAT(6).LT.ZERO
24897       NQBINS = MAX(INT(ABS(WHAT(6))),1)
24898       DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24899       IF (LQLOG) THEN
24900          AQ2LO  = LOG10(Q2LO)
24901          AQ2HI  = LOG10(Q2HI)
24902          ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24903       ENDIF
24904
24905       IF ( ELO.EQ. EHI) NEBINS = 0
24906       IF (Q2LO.EQ.Q2HI) NQBINS = 0
24907
24908       WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24909  1000 FORMAT(/,1X,'XSTABL:  E_lo  =',E10.3,' GeV  E_hi  =',E10.3,
24910      &       ' GeV     Lab = ',L1,'  qel: ',I2,/,10X,'Q2_lo =',F10.5,
24911      &       ' GeV^2  Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24912      &       '   A_p = ',I3,'   A_t = ',I3,/)
24913
24914 C     IF (IJPROJ.NE.7) THEN
24915          WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24916 * normalize fractions of emulsion components
24917          IF (NCOMPO.GT.0) THEN
24918             SUMFRA = ZERO
24919             DO 10 I=1,NCOMPO
24920                SUMFRA = SUMFRA+EMUFRA(I)
24921    10       CONTINUE
24922             IF (SUMFRA.GT.ZERO) THEN
24923                DO 11 I=1,NCOMPO
24924                   EMUFRA(I) = EMUFRA(I)/SUMFRA
24925    11          CONTINUE
24926             ENDIF
24927          ENDIF
24928 C     ELSE
24929 C        WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24930 C     ENDIF
24931       DO 1 I=1,NEBINS+1
24932          IF (LELOG) THEN
24933             E = 10**(AELO+DBLE(I-1)*ADEBIN)
24934          ELSE
24935             E = ELO+DBLE(I-1)*DEBINS
24936          ENDIF
24937          DO 2 J=1,NQBINS+1
24938             IF (LQLOG) THEN
24939                Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24940             ELSE
24941                Q2 = Q2LO+DBLE(J-1)*DQBINS
24942             ENDIF
24943 c            IF (IJPROJ.NE.7) THEN
24944                IF (LLAB) THEN
24945                   PLAB = ZERO
24946                   ECM  = ZERO
24947                   CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24948                ELSE
24949                   ECM = E
24950                ENDIF
24951                XI  = ZERO
24952                Q2I = ZERO
24953                IF (IJPROJ.EQ.7) Q2I = Q2
24954                IF (NCOMPO.GT.0) THEN
24955                   DO 20 IC=1,NCOMPO
24956                      IIT = IEMUMA(IC)
24957                      CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
24958    20             CONTINUE
24959                ELSE
24960                   CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
24961 C                 CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
24962                ENDIF
24963                IF (NCOMPO.GT.0) THEN
24964                   XTOT = ZERO
24965                   ETOT = ZERO
24966                   XELA = ZERO
24967                   EELA = ZERO
24968                   XQEP = ZERO
24969                   EQEP = ZERO
24970                   XQET = ZERO
24971                   EQET = ZERO
24972                   XQE2 = ZERO
24973                   EQE2 = ZERO
24974                   XPRO = ZERO
24975                   EPRO = ZERO
24976                   XPRO1= ZERO
24977                   XDEL = ZERO
24978                   EDEL = ZERO
24979                   XDQE = ZERO
24980                   EDQE = ZERO
24981                   DO 21 IC=1,NCOMPO
24982                      XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
24983                      ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
24984                      XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
24985                      EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
24986                      XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
24987                      EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
24988                      XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
24989                      EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
24990                      XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
24991                      EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
24992                      XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
24993                      EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
24994                      XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
24995                      EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
24996                      XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
24997                      EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
24998                      YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
24999      &                     -XSQEP(1,1,IC)-XSQET(1,1,IC)
25000      &                     -XSQE2(1,1,IC)
25001                      XPRO1= XPRO1+EMUFRA(IC)*YPRO
25002    21             CONTINUE
25003                   ETOT = SQRT(ETOT)
25004                   EELA = SQRT(EELA)
25005                   EQEP = SQRT(EQEP)
25006                   EQET = SQRT(EQET)
25007                   EQE2 = SQRT(EQE2)
25008                   EPRO = SQRT(EPRO)
25009                   EDEL = SQRT(EDEL)
25010                   EDQE = SQRT(EDQE)
25011                   WRITE(LOUT,'(8E9.3)')
25012      &               E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
25013 C                 WRITE(LOUT,'(4E9.3)')
25014 C    &               E,XDEL,XDQE,XDEL+XDQE
25015                ELSE
25016                   WRITE(LOUT,'(11E10.3)')
25017      &              E,
25018      &              XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
25019      &              XSQE2(1,1,1),XSPRO(1,1,1),
25020      &              XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
25021      &             -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
25022      &              XSDEL(1,1,1)+XSDQE(1,1,1)
25023 C                 WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
25024 C    &                                    XSDEL(1,1,1)+XSDQE(1,1,1)
25025                ENDIF
25026 c            ELSE
25027 c               IF (LLAB) THEN
25028 c                  IF (IT.GT.1) THEN
25029 c                     IF (IXSQEL.EQ.0) THEN
25030 cC                       CALL DT_SIGGA(IT,  Q2, E,ZERO,ZERO,
25031 cC                       CALL DT_SIGGA(IT,   E,Q2,ZERO,ZERO,
25032 c                        CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
25033 c     &                             STOT,ETOT,SIN,EIN,STOT0)
25034 c                        IF (IRATIO.EQ.1) THEN
25035 c                           CALL DT_SIGGP(  Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
25036 cC                          CALL DT_SIGGP(   E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
25037 cC                          CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
25038 c*!! save cross sections
25039 c                           STOTA = STOT
25040 c                           ETOTA = ETOT
25041 c                           STOTP = STGP
25042 c*!!
25043 c                           STOT  = STOT/(DBLE(IT)*STGP)
25044 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
25045 c                           STOT0 = STGP
25046 c                           ETOT  = ZERO
25047 c                           EIN   = ZERO
25048 c                        ENDIF
25049 c                     ELSE
25050 c                        WRITE(LOUT,*)
25051 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
25052 c                        STOP
25053 c                     ENDIF
25054 c                  ELSE
25055 c                     ETOT = ZERO
25056 c                     EIN  = ZERO
25057 c                     STOT0= ZERO
25058 c                     IF (IXSQEL.EQ.0) THEN
25059 c                        CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
25060 c                     ELSE
25061 c                       SIN = ZERO
25062 c                       CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
25063 c                     ENDIF
25064 c                  ENDIF
25065 c               ELSE
25066 c                  IF (IT.GT.1) THEN
25067 c                     IF (IXSQEL.EQ.0) THEN
25068 c                        CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
25069 c     &                             STOT,ETOT,SIN,EIN,STOT0)
25070 c                        IF (IRATIO.EQ.1) THEN
25071 c                           CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
25072 c*!! save cross sections
25073 c                           STOTA = STOT
25074 c                           ETOTA = ETOT
25075 c                           STOTP = STGP
25076 c*!!
25077 c                           STOT  = STOT/(DBLE(IT)*STGP)
25078 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
25079 c                           STOT0 = STGP
25080 c                           ETOT  = ZERO
25081 c                           EIN   = ZERO
25082 c                        ENDIF
25083 c                     ELSE
25084 c                        WRITE(LOUT,*)
25085 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
25086 c                        STOP
25087 c                     ENDIF
25088 c                  ELSE
25089 c                     ETOT = ZERO
25090 c                     EIN  = ZERO
25091 c                     STOT0= ZERO
25092 c                     IF (IXSQEL.EQ.0) THEN
25093 c                        CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
25094 c                     ELSE
25095 c                       SIN = ZERO
25096 c                       CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
25097 c                     ENDIF
25098 c                  ENDIF
25099 c               ENDIF
25100 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
25101 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
25102 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
25103 c               WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
25104 c            ENDIF
25105     2    CONTINUE
25106     1 CONTINUE
25107
25108       RETURN
25109       END
25110
25111 *$ CREATE DT_TESTXS.FOR
25112 *COPY DT_TESTXS
25113 *
25114 *===testxs=============================================================*
25115 *
25116       SUBROUTINE DT_TESTXS
25117
25118       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25119       SAVE
25120
25121       DIMENSION XSTOT(26,2),XSELA(26,2)
25122
25123       OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
25124       OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
25125       OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
25126       OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
25127       DUMECM = 0.0D0
25128       PLABL = 0.01D0
25129       PLABH = 10000.0D0
25130       NBINS = 120
25131       APLABL = LOG10(PLABL)
25132       APLABH = LOG10(PLABH)
25133       ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
25134       DO 1 I=1,NBINS+1
25135          ADP = APLABL+DBLE(I-1)*ADPLAB
25136          P = 10.0D0**ADP
25137          DO 2 J=1,26
25138             CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
25139             CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
25140     2    CONTINUE
25141          WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
25142          WRITE(11,1000) P,(XSELA(K,1),K=1,26)
25143          WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
25144          WRITE(13,1000) P,(XSELA(K,2),K=1,26)
25145     1 CONTINUE
25146  1000 FORMAT(F8.3,26F9.3)
25147
25148       RETURN
25149       END
25150
25151 ************************************************************************
25152 *                                                                      *
25153 *  DTUNUC 2.0:   library routines                                      *
25154 *                                   processed by S. Roesler, 6.5.95    *
25155 *                                                                      *
25156 ************************************************************************
25157 *
25158 *     1) Handling of parton momenta
25159 *          SUBROUTINE MASHEL
25160 *          SUBROUTINE DFERMI
25161 *
25162 *     2) Handling of parton flavors and particle indices
25163 *          INTEGER FUNCTION IPDG2B
25164 *          INTEGER FUNCTION IB2PDG
25165 *          INTEGER FUNCTION IQUARK
25166 *          INTEGER FUNCTION IBJQUA
25167 *          INTEGER FUNCTION ICIHAD
25168 *          INTEGER FUNCTION IPDGHA
25169 *          INTEGER FUNCTION MCHAD
25170 *          SUBROUTINE FLAHAD
25171 *
25172 *     3) Energy-momentum and quantum number conservation check routines
25173 *          SUBROUTINE EMC1
25174 *          SUBROUTINE EMC2
25175 *          SUBROUTINE EVTEMC
25176 *          SUBROUTINE EVTFLC
25177 *          SUBROUTINE EVTCHG
25178 *
25179 *     4) Transformations
25180 *          SUBROUTINE LTINI
25181 *          SUBROUTINE LTRANS
25182 *          SUBROUTINE LTNUC
25183 *          SUBROUTINE DALTRA
25184 *          SUBROUTINE DTRAFO
25185 *          SUBROUTINE STTRAN
25186 *          SUBROUTINE MYTRAN
25187 *          SUBROUTINE LT2LAO
25188 *          SUBROUTINE LT2LAB
25189 *
25190 *     5) Sampling from distributions
25191 *          INTEGER FUNCTION NPOISS
25192 *          DOUBLE PRECISION FUNCTION SAMPXB
25193 *          DOUBLE PRECISION FUNCTION SAMPEX
25194 *          DOUBLE PRECISION FUNCTION SAMSQX
25195 *          DOUBLE PRECISION FUNCTION BETREJ
25196 *          DOUBLE PRECISION FUNCTION DGAMRN
25197 *          DOUBLE PRECISION FUNCTION DBETAR
25198 *          SUBROUTINE RANNOR
25199 *          SUBROUTINE DPOLI
25200 *          SUBROUTINE DSFECF
25201 *          SUBROUTINE RACO
25202 *
25203 *     6) Special functions, algorithms and service routines
25204 *          DOUBLE PRECISION FUNCTION YLAMB
25205 *          SUBROUTINE SORT
25206 *          SUBROUTINE SORT1
25207 *          SUBROUTINE DT_XTIME
25208 *
25209 *     7) Random number generator package
25210 *          DOUBLE PRECISION FUNCTION DT_RNDM
25211 *          SUBROUTINE DT_RNDMST
25212 *          SUBROUTINE DT_RNDMIN
25213 *          SUBROUTINE DT_RNDMOU
25214 *          SUBROUTINE DT_RNDMTE
25215 *
25216 ************************************************************************
25217 *                                                                      *
25218 *                 1) Handling of parton momenta                        *
25219 *                                                                      *
25220 ************************************************************************
25221 *$ CREATE DT_MASHEL.FOR
25222 *COPY DT_MASHEL
25223 *
25224 *===mashel=============================================================*
25225 *
25226       SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
25227
25228 ************************************************************************
25229 *                                                                      *
25230 *    rescaling of momenta of two partons to put both                   *
25231 *                                       on mass shell                  *
25232 *                                                                      *
25233 *    input:       PA1,PA2   input momentum vectors                     *
25234 *                 XM1,2     desired masses of particles afterwards     *
25235 *                 P1,P2     changed momentum vectors                   *
25236 *                                                                      *
25237 * The original version is written by R. Engel.                         *
25238 * This version dated 12.12.94 is modified by S. Roesler.               *
25239 ************************************************************************
25240
25241       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25242       SAVE
25243       PARAMETER ( LINP = 10 ,
25244      &            LOUT = 6 ,
25245      &            LDAT = 9 )
25246       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
25247
25248       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
25249
25250       IREJ = 0
25251
25252 * Lorentz transformation into system CMS
25253       PX  = PA1(1)+PA2(1)
25254       PY  = PA1(2)+PA2(2)
25255       PZ  = PA1(3)+PA2(3)
25256       EE  = PA1(4)+PA2(4)
25257       XPTOT = SQRT(PX**2+PY**2+PZ**2)
25258       XMS   = (EE-XPTOT)*(EE+XPTOT)
25259       IF(XMS.LT.(XM1+XM2)**2) THEN
25260 C        WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
25261          GOTO 9999
25262       ENDIF
25263       XMS = SQRT(XMS)
25264       BGX = PX/XMS
25265       BGY = PY/XMS
25266       BGZ = PZ/XMS
25267       GAM = EE/XMS
25268       CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
25269      &           PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
25270 * rotation angles
25271       COD = P1(3)/PTOT1
25272 C     SID = SQRT((ONE-COD)*(ONE+COD))
25273       PPT = SQRT(P1(1)**2+P1(2)**2)
25274       SID = PPT/PTOT1
25275       COF = ONE
25276       SIF = ZERO
25277       IF(PTOT1*SID.GT.TINY10) THEN
25278          COF   = P1(1)/(SID*PTOT1)
25279          SIF   = P1(2)/(SID*PTOT1)
25280          ANORF = SQRT(COF*COF+SIF*SIF)
25281          COF   = COF/ANORF
25282          SIF   = SIF/ANORF
25283       ENDIF
25284 * new CM momentum and energies (for masses XM1,XM2)
25285       XM12 = SIGN(XM1**2,XM1)
25286       XM22 = SIGN(XM2**2,XM2)
25287       SS   = XMS**2
25288       PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
25289       EE1  = SQRT(XM12+PCMP**2)
25290       EE2  = XMS-EE1
25291 * back rotation
25292       MODE = 1
25293       CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
25294       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
25295      &            PTOT1,P1(1),P1(2),P1(3),P1(4))
25296       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
25297      &            PTOT2,P2(1),P2(2),P2(3),P2(4))
25298 * check consistency
25299       DEL = XMS*0.0001D0
25300       IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
25301         IDEV = 1
25302       ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
25303         IDEV = 2
25304       ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
25305         IDEV = 3
25306       ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
25307         IDEV = 4
25308       ELSE
25309         IDEV = 0
25310       ENDIF
25311       IF (IDEV.NE.0) THEN
25312          WRITE(LOUT,'(/1X,A,I3)')
25313      &      'MASHEL: inconsistent transformation',IDEV
25314          WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25315          WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25316          WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25317          WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25318          WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25319          WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25320       ENDIF
25321       RETURN
25322
25323  9999 CONTINUE
25324       IREJ = 1
25325       RETURN
25326       END
25327
25328 *$ CREATE DT_DFERMI.FOR
25329 *COPY DT_DFERMI
25330 *
25331 *===dfermi=============================================================*
25332 *
25333       SUBROUTINE DT_DFERMI(GPART)
25334
25335 ************************************************************************
25336 * Find largest of three random numbers.                                *
25337 ************************************************************************
25338
25339       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25340       SAVE
25341
25342       DIMENSION G(3)
25343
25344       DO 10 I=1,3
25345         G(I)=DT_RNDM(GPART)
25346    10 CONTINUE
25347       IF (G(3).LT.G(2)) GOTO 40
25348       IF (G(3).LT.G(1)) GOTO 30
25349       GPART = G(3)
25350    20 RETURN
25351    30 GPART = G(1)
25352       GOTO 20
25353    40 IF (G(2).LT.G(1)) GOTO 30
25354       GPART = G(2)
25355       GOTO 20
25356
25357       END
25358
25359 ************************************************************************
25360 *                                                                      *
25361 *         2) Handling of parton flavors and particle indices           *
25362 *                                                                      *
25363 ************************************************************************
25364 *$ CREATE IDT_IPDG2B.FOR
25365 *COPY IDT_IPDG2B
25366 *
25367 *===ipdg2b=============================================================*
25368 *
25369       INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25370
25371 ************************************************************************
25372 *                                                                      *
25373 *     conversion of quark numbering scheme                             *
25374 *                                                                      *
25375 *     input:   PDG parton numbering                                    *
25376 *              for diquarks:  NN number of the constituent quark       *
25377 *                             (e.g. ID=2301,NN=1 -> ICONV2=1)          *
25378 *                                                                      *
25379 *     output:  BAMJET particle codes                                   *
25380 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
25381 *              2 d     8 a-d             -2 a-d                        *
25382 *              3 s     9 a-s             -3 a-s                        *
25383 *              4 c    10 a-c             -4 a-c                        *
25384 *                                                                      *
25385 * This is a modified version of ICONV2 written by R. Engel.            *
25386 * This version dated 13.12.94 is written by S. Roesler.                *
25387 ************************************************************************
25388
25389       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25390       SAVE
25391       PARAMETER ( LINP = 10 ,
25392      &            LOUT = 6 ,
25393      &            LDAT = 9 )
25394
25395       IDA = ABS(ID)
25396 * diquarks
25397       IF (IDA.GT.6) THEN
25398         KF  = 3
25399         IF (IDA.GE.1000) KF = 4
25400         IDA = IDA/(10**(KF-NN))
25401         IDA = MOD(IDA,10)
25402       ENDIF
25403 * exchange up and dn quarks
25404       IF (IDA.EQ.1) THEN
25405         IDA = 2
25406       ELSEIF (IDA.EQ.2) THEN
25407         IDA = 1
25408       ENDIF
25409 * antiquarks
25410       IF (ID.LT.0) THEN
25411          IF (MODE.EQ.1) THEN
25412             IDA = IDA+6
25413          ELSE
25414             IDA = -IDA
25415          ENDIF
25416       ENDIF
25417       IDT_IPDG2B = IDA
25418
25419       RETURN
25420       END
25421
25422 *$ CREATE IDT_IB2PDG.FOR
25423 *COPY IDT_IB2PDG
25424 *
25425 *===ib2pdg=============================================================*
25426 *
25427       INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25428
25429 ************************************************************************
25430 *                                                                      *
25431 *     conversion of quark numbering scheme                             *
25432 *                                                                      *
25433 *     input:   BAMJET particle codes                                   *
25434 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
25435 *              2 d     8 a-d             -2 a-d                        *
25436 *              3 s     9 a-s             -3 a-s                        *
25437 *              4 c    10 a-c             -4 a-c                        *
25438 *                                                                      *
25439 *     output:  PDG parton numbering                                    *
25440 *                                                                      *
25441 * This version dated 13.12.94 is written by S. Roesler.                *
25442 ************************************************************************
25443
25444       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25445       SAVE
25446       PARAMETER ( LINP = 10 ,
25447      &            LOUT = 6 ,
25448      &            LDAT = 9 )
25449
25450       DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25451       DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25452       DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25453      &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25454      &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25455
25456       IDA = ID1
25457       IDB = ID2
25458       IF (MODE.EQ.1) THEN
25459          IF (ID1.GT.6) IDA = -(ID1-6)
25460          IF (ID2.GT.6) IDB = -(ID2-6)
25461       ENDIF
25462       IF (ID2.EQ.0) THEN
25463          IDT_IB2PDG = IHKKQ(IDA)
25464       ELSE
25465          IDT_IB2PDG = IHKKQQ(IDA,IDB)
25466       ENDIF
25467
25468       RETURN
25469       END
25470
25471 *$ CREATE IDT_IQUARK.FOR
25472 *COPY IDT_IQUARK
25473 *
25474 *===ipdgqu=============================================================*
25475 *
25476       INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25477
25478 ************************************************************************
25479 *                                                                      *
25480 *     quark contents according to PDG conventions                      *
25481 *     (random selection in case of quark mixing)                       *
25482 *                                                                      *
25483 *     input:   IDBAMJ BAMJET particle code                             *
25484 *              K      1..3   quark number                              *
25485 *                                                                      *
25486 *     output:  1   d  (anti --> neg.)                                  *
25487 *              2   u                                                   *
25488 *              3   s                                                   *
25489 *              4   c                                                   *
25490 *                                                                      *
25491 * This version written by R. Engel.                                    *
25492 ************************************************************************
25493
25494       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25495       SAVE
25496
25497       IQ = IDT_IBJQUA(K,IDBAMJ)
25498 * quark-antiquark
25499       IF (IQ.GT.6) THEN
25500          IQ = 6-IQ
25501       ENDIF
25502 * exchange of up and down
25503       IF (ABS(IQ).EQ.1) THEN
25504          IQ = SIGN(2,IQ)
25505       ELSEIF (ABS(IQ).EQ.2) THEN
25506          IQ = SIGN(1,IQ)
25507       ENDIF
25508       IDT_IQUARK = IQ
25509
25510       RETURN
25511       END
25512
25513 *$ CREATE IDT_IBJQUA.FOR
25514 *COPY IDT_IBJQUA
25515 *
25516 *===ibamq==============================================================*
25517 *
25518       INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25519
25520 ************************************************************************
25521 *                                                                      *
25522 *     quark contents according to BAMJET conventions                   *
25523 *     (random selection in case of quark mixing)                       *
25524 *                                                                      *
25525 *     input:   IDBAMJ BAMJET particle code                             *
25526 *              K      1..3   quark number                              *
25527 *                                                                      *
25528 *     output:  1   u      7   u bar                                    *
25529 *              2   d      8   d bar                                    *
25530 *              3   s      9   s bar                                    *
25531 *              4   c     10   c bar                                    *
25532 *                                                                      *
25533 * This version written by R. Engel.                                    *
25534 ************************************************************************
25535
25536       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25537       SAVE
25538
25539       DIMENSION ITAB(3,210)
25540       DATA ((ITAB(I,K),I=1,3),K=1,30) /
25541      &    1,  1,  2,   7,  7,  8,   0,  0,  0,
25542      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25543      &    0,  0,  0,   1,  2,  2,   7,  8,  8,
25544 *sr 10.1.94
25545 C    &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25546      &    0,  0,  0,   0,  0,  0,   3,  8,  0,
25547 *
25548      &    1,  8,  0,   2,  7,  0,   1,  9,  0,
25549 *sr 10.1.94
25550 C    &    3,  7,  0,   0,  0,  0,   0,  0,  0,
25551      &    3,  7,  0,   3,  1,  2,   9,  7,  8,
25552 *sr 10.1.94
25553 C    &    0,  0,  0,   2,  2,  3,   1,  1,  3,
25554      &    2,  9,  0,   2,  2,  3,   1,  1,  3,
25555 *
25556      &    1,  2,  3, 201,202,  0,   2,  9,  0,
25557      &    3,  8,  0,   0,  0,  0,   0,  0,  0,
25558      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25559       DATA ((ITAB(I,K),I=1,3),K=31,60) /
25560      &    3,  9,  0,   1,  8,  0, 203,204,  0,
25561      &    2,  7,  0,   0,  0,  0,   1,  9,  0,
25562      &    2,  9,  0,   3,  7,  0,   3,  8,  0,
25563      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25564      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25565      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25566      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25567      &    0,  0,  0,   1,  1,  1,   1,  1,  2,
25568      &    1,  2,  2,   2,  2,  2,   0,  0,  0,
25569      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25570       DATA ((ITAB(I,K),I=1,3),K=61,90) /
25571      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25572      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25573      &    7,  7,  7,   7,  7,  8,   7,  8,  8,
25574      &    8,  8,  8,   0,  0,  0,   0,  0,  0,
25575      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25576      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25577      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25578      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25579      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25580      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25581       DATA ((ITAB(I,K),I=1,3),K=91,120) /
25582      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25583      &    0,  0,  0,   0,  0,  0,   3,  9,  0,
25584      &    1,  3,  3,   2,  3,  3,   7,  7,  9,
25585      &    7,  8,  9,   8,  8,  9,   7,  9,  9,
25586      &    8,  9,  9,   1,  1,  3,   1,  2,  3,
25587      &    2,  2,  3,   1,  3,  3,   2,  3,  3,
25588      &    3,  3,  3,   7,  7,  9,   7,  8,  9,
25589      &    8,  8,  9,   7,  9,  9,   8,  9,  9,
25590      &    9,  9,  9,   4,  7,  0,   4,  8,  0,
25591      &    2, 10,  0,   1, 10,  0,   4,  9,  0 /
25592       DATA ((ITAB(I,K),I=1,3),K=121,150) /
25593      &    3, 10,  0,   4, 10,  0,   4,  7,  0,
25594      &    4,  8,  0,   2, 10,  0,   1, 10,  0,
25595      &    4,  9,  0,   3, 10,  0,   4, 10,  0,
25596      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25597      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25598      &    0,  0,  0,   1,  2,  4,   1,  3,  4,
25599      &    2,  3,  4,   1,  1,  4,   0,  0,  0,
25600      &    2,  2,  4,   0,  0,  0,   0,  0,  0,
25601      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
25602      &    3,  4,  4,   7,  8, 10,   7,  9, 10 /
25603       DATA ((ITAB(I,K),I=1,3),K=151,180) /
25604      &    8,  9, 10,   7,  7, 10,   0,  0,  0,
25605      &    8,  8, 10,   0,  0,  0,   0,  0,  0,
25606      &    9,  9, 10,   7, 10, 10,   8, 10, 10,
25607      &    9, 10, 10,   1,  1,  4,   1,  2,  4,
25608      &    2,  2,  4,   1,  3,  4,   2,  3,  4,
25609      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
25610      &    3,  4,  4,   4,  4,  4,   7,  7, 10,
25611      &    7,  8, 10,   8,  8, 10,   7,  9, 10,
25612      &    8,  9, 10,   9,  9, 10,   7, 10, 10,
25613      &    8, 10, 10,   9, 10, 10,  10, 10, 10 /
25614       DATA ((ITAB(I,K),I=1,3),K=181,210) /
25615      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25616      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25617      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25618      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25619      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25620      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25621      &    0,  0,  0,   0,  0,  0,   1,  7,  0,
25622      &    2,  8,  0,   1,  7,  0,   2,  8,  0,
25623      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25624      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25625       DATA IDOLD /0/
25626
25627       ONE = 1.0D0
25628       IF (ITAB(1,IDBAMJ).LE.200) THEN
25629          ID = ITAB(K,IDBAMJ)
25630       ELSE
25631          IF(IDOLD.NE.IDBAMJ) THEN
25632             IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25633      &           DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25634         ELSE
25635            IDOLD = 0
25636         ENDIF
25637         ID = ITAB(K,IT)
25638       ENDIF
25639       IDOLD  = IDBAMJ
25640       IDT_IBJQUA = ID
25641
25642       RETURN
25643       END
25644
25645 *$ CREATE IDT_ICIHAD.FOR
25646 *COPY IDT_ICIHAD
25647 *
25648 *===icihad=============================================================*
25649 *
25650       INTEGER FUNCTION IDT_ICIHAD(MCIND)
25651
25652 ************************************************************************
25653 * Conversion of particle index PDG proposal --> BAMJET-index scheme    *
25654 * This is a completely new version dated 25.10.95.                     *
25655 * Renamed to be not in conflict with the modified PHOJET-version       *
25656 ************************************************************************
25657
25658       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25659       SAVE
25660
25661 * hadron index conversion (BAMJET <--> PDG)
25662       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25663      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25664      &                IAMCIN(210)
25665
25666       IDT_ICIHAD = 0
25667       KPDG   = ABS(MCIND)
25668       IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25669       IF (MCIND.LT.0) THEN
25670          JSIGN = 1
25671       ELSE
25672          JSIGN = 2
25673       ENDIF
25674       IF (KPDG.GE.10000) THEN
25675          DO 1 I=1,19
25676             IDT_ICIHAD = IBAM5(JSIGN,I)
25677             IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25678             IDT_ICIHAD = 0
25679     1    CONTINUE
25680       ELSEIF (KPDG.GE.1000) THEN
25681          DO 2 I=1,29
25682             IDT_ICIHAD = IBAM4(JSIGN,I)
25683             IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25684             IDT_ICIHAD = 0
25685     2    CONTINUE
25686       ELSEIF (KPDG.GE.100) THEN
25687          DO 3 I=1,22
25688             IDT_ICIHAD = IBAM3(JSIGN,I)
25689             IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25690             IDT_ICIHAD = 0
25691     3    CONTINUE
25692       ELSEIF (KPDG.GE.10) THEN
25693          DO 4 I=1,7
25694             IDT_ICIHAD = IBAM2(JSIGN,I)
25695             IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25696             IDT_ICIHAD = 0
25697     4    CONTINUE
25698       ENDIF
25699     5 CONTINUE
25700
25701       RETURN
25702       END
25703
25704 *$ CREATE IDT_IPDGHA.FOR
25705 *COPY IDT_IPDGHA
25706 *
25707 *===ipdgha=============================================================*
25708 *
25709       INTEGER FUNCTION IDT_IPDGHA(MCIND)
25710
25711 ************************************************************************
25712 * Conversion of particle index BAMJET-index scheme --> PDG proposal    *
25713 * Adopted from the original by S. Roesler. This version dated 12.5.95  *
25714 * Renamed to be not in conflict with the modified PHOJET-version       *
25715 ************************************************************************
25716
25717       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25718       SAVE
25719
25720 * hadron index conversion (BAMJET <--> PDG)
25721       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25722      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25723      &                IAMCIN(210)
25724
25725       IDT_IPDGHA = IAMCIN(MCIND)
25726
25727       RETURN
25728       END
25729
25730 *$ CREATE DT_FLAHAD.FOR
25731 *COPY DT_FLAHAD
25732 *
25733 *===flahad=============================================================*
25734 *
25735       SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25736
25737 ************************************************************************
25738 * sampling of FLAvor composition for HADrons/photons                   *
25739 *              ID         BAMJET-id of hadron                          *
25740 *              IF1,2,3    flavor content                               *
25741 *                         (u,d,s: 1,2,3;  au,ad,as: -1,-1,-3)          *
25742 * Note:  -  u,d numbering as in BAMJET                                 *
25743 *        -  ID .le. 30 !!                                              *
25744 * This version dated 12.03.96 is written by S. Roesler                 *
25745 ************************************************************************
25746
25747       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25748       SAVE
25749
25750 * auxiliary common for reggeon exchange (DTUNUC 1.x)
25751       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25752      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25753      &                IQTCHR(-6:6),MQUARK(3,39)
25754
25755       DIMENSION JSEL(3,6)
25756       DATA JSEL/ 1,2,3,  2,3,1,  3,1,2,  1,3,2,   2,1,3,   3,2,1/
25757
25758       ONE = 1.0D0
25759       IF (ID.EQ.7) THEN
25760 * photon (charge dependent flavour sampling)
25761          K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25762          IF (K.LE.4) THEN
25763             IF1 = 2
25764             IF2 = -2
25765          ELSE IF(K.EQ.5) THEN
25766             IF1 = 1
25767             IF2 = -1
25768          ELSE
25769             IF1 = 3
25770             IF2 = -3
25771          ENDIF
25772          IF(DT_RNDM(ONE).LT.0.5D0) THEN
25773             K   = IF1
25774             IF1 = IF2
25775             IF2 = K
25776          ENDIF
25777          IF3 = 0
25778       ELSE
25779 * hadron
25780          IX  = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25781          IF1 = MQUARK(JSEL(1,IX),ID)
25782          IF2 = MQUARK(JSEL(2,IX),ID)
25783          IF3 = MQUARK(JSEL(3,IX),ID)
25784          IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25785             IF1 = IF3
25786             IF3 = 0
25787          ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25788             IF2 = IF3
25789             IF3 = 0
25790          ENDIF
25791       ENDIF
25792
25793       RETURN
25794       END
25795
25796 *$ CREATE IDT_MCHAD.FOR
25797 *COPY IDT_MCHAD
25798 *
25799 *===mchad==============================================================*
25800 *
25801       INTEGER FUNCTION IDT_MCHAD(ITDTU)
25802
25803 ************************************************************************
25804 * Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25805 * Adopted from the original by S. Roesler. This version dated 6.5.95   *
25806 *                                                                      *
25807 * Last change 28.12.2006 by S. Roesler.                                *
25808 ************************************************************************
25809
25810       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25811       SAVE
25812
25813       DIMENSION ITRANS(210)
25814       DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25815      &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25816      &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25817      &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25818      &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25819      &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25820      &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25821
25822       IF ( ITDTU .GT. 0 ) THEN
25823          IDT_MCHAD = ITRANS(ITDTU)
25824       ELSE
25825          IDT_MCHAD = -1
25826       END IF
25827
25828       RETURN
25829       END
25830
25831 ************************************************************************
25832 *                                                                      *
25833 *   3) Energy-momentum and quantum number conservation check routines  *
25834 *                                                                      *
25835 ************************************************************************
25836 *$ CREATE DT_EMC1.FOR
25837 *COPY DT_EMC1
25838 *
25839 *===emc1===============================================================*
25840 *
25841       SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25842
25843 ************************************************************************
25844 * This version dated 15.12.94 is written by S. Roesler                 *
25845 ************************************************************************
25846
25847       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25848       SAVE
25849       PARAMETER ( LINP = 10 ,
25850      &            LOUT = 6 ,
25851      &            LDAT = 9 )
25852       PARAMETER (TINY10=1.0D-10)
25853
25854       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25855
25856       IREJ = 0
25857
25858       IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25859      &   WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25860
25861       IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25862          IF (MODE.EQ.1) THEN
25863             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25864          ELSEIF (MODE.EQ.2) THEN
25865             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25866          ENDIF
25867          CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25868          CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25869          CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25870       ELSEIF (MODE.LT.0) THEN
25871          IF (MODE.EQ.-1) THEN
25872             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
25873          ELSEIF (MODE.EQ.-2) THEN
25874             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
25875          ENDIF
25876          CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
25877          CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
25878          CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
25879       ENDIF
25880
25881       IF (ABS(MODE).EQ.3) THEN
25882          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25883          IF (IREJ1.NE.0) GOTO 9999
25884       ENDIF
25885       RETURN
25886
25887  9999 CONTINUE
25888       IREJ = 1
25889       RETURN
25890       END
25891
25892 *$ CREATE DT_EMC2.FOR
25893 *COPY DT_EMC2
25894 *
25895 *===emc2===============================================================*
25896 *
25897       SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25898      &                                                MODE,IPOS,IREJ)
25899
25900 ************************************************************************
25901 *             MODE = 1   energy-momentum cons. check                   *
25902 *                  = 2   flavor-cons. check                            *
25903 *                  = 3   energy-momentum & flavor cons. check          *
25904 *                  = 4   energy-momentum & charge cons. check          *
25905 *                  = 5   energy-momentum & flavor & charge cons. check *
25906 * This version dated 16.01.95 is written by S. Roesler                 *
25907 ************************************************************************
25908
25909       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25910       SAVE
25911       PARAMETER ( LINP = 10 ,
25912      &            LOUT = 6 ,
25913      &            LDAT = 9 )
25914       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25915
25916 * event history
25917       PARAMETER (NMXHKK=200000)
25918       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25919      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25920      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25921 * extended event history
25922       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25923      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25924      &                IHIST(2,NMXHKK)
25925
25926       IREJ  = 0
25927       IREJ1 = 0
25928       IREJ2 = 0
25929       IREJ3 = 0
25930
25931       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25932      &                CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25933       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25934      &                                CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25935       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25936       DO 1 I=1,NHKK
25937          IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25938      &       (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25939      &       (ISTHKK(I).EQ.IP5))                          THEN
25940             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25941      &                                    .OR.(MODE.EQ.5))
25942      &      CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25943      &                                               2,IDUM,IDUM)
25944             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25945      &         CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25946             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25947      &                            CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25948          ENDIF
25949          IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25950      &       (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25951      &       (ISTHKK(I).EQ.IN5))                          THEN
25952             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25953      &                                    .OR.(MODE.EQ.5))
25954      &      CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25955      &                                                   2,IDUM,IDUM)
25956             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25957      &         CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25958             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25959      &                            CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
25960          ENDIF
25961     1 CONTINUE
25962       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25963      &   CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
25964       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25965      &   CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
25966       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
25967       IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
25968
25969       RETURN
25970
25971  9999 CONTINUE
25972       IREJ = 1
25973       RETURN
25974       END
25975
25976 *$ CREATE DT_EVTEMC.FOR
25977 *COPY DT_EVTEMC
25978 *
25979 *===evtemc=============================================================*
25980 *
25981       SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
25982
25983 ************************************************************************
25984 * This version dated 13.12.94 is written by S. Roesler                 *
25985 ************************************************************************
25986
25987       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25988       SAVE
25989       PARAMETER ( LINP = 10 ,
25990      &            LOUT = 6 ,
25991      &            LDAT = 9 )
25992       PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
25993      &           ZERO=0.0D0)
25994
25995 * event history
25996       PARAMETER (NMXHKK=200000)
25997       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25998      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25999      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26000 * flags for input different options
26001       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
26002       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
26003      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
26004
26005       IREJ = 0
26006
26007       MODE = IMODE
26008       CHKLEV = TINY10
26009       IF (MODE.EQ.4) THEN
26010          CHKLEV = TINY2
26011          MODE   = 3
26012       ELSEIF (MODE.EQ.5) THEN
26013          CHKLEV = TINY1
26014          MODE   = 3
26015       ELSEIF (MODE.EQ.-1) THEN
26016          CHKLEV = EIO
26017          MODE   = 3
26018       ENDIF
26019
26020       IF (ABS(MODE).EQ.3) THEN
26021          PXDEV = PX
26022          PYDEV = PY
26023          PZDEV = PZ
26024          EDEV  = E
26025          IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
26026          IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
26027      &       (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
26028             IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
26029      &         'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
26030      &         '  event  ',NEVHKK,
26031      &         ' ! ',PXDEV,PYDEV,PZDEV,EDEV
26032             PX   = 0.0D0
26033             PY   = 0.0D0
26034             PZ   = 0.0D0
26035             E    = 0.0D0
26036             GOTO 9999
26037          ENDIF
26038          PX   = 0.0D0
26039          PY   = 0.0D0
26040          PZ   = 0.0D0
26041          E    = 0.0D0
26042          RETURN
26043       ENDIF
26044
26045       IF (MODE.EQ.1) THEN
26046          PX = 0.0D0
26047          PY = 0.0D0
26048          PZ = 0.0D0
26049          E  = 0.0D0
26050       ENDIF
26051
26052       PX = PX+PXIO
26053       PY = PY+PYIO
26054       PZ = PZ+PZIO
26055       E  = E+EIO
26056
26057       RETURN
26058
26059  9999 CONTINUE
26060       IREJ = 1
26061       RETURN
26062       END
26063
26064 *$ CREATE DT_EVTFLC.FOR
26065 *COPY DT_EVTFLC
26066 *
26067 *===evtflc=============================================================*
26068 *
26069       SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
26070
26071 ************************************************************************
26072 * Flavor conservation check.                                           *
26073 *        ID       identity of particle                                 *
26074 *        ID1 = 1  ID for q,aq,qq,aqaq in PDG-numbering scheme          *
26075 *            = 2  ID for particle/resonance in BAMJET numbering scheme *
26076 *            = 3  ID for particle/resonance in PDG    numbering scheme *
26077 *        MODE = 1 initialization and add ID                            *
26078 *             =-1 initialization and subtract ID                       *
26079 *             = 2 add ID                                               *
26080 *             =-2 subtract ID                                          *
26081 *             = 3 check flavor cons.                                   *
26082 *        IPOS     flag to give position of call of EVTFLC to output    *
26083 *                 unit in case of violation                            *
26084 * This version dated 10.01.95 is written by S. Roesler                 *
26085 ************************************************************************
26086
26087       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26088       SAVE
26089       PARAMETER ( LINP = 10 ,
26090      &            LOUT = 6 ,
26091      &            LDAT = 9 )
26092       PARAMETER (TINY10=1.0D-10)
26093
26094       IREJ = 0
26095
26096       IF (MODE.EQ.3) THEN
26097          IF (IFL.NE.0) THEN
26098             WRITE(LOUT,'(1X,A,I3,A,I3)')
26099      &         'EVTFLC: flavor-conservation failure at pos. ',IPOS,
26100      &         ' !  IFL = ',IFL
26101             IFL = 0
26102             GOTO 9999
26103          ENDIF
26104          IFL = 0
26105          RETURN
26106       ENDIF
26107
26108       IF (MODE.EQ.1) IFL = 0
26109       IF (ID.EQ.0)   RETURN
26110
26111       IF (ID1.EQ.1) THEN
26112          IDD = ABS(ID)
26113          NQ  = 1
26114          IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
26115          IF (IDD.GE.1000) NQ = 3
26116          DO 1 I=1,NQ
26117             IFBAM = IDT_IPDG2B(ID,I,2)
26118             IF (ABS(IFBAM).EQ.1) THEN
26119                IFBAM = SIGN(2,IFBAM)
26120             ELSEIF (ABS(IFBAM).EQ.2) THEN
26121                IFBAM = SIGN(1,IFBAM)
26122             ENDIF
26123             IF (MODE.GT.0) THEN
26124                IFL = IFL+IFBAM
26125             ELSE
26126                IFL = IFL-IFBAM
26127             ENDIF
26128     1    CONTINUE
26129          RETURN
26130       ENDIF
26131
26132       IDD = ID
26133       IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
26134       IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
26135          DO 2 I=1,3
26136             IF (MODE.GT.0) THEN
26137                IFL = IFL+IDT_IQUARK(I,IDD)
26138             ELSE
26139                IFL = IFL-IDT_IQUARK(I,IDD)
26140             ENDIF
26141     2    CONTINUE
26142       ENDIF
26143       RETURN
26144
26145  9999 CONTINUE
26146       IREJ = 1
26147       RETURN
26148       END
26149
26150 *$ CREATE DT_EVTCHG.FOR
26151 *COPY DT_EVTCHG
26152 *
26153 *===evtchg=============================================================*
26154 *
26155       SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
26156
26157 ************************************************************************
26158 * Charge conservation check.                                           *
26159 *        ID       identity of particle (PDG-numbering scheme)          *
26160 *        MODE = 1 initialization                                       *
26161 *             =-2 subtract ID-charge                                   *
26162 *             = 2 add ID-charge                                        *
26163 *             = 3 check charge cons.                                   *
26164 *        IPOS     flag to give position of call of EVTCHG to output    *
26165 *                 unit in case of violation                            *
26166 * This version dated 10.01.95 is written by S. Roesler                 *
26167 * Last change: s.r. 21.01.01                                           *
26168 ************************************************************************
26169
26170       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26171       SAVE
26172       PARAMETER ( LINP = 10 ,
26173      &            LOUT = 6 ,
26174      &            LDAT = 9 )
26175
26176 * event history
26177       PARAMETER (NMXHKK=200000)
26178       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26179      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26180      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26181 * particle properties (BAMJET index convention)
26182       CHARACTER*8  ANAME
26183       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26184      &                IICH(210),IIBAR(210),K1(210),K2(210)
26185
26186       IREJ = 0
26187
26188       IF (MODE.EQ.1) THEN
26189          ICH  = 0
26190          IBAR = 0
26191          RETURN
26192       ENDIF
26193
26194       IF (MODE.EQ.3) THEN
26195          IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
26196             WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
26197      &         'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
26198      &         '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
26199             ICH  = 0
26200             IBAR = 0
26201             GOTO 9999
26202          ENDIF
26203          ICH  = 0
26204          IBAR = 0
26205          RETURN
26206       ENDIF
26207
26208       IF (ID.EQ.0)   RETURN
26209
26210       IDD = IDT_ICIHAD(ID)
26211 * modification 21.1.01: use intrinsic phojet-functions to determine charge
26212 * and baryon number
26213 C     IF (IDD.GT.0) THEN
26214 C        IF (MODE.EQ.2) THEN
26215 C           ICH  = ICH+IICH(IDD)
26216 C           IBAR = IBAR+IIBAR(IDD)
26217 C        ELSEIF (MODE.EQ.-2) THEN
26218 C           ICH  = ICH-IICH(IDD)
26219 C           IBAR = IBAR-IIBAR(IDD)
26220 C        ENDIF
26221 C     ELSE
26222 C        WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
26223 C        CALL DT_EVTOUT(4)
26224 C        STOP
26225 C     ENDIF
26226       IF (MODE.EQ.2) THEN
26227          ICH  = ICH+IPHO_CHR3(ID,1)/3
26228          IBAR = IBAR+IPHO_BAR3(ID,1)/3
26229       ELSEIF (MODE.EQ.-2) THEN
26230          ICH  = ICH-IPHO_CHR3(ID,1)/3
26231          IBAR = IBAR-IPHO_BAR3(ID,1)/3
26232       ENDIF
26233
26234       RETURN
26235
26236  9999 CONTINUE
26237       IREJ = 1
26238       RETURN
26239       END
26240
26241 ************************************************************************
26242 *                                                                      *
26243 *                 4) Transformations                                   *
26244 *                                                                      *
26245 ************************************************************************
26246 *$ CREATE DT_LTINI.FOR
26247 *COPY DT_LTINI
26248 *
26249 *===ltini==============================================================*
26250 *
26251       SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
26252
26253 ************************************************************************
26254 * Initializations of Lorentz-transformations, calculation of Lorentz-  *
26255 * parameters.                                                          *
26256 * This version dated 13.11.95 is written by  S. Roesler.               *
26257 ************************************************************************
26258
26259       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26260       SAVE
26261       PARAMETER ( LINP = 10 ,
26262      &            LOUT = 6 ,
26263      &            LDAT = 9 )
26264       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
26265      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
26266
26267 * Lorentz-parameters of the current interaction
26268       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26269      &                UMO,PPCM,EPROJ,PPROJ
26270 * properties of photon/lepton projectiles
26271       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
26272 * particle properties (BAMJET index convention)
26273       CHARACTER*8  ANAME
26274       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26275      &                IICH(210),IIBAR(210),K1(210),K2(210)
26276 * nucleon-nucleon event-generator
26277       CHARACTER*8 CMODEL
26278       LOGICAL LPHOIN
26279       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26280
26281       Q2   = VIRT
26282       IDP  = IDPR
26283       IF (MCGENE.NE.3) THEN
26284 * lepton-projectiles and PHOJET: initialize real photon instead
26285          IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26286      &       (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26287      &       (IDPR.EQ. 5).OR.(IDPR.EQ. 6))   THEN
26288             IDP = 7
26289             Q2  = ZERO
26290          ENDIF
26291       ENDIF
26292       IDT  = IDTA
26293       EPN  = EPN0
26294       PPN  = PPN0
26295       ECM  = ECM0
26296       AMP  = AAM(IDP)-SQRT(ABS(Q2))
26297       AMT  = AAM(IDT)
26298       AMP2 = SIGN(AMP**2,AMP)
26299       AMT2 = AMT**2
26300       IF (ECM0.GT.ZERO) THEN
26301          EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26302          IF (AMP2.GT.ZERO) THEN
26303             PPN = SQRT((EPN+AMP)*(EPN-AMP))
26304          ELSE
26305             PPN = SQRT(EPN**2-AMP2)
26306          ENDIF
26307       ELSE
26308          IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26309             IF (IDP.EQ.7) EPN = ABS(EPN)
26310             IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26311             IF (AMP2.GT.ZERO) THEN
26312                PPN = SQRT((EPN+AMP)*(EPN-AMP))
26313             ELSE
26314                PPN = SQRT(EPN**2-AMP2)
26315             ENDIF
26316          ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26317             IF (AMP2.GT.ZERO) THEN
26318                EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26319             ELSE
26320                EPN = SQRT(PPN**2+AMP2)
26321             ENDIF
26322          ENDIF
26323          ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26324       ENDIF
26325       UMO   = ECM
26326       EPROJ = EPN
26327       PPROJ = PPN
26328       IF (AMP2.GT.ZERO) THEN
26329          ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26330          PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26331       ELSE
26332          ETARG = TINY10
26333          PTARG = TINY10
26334       ENDIF
26335 * photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26336       IF (IDP.EQ.7) THEN
26337          PGAMM(1) = ZERO
26338          PGAMM(2) = ZERO
26339          AMGAM  = AMP
26340          AMGAM2 = AMP2
26341          IF (ECM0.GT.ZERO) THEN
26342             S = ECM0**2
26343          ELSE
26344             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26345                S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26346             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26347                S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26348             ENDIF
26349          ENDIF
26350          PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26351      &                     +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26352          PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26353          IF (MODE.EQ.1) THEN
26354             PNUCL(1) = ZERO
26355             PNUCL(2) = ZERO
26356             PNUCL(3) = -PGAMM(3)
26357             PNUCL(4) = SQRT(S)-PGAMM(4)
26358          ENDIF
26359       ENDIF
26360       IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26361      &    (IDPR.EQ.10).OR.(IDPR.EQ.11))   THEN
26362          PLEPT0(1) = ZERO
26363          PLEPT0(2) = ZERO
26364 * neglect lepton masses
26365 C        AMLPT2   = AAM(IDPR)**2
26366          AMLPT2   = ZERO
26367 *
26368          IF (ECM0.GT.ZERO) THEN
26369             S = ECM0**2
26370          ELSE
26371             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26372                S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26373             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26374                S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26375             ENDIF
26376          ENDIF
26377          PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26378      &                     +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26379          PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26380          PNUCL(1) = ZERO
26381          PNUCL(2) = ZERO
26382          PNUCL(3) = -PLEPT0(3)
26383          PNUCL(4) = SQRT(S)-PLEPT0(4)
26384       ENDIF
26385 * Lorentz-parameter for transformation Lab. - projectile rest system
26386       IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26387          GALAB = TINY10
26388          BGLAB = TINY10
26389          BLAB  = TINY10
26390       ELSE
26391          GALAB = EPROJ/AMP
26392          BGLAB = PPROJ/AMP
26393          BLAB  = BGLAB/GALAB
26394       ENDIF
26395 * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26396       IF (IDP.EQ.7) THEN
26397          GACMS(1) = TINY10
26398          BGCMS(1) = TINY10
26399       ELSE
26400          GACMS(1) = (ETARG+AMP)/UMO
26401          BGCMS(1) = PTARG/UMO
26402       ENDIF
26403 * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26404       GACMS(2) = (EPROJ+AMT)/UMO
26405       BGCMS(2) = PPROJ/UMO
26406       PPCM     = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26407
26408       EPN0 = EPN
26409       PPN0 = PPN
26410       ECM0 = ECM
26411
26412       RETURN
26413       END
26414
26415 *$ CREATE DT_LTRANS.FOR
26416 *COPY DT_LTRANS
26417 *
26418 *===ltrans=============================================================*
26419 *
26420       SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26421
26422 ************************************************************************
26423 * Lorentz-transformations.                                             *
26424 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
26425 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
26426 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
26427 * This version dated 01.11.95 is written by  S. Roesler.               *
26428 ************************************************************************
26429
26430       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26431       SAVE
26432       PARAMETER ( LINP = 10 ,
26433      &            LOUT = 6 ,
26434      &            LDAT = 9 )
26435       PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26436
26437       PARAMETER (SQTINF=1.0D+15)
26438
26439 * particle properties (BAMJET index convention)
26440       CHARACTER*8  ANAME
26441       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26442      &                IICH(210),IIBAR(210),K1(210),K2(210)
26443
26444       PXO = PXI
26445       PYO = PYI
26446       CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26447
26448 * check particle mass for consistency (numerical rounding errors)
26449       PO     = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26450       AMO2   = (PEO-PO)*(PEO+PO)
26451       AMORQ2 = AAM(ID)**2
26452       AMDIF2 = ABS(AMO2-AMORQ2)
26453       IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26454          DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26455          PEO   = PEO+DELTA
26456          PO1   = PO -DELTA
26457          PXO   = PXO*PO1/PO
26458          PYO   = PYO*PO1/PO
26459          PZO   = PZO*PO1/PO
26460 C        WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26461       ENDIF
26462
26463       RETURN
26464       END
26465
26466 *$ CREATE DT_LTNUC.FOR
26467 *COPY DT_LTNUC
26468 *
26469 *===ltnuc==============================================================*
26470 *
26471       SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26472
26473 ************************************************************************
26474 * Lorentz-transformations.                                             *
26475 *   PIN        longitudnal momentum       (input)                      *
26476 *   EIN        energy                     (input)                      *
26477 *   POUT       transformed long. momentum (output)                     *
26478 *   EOUT       transformed energy         (output)                     *
26479 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
26480 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
26481 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
26482 * This version dated 01.11.95 is written by  S. Roesler.               *
26483 ************************************************************************
26484
26485       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26486       SAVE
26487       PARAMETER ( LINP = 10 ,
26488      &            LOUT = 6 ,
26489      &            LDAT = 9 )
26490       PARAMETER (ZERO=0.0D0)
26491
26492 * Lorentz-parameters of the current interaction
26493       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26494      &                UMO,PPCM,EPROJ,PPROJ
26495
26496       BDUM1 = ZERO
26497       BDUM2 = ZERO
26498       PDUM1 = ZERO
26499       PDUM2 = ZERO
26500       IF (ABS(MODE).EQ.1) THEN
26501          BG = -SIGN(BGLAB,DBLE(MODE))
26502          CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26503      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26504       ELSEIF (ABS(MODE).EQ.2) THEN
26505          BG = SIGN(BGCMS(1),DBLE(MODE))
26506          CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26507      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26508       ELSEIF (ABS(MODE).EQ.3) THEN
26509          BG = -SIGN(BGCMS(2),DBLE(MODE))
26510          CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26511      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26512       ELSE
26513          WRITE(LOUT,1000) MODE
26514  1000    FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26515          EOUT = EIN
26516          POUT = PIN
26517       ENDIF
26518
26519       RETURN
26520       END
26521
26522 *$ CREATE DT_DALTRA.FOR
26523 *COPY DT_DALTRA
26524 *
26525 *===daltra=============================================================*
26526 *
26527       SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26528
26529 ************************************************************************
26530 * Arbitrary Lorentz-transformation.                                    *
26531 * Adopted from the original by S. Roesler. This version dated 15.01.95 *
26532 ************************************************************************
26533
26534       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26535       SAVE
26536       PARAMETER (ONE=1.0D0)
26537
26538       EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26539       PE = EP/(GA+ONE)+EC
26540       PX = PCX+BGX*PE
26541       PY = PCY+BGY*PE
26542       PZ = PCZ+BGZ*PE
26543       P  = SQRT(PX*PX+PY*PY+PZ*PZ)
26544       E  = GA*EC+EP
26545
26546       RETURN
26547       END
26548
26549 *$ CREATE DT_DTRAFO.FOR
26550 *COPY DT_DTRAFO
26551 *
26552 *====dtrafo============================================================*
26553 *
26554       SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26555      &                                    PL,CXL,CYL,CZL,EL)
26556
26557 C     LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26558
26559       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26560       SAVE
26561
26562       IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26563       SID  = SQRT(1.D0-COD*COD)
26564       PLX  = P*SID*COF
26565       PLY  = P*SID*SIF
26566       PCMZ = P*COD
26567       PLZ  = GAM*PCMZ+BGAM*ECM
26568       PL   = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26569       EL   = GAM*ECM+BGAM*PCMZ
26570 C     ROTATION INTO THE ORIGINAL DIRECTION
26571       COZ  = PLZ/PL
26572       SIZ  = SQRT(1.D0-COZ**2)
26573       CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26574
26575       RETURN
26576       END
26577
26578 *$ CREATE DT_STTRAN.FOR
26579 *COPY DT_STTRAN
26580 *
26581 *====sttran============================================================*
26582 *
26583       SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26584
26585       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26586       SAVE
26587       DATA ANGLSQ/1.D-30/
26588 ************************************************************************
26589 *     VERSION BY                     J. RANFT                          *
26590 *                                    LEIPZIG                           *
26591 *                                                                      *
26592 *     THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES      *
26593 *                                                                      *
26594 *     INPUT VARIABLES:                                                 *
26595 *        XO,YO,ZO = ORIGINAL DIRECTION COSINES                         *
26596 *        CDE,SDE  = COSINE AND SINE OF THE POLAR (THETA)               *
26597 *                   ANGLE OF "SCATTERING"                              *
26598 *        SDE      = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING"    *
26599 *        SFE,CFE  = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE       *
26600 *                   OF "SCATTERING"                                    *
26601 *                                                                      *
26602 *     OUTPUT VARIABLES:                                                *
26603 *        X,Y,Z     = NEW DIRECTION COSINES                             *
26604 *                                                                      *
26605 *     ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 )                  *
26606 ************************************************************************
26607 *
26608 *
26609 *  Changed by A. Ferrari
26610 *
26611 *     IF (ABS(XO)-0.0001D0) 1,1,2
26612 *   1 IF (ABS(YO)-0.0001D0) 3,3,2
26613 *   3 CONTINUE
26614       A = XO**2 + YO**2
26615       IF ( A .LT. ANGLSQ ) THEN
26616          X=SDE*CFE
26617          Y=SDE*SFE
26618          Z=CDE*ZO
26619       ELSE
26620          XI=SDE*CFE
26621          YI=SDE*SFE
26622          ZI=CDE
26623          A=SQRT(A)
26624          X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26625          Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26626          Z=A*YI+ZO*ZI
26627       ENDIF
26628
26629       RETURN
26630       END
26631
26632 *$ CREATE DT_MYTRAN.FOR
26633 *COPY DT_MYTRAN
26634 *
26635 *===mytran=============================================================*
26636 *
26637       SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26638
26639 ************************************************************************
26640 * This subroutine rotates the coordinate frame                         *
26641 *    a) theta  around y                                                *
26642 *    b) phi    around z      if IMODE = 1                              *
26643 *                                                                      *
26644 *     x'          cos(ph) -sin(ph) 0      cos(th)  0  sin(th)   x      *
26645 *     y' = A B =  sin(ph) cos(ph)  0  .   0        1        0   y      *
26646 *     z'          0       0        1     -sin(th)  0  cos(th)   z      *
26647 *                                                                      *
26648 * and vice versa if IMODE = 0.                                         *
26649 * This version dated 5.4.94 is based on the original version DTRAN     *
26650 * by J. Ranft and is written by S. Roesler.                            *
26651 ************************************************************************
26652
26653       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26654       SAVE
26655       PARAMETER ( LINP = 10 ,
26656      &            LOUT = 6 ,
26657      &            LDAT = 9 )
26658
26659       IF (IMODE.EQ.1) THEN
26660          X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26661          Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26662          Z=-SDE    *XO       +CDE    *ZO
26663       ELSE
26664          X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26665          Y= -SFE*XO+CFE*YO
26666          Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26667       ENDIF
26668       RETURN
26669       END
26670
26671 *$ CREATE DT_LT2LAO.FOR
26672 *COPY DT_LT2LAO
26673 *
26674 *===lt2lab=============================================================*
26675 *
26676       SUBROUTINE DT_LT2LAO
26677
26678 ************************************************************************
26679 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
26680 * for final state particles/fragments defined in nucleon-nucleon-cms   *
26681 * and transforms them back to the lab.                                 *
26682 * This version dated 16.11.95 is written by S. Roesler                 *
26683 ************************************************************************
26684
26685       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26686       SAVE
26687       PARAMETER ( LINP = 10 ,
26688      &            LOUT = 6 ,
26689      &            LDAT = 9 )
26690
26691 * event history
26692       PARAMETER (NMXHKK=200000)
26693       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26694      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26695      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26696 * extended event history
26697       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26698      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26699      &                IHIST(2,NMXHKK)
26700
26701       NEND      = NHKK
26702       NPOINT(5) = NHKK+1
26703       IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26704       DO 1 I=NPOINT(4),NEND
26705 C     DO 1 I=1,NEND
26706          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26707      &                                (ISTHKK(I).EQ.1001)) THEN
26708             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26709             NOB = NOBAM(I)
26710             CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26711      &                            PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26712             IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26713                ISTHKK(I) = 3*ISTHKK(I)
26714                NOBAM(NHKK)  = NOB
26715             ELSE
26716                IF (ISTHKK(I).EQ.-1) NOBAM(NHKK)  = NOB
26717                ISTHKK(I) = SIGN(3,ISTHKK(I))
26718             ENDIF
26719             JDAHKK(1,I) = NHKK
26720          ENDIF
26721     1 CONTINUE
26722
26723       RETURN
26724       END
26725
26726 *$ CREATE DT_LT2LAB.FOR
26727 *COPY DT_LT2LAB
26728 *
26729 *===lt2lab=============================================================*
26730 *
26731       SUBROUTINE DT_LT2LAB
26732
26733 ************************************************************************
26734 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
26735 * for final state particles/fragments defined in nucleon-nucleon-cms   *
26736 * and transforms them to the lab.                                      *
26737 * This version dated 07.01.96 is written by S. Roesler                 *
26738 ************************************************************************
26739
26740       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26741       SAVE
26742       PARAMETER ( LINP = 10 ,
26743      &            LOUT = 6 ,
26744      &            LDAT = 9 )
26745
26746 * event history
26747       PARAMETER (NMXHKK=200000)
26748       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26749      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26750      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26751 * extended event history
26752       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26753      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26754      &                IHIST(2,NMXHKK)
26755
26756       IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26757       DO 1 I=NPOINT(4),NHKK
26758          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26759      &                                (ISTHKK(I).EQ.1001)) THEN
26760             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26761             PHKK(3,I) = PZ
26762             PHKK(4,I) = PE
26763          ENDIF
26764     1 CONTINUE
26765
26766       RETURN
26767       END
26768
26769 ************************************************************************
26770 *                                                                      *
26771 *                 5) Sampling from distributions                       *
26772 *                                                                      *
26773 ************************************************************************
26774 *$ CREATE IDT_NPOISS.FOR
26775 *COPY IDT_NPOISS
26776 *
26777 *===npoiss=============================================================*
26778 *
26779       INTEGER FUNCTION IDT_NPOISS(AVN)
26780
26781 ************************************************************************
26782 * Sample according to Poisson distribution with Poisson parameter AVN. *
26783 * The original version written by J. Ranft.                            *
26784 * This version dated 11.1.95 is written by S. Roesler.                 *
26785 ************************************************************************
26786
26787       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26788       SAVE
26789       PARAMETER ( LINP = 10 ,
26790      &            LOUT = 6 ,
26791      &            LDAT = 9 )
26792
26793       EXPAVN = EXP(-AVN)
26794       K = 1
26795       A = 1.0D0
26796
26797    10 CONTINUE
26798       A = DT_RNDM(A)*A
26799       IF (A.GE.EXPAVN) THEN
26800          K = K+1
26801          GOTO 10
26802       ENDIF
26803       IDT_NPOISS = K-1
26804
26805       RETURN
26806       END
26807
26808 *$ CREATE DT_SAMPXB.FOR
26809 *COPY DT_SAMPXB
26810 *
26811 *===sampxb=============================================================*
26812 *
26813       DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26814
26815 ************************************************************************
26816 * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2.             *
26817 * Processed by S. Roesler, 6.5.95                                      *
26818 ************************************************************************
26819
26820       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26821       SAVE
26822       PARAMETER (TWO=2.0D0)
26823
26824       A1 = LOG(X1+SQRT(X1**2+B**2))
26825       A2 = LOG(X2+SQRT(X2**2+B**2))
26826       AN = A2-A1
26827       A  = AN*DT_RNDM(A1)+A1
26828       BB = EXP(A)
26829       DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26830
26831       RETURN
26832       END
26833
26834 *$ CREATE DT_SAMPEX.FOR
26835 *COPY DT_SAMPEX
26836 *
26837 *===sampex=============================================================*
26838 *
26839       DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26840
26841 ************************************************************************
26842 * Sampling from f(x)=1./x between x1 and x2.                           *
26843 * Processed by S. Roesler, 6.5.95                                      *
26844 ************************************************************************
26845
26846       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26847       SAVE
26848       PARAMETER (ONE=1.0D0)
26849
26850       R   = DT_RNDM(X1)
26851       AL1 = LOG(X1)
26852       AL2 = LOG(X2)
26853       DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26854
26855       RETURN
26856       END
26857
26858 *$ CREATE DT_SAMSQX.FOR
26859 *COPY DT_SAMSQX
26860 *
26861 *===samsqx=============================================================*
26862 *
26863       DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26864
26865 ************************************************************************
26866 * Sampling from f(x)=1./x^0.5 between x1 and x2.                       *
26867 * Processed by S. Roesler, 6.5.95                                      *
26868 ************************************************************************
26869
26870       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26871       SAVE
26872       PARAMETER (ONE=1.0D0)
26873
26874       R = DT_RNDM(X1)
26875       DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26876
26877       RETURN
26878       END
26879
26880 *$ CREATE DT_SAMPLW.FOR
26881 *COPY DT_SAMPLW
26882 *
26883 *===samplw=============================================================*
26884 *
26885       DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26886
26887 ************************************************************************
26888 * Sampling from f(x)=1/x^b between x_min and x_max.                    *
26889 * S. Roesler, 18.4.98                                                  *
26890 ************************************************************************
26891
26892       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26893       SAVE
26894       PARAMETER (ONE=1.0D0)
26895
26896       R = DT_RNDM(B)
26897       IF (B.EQ.ONE) THEN
26898          DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26899       ELSE
26900          ONEMB  = ONE-B
26901          DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26902       ENDIF
26903
26904       RETURN
26905       END
26906
26907 *$ CREATE DT_BETREJ.FOR
26908 *COPY DT_BETREJ
26909 *
26910 *===betrej=============================================================*
26911 *
26912       DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26913
26914       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26915       SAVE
26916
26917       PARAMETER ( LINP = 10 ,
26918      &            LOUT = 6 ,
26919      &            LDAT = 9 )
26920       PARAMETER (ONE=1.0D0)
26921
26922       IF (XMIN.GE.XMAX)THEN
26923          WRITE (LOUT,500) XMIN,XMAX
26924   500    FORMAT(1X,'DT_BETREJ:  XMIN<XMAX execution stopped ',2F10.5)
26925          STOP
26926       ENDIF
26927
26928    10 CONTINUE
26929       XX     = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26930       BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26931       YY     = BETMAX*DT_RNDM(XX)
26932       BETXX  = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26933       IF (YY.GT.BETXX) GOTO 10
26934       DT_BETREJ = XX
26935
26936       RETURN
26937       END
26938
26939 *$ CREATE DT_DGAMRN.FOR
26940 *COPY DT_DGAMRN
26941 *
26942 *===dgamrn=============================================================*
26943 *
26944       DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26945
26946 ************************************************************************
26947 * Sampling from Gamma-distribution.                                    *
26948 *       F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)            *
26949 * Processed by S. Roesler, 6.5.95                                      *
26950 ************************************************************************
26951
26952       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26953       SAVE
26954       PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
26955
26956       NCOU = 0
26957       N    = INT(ETA)
26958       F    = ETA-DBLE(N)
26959       IF (F.EQ.ZERO) GOTO 20
26960    10 R = DT_RNDM(F)
26961       NCOU = NCOU+1
26962       IF (NCOU.GE.11) GOTO 20
26963       IF (R.LT.F/(F+2.71828D0)) GOTO 30
26964       YYY = LOG(DT_RNDM(R)+TINY9)/F
26965       IF (ABS(YYY).GT.50.0D0) GOTO 20
26966       Y = EXP(YYY)
26967       IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
26968       GOTO 40
26969    20 Y = 0.0D0
26970       GOTO 50
26971    30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
26972       IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
26973    40 IF (N.EQ.0) GOTO 70
26974    50 Z = 1.0D0
26975       DO 60 I = 1,N
26976    60 Z = Z*DT_RNDM(Z)
26977       Y = Y-LOG(Z+TINY9)
26978    70 DT_DGAMRN = Y/ALAM
26979
26980       RETURN
26981       END
26982
26983 *$ CREATE DT_DBETAR.FOR
26984 *COPY DT_DBETAR
26985 *
26986 *===dbetar=============================================================*
26987 *
26988       DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
26989
26990 ************************************************************************
26991 * Sampling from Beta -distribution between 0.0 and 1.0                 *
26992 *  F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
26993 * Processed by S. Roesler, 6.5.95                                      *
26994 ************************************************************************
26995
26996       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26997       SAVE
26998
26999       Y = DT_DGAMRN(1.0D0,GAM)
27000       Z = DT_DGAMRN(1.0D0,ETA)
27001       DT_DBETAR = Y/(Y+Z)
27002
27003       RETURN
27004       END
27005
27006 *$ CREATE DT_RANNOR.FOR
27007 *COPY DT_RANNOR
27008 *
27009 *===rannor=============================================================*
27010 *
27011       SUBROUTINE DT_RANNOR(X,Y)
27012
27013 ************************************************************************
27014 * Sampling from Gaussian distribution.                                 *
27015 * Processed by S. Roesler, 6.5.95                                      *
27016 ************************************************************************
27017
27018       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27019       SAVE
27020       PARAMETER (TINY10=1.0D-10)
27021
27022       CALL DT_DSFECF(SFE,CFE)
27023       V = MAX(TINY10,DT_RNDM(X))
27024       A = SQRT(-2.D0*LOG(V))
27025       X = A*SFE
27026       Y = A*CFE
27027
27028       RETURN
27029       END
27030
27031 *$ CREATE DT_DPOLI.FOR
27032 *COPY DT_DPOLI
27033 *
27034 *===dpoli==============================================================*
27035 *
27036       SUBROUTINE DT_DPOLI(CS,SI)
27037
27038       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27039       SAVE
27040
27041       U  = DT_RNDM(CS)
27042       CS = DT_RNDM(U)
27043       IF (U.LT.0.5D0) CS=-CS
27044       SI = SQRT(1.0D0-CS*CS+1.0D-10)
27045
27046       RETURN
27047       END
27048
27049 *$ CREATE DT_DSFECF.FOR
27050 *COPY DT_DSFECF
27051 *
27052 *===dsfecf=============================================================*
27053 *
27054       SUBROUTINE DT_DSFECF(SFE,CFE)
27055
27056       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27057       SAVE
27058       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27059
27060     1 CONTINUE
27061       X  = DT_RNDM(SFE)
27062       Y  = DT_RNDM(X)
27063       XX = X*X
27064       YY = Y*Y
27065       XY = XX+YY
27066       IF (XY.GT.ONE) GOTO 1
27067       CFE = (XX-YY)/XY
27068       SFE = TWO*X*Y/XY
27069       IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
27070       RETURN
27071       END
27072
27073 *$ CREATE DT_RACO.FOR
27074 *COPY DT_RACO
27075 *
27076 *===raco===============================================================*
27077 *
27078       SUBROUTINE DT_RACO(WX,WY,WZ)
27079
27080 ************************************************************************
27081 * Direction cosines of random uniform (isotropic) direction in three   *
27082 * dimensional space                                                    *
27083 * Processed by S. Roesler, 20.11.95                                    *
27084 ************************************************************************
27085
27086       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27087       SAVE
27088       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27089
27090   10  CONTINUE
27091       X  = TWO*DT_RNDM(WX)-ONE
27092       Y  = DT_RNDM(X)
27093       X2 = X*X
27094       Y2 = Y*Y
27095       IF (X2+Y2.GT.ONE) GOTO 10
27096
27097       CFE = (X2-Y2)/(X2+Y2)
27098       SFE = TWO*X*Y/(X2+Y2)
27099 * z = 1/2 [ 1 + cos (theta) ]
27100       Z   = DT_RNDM(X)
27101 * 1/2 sin (theta)
27102       WZ = SQRT(Z*(ONE-Z))
27103       WX = TWO*WZ*CFE
27104       WY = TWO*WZ*SFE
27105       WZ = TWO*Z-ONE
27106
27107       RETURN
27108       END
27109
27110 ************************************************************************
27111 *                                                                      *
27112 *           6) Special functions, algorithms and service routines      *
27113 *                                                                      *
27114 ************************************************************************
27115 *$ CREATE DT_YLAMB.FOR
27116 *COPY DT_YLAMB
27117 *
27118 *===ylamb==============================================================*
27119 *
27120       DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
27121
27122 ************************************************************************
27123 *                                                                      *
27124 *     auxiliary function for three particle decay mode                 *
27125 *     (standard LAMBDA**(1/2) function)                                *
27126 *                                                                      *
27127 * Adopted from an original version written by R. Engel.                *
27128 * This version dated 12.12.94 is written by S. Roesler.                *
27129 ************************************************************************
27130
27131       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27132       SAVE
27133
27134       YZ   = Y-Z
27135       XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
27136       IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
27137       DT_YLAMB = SQRT(XLAM)
27138
27139       RETURN
27140       END
27141
27142 *$ CREATE DT_SORT.FOR
27143 *COPY DT_SORT
27144 *
27145 *===sort1==============================================================*
27146 *
27147       SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
27148
27149 ************************************************************************
27150 * This subroutine sorts entries in A in increasing/decreasing order    *
27151 * of A(3,i).                                                           *
27152 *              MODE  = 1     increasing in A(3,i=1..N)                 *
27153 *                    = 2     decreasing in A(3,i=1..N)                 *
27154 * This version dated 21.04.95 is revised by S. Roesler                 *
27155 ************************************************************************
27156
27157       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27158       SAVE
27159
27160       DIMENSION A(3,N)
27161
27162       M = I1
27163    10 CONTINUE
27164       M = I1-1
27165       IF (M.LE.0) RETURN
27166       L = 0
27167       DO 20 I=I0,M
27168          J = I+1
27169          IF (MODE.EQ.1) THEN
27170             IF (A(3,I).LE.A(3,J)) GOTO 20
27171          ELSE
27172             IF (A(3,I).GE.A(3,J)) GOTO 20
27173          ENDIF
27174          B = A(3,I)
27175          C = A(1,I)
27176          D = A(2,I)
27177          A(3,I) = A(3,J)
27178          A(2,I) = A(2,J)
27179          A(1,I) = A(1,J)
27180          A(3,J) = B
27181          A(1,J) = C
27182          A(2,J) = D
27183          L = 1
27184    20 CONTINUE
27185       IF (L.EQ.1) GOTO 10
27186
27187       RETURN
27188       END
27189
27190 *$ CREATE DT_SORT1.FOR
27191 *COPY DT_SORT1
27192 *
27193 *===sort1==============================================================*
27194 *
27195       SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
27196
27197 ************************************************************************
27198 * This subroutine sorts entries in A in increasing/decreasing order    *
27199 * of A(i).                                                             *
27200 *              MODE  = 1     increasing in A(i=1..N)                   *
27201 *                    = 2     decreasing in A(i=1..N)                   *
27202 * This version dated 21.04.95 is revised by S. Roesler                 *
27203 ************************************************************************
27204
27205       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27206       SAVE
27207
27208       DIMENSION A(N),IDX(N)
27209
27210       M = I1
27211    10 CONTINUE
27212       M = I1-1
27213       IF (M.LE.0) RETURN
27214       L = 0
27215       DO 20 I=I0,M
27216          J = I+1
27217          IF (MODE.EQ.1) THEN
27218             IF (A(I).LE.A(J)) GOTO 20
27219          ELSE
27220             IF (A(I).GE.A(J)) GOTO 20
27221          ENDIF
27222          B    = A(I)
27223          A(I) = A(J)
27224          A(J) = B
27225          IX     = IDX(I)
27226          IDX(I) = IDX(J)
27227          IDX(J) = IX
27228          L = 1
27229    20 CONTINUE
27230       IF (L.EQ.1) GOTO 10
27231
27232       RETURN
27233       END
27234
27235 *$ CREATE DT_XTIME.FOR
27236 *COPY DT_XTIME
27237 *
27238 *===xtime==============================================================*
27239 *
27240       SUBROUTINE DT_XTIME
27241
27242       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27243       SAVE
27244       PARAMETER ( LINP = 10 ,
27245      &            LOUT = 6 ,
27246      &            LDAT = 9 )
27247
27248       CHARACTER DAT*9,TIM*11
27249
27250       DAT = '         '
27251       TIM = '           '
27252 C     CALL GETDAT(IYEAR,IMONTH,IDAY)
27253 C     CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
27254
27255 C     CALL DATE(DAT)
27256 C     CALL TIME(TIM)
27257 C     WRITE(LOUT,1000) DAT,TIM
27258  1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
27259
27260       RETURN
27261       END
27262
27263 ************************************************************************
27264 *                                                                      *
27265 *                 7) Random number generator package                   *
27266 *                                                                      *
27267 *    THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND        *
27268 *    SERVICE ROUTINES.                                                 *
27269 *    THE ALGORITHM IS FROM                                             *
27270 *      'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR'                     *
27271 *      G.MARSAGLIA, A.ZAMAN ;  FSU-SCRI-87-50                          *
27272 *    IMPLEMENTATION BY K. HAHN  DEC. 88,                               *
27273 *    THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27274 *    AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ),        *
27275 *    THE PERIOD IS ABOUT 2**144,                                       *
27276 *    TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS,            *
27277 *    THE PACKAGE CONTAINS                                              *
27278 *      FUNCTION DT_RNDM(I)                  : GENERATOR                *
27279 *      SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION           *
27280 *      SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)  : PUT SEED TO GENERATOR    *
27281 *      SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)  : TAKE SEED FROM GENERATOR *
27282 *      SUBROUTINE DT_RNDMTE(IO)             : TEST OF GENERATOR        *
27283 *---                                                                   *
27284 *    FUNCTION DT_RNDM(I)                                               *
27285 *       GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS  IN (0..1)          *
27286 *       I  - DUMMY VARIABLE, NOT USED                                  *
27287 *    SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)                             *
27288 *       INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27289 *       NA1,NA2,NA3,NB1  - VALUES FOR INITIALIZING THE GENERATOR       *
27290 *                          NA? MUST BE IN 1..178 AND NOT ALL 1         *
27291 *                          12,34,56  ARE THE STANDARD VALUES           *
27292 *                          NB1 MUST BE IN 1..168                       *
27293 *                          78  IS THE STANDARD VALUE                   *
27294 *    SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)                               *
27295 *       PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS   *
27296 *       AS AFTER THE LAST DT_RNDMOU CALL )                             *
27297 *       U(97),C,CD,CM,I,J  - SEED VALUES AS TAKEN FROM DT_RNDMOU       *
27298 *    SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)                               *
27299 *       TAKES SEED FROM GENERATOR                                      *
27300 *       U(97),C,CD,CM,I,J  - SEED VALUES                               *
27301 *    SUBROUTINE DT_RNDMTE(IO)                                          *
27302 *       TEST OF THE GENERATOR                                          *
27303 *       IO     - DEFINES OUTPUT                                        *
27304 *                  = 0  OUTPUT ONLY IF AN ERROR IS DETECTED            *
27305 *                  = 1  OUTPUT INDEPENDEND ON AN ERROR                 *
27306 *       DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO   *
27307 *       SAME STATUS                                                    *
27308 *       AS BEFORE CALL OF DT_RNDMTE                                    *
27309 ************************************************************************
27310 *$ CREATE DT_RNDM.FOR
27311 *COPY DT_RNDM
27312 *
27313 *===rndm===============================================================*
27314 *
27315       DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27316
27317       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27318       SAVE
27319
27320 * random number generator
27321       COMMON /DTRAND/ U(97),C,CD,CM,I,J
27322
27323 * counter of calls to random number generator
27324 * uncomment if needed
27325 C     COMMON /DTRNCT/ IRNCT0,IRNCT1
27326 C     LOGICAL LFIRST
27327 C     DATA LFIRST /.TRUE./
27328
27329 * counter of calls to random number generator
27330 * uncomment if needed
27331 C     IF (LFIRST) THEN
27332 C        IRNCT0 = 0
27333 C        IRNCT1 = 0
27334 C        LFIRST = .FALSE.
27335 C     ENDIF
27336  100  CONTINUE
27337       DT_RNDM = U(I)-U(J)
27338       IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27339       U(I) = DT_RNDM
27340       I    = I-1
27341       IF ( I.EQ.0 ) I = 97
27342       J    = J-1
27343       IF ( J.EQ.0 ) J = 97
27344       C    = C-CD
27345       IF ( C.LT.0.0D0 ) C = C+CM
27346       DT_RNDM = DT_RNDM-C
27347       IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27348
27349       IF ((DT_RNDM.EQ.0.D0).OR.(DT_RNDM.EQ.1.D0)) GOTO 100
27350
27351 * counter of calls to random number generator
27352 * uncomment if needed
27353 C     IRNCT0 = IRNCT0+1
27354
27355       RETURN
27356       END
27357
27358 *$ CREATE DT_RNDMST.FOR
27359 *COPY DT_RNDMST
27360 *
27361 *===rndmst=============================================================*
27362 *
27363       SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27364
27365       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27366       SAVE
27367
27368 * random number generator
27369       COMMON /DTRAND/ U(97),C,CD,CM,I,J
27370
27371       MA1 = NA1
27372       MA2 = NA2
27373       MA3 = NA3
27374       MB1 = NB1
27375       I   = 97
27376       J   = 33
27377       DO 20 II2 = 1,97
27378         S = 0
27379         T = 0.5D0
27380         DO 10 II1 = 1,24
27381           MAT  = MOD(MOD(MA1*MA2,179)*MA3,179)
27382           MA1  = MA2
27383           MA2  = MA3
27384           MA3  = MAT
27385           MB1  = MOD(53*MB1+1,169)
27386           IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27387    10   T = 0.5D0*T
27388    20 U(II2) = S
27389       C  =   362436.0D0/16777216.0D0
27390       CD =  7654321.0D0/16777216.0D0
27391       CM = 16777213.0D0/16777216.0D0
27392       RETURN
27393       END
27394
27395 *$ CREATE DT_RNDMIN.FOR
27396 *COPY DT_RNDMIN
27397 *
27398 *===rndmin=============================================================*
27399 *
27400       SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27401
27402       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27403       SAVE
27404
27405 * random number generator
27406       COMMON /DTRAND/ U(97),C,CD,CM,I,J
27407
27408       DIMENSION UIN(97)
27409
27410       DO 10 KKK = 1,97
27411    10 U(KKK) = UIN(KKK)
27412       C  = CIN
27413       CD = CDIN
27414       CM = CMIN
27415       I  = IIN
27416       J  = JIN
27417
27418       RETURN
27419       END
27420
27421 *$ CREATE DT_RNDMOU.FOR
27422 *COPY DT_RNDMOU
27423 *
27424 *===rndmou=============================================================*
27425 *
27426       SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
27427
27428       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27429       SAVE
27430
27431 * random number generator
27432       COMMON /DTRAND/ U(97),C,CD,CM,I,J
27433
27434       DIMENSION UOUT(97)
27435
27436       DO 10 KKK = 1,97
27437    10 UOUT(KKK) = U(KKK)
27438       COUT  = C
27439       CDOUT = CD
27440       CMOUT = CM
27441       IOUT  = I
27442       JOUT  = J
27443
27444       RETURN
27445       END
27446
27447 *$ CREATE DT_RNDMTE.FOR
27448 *COPY DT_RNDMTE
27449 *
27450 *===rndmte=============================================================*
27451 *
27452       SUBROUTINE DT_RNDMTE(IO)
27453
27454       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27455       SAVE
27456
27457       DIMENSION UU(97),U(6),X(6),D(6)
27458       DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27459      +8354498.D0, 10633180.D0/
27460
27461       CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27462       CALL DT_RNDMST(12,34,56,78)
27463       DO 10 II1 = 1,20000
27464    10 XX = DT_RNDM(XX)
27465       SD        = 0.0D0
27466       DO 20 II2 = 1,6
27467         X(II2)  = 4096.D0*(4096.D0*DT_RNDM(SD))
27468         D(II2)  = X(II2)-U(II2)
27469    20 SD = SD+D(II2)
27470       CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27471 **sr 24.01.95
27472 C     IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27473       IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27474 C        WRITE(6,1000)
27475  1000    FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27476      &          ' passed')
27477       ENDIF
27478 **
27479       RETURN
27480   500 FORMAT('  === TEST OF THE RANDOM-GENERATOR ===',/,
27481      &'    EXPECTED VALUE    CALCULATED VALUE     DIFFERENCE',/, 6(F17.
27482      &1,F20.1,F15.3,/), '  === END OF TEST ;',
27483      &'  GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27484       END
27485 *
27486 *$ CREATE PHO_RNDM.FOR
27487 *COPY PHO_RNDM
27488 *
27489 *===pho_rndm===========================================================*
27490 *
27491       DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27492
27493       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27494       SAVE
27495
27496       PHO_RNDM = DT_RNDM(DUMMY)
27497
27498       RETURN
27499       END
27500
27501 *$ CREATE PYR.FOR
27502 *COPY PYR
27503 *
27504 *===pyr================================================================*
27505 *
27506       DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27507
27508       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27509       SAVE
27510
27511       DUMMY = DBLE(IDUMMY)
27512       PYR = DT_RNDM(DUMMY)
27513
27514       RETURN
27515       END
27516
27517 *$ CREATE DT_TITLE.FOR
27518 *COPY DT_TITLE
27519 *
27520 *===title==============================================================*
27521 *
27522       SUBROUTINE DT_TITLE
27523
27524       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27525       SAVE
27526       PARAMETER ( LINP = 10 ,
27527      &            LOUT = 6 ,
27528      &            LDAT = 9 )
27529
27530       CHARACTER*6 CVERSI
27531       CHARACTER*11 CCHANG
27532       DATA CVERSI,CCHANG /'3.0-5 ','08 Jan 2007'/
27533
27534       CALL DT_XTIME
27535       WRITE(LOUT,1000) CVERSI,CCHANG
27536  1000 FORMAT(1X,'+-------------------------------------------------',
27537      &                  '----------------------+',/,
27538      &     1X,'|',71X,'|',/,
27539      &     1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27540      &     1X,'|',71X,'|',/,
27541      &     1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27542      &     1X,'|',71X,'|',/,
27543      &     1X,'|',12X,'Authors: Stefan Roesler   (CERN)',27X,'|',/,
27544      &     1X,'|',21X,'Ralph Engel      (FZ Karlsruhe)',19X,'|',/,
27545      &     1X,'|',21X,'Johannes Ranft   (Siegen Univ.)',19X,'|',/,
27546      &     1X,'|',71X,'|',/,
27547      &     1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27548      &                                              17X,'|',/,
27549      &     1X,'|',71X,'|',/,
27550      &     1X,'+-------------------------------------------------',
27551      &                '----------------------+',/,
27552      &     1X,'| Please send suggestions, bug reports, etc. to: ',
27553      &                                  'Stefan.Roesler@cern.ch |',/,
27554      &     1X,'+-------------------------------------------------',
27555      &                '----------------------+',/)
27556
27557       RETURN
27558       END
27559
27560 *$ CREATE DT_EVTINI.FOR
27561 *COPY DT_EVTINI
27562 *
27563 *===evtini=============================================================*
27564 *
27565       SUBROUTINE DT_EVTINI
27566
27567 ************************************************************************
27568 * Initialization of DTEVT1.                                            *
27569 * This version dated 15.01.94 is written by S. Roesler                 *
27570 ************************************************************************
27571
27572       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27573       SAVE
27574       PARAMETER ( LINP = 10 ,
27575      &            LOUT = 6 ,
27576      &            LDAT = 9 )
27577
27578 * event history
27579       PARAMETER (NMXHKK=200000)
27580       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27581      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27582      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27583 * extended event history
27584       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27585      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27586      &                IHIST(2,NMXHKK)
27587 * event flag
27588       COMMON /DTEVNO/ NEVENT,ICASCA
27589       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27590 * emulsion treatment
27591       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27592      &                NCOMPO,IEMUL
27593
27594 * initialization of DTEVT1/DTEVT2
27595       NEND = NHKK
27596       IF (NEVENT.EQ.1) NEND = NMXHKK
27597       NHKK   = 0
27598       NEVHKK = NEVENT
27599       DO 1 I=1,NEND
27600          ISTHKK(I)   = 0
27601          IDHKK(I)    = 0
27602          JMOHKK(1,I) = 0
27603          JMOHKK(2,I) = 0
27604          JDAHKK(1,I) = 0
27605          JDAHKK(2,I) = 0
27606          IDRES(I)    = 0
27607          IDXRES(I)   = 0
27608          NOBAM(I)    = 0
27609          IDCH(I)     = 0
27610          IHIST(1,I)  = 0
27611          IHIST(2,I)  = 0
27612          DO 2 J=1,4
27613             PHKK(J,I) = 0.0D0
27614             VHKK(J,I) = 0.0D0
27615             WHKK(J,I) = 0.0D0
27616     2    CONTINUE
27617          PHKK(5,I) = 0.0D0
27618     1 CONTINUE
27619       DO 3 I=1,10
27620          NPOINT(I) = 0
27621     3 CONTINUE
27622       CALL DT_CHASTA(-1)
27623
27624 C* initialization of DTLTRA
27625 C      IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27626
27627       RETURN
27628       END
27629
27630 *$ CREATE DT_STATIS.FOR
27631 *COPY DT_STATIS
27632 *
27633 *===statis=============================================================*
27634 *
27635       SUBROUTINE DT_STATIS(MODE)
27636
27637 ************************************************************************
27638 * Initialization and output of run-statistics.                         *
27639 *              MODE  = 1     initialization                            *
27640 *                    = 2     output                                    *
27641 * This version dated 23.01.94 is written by S. Roesler                 *
27642 ************************************************************************
27643
27644       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27645       SAVE
27646       PARAMETER ( LINP = 10 ,
27647      &            LOUT = 6 ,
27648      &            LDAT = 9 )
27649       PARAMETER (TINY3=1.0D-3)
27650
27651 * statistics
27652       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27653      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27654      &                ICEVTG(8,0:30)
27655 * rejection counter
27656       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27657      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27658      &                IREXCI(3),IRDIFF(2),IRINC
27659 * central particle production, impact parameter biasing
27660       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27661 * various options for treatment of partons (DTUNUC 1.x)
27662 * (chain recombination, Cronin,..)
27663       LOGICAL LCO2CR,LINTPT
27664       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27665      &                LCO2CR,LINTPT
27666 * nucleon-nucleon event-generator
27667       CHARACTER*8 CMODEL
27668       LOGICAL LPHOIN
27669       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27670 * flags for particle decays
27671       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27672      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27673      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27674 * diquark-breaking mechanism
27675       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27676
27677       DIMENSION PP(4),PT(4)
27678
27679       GOTO (1,2) MODE
27680
27681 * initialization
27682     1 CONTINUE
27683
27684 *   initialize statistics counter
27685       ICREQU = 0
27686       ICSAMP = 0
27687       ICCPRO = 0
27688       ICDPR  = 0
27689       ICDTA  = 0
27690       ICRJSS = 0
27691       ICVV2S = 0
27692       DO 10 I=1,9
27693          ICRES(I)    = 0
27694          ICCHAI(1,I) = 0
27695          ICCHAI(2,I) = 0
27696    10 CONTINUE
27697 *   initialize rejection counter
27698       IRPT      = 0
27699       IRHHA     = 0
27700       LOMRES    = 0
27701       LOBRES    = 0
27702       IRFRAG    = 0
27703       IREVT     = 0
27704       IRRES(1)  = 0
27705       IRRES(2)  = 0
27706       IRCHKI(1) = 0
27707       IRCHKI(2) = 0
27708       IRCRON(1) = 0
27709       IRCRON(2) = 0
27710       IRCRON(3) = 0
27711       IRDIFF(1) = 0
27712       IRDIFF(2) = 0
27713       IRINC     = 0
27714       DO 11 I=1,5
27715          ICDIFF(I) = 0
27716    11 CONTINUE
27717       DO 12 I=1,8
27718          DO 13 J=0,30
27719             ICEVTG(I,J) = 0
27720    13    CONTINUE
27721    12 CONTINUE
27722
27723       RETURN
27724
27725 * output
27726     2 CONTINUE
27727
27728 *   statistics counter
27729       WRITE(LOUT,1000)
27730  1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27731      &       28X,'---------------------')
27732       WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27733  1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27734      &       I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27735      &       'event',11X,F9.1)
27736       IF (ICDIFF(1).NE.0) THEN
27737          WRITE(LOUT,1009) ICDIFF
27738  1009    FORMAT(/,1X,'diffractive events:    total   ',I8,/,49X,
27739      &          'low mass   high mass',/,24X,'single diffraction',
27740      &          7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27741       ENDIF
27742       IF (ICENTR.GT.0) THEN
27743          WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27744      &                    DBLE(ICSAMP)/DBLE(ICCPRO)
27745  1002    FORMAT(/,1X,'central production:',/,2X,'mean number',
27746      &          ' of sampled Glauber-events per event',9X,F9.1,/,
27747      &          2X,'fraction of production cross section',21X,F10.6)
27748       ENDIF
27749       WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27750      &                 DBLE(ICDTA)/DBLE(ICSAMP)
27751  1003 FORMAT(/,54X,'proj.    targ.',/,1X,'average number of wounded',
27752      &       ' nucleons after x-sampling',2(4X,F6.2))
27753
27754       IF (MCGENE.EQ.1) THEN
27755          WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27756  1004    FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27757      &          ' event',3X,F9.1)
27758          IF (ISICHA.EQ.1) THEN
27759             WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27760  1005       FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27761      &             'of single chains  per event',13X,F9.1)
27762          ENDIF
27763          WRITE(LOUT,1006)
27764  1006    FORMAT(/,1X,'chain system statistics:  (per event)',/,
27765      &       23X,'mean number of chains      mean number of chains',/,
27766      &       23X,'sampled    hadronized      having mass of a reso.')
27767          WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27768      &                     DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27769      &                     DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27770      &                  DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27771  1007    FORMAT(1X,'sea     - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27772      &          1X,'disea   - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27773      &          1X,'sea     - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27774      &          1X,'sea     - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27775      &          1X,'disea   - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27776      &          1X,'valence - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27777      &          1X,'valence - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27778      &          1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27779      &          1X,'fused chains      ',18X,F4.1,17X,F4.1,/)
27780          WRITE(LOUT,1008)
27781      &     (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27782      &     DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27783      &     DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27784      &     (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27785      &     (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27786      &     DBLE(IRHHA)/DBLE(ICREQU),
27787      &     DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27788      &     (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27789  1008    FORMAT(/,1X,'Rejection counter:  (NEVT = no. of events)',/,/,
27790      &       1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27791      &       F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27792      &       'Intrins. p_t (GETSPT)',21X,'IRPT     /NEVT = ',F7.2,/,
27793      &       1X,'Chain mass corr. for resonances (EVTRES)',2X,
27794      &       'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES)  IRRES(2) /',
27795      &       'NEVT = ',F7.2,/,43X,'LOMRES   /NEVT = ',F7.2,/,
27796      &       43X,'LOBRES   /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27797      &       ' 2-chain systems (CHKINE)  IRCHKI(1)/NEVT = ',F7.2,/,
27798      &       43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27799      &       'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27800      &       F7.2,/,1X,'Total no. of rej.',
27801      &       ' in chain-systems treatment (GETCSY)',/,43X,
27802      &       'IRHHA    /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27803      &       ' (not yet used!)',4X,'IRFRAG   /NEVT = ',F7.2,/,
27804      &       1X,'Total no. of rej. in DPM-treatment of one event',
27805      &       ' (EVENTA)',/,43X,'IREVT    /NEVT = ',F7.2,/,1X,
27806      &       'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27807      &       ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27808      &       'IREXCI(3) = ',I5,/)
27809       ELSEIF (MCGENE.EQ.2) THEN
27810          WRITE(LOUT,1010) ELOJET
27811  1010    FORMAT(/,/,1X,'PHOJET-treatment of chain systems above  ',
27812      &          F4.1,' GeV')
27813          WRITE(LOUT,1011)
27814  1011    FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27815      &          30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27816      &          5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27817          WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27818      &                    (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27819      &                    (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27820      &                    ((ICEVTG(I,J),I=1,8),J=3,7),
27821      &                    ((ICEVTG(I,J),I=1,8),J=19,21),
27822      &                    (ICEVTG(I,8),I=1,8),
27823      &                    ((ICEVTG(I,J),I=1,8),J=22,24),
27824      &                    (ICEVTG(I,9),I=1,8),
27825      &                    ((ICEVTG(I,J),I=1,8),J=25,28),
27826      &                    ((ICEVTG(I,J),I=1,8),J=10,18)
27827  1012    FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27828      &          8I8,/,/,1X,'PHOJET ',8I8,/,'   sngl ',8I8,/,/,
27829      &          ' no-dif.',8I8,/,
27830      &          ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27831      &          ' diff-1 ',8I8,/,'  low   ',8I8,/,'  high  ',8I8,/,
27832      &          '  h-diff',8I8,/,' diff-2 ',8I8,/,'  low   ',8I8,/,
27833      &          '  high  ',8I8,/,'  h-diff',8I8,/,' dbl-di.',8I8,/,
27834      &          '  lo-lo ',8I8,/,'  hi-hi ',8I8,/,'  lo-hi ',8I8,/,
27835      &          '  hi-lo ',8I8,/,
27836      &          ' dir-ga.',8I8,/,/,' dir-1  ',8I8,/,' dir-2  ',8I8,/,
27837      &          ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27838      &          ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27839          WRITE(LOUT,1013)
27840  1013    FORMAT(/,1X,'2. chain system statistics -',
27841      &          ' mean numbers per evt:',/,30X,'---------------------',
27842      &          /,/,16X,'s-s',7X,'d-s',7X,'s-d')
27843          WRITE(LOUT,1014)
27844      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27845      &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27846      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27847  1014    FORMAT(/,1X,'req.to.    ',3E10.2,/,/,1X,'low rq.    ',3E10.2,/,
27848      &          1X,'low ac.    ',3E10.2,/,/,1X,'PHOJET     ',3E10.2,/,/,
27849      &          ' no-dif.    ',3E10.2,/,' el-sca.    ',3E10.2,/,
27850      &          ' qel-sc.    ',3E10.2,/,' dbl-Po.    ',3E10.2,/,
27851      &          ' diff-1     ',3E10.2,/,' diff-2     ',3E10.2,/,
27852      &          ' dbl-di.    ',3E10.2,/,' dir-ga.    ',3E10.2,/,/,
27853      &          ' dir-1      ',3E10.2,/,' dir-2      ',3E10.2,/,
27854      &          ' dbl-dir    ',3E10.2,/,' s-Pom.     ',3E10.2,/,
27855      &          ' h-Pom.     ',3E10.2,/,' s-Reg.     ',3E10.2,/,
27856      &          ' enh-trg    ',3E10.2,/,' enh-log    ',3E10.2)
27857          WRITE(LOUT,1015)
27858  1015    FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
27859          WRITE(LOUT,1016)
27860      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27861      &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27862      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27863  1016    FORMAT(/,1X,'req.to.    ',5E10.2,/,/,1X,'low rq.    ',5E10.2,/,
27864      &          1X,'low ac.    ',5E10.2,/,/,1X,'PHOJET     ',5E10.2,/,/,
27865      &          ' no-dif.    ',5E10.2,/,' el-sca.    ',5E10.2,/,
27866      &          ' qel-sc.    ',5E10.2,/,' dbl-Po.    ',5E10.2,/,
27867      &          ' diff-1     ',5E10.2,/,' diff-2     ',5E10.2,/,
27868      &          ' dbl-di.    ',5E10.2,/,' dir-ga.    ',5E10.2,/,/,
27869      &          ' dir-1      ',5E10.2,/,' dir-2      ',5E10.2,/,
27870      &          ' dbl-dir    ',5E10.2,/,' s-Pom.     ',5E10.2,/,
27871      &          ' h-Pom.     ',5E10.2,/,' s-Reg.     ',5E10.2,/,
27872      &          ' enh-trg    ',5E10.2,/,' enh-log    ',5E10.2)
27873
27874       ENDIF
27875       CALL DT_CHASTA(1)
27876
27877       IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27878      &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
27879          WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27880      &    DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27881      &    DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27882          WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27883      &    DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27884      &    DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27885          WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27886      &    DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27887      &    DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27888          WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27889      &    DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27890      &    DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27891          WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27892      &    DBRKA(3,1),DBRKA(3,2),
27893      &    DBRKA(3,3),DBRKA(3,4)
27894          WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27895      &    DBRKR(3,1),DBRKR(3,2),
27896      &    DBRKR(3,3),DBRKR(3,4)
27897          WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27898      &    DBRKA(3,5),DBRKA(3,6),
27899      &    DBRKA(3,7),DBRKA(3,8)
27900          WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27901      &    DBRKR(3,5),DBRKR(3,6),
27902      &    DBRKR(3,7),DBRKR(3,8)
27903       ENDIF
27904
27905       FAC = 1.0D0
27906       IF (MCGENE.EQ.2) THEN
27907 C        CALL PHO_PHIST(-2,SIGMAX)
27908          CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27909       ENDIF
27910
27911       CALL DT_XTIME
27912
27913       RETURN
27914       END
27915
27916 *$ CREATE DT_EVTOUT.FOR
27917 *COPY DT_EVTOUT
27918 *
27919 *===evtout=============================================================*
27920 *
27921       SUBROUTINE DT_EVTOUT(MODE)
27922
27923 ************************************************************************
27924 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
27925 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
27926 *                    4  plot entries of DTEVT1 and DTEVT2              *
27927 * This version dated 11.12.94 is written by S. Roesler                 *
27928 ************************************************************************
27929
27930       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27931       SAVE
27932       PARAMETER ( LINP = 10 ,
27933      &            LOUT = 6 ,
27934      &            LDAT = 9 )
27935 * event history
27936       PARAMETER (NMXHKK=200000)
27937       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27938      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27939      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27940
27941       DIMENSION IRANGE(NMXHKK)
27942
27943       IF (MODE.EQ.2) RETURN
27944
27945       CALL DT_EVTPLO(IRANGE,MODE)
27946
27947       RETURN
27948       END
27949
27950 *$ CREATE DT_EVTPLO.FOR
27951 *COPY DT_EVTPLO
27952 *
27953 *===evtplo=============================================================*
27954 *
27955       SUBROUTINE DT_EVTPLO(IRANGE,MODE)
27956
27957 ************************************************************************
27958 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
27959 *                    2  plot entries of DTEVT1 given by IRANGE         *
27960 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
27961 *                    4  plot entries of DTEVT1 and DTEVT2              *
27962 *                    5  plot rejection counter                         *
27963 * This version dated 11.12.94 is written by S. Roesler                 *
27964 ************************************************************************
27965
27966       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27967       SAVE
27968       PARAMETER ( LINP = 10 ,
27969      &            LOUT = 6 ,
27970      &            LDAT = 9 )
27971
27972       CHARACTER*16 CHAU
27973
27974 * event history
27975       PARAMETER (NMXHKK=200000)
27976       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27977      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27978      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27979 * extended event history
27980       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27981      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27982      &                IHIST(2,NMXHKK)
27983 * rejection counter
27984       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27985      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27986      &                IREXCI(3),IRDIFF(2),IRINC
27987
27988       DIMENSION IRANGE(NMXHKK)
27989
27990       IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
27991          WRITE(LOUT,1000)
27992  1000    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTEVT1/',/,
27993      &         15X,'           --------------------------',/,/,
27994      &             '       ST    ID  M1   M2   D1   D2     PX     PY',
27995      &             '     PZ      E       M',/)
27996          DO 1 I=1,NHKK
27997             WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27998      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27999      &                       PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28000      &                       PHKK(5,I)
28001 C           WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28002 C    &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28003 C    &                       PHKK(3,I),PHKK(4,I)
28004 C           WRITE(LOUT,'(4E15.4)')
28005 C    &         VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
28006  1001       FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
28007  1011       FORMAT(I5,I5,I6,4I5,2E15.5)
28008     1    CONTINUE
28009          WRITE(LOUT,*)
28010 C        DO 4 I=1,NHKK
28011 C           WRITE(LOUT,1006) I,ISTHKK(I),
28012 C    &                    VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
28013 C    &                    WHKK(2,I),WHKK(3,I)
28014 C1006       FORMAT(1X,I4,I6,6E10.3)
28015 C   4    CONTINUE
28016       ENDIF
28017
28018       IF (MODE.EQ.2) THEN
28019          WRITE(LOUT,1000)
28020          NC = 0
28021     2    CONTINUE
28022          NC = NC+1
28023          IF (IRANGE(NC).EQ.-100) GOTO 9999
28024          I = IRANGE(NC)
28025          WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28026      &                    JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28027      &                    PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28028      &                    PHKK(5,I)
28029          GOTO 2
28030       ENDIF
28031
28032       IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
28033          WRITE(LOUT,1002)
28034  1002    FORMAT(/,1X,'EVTPLO:',14X,
28035      &         ' content of COMMON /DTEVT1/,/DTEVT2/',/,
28036      &         15X,'        -----------------------------------',/,/,
28037      &             '       ST    ID   M1   M2   D1   D2  IDR  IDXR',
28038      &             ' NOBAM IDCH    M',/)
28039          DO 3 I=1,NHKK
28040 C           IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
28041                KF    = IDHKK(I)
28042                IDCHK = KF/10000
28043                IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28044      &            (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
28045                CALL PYNAME(KF,CHAU)
28046                WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28047      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28048      &                       IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
28049      &                       PHKK(5,I),CHAU
28050  1003          FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
28051 C           ENDIF
28052     3    CONTINUE
28053       ENDIF
28054
28055       IF (MODE.EQ.5) THEN
28056          WRITE(LOUT,1004)
28057  1004    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTREJC/',/,
28058      &         15X,'           --------------------------',/)
28059          WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
28060      &                    IRSEA,IRCRON
28061  1005    FORMAT(1X,'IRPT   = ',I5,'  IRHHA = ',I5,/,
28062      &          1X,'IRRES  = ',2I5,'  LOMRES = ',I5,'  LOBRES = ',I5,/,
28063      &          1X,'IREMC  = ',10I5,/,
28064      &          1X,'IRFRAG = ',I5,'  IRSEA = ',I5,' IRCRON = ',I5,/)
28065       ENDIF
28066
28067  9999 RETURN
28068       END
28069
28070 *$ CREATE DT_EVTPUT.FOR
28071 *COPY DT_EVTPUT
28072 *
28073 *===evtput=============================================================*
28074 *
28075       SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
28076
28077       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28078       SAVE
28079       PARAMETER ( LINP = 10 ,
28080      &            LOUT = 6 ,
28081      &            LDAT = 9 )
28082       PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
28083      &           TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
28084
28085 * event history
28086       PARAMETER (NMXHKK=200000)
28087       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28088      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28089      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28090 * extended event history
28091       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28092      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28093      &                IHIST(2,NMXHKK)
28094 * Lorentz-parameters of the current interaction
28095       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28096      &                UMO,PPCM,EPROJ,PPROJ
28097 * particle properties (BAMJET index convention)
28098       CHARACTER*8  ANAME
28099       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28100      &                IICH(210),IIBAR(210),K1(210),K2(210)
28101
28102 C     IF (MODE.GT.100) THEN
28103 C        WRITE(LOUT,'(1X,A,I5,A,I5)')
28104 C    &        'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
28105 C        NHKK = NHKK-MODE+100
28106 C        RETURN
28107 C     ENDIF
28108       MO1  = M1
28109       MO2  = M2
28110       NHKK = NHKK+1
28111
28112       IF (NHKK.GT.NMXHKK) THEN
28113          WRITE(LOUT,1000) NHKK
28114  1000    FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
28115      &             '! program execution stopped..')
28116          STOP
28117       ENDIF
28118       IF (M1.LT.0) MO1 = NHKK+M1
28119       IF (M2.LT.0) MO2 = NHKK+M2
28120       ISTHKK(NHKK)   = IST
28121       IDHKK(NHKK)    = ID
28122       JMOHKK(1,NHKK) = MO1
28123       JMOHKK(2,NHKK) = MO2
28124       JDAHKK(1,NHKK) = 0
28125       JDAHKK(2,NHKK) = 0
28126       IDRES(NHKK)    = IDR
28127       IDXRES(NHKK)   = IDXR
28128       IDCH(NHKK)     = IDC
28129 ** here we need to do something..
28130       IF (ID.EQ.88888) THEN
28131          IDMO1 = ABS(IDHKK(MO1))
28132          IDMO2 = ABS(IDHKK(MO2))
28133          IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
28134          IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
28135          IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
28136          IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
28137       ELSE
28138          NOBAM(NHKK) = 0
28139       ENDIF
28140       IDBAM(NHKK) = IDT_ICIHAD(ID)
28141       IF (MO1.GT.0) THEN
28142          IF (JDAHKK(1,MO1).NE.0) THEN
28143             JDAHKK(2,MO1) = NHKK
28144          ELSE
28145             JDAHKK(1,MO1) = NHKK
28146          ENDIF
28147       ENDIF
28148       IF (MO2.GT.0) THEN
28149          IF (JDAHKK(1,MO2).NE.0) THEN
28150             JDAHKK(2,MO2) = NHKK
28151          ELSE
28152             JDAHKK(1,MO2) = NHKK
28153          ENDIF
28154       ENDIF
28155 C      IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
28156 C         PTOT   = SQRT(PX**2+PY**2+PZ**2)
28157 C         AM0    = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
28158 C         AMRQ   = AAM(IDBAM(NHKK))
28159 C         AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
28160 C         IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
28161 C     &       (PTOT.GT.ZERO)) THEN
28162 C            DELTA = -AMDIF2/(2.0D0*(E+PTOT))
28163 CC           DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
28164 C            E     = E+DELTA
28165 C            PTOT1 = PTOT-DELTA
28166 C            PX    = PX*PTOT1/PTOT
28167 C            PY    = PY*PTOT1/PTOT
28168 C            PZ    = PZ*PTOT1/PTOT
28169 C         ENDIF
28170 C      ENDIF
28171       PHKK(1,NHKK) = PX
28172       PHKK(2,NHKK) = PY
28173       PHKK(3,NHKK) = PZ
28174       PHKK(4,NHKK) = E
28175       PTOT = SQRT( PX**2+PY**2+PZ**2 )
28176       IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
28177          PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
28178          PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
28179       ELSE
28180          PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
28181 C        IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
28182 C    &      WRITE(LOUT,'(1X,A,G10.3)')
28183 C    &        'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
28184          PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
28185       ENDIF
28186       IDCHK = ID/10000
28187       IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
28188 * special treatment for chains:
28189 *    z coordinate of chain in Lab  = pos. of target nucleon
28190 *    time of chain-creation in Lab = time of passage of projectile
28191 *                                    nucleus at pos. of taget nucleus
28192 C        VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
28193 C        VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
28194          VHKK(1,NHKK) = VHKK(1,MO2)
28195          VHKK(2,NHKK) = VHKK(2,MO2)
28196          VHKK(3,NHKK) = VHKK(3,MO2)
28197          VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
28198 C        WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
28199 C        WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
28200          WHKK(1,NHKK) = WHKK(1,MO1)
28201          WHKK(2,NHKK) = WHKK(2,MO1)
28202          WHKK(3,NHKK) = WHKK(3,MO1)
28203          WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
28204       ELSE
28205          IF (MO1.GT.0) THEN
28206             DO 1 I=1,4
28207                VHKK(I,NHKK) = VHKK(I,MO1)
28208                WHKK(I,NHKK) = WHKK(I,MO1)
28209     1       CONTINUE
28210          ELSE
28211             DO 2 I=1,4
28212                VHKK(I,NHKK) = ZERO
28213                WHKK(I,NHKK) = ZERO
28214     2       CONTINUE
28215          ENDIF
28216       ENDIF
28217
28218       RETURN
28219       END
28220
28221 *$ CREATE DT_CHASTA.FOR
28222 *COPY DT_CHASTA
28223 *
28224 *===chasta=============================================================*
28225 *
28226       SUBROUTINE DT_CHASTA(MODE)
28227
28228 ************************************************************************
28229 * This subroutine performs CHAin STAtistics and checks sequence of     *
28230 * partons in dtevt1 and sorts them with projectile partons coming      *
28231 * first if necessary.                                                  *
28232 *                                                                      *
28233 * This version dated  8.5.00  is written by S. Roesler.                *
28234 ************************************************************************
28235
28236       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28237       SAVE
28238       PARAMETER ( LINP = 10 ,
28239      &            LOUT = 6 ,
28240      &            LDAT = 9 )
28241
28242       CHARACTER*5 CCHTYP
28243
28244 * event history
28245       PARAMETER (NMXHKK=200000)
28246       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28247      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28248      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28249 * extended event history
28250       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28251      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28252      &                IHIST(2,NMXHKK)
28253 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28254       PARAMETER (MAXCHN=10000)
28255       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28256
28257       DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28258      &          CCHTYP(9),ICHSTA(10),ITOT(10)
28259       DATA ICHCFG /1800*0/
28260       DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28261       DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28262       DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28263       DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28264       DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28265       DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28266       DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28267      &              'ad aq',' d ad','ad d ',' g g '/
28268 *
28269 * initialization
28270 *
28271       IF (MODE.EQ.-1) THEN
28272          NCHAIN = 0
28273 *
28274 * loop over DTEVT1 and analyse chain configurations
28275 *
28276       ELSEIF (MODE.EQ.0) THEN
28277          DO 21 IDX=NPOINT(3),NHKK
28278             IDCHK = IDHKK(IDX)/10000
28279             IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28280      &          (IDHKK(IDX).NE.80000).AND.
28281      &          (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28282                IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28283                   WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28284      &                          ' at entry ',IDX
28285                   GOTO 21
28286                ENDIF
28287 *
28288                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28289                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28290                IMO1 = IST1/10
28291                IMO1 = IST1-10*IMO1
28292                IMO2 = IST2/10
28293                IMO2 = IST2-10*IMO2
28294 *   swop parton entries if necessary since we need projectile partons
28295 *   to come first in the common
28296                IF (IMO1.GT.IMO2) THEN
28297                   NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28298                   DO 22 K=1,NPTN/2
28299                      I0 = JMOHKK(1,IDX)-1+K
28300                      I1 = JMOHKK(2,IDX)+1-K
28301                      ITMP = ISTHKK(I0)
28302                      ISTHKK(I0) = ISTHKK(I1)
28303                      ISTHKK(I1) = ITMP
28304                      ITMP = IDHKK(I0)
28305                      IDHKK(I0) = IDHKK(I1)
28306                      IDHKK(I1) = ITMP
28307                      IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28308      &                  JDAHKK(1,JMOHKK(1,I0)) = I1
28309                      IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28310      &                  JDAHKK(2,JMOHKK(1,I0)) = I1
28311                      IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28312      &                  JDAHKK(1,JMOHKK(2,I0)) = I1
28313                      IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28314      &                  JDAHKK(2,JMOHKK(2,I0)) = I1
28315                      IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28316      &                  JDAHKK(1,JMOHKK(1,I1)) = I0
28317                      IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28318      &                  JDAHKK(2,JMOHKK(1,I1)) = I0
28319                      IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28320      &                  JDAHKK(1,JMOHKK(2,I1)) = I0
28321                      IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28322      &                  JDAHKK(2,JMOHKK(2,I1)) = I0
28323                      ITMP = JMOHKK(1,I0)
28324                      JMOHKK(1,I0) = JMOHKK(1,I1)
28325                      JMOHKK(1,I1) = ITMP
28326                      ITMP = JMOHKK(2,I0)
28327                      JMOHKK(2,I0) = JMOHKK(2,I1)
28328                      JMOHKK(2,I1) = ITMP
28329                      ITMP = JDAHKK(1,I0)
28330                      JDAHKK(1,I0) = JDAHKK(1,I1)
28331                      JDAHKK(1,I1) = ITMP
28332                      ITMP = JDAHKK(2,I0)
28333                      JDAHKK(2,I0) = JDAHKK(2,I1)
28334                      JDAHKK(2,I1) = ITMP
28335                      DO 23 J=1,4
28336                         RTMP1 = PHKK(J,I0)
28337                         RTMP2 = VHKK(J,I0)
28338                         RTMP3 = WHKK(J,I0)
28339                         PHKK(J,I0) = PHKK(J,I1)
28340                         VHKK(J,I0) = VHKK(J,I1)
28341                         WHKK(J,I0) = WHKK(J,I1)
28342                         PHKK(J,I1) = RTMP1
28343                         VHKK(J,I1) = RTMP2
28344                         WHKK(J,I1) = RTMP3
28345    23                CONTINUE
28346                      RTMP1 = PHKK(5,I0)
28347                      PHKK(5,I0) = PHKK(5,I1)
28348                      PHKK(5,I1) = RTMP1
28349                      ITMP = IDRES(I0)
28350                      IDRES(I0) = IDRES(I1)
28351                      IDRES(I1) = ITMP
28352                      ITMP = IDXRES(I0)
28353                      IDXRES(I0) = IDXRES(I1)
28354                      IDXRES(I1) = ITMP
28355                      ITMP = NOBAM(I0)
28356                      NOBAM(I0) = NOBAM(I1)
28357                      NOBAM(I1) = ITMP
28358                      ITMP = IDBAM(I0)
28359                      IDBAM(I0) = IDBAM(I1)
28360                      IDBAM(I1) = ITMP
28361                      ITMP = IDCH(I0)
28362                      IDCH(I0) = IDCH(I1)
28363                      IDCH(I1) = ITMP
28364                      ITMP = IHIST(1,I0)
28365                      IHIST(1,I0) = IHIST(1,I1)
28366                      IHIST(1,I1) = ITMP
28367                      ITMP = IHIST(2,I0)
28368                      IHIST(2,I0) = IHIST(2,I1)
28369                      IHIST(2,I1) = ITMP
28370    22             CONTINUE
28371                ENDIF
28372                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28373                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28374 *
28375 *   parton 1 (projectile side)
28376                IF (IST1.EQ.21) THEN
28377                   IDX1 = 1
28378                ELSEIF (IST1.EQ.22) THEN
28379                   IDX1 = 2
28380                ELSEIF (IST1.EQ.31) THEN
28381                   IDX1 = 3
28382                ELSEIF (IST1.EQ.32) THEN
28383                   IDX1 = 4
28384                ELSEIF (IST1.EQ.41) THEN
28385                   IDX1 = 5
28386                ELSEIF (IST1.EQ.42) THEN
28387                   IDX1 = 6
28388                ELSEIF (IST1.EQ.51) THEN
28389                   IDX1 = 7
28390                ELSEIF (IST1.EQ.52) THEN
28391                   IDX1 = 8
28392                ELSEIF (IST1.EQ.61) THEN
28393                   IDX1 = 9
28394                ELSEIF (IST1.EQ.62) THEN
28395                   IDX1 = 10
28396                ELSE
28397 c                 WRITE(LOUT,*)
28398 c    &               ' CHASTA: unknown parton status flag (',
28399 c    &               IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28400                   GOTO 21
28401                ENDIF
28402                ID = IDHKK(JMOHKK(1,IDX))
28403                IF (ABS(ID).LE.4) THEN
28404                   IF (ID.GT.0) THEN
28405                      ITYP1 = 1
28406                   ELSE
28407                      ITYP1 = 2
28408                   ENDIF
28409                ELSEIF (ABS(ID).GE.1000) THEN
28410                   IF (ID.GT.0) THEN
28411                      ITYP1 = 3
28412                   ELSE
28413                      ITYP1 = 4
28414                   ENDIF
28415                ELSEIF (ID.EQ.21) THEN
28416                   ITYP1 = 5
28417                ELSE
28418                   WRITE(LOUT,*)
28419      &               ' CHASTA: inconsistent parton identity (',
28420      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28421                   GOTO 21
28422                ENDIF
28423 *
28424 *   parton 2 (target side)
28425                IF (IST2.EQ.21) THEN
28426                   IDX2 = 1
28427                ELSEIF (IST2.EQ.22) THEN
28428                   IDX2 = 2
28429                ELSEIF (IST2.EQ.31) THEN
28430                   IDX2 = 3
28431                ELSEIF (IST2.EQ.32) THEN
28432                   IDX2 = 4
28433                ELSEIF (IST2.EQ.41) THEN
28434                   IDX2 = 5
28435                ELSEIF (IST2.EQ.42) THEN
28436                   IDX2 = 6
28437                ELSEIF (IST2.EQ.51) THEN
28438                   IDX2 = 7
28439                ELSEIF (IST2.EQ.52) THEN
28440                   IDX2 = 8
28441                ELSEIF (IST2.EQ.61) THEN
28442                   IDX2 = 9
28443                ELSEIF (IST2.EQ.62) THEN
28444                   IDX2 = 10
28445                ELSE
28446 c                 WRITE(LOUT,*)
28447 c    &               ' CHASTA: unknown parton status flag (',
28448 c    &               IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28449                   GOTO 21
28450                ENDIF
28451                ID = IDHKK(JMOHKK(2,IDX))
28452                IF (ABS(ID).LE.4) THEN
28453                   IF (ID.GT.0) THEN
28454                      ITYP2 = 1
28455                   ELSE
28456                      ITYP2 = 2
28457                   ENDIF
28458                ELSEIF (ABS(ID).GE.1000) THEN
28459                   IF (ID.GT.0) THEN
28460                      ITYP2 = 3
28461                   ELSE
28462                      ITYP2 = 4
28463                   ENDIF
28464                ELSEIF (ID.EQ.21) THEN
28465                   ITYP2 = 5
28466                ELSE
28467                   WRITE(LOUT,*)
28468      &               ' CHASTA: inconsistent parton identity (',
28469      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28470                   GOTO 21
28471                ENDIF
28472 *
28473 *   fill counter
28474                ITYPE = ICHTYP(ITYP1,ITYP2)
28475                IF (ITYPE.NE.0) THEN
28476                   ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28477                   NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28478                   ICHCFG(IDX1,IDX2,ITYPE,2) =
28479      &               ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28480
28481                   NCHAIN = NCHAIN+1
28482                   IF (NCHAIN.GT.MAXCHN) THEN
28483                      WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28484      &                  NCHAIN,MAXCHN
28485                      STOP
28486                   ENDIF
28487                   IDXCHN(1,NCHAIN) = IDX
28488                   IDXCHN(2,NCHAIN) = ITYPE
28489                ELSE
28490                   WRITE(LOUT,*)
28491      &               ' CHASTA: inconsistent chain at entry ',IDX
28492                   GOTO 21
28493                ENDIF
28494             ENDIF
28495    21    CONTINUE
28496 *
28497 * write statistics to output unit
28498 *
28499       ELSEIF (MODE.EQ.1) THEN
28500          WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28501          DO 31 I=1,10
28502             WRITE(LOUT,'(/,2A)')
28503      &         ' -----------------------------------------',
28504      &         '------------------------------------'
28505             WRITE(LOUT,'(2A)')
28506      &         ' p\\t         21     22     31     32     41',
28507      &         '     42     51     52     61     62'
28508             WRITE(LOUT,'(2A)')
28509      &         ' -----------------------------------------',
28510      &         '------------------------------------'
28511             DO 32 J=1,10
28512                ITOT(J) = 0
28513                DO 33 K=1,9
28514                   ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28515    33          CONTINUE
28516    32       CONTINUE
28517             WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28518             DO 34 K=1,9
28519                ISUM = 0
28520                DO 35 J=1,10
28521                   ISUM = ISUM+ICHCFG(I,J,K,1)
28522    35          CONTINUE
28523                IF (ISUM.GT.0)
28524      &            WRITE(LOUT,'(1X,A5,2X,10I7)')
28525      &               CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28526    34       CONTINUE
28527 C           WRITE(LOUT,'(2A)')
28528 C    &         ' -----------------------------------------',
28529 C    &         '-------------------------------'
28530    31    CONTINUE
28531 *
28532       ELSE
28533          WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28534          STOP
28535       ENDIF
28536
28537       RETURN
28538       END
28539 *$ CREATE PHO_PHIST.FOR
28540 *COPY PHO_PHIST
28541 *
28542 *===pohist=============================================================*
28543 *
28544       SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28545
28546       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28547       SAVE
28548
28549       PARAMETER ( LINP = 10 ,
28550      &            LOUT = 6 ,
28551      &            LDAT = 9 )
28552       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28553 * Glauber formalism: cross sections
28554       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28555      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28556      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28557      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28558      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28559      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28560      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28561      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28562      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28563      &                BSLOPE,NEBINI,NQBINI
28564
28565       ILAB = 0
28566       IF (IMODE.EQ.10) THEN
28567          IMODE = 1
28568          ILAB  = 1
28569       ENDIF
28570       IF (ABS(IMODE).LT.1000) THEN
28571 * PHOJET-statistics
28572 C        CALL POHISX(IMODE,WEIGHT)
28573          IF (IMODE.EQ.-1) THEN
28574             MODE = 1
28575             XSTOT(1,1,1) = WEIGHT
28576          ENDIF
28577          IF (IMODE.EQ. 1) MODE = 2
28578          IF (IMODE.EQ.-2) MODE = 3
28579          IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28580 C        IF (MODE.EQ.3) WRITE(LOUT,*)
28581 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
28582          CALL DT_HISTOG(MODE)
28583          CALL DT_USRHIS(MODE)
28584       ELSE
28585 * DTUNUC-statistics
28586          MODE = IMODE/1000
28587 C        IF (MODE.EQ.3) WRITE(LOUT,*)
28588 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
28589          CALL DT_HISTOG(MODE)
28590          CALL DT_USRHIS(MODE)
28591       ENDIF
28592
28593       RETURN
28594       END
28595
28596 *$ CREATE DT_SWPPHO.FOR
28597 *COPY DT_SWPPHO
28598 *
28599 *===swppho=============================================================*
28600 *
28601       SUBROUTINE DT_SWPPHO(ILAB)
28602
28603       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28604       SAVE
28605       PARAMETER ( LINP = 10 ,
28606      &            LOUT = 6 ,
28607      &            LDAT = 9 )
28608       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28609
28610       LOGICAL LSTART
28611
28612 * event history
28613       PARAMETER (NMXHKK=200000)
28614       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28615      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28616      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28617 * extended event history
28618       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28619      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28620      &                IHIST(2,NMXHKK)
28621 * flags for input different options
28622       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28623       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28624      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28625 * properties of photon/lepton projectiles
28626       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28627
28628 **PHOJET105a
28629 C     PARAMETER (NMXHEP=2000)
28630 C     COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28631 C    &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28632 C     COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28633 C     COMMON /PLASAV/ PLAB
28634 **PHOJET110
28635 C  standard particle data interface
28636       INTEGER NMXHEP
28637       PARAMETER (NMXHEP=4000)
28638       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28639       DOUBLE PRECISION PHEP,VHEP
28640       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28641      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28642      &                VHEP(4,NMXHEP)
28643 C  extension to standard particle data interface (PHOJET specific)
28644       INTEGER IMPART,IPHIST,ICOLOR
28645       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28646 C  global event kinematics and particle IDs
28647       INTEGER IFPAP,IFPAB
28648       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28649       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28650 **
28651       DATA ICOUNT/0/
28652
28653       DATA LSTART /.TRUE./
28654
28655 C     IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28656       IF ((IFRAME.EQ.1).AND.LSTART) THEN
28657          UMO  = ECM
28658          ELA  = ZERO
28659          PLA  = ZERO
28660          IDP  = IDT_ICIHAD(IFPAP(1))
28661          IDT  = IDT_ICIHAD(IFPAP(2))
28662          VIRT = PVIRT(1)
28663          CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28664          PLAB = PLA
28665          LSTART = .FALSE.
28666       ENDIF
28667
28668       NHKK   = 0
28669       ICOUNT = ICOUNT+1
28670 C     NEVHKK = NEVHEP
28671       NEVHKK = ICOUNT
28672       IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28673       DO 1 I=3,NHEP
28674          IF (ISTHEP(I).EQ.1) THEN
28675             NHKK = NHKK+1
28676             ISTHKK(NHKK) = 1
28677             IDHKK(NHKK)  = IDHEP(I)
28678             JMOHKK(1,NHKK) = 0
28679             JMOHKK(2,NHKK) = 0
28680             JDAHKK(1,NHKK) = 0
28681             JDAHKK(2,NHKK) = 0
28682             DO 2 K=1,4
28683                PHKK(K,NHKK) = PHEP(K,I)
28684                VHKK(K,NHKK) = ZERO
28685                WHKK(K,NHKK) = ZERO
28686     2       CONTINUE
28687             IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28688      &         CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28689      &                    PHKK(3,NHKK),PHKK(4,NHKK),-3)
28690             PHKK(5,NHKK) = PHEP(5,I)
28691             IDRES(NHKK)  = 0
28692             IDXRES(NHKK) = 0
28693             NOBAM(NHKK)  = 0
28694             IDBAM(NHKK)  = IDT_ICIHAD(IDHEP(I))
28695             IDCH(NHKK)   = 0
28696          ENDIF
28697     1 CONTINUE
28698
28699       RETURN
28700       END
28701
28702 *$ CREATE DT_HISTOG.FOR
28703 *COPY DT_HISTOG
28704 *
28705 *===histog=============================================================*
28706 *
28707       SUBROUTINE DT_HISTOG(MODE)
28708
28709 ************************************************************************
28710 * This version dated 25.03.96 is written by S. Roesler                 *
28711 ************************************************************************
28712
28713       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28714       SAVE
28715       PARAMETER ( LINP = 10 ,
28716      &            LOUT = 6 ,
28717      &            LDAT = 9 )
28718
28719       LOGICAL LFSP,LRNL
28720
28721 * event history
28722       PARAMETER (NMXHKK=200000)
28723       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28724      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28725      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28726 * extended event history
28727       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28728      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28729      &                IHIST(2,NMXHKK)
28730 * event flag used for histograms
28731       COMMON /DTNORM/ ICEVT,IEVHKK
28732 * flags for activated histograms
28733       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28734
28735       IEVHKK = NEVHKK
28736       GOTO (1,2,3) MODE
28737
28738 *------------------------------------------------------------------
28739 * initialization
28740     1 CONTINUE
28741       ICEVT = 0
28742       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28743       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28744
28745       RETURN
28746 *------------------------------------------------------------------
28747 * filling of histogram with event-record
28748     2 CONTINUE
28749       ICEVT = ICEVT+1
28750
28751       DO 20 I=1,NHKK
28752          CALL DT_SWPFSP(I,LFSP,LRNL)
28753          IF (LFSP) THEN
28754             IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28755             IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28756          ENDIF
28757          IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28758    20 CONTINUE
28759       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28760
28761       RETURN
28762 *------------------------------------------------------------------
28763 * output
28764     3 CONTINUE
28765       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28766       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28767
28768       RETURN
28769       END
28770
28771 *$ CREATE DT_SWPFSP.FOR
28772 *COPY DT_SWPFSP
28773 *
28774 *===swpfsp=============================================================*
28775 *
28776       SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28777
28778       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28779       SAVE
28780       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28781       PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28782      &           PI   =TWOPI/TWO,
28783      &           BOG  =TWOPI/360.0D0)
28784
28785 * event history
28786       PARAMETER (NMXHKK=200000)
28787       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28788      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28789      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28790 * extended event history
28791       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28792      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28793      &                IHIST(2,NMXHKK)
28794 * particle properties (BAMJET index convention)
28795       CHARACTER*8  ANAME
28796       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28797      &                IICH(210),IIBAR(210),K1(210),K2(210)
28798 * Lorentz-parameters of the current interaction
28799       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28800      &                UMO,PPCM,EPROJ,PPROJ
28801 * flags for input different options
28802       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28803       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28804      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28805 * (original name: PAREVT)
28806       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28807      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
28808       PARAMETER ( NALLWP = 39   )
28809       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
28810      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28811      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28812      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
28813 * temporary storage for one final state particle
28814       LOGICAL LFRAG,LGREY,LBLACK
28815       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28816      &                SINTHE,COSTHE,THETA,THECMS,
28817      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28818      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28819      &                LFRAG,LGREY,LBLACK
28820
28821       LOGICAL LFSP,LRNL
28822
28823       LFSP = .FALSE.
28824       LRNL = .FALSE.
28825       ISTRNL = 1000
28826       MULDEF = 1
28827       IF (LEVPRT) ISTRNL = 1001
28828
28829       IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28830          IST    = ISTHKK(IDX)
28831          IDPDG  = IDHKK(IDX)
28832          LFRAG  = .FALSE.
28833          IF (IDHKK(IDX).LT.80000) THEN
28834             IDBJT  = IDBAM(IDX)
28835             IBARY  = IIBAR(IDBJT)
28836             ICHAR  = IICH(IDBJT)
28837             AMASS  = AAM(IDBJT)
28838          ELSEIF (IDHKK(IDX).EQ.80000) THEN
28839             IDBJT  = 0
28840             IBARY  = IDRES(IDX)
28841             ICHAR  = IDXRES(IDX)
28842             AMASS  = PHKK(5,IDX)
28843             INUT   = IBARY-ICHAR
28844             IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28845             IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28846             IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28847             IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28848             IF (IDBJT.EQ.0) LFRAG = .TRUE.
28849          ELSE
28850             GOTO 9999
28851          ENDIF
28852          PE     = PHKK(4,IDX)
28853          PX     = PHKK(1,IDX)
28854          PY     = PHKK(2,IDX)
28855          PZ     = PHKK(3,IDX)
28856          PT2    = PX**2+PY**2
28857          PT     = SQRT(PT2)
28858          PTOT   = SQRT(PT2+PZ**2)
28859          SINTHE = PT/MAX(PTOT,TINY14)
28860          COSTHE = PZ/MAX(PTOT,TINY14)
28861          IF (COSTHE.GT.ONE) THEN
28862             THETA = ZERO
28863          ELSEIF (COSTHE.LT.-ONE) THEN
28864             THETA = TWOPI/2.0D0
28865          ELSE
28866             THETA = ACOS(COSTHE)
28867          ENDIF
28868          EKIN   = PE-AMASS
28869 **sr 15.4.96 new E_t-definition
28870          IF (IBARY.GT.0) THEN
28871             ET = EKIN*SINTHE
28872          ELSEIF (IBARY.LT.0) THEN
28873             ET = (EKIN+TWO*AMASS)*SINTHE
28874          ELSE
28875             ET = PE*SINTHE
28876          ENDIF
28877 **
28878          XLAB   = PZ/MAX(PPROJ,TINY14)
28879 C        XLAB   = PE/MAX(EPROJ,TINY14)
28880          BETA   = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28881      &                     *(ONE+AMASS/MAX(PE,TINY14)) ))
28882          PPLUS  = PE+PZ
28883          PMINUS = PE-PZ
28884          IF (PMINUS.GT.TINY14) THEN
28885             YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28886          ELSE
28887             YY = 100.0D0
28888          ENDIF
28889          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28890             ETA = -LOG(TAN(THETA/TWO))
28891          ELSE
28892             ETA = 100.0D0
28893          ENDIF
28894          IF (IFRAME.EQ.1) THEN
28895             CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28896             PPLUS  = EECMS+PZCMS
28897             PMINUS = EECMS-PZCMS
28898             IF ((PPLUS*PMINUS).GT.TINY14) THEN
28899                YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28900             ELSE
28901                YYCMS = 100.0D0
28902             ENDIF
28903             PTOTCM = SQRT(PT2+PZCMS**2)
28904             COSTH = PZCMS/MAX(PTOTCM,TINY14)
28905             IF (COSTH.GT.ONE) THEN
28906                THECMS = ZERO
28907             ELSEIF (COSTH.LT.-ONE) THEN
28908                THECMS = TWOPI/2.0D0
28909             ELSE
28910                THECMS = ACOS(COSTH)
28911             ENDIF
28912             IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28913                ETACMS = -LOG(TAN(THECMS/TWO))
28914             ELSE
28915                ETACMS = 100.0D0
28916             ENDIF
28917             XF = PZCMS/MAX(PPCM,TINY14)
28918             THECMS = THECMS/BOG
28919          ELSE
28920             PZCMS  = PZ
28921             EECMS  = PE
28922             YYCMS  = YY
28923             ETACMS = ETA
28924             XF     = XLAB
28925             THECMS = THETA/BOG
28926          ENDIF
28927          THETA  = THETA/BOG
28928
28929 * set flag for "grey/black"
28930          LGREY  = .FALSE.
28931          LBLACK = .FALSE.
28932          EK     = EKIN
28933          IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28934          IF (MULDEF.EQ.1) THEN
28935 *  EMU01-Def.
28936             IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28937      &                              (EK.LE.375.0D-3)      ).OR.
28938      &           ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28939      &                              (EK.LE. 56.0D-3)      ).OR.
28940      &           ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28941      &                              (EK.LE. 56.0D-3)      ).OR.
28942      &           ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28943      &                              (EK.LE.198.0D-3)      ).OR.
28944      &           ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28945      &                              (EK.LE.198.0D-3)      ).OR.
28946      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28947      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28948      &             (IDBJT.NE.16).AND.
28949      &             (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)    ) )
28950      &         LGREY = .TRUE.
28951             IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
28952      &           ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
28953      &           ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
28954      &           ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
28955      &           ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
28956      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28957      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28958      &             (IDBJT.NE.16).AND.(BETA.LE.0.23D0)  ) )
28959      &         LBLACK = .TRUE.
28960          ELSE
28961 *  common Def.
28962             IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
28963             IF (BETA.LE.0.23D0) LBLACK=.TRUE.
28964          ENDIF
28965          LFSP = .TRUE.
28966       ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
28967          IST    = ISTHKK(IDX)
28968          IDPDG  = IDHKK(IDX)
28969          LFRAG  = .TRUE.
28970          IDBJT  = 0
28971          IBARY  = IDRES(IDX)
28972          ICHAR  = IDXRES(IDX)
28973          AMASS  = PHKK(5,IDX)
28974          PE     = PHKK(4,IDX)
28975          PX     = PHKK(1,IDX)
28976          PY     = PHKK(2,IDX)
28977          PZ     = PHKK(3,IDX)
28978          PT2    = PX**2+PY**2
28979          PT     = SQRT(PT2)
28980          PTOT   = SQRT(PT2+PZ**2)
28981          SINTHE = PT/MAX(PTOT,TINY14)
28982          COSTHE = PZ/MAX(PTOT,TINY14)
28983          IF (COSTHE.GT.ONE) THEN
28984             THETA = ZERO
28985          ELSEIF (COSTHE.LT.-ONE) THEN
28986             THETA = TWOPI/2.0D0
28987          ELSE
28988             THETA  = ACOS(COSTHE)
28989          ENDIF
28990          EKIN   = PE-AMASS
28991 **sr 15.4.96 new E_t-definition
28992 C        ET     = PE*SINTHE
28993          ET     = EKIN*SINTHE
28994 **
28995          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28996             ETA = -LOG(TAN(THETA/TWO))
28997          ELSE
28998             ETA = 100.0D0
28999          ENDIF
29000          THETA  = THETA/BOG
29001          LRNL   = .TRUE.
29002       ENDIF
29003
29004  9999 CONTINUE
29005       RETURN
29006       END
29007
29008 *$ CREATE DT_HIMULT.FOR
29009 *COPY DT_HIMULT
29010 *
29011 *===himult=============================================================*
29012 *
29013       SUBROUTINE DT_HIMULT(MODE)
29014
29015 ************************************************************************
29016 * Tables of average energies/multiplicities.                           *
29017 * This version dated 30.08.2000 is written by S. Roesler               *
29018 ************************************************************************
29019
29020       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29021       SAVE
29022       PARAMETER ( LINP = 10 ,
29023      &            LOUT = 6 ,
29024      &            LDAT = 9 )
29025       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29026
29027       PARAMETER (SWMEXP=1.7D0)
29028
29029       CHARACTER*8 ANAMEH(4)
29030
29031 * particle properties (BAMJET index convention)
29032       CHARACTER*8  ANAME
29033       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29034      &                IICH(210),IIBAR(210),K1(210),K2(210)
29035 * temporary storage for one final state particle
29036       LOGICAL LFRAG,LGREY,LBLACK
29037       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29038      &                SINTHE,COSTHE,THETA,THECMS,
29039      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29040      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29041      &                LFRAG,LGREY,LBLACK
29042 * event flag used for histograms
29043       COMMON /DTNORM/ ICEVT,IEVHKK
29044 * Lorentz-parameters of the current interaction
29045       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
29046      &                UMO,PPCM,EPROJ,PPROJ
29047
29048       PARAMETER (NOPART=210)
29049       DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
29050      &          AVPT(4,NOPART),IAVPT(4,NOPART)
29051       DATA ANAMEH /'DEUTERON','3-H     ','3-HE    ','4-HE    '/
29052
29053       GOTO (1,2,3) MODE
29054
29055 *------------------------------------------------------------------
29056 * initialization
29057     1 CONTINUE
29058       DO 10 I=1,NOPART
29059          DO 11 J=1,4
29060             AVMULT(J,I) = ZERO
29061             AVE(J,I)    = ZERO
29062             AVSWM(J,I)  = ZERO
29063             AVPT(J,I)   = ZERO
29064             IAVPT(J,I)  = 0
29065    11    CONTINUE
29066    10 CONTINUE
29067
29068       RETURN
29069
29070 *------------------------------------------------------------------
29071 * filling of histogram with event-record
29072     2 CONTINUE
29073       IF (PE.LT.0.0D0) THEN
29074          WRITE(LOUT,*) ' HIMULT:  PE < 0 ! ',PE
29075          RETURN
29076       ENDIF
29077       IF (.NOT.LFRAG) THEN
29078          IVEL = 2
29079          IF (LGREY)  IVEL = 3
29080          IF (LBLACK) IVEL = 4
29081          AVE(1,IDBJT)       = AVE(1,IDBJT)   +PE
29082          AVE(IVEL,IDBJT)    = AVE(IVEL,IDBJT)+PE
29083          AVPT(1,IDBJT)     = AVPT(1,IDBJT)   +PT
29084          AVPT(IVEL,IDBJT)  = AVPT(IVEL,IDBJT)+PT
29085          IAVPT(1,IDBJT)    = IAVPT(1,IDBJT)   +1
29086          IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
29087          AVSWM(1,IDBJT)     = AVSWM(1,IDBJT)   +PE**SWMEXP
29088          AVSWM(IVEL,IDBJT)  = AVSWM(IVEL,IDBJT)+PE**SWMEXP
29089          AVMULT(1,IDBJT)    = AVMULT(1,IDBJT)   +ONE
29090          AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
29091          IF (IDBJT.LT.116) THEN
29092 *   total energy, multiplicity
29093             AVE(1,30)       = AVE(1,30)   +PE
29094             AVE(IVEL,30)    = AVE(IVEL,30)+PE
29095             AVPT(1,30)     = AVPT(1,30)   +PT
29096             AVPT(IVEL,30)  = AVPT(IVEL,30)+PT
29097             IAVPT(1,30)    = IAVPT(1,30)   +1
29098             IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
29099             AVSWM(1,30)     = AVSWM(1,30)+PE**SWMEXP
29100             AVSWM(IVEL,30)  = AVSWM(IVEL,30)+PE**SWMEXP
29101             AVMULT(1,30)    = AVMULT(1,30)   +ONE
29102             AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
29103 *   charged energy, multiplicity
29104             IF (ICHAR.LT.0) THEN
29105                AVE(1,26)       = AVE(1,26)   +PE
29106                AVE(IVEL,26)    = AVE(IVEL,26)+PE
29107                AVPT(1,26)     = AVPT(1,26)   +PT
29108                AVPT(IVEL,26)  = AVPT(IVEL,26)+PT
29109                IAVPT(1,26)    = IAVPT(1,26)   +1
29110                IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
29111                AVSWM(1,26)     = AVSWM(1,26)   +PE**SWMEXP
29112                AVSWM(IVEL,26)  = AVSWM(IVEL,26)+PE**SWMEXP
29113                AVMULT(1,26)    = AVMULT(1,26)   +ONE
29114                AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
29115             ENDIF
29116             IF (ICHAR.NE.0) THEN
29117                AVE(1,27)       = AVE(1,27)   +PE
29118                AVE(IVEL,27)    = AVE(IVEL,27)+PE
29119                AVPT(1,27)     = AVPT(1,27)   +PT
29120                AVPT(IVEL,27)  = AVPT(IVEL,27)+PT
29121                IAVPT(1,27)    = IAVPT(1,27)   +1
29122                IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
29123                AVSWM(1,27)     = AVSWM(1,27)   +PE**SWMEXP
29124                AVSWM(IVEL,27)  = AVSWM(IVEL,27)+PE**SWMEXP
29125                AVMULT(1,27)    = AVMULT(1,27)   +ONE
29126                AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
29127             ENDIF
29128          ENDIF
29129       ENDIF
29130
29131       RETURN
29132
29133 *------------------------------------------------------------------
29134 * output
29135     3 CONTINUE
29136       WRITE(LOUT,3000)
29137  3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
29138      &       29X,'---------------------',/)
29139       IF (MULDEF.EQ.1) THEN
29140          WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
29141       ELSE
29142          BETGRE = 0.7D0
29143          BETBLC = 0.23D0
29144          WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
29145  3002    FORMAT(1X,'fast:  beta > ',F4.2,'    grey:  ',F4.2,' > beta > '
29146      &          ,F4.2,'    black:  beta < ',F4.2,/)
29147       ENDIF
29148       WRITE(LOUT,3003) SWMEXP
29149  3003 FORMAT(1X,'particle    |',12X,'average multiplicity',/,
29150      &      13X,'|     total         fast',
29151 C    &      '       grey     black      K      f(',F3.1,')',/,1X,
29152      &      '       grey     black    <pt>     f(',F3.1,')',/,1X,
29153      &      '------------+--------------',
29154      &      '-------------------------------------------------')
29155       DO 30 I=1,NOPART
29156          DO 31 J=1,4
29157             AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
29158             AVE(J,I)    = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
29159             AVPT(J,I)   = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
29160             AVSWM(J,I)  = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
29161    31    CONTINUE
29162          IF (I.LE.115) THEN
29163             WRITE(LOUT,3004) ANAME(I),I,
29164      &                       AVMULT(1,I),AVMULT(2,I),
29165      &                       AVMULT(3,I),AVMULT(4,I),
29166 C    &                       AVE(1,I),AVSWM(1,I)
29167      &                       AVPT(1,I),AVSWM(1,I)
29168          ELSEIF (I.LE.119) THEN
29169             WRITE(LOUT,3004) ANAMEH(I-115),I,
29170      &                       AVMULT(1,I),AVMULT(2,I),
29171      &                       AVMULT(3,I),AVMULT(4,I),
29172 C    &                       AVE(1,I),AVSWM(1,I)
29173      &                       AVPT(1,I),AVSWM(1,I)
29174          ENDIF
29175  3004    FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29176    30 CONTINUE
29177 **temporary
29178 C     WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29179 C    &               AVMULT(3,27)+AVMULT(4,27)
29180 **
29181
29182       RETURN
29183       END
29184
29185 *$ CREATE DT_HISTAT.FOR
29186 *COPY DT_HISTAT
29187 *
29188 *===histat=============================================================*
29189 *
29190       SUBROUTINE DT_HISTAT(IDX,MODE)
29191
29192 ************************************************************************
29193 * This version dated 26.02.96 is written by S. Roesler                 *
29194 *                                                                      *
29195 * Last change 27.12.2006 by S. Roesler.                                *
29196 ************************************************************************
29197
29198       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29199       SAVE
29200       PARAMETER ( LINP = 10 ,
29201      &            LOUT = 6 ,
29202      &            LDAT = 9 )
29203       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29204       PARAMETER (NDIM=199)
29205
29206 * event history
29207       PARAMETER (NMXHKK=200000)
29208       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29209      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29210      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29211 * extended event history
29212       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29213      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29214      &                IHIST(2,NMXHKK)
29215 * particle properties (BAMJET index convention)
29216       CHARACTER*8  ANAME
29217       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29218      &                IICH(210),IIBAR(210),K1(210),K2(210)
29219       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29220 * Glauber formalism: cross sections
29221       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29222      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29223      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29224      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29225      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29226      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29227      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29228      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29229      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29230      &                BSLOPE,NEBINI,NQBINI
29231 * emulsion treatment
29232       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29233      &                NCOMPO,IEMUL
29234 * properties of interacting particles
29235       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29236 * rejection counter
29237       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29238      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29239      &                IREXCI(3),IRDIFF(2),IRINC
29240 * statistics: residual nuclei
29241       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29242      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29243      &                NINCST(2,4),NINCEV(2),
29244      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29245      &                NRESPB(2),NRESCH(2),NRESEV(4),
29246      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29247      &                NEVAFI(2,2)
29248 * parameter for intranuclear cascade
29249       LOGICAL LPAULI
29250       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29251 * (original name: PAREVT)
29252       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29253      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
29254       PARAMETER ( NALLWP = 39   )
29255       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
29256      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29257      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29258      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
29259 * (original name: FRBKCM)
29260       PARAMETER ( MXFFBK =     6 )
29261       PARAMETER ( MXZFBK =     9 )
29262       PARAMETER ( MXNFBK =    10 )
29263       PARAMETER ( MXAFBK =    16 )
29264       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
29265       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
29266       PARAMETER ( NXAFBK = MXAFBK + 1 )
29267       PARAMETER ( MXPSST =   300 )
29268       PARAMETER ( MXPSFB = 41000 )
29269       LOGICAL LFRMBK, LNCMSS
29270       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29271      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
29272      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
29273      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
29274      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29275      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
29276      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29277      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
29278      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
29279 * (original name: INPFLG)
29280       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
29281 * temporary storage for one final state particle
29282       LOGICAL LFRAG,LGREY,LBLACK
29283       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29284      &                SINTHE,COSTHE,THETA,THECMS,
29285      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29286      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29287      &                LFRAG,LGREY,LBLACK
29288 * event flag used for histograms
29289       COMMON /DTNORM/ ICEVT,IEVHKK
29290 * statistics: double-Pomeron exchange
29291       COMMON /DTFLG2/ INTFLG,IPOPO
29292
29293       DIMENSION EMUSAM(NCOMPX)
29294
29295       CHARACTER*13 CMSG(3)
29296       DATA CMSG /'not requested','not requested','not requested'/
29297
29298       GOTO (1,2,3,4,5) MODE
29299
29300 *------------------------------------------------------------------
29301 * initialization
29302     1 CONTINUE
29303 *  emulsion treatment
29304       IF (NCOMPO.GT.0) THEN
29305          DO 10 I=1,NCOMPX
29306             EMUSAM(I) = ZERO
29307    10    CONTINUE
29308       ENDIF
29309 * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29310       NINCGE = 0
29311       DO 11 I=1,2
29312          EXCDPM(I)   = ZERO
29313          EXCDPM(I+2) = ZERO
29314          EXCEVA(I)   = ZERO
29315          NINCWO(I)   = 0
29316          NINCEV(I)   = 0
29317          NRESTO(I)   = 0
29318          NRESPR(I)   = 0
29319          NRESNU(I)   = 0
29320          NRESBA(I)   = 0
29321          NRESPB(I)   = 0
29322          NRESCH(I)   = 0
29323          NRESEV(I)   = 0
29324          NRESEV(I+2) = 0
29325          NEVAGA(I)   = 0
29326          NEVAHT(I)   = 0
29327          NEVAFI(1,I) = 0
29328          NEVAFI(2,I) = 0
29329          DO 12 J=1,6
29330             IF (J.LE.2) NINCHR(I,J) = 0
29331             IF (J.LE.3) NINCCO(I,J) = 0
29332             IF (J.LE.4) NINCST(I,J) = 0
29333             NEVA(I,J) = 0
29334    12    CONTINUE
29335          DO 13 J=1,210
29336             NEVAHY(1,I,J) = 0
29337             NEVAHY(2,I,J) = 0
29338    13    CONTINUE
29339    11 CONTINUE
29340       MAXGEN = 0
29341 **dble Po statistics.
29342       KPOPO = 0
29343
29344       RETURN
29345 *------------------------------------------------------------------
29346 * filling of histogram with event-record
29347     2 CONTINUE
29348       IF (IST.EQ.-1) THEN
29349          IF (.NOT.LFRAG) THEN
29350             IF (IDPDG.EQ.2212) THEN
29351                NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29352             ELSEIF (IDPDG.EQ.2112) THEN
29353                NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29354             ELSEIF (IDPDG.EQ.22) THEN
29355                NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29356             ELSEIF (IDPDG.EQ.80000) THEN
29357                IF (IDBJT.EQ.116) THEN
29358                   NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29359                ELSEIF (IDBJT.EQ.117) THEN
29360                   NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29361                ELSEIF (IDBJT.EQ.118) THEN
29362                   NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29363                ELSEIF (IDBJT.EQ.119) THEN
29364                   NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29365                ENDIF
29366             ENDIF
29367          ELSE
29368 *   heavy fragments (here: fission products only)
29369             NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29370             NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29371             NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29372          ENDIF
29373       ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29374          IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29375       ENDIF
29376
29377       RETURN
29378 *------------------------------------------------------------------
29379 * output
29380     3 CONTINUE
29381
29382 **dble Po statistics.
29383 C     WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29384 C    &   '# evts. / # dble-Po. evts / s_in / s_popo :',
29385 C    & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29386
29387 *  emulsion treatment
29388       IF (NCOMPO.GT.0) THEN
29389          WRITE(LOUT,3000)
29390  3000    FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29391      &          22X,'----------------------------',/,/,19X,
29392      &          'mass    charge          fraction',/,39X,
29393      &          'input     treated',/)
29394          DO 30 I=1,NCOMPO
29395             WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29396      &                       EMUSAM(I)/DBLE(ICEVT)
29397  3013       FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29398    30    CONTINUE
29399       ENDIF
29400
29401 *  i.n.c. statistics: output
29402       WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29403  3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29404      &       22X,'---------------------------------',/,/,1X,
29405      &       'no. of events for normalization: (accepted final events,',
29406      &       ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29407      &       /,1X,'no. of rejected events due to intranuclear',
29408      &       ' cascade',15X,I6,/)
29409       ICEV  = MAX(ICEVT,1)
29410       ICEV1 = ICEV
29411       IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29412       WRITE(LOUT,3002)
29413      &     (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29414      &     ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29415      &     KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29416      &    (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29417      &     (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29418      &     (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29419      &     (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29420  3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29421      &       5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29422      &       ' proj./ target (mean per evt)',/,8X,'baryons:  pos. ',
29423      &       F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,/,8X,
29424      &       'mesons:   pos. ',F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,
29425      &       /,1X,'maximum no. of generations treated (maximum allowed:'
29426      &       ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29427      &       ' interactions in proj./ target (mean per evt1)',
29428      &       F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29429      &       ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29430      &       'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29431      &       '(ap, K-, pi- only)     ',F7.3,' /',F7.3,/)
29432       WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29433      &                 IREXCI(1)+IREXCI(2)+IREXCI(3)
29434  3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29435      &       'evaporation',/,22X,'-----------------------------',
29436      &       '------------',/,/,1X,'no. of events for normal.: ',
29437      &       '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29438      &       ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29439      &       ' rejected events     (',I4,',',I4,',',I4,')',22X,I6,/)
29440
29441       WRITE(LOUT,3004)
29442  3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29443       ICEV  = MAX(NRESEV(2),1)
29444       WRITE(LOUT,3005)
29445      &     (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29446      &     (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29447      &     (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29448      &     (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29449      &     (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29450      &     (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29451      &     (EXCDPM(I)/DBLE(ICEV),I=1,2),
29452      &     (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29453  3005    FORMAT(1X,'residual nuclei:  (mean values per evt)',12X,
29454      &       'proj. / target',/,/,8X,'total number of particles',15X,
29455      &       2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29456      &       'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29457      &       'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29458      &       /,8X,'excitation energy (bef. evap.-step)   ',2E11.3,/,
29459      &       8X,'excitation energy per nucleon         ',2E11.3,/,/)
29460
29461 * evaporation / fission / fragmentation statistics: output
29462       ICEV  = MAX(NRESEV(2),1)
29463       ICEV1 = MAX(NRESEV(4),1)
29464       NTEVA1 =
29465      &   NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29466       NTEVA2 =
29467      &   NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29468       IF (LEVPRT) THEN
29469          IF (IFISS.EQ.1) CMSG(1) = 'requested    '
29470          IF (LFRMBK)     CMSG(2) = 'requested    '
29471          IF (LDEEXG)     CMSG(3) = 'requested    '
29472          WRITE(LOUT,3006)
29473      &        CMSG,
29474      &        DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29475      &        (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29476      &        (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29477      &        (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29478      &        (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29479      &        (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29480      &        (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29481      &        (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29482      &        (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29483  3006    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,'Fission:',
29484      &       13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29485      &       'deexcitation:',2X,A13,/,/,
29486      &       1X,'evaporation/deexcitation:  (mean values per evt1)  ',
29487      &       'proj. / target',/,/,8X,'total number of evap. particles',
29488      &       9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29489      &       'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29490      &       '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29491      &       2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29492      &       'heavy fragments',25X,2F9.3,/)
29493          IF (IFISS.EQ.1) THEN
29494             WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29495      &                       NEVAFI(2,1),NEVAFI(2,2),
29496      &             DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29497      &             DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29498  3007       FORMAT(1X,'Fission:   total number of events',14X,2I9,/
29499      &             12X,'out of which fission occured',8X,2I9,/,
29500      &             50X,'(',F5.2,'%) (',F5.2,'%)',/)
29501          ENDIF
29502 C        IF ((LFRMBK).OR.(IFISS.EQ.1)) THEN
29503 C           WRITE(LOUT,3008)
29504 C3008       FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29505 C    &             '       proj.   / target',/)
29506 C           DO 31 I=1,210
29507 C              IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29508 C                 WRITE(LOUT,3009) I,
29509 C    &            (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29510 C3009             FORMAT(38X,I3,3X,2E12.3)
29511 C              ENDIF
29512 C  31       CONTINUE
29513 C           WRITE(LOUT,3010)
29514 C3010       FORMAT(1X,'heavy fragments - statistics:',7X,'mass  ',
29515 C    &             '       proj.   / target',/)
29516 C           DO 32 I=1,210
29517 C              IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29518 C                 WRITE(LOUT,3011) I,
29519 C    &            (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29520 C3011             FORMAT(38X,I3,3X,2E12.3)
29521 C              ENDIF
29522 C  32       CONTINUE
29523 C           WRITE(LOUT,*)
29524 C        ENDIF
29525       ELSE
29526          WRITE(LOUT,3012)
29527  3012    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,
29528      &       'Evaporation:         not requested',/)
29529       ENDIF
29530
29531       RETURN
29532 *------------------------------------------------------------------
29533 * filling of histogram with event-record
29534     4 CONTINUE
29535 *  emulsion treatment
29536       IF (NCOMPO.GT.0) THEN
29537          DO 40 I=1,NCOMPO
29538             IF (IT.EQ.IEMUMA(I)) THEN
29539                EMUSAM(I) = EMUSAM(I)+ONE
29540             ENDIF
29541    40    CONTINUE
29542       ENDIF
29543       NINCGE = NINCGE+MAXGEN
29544       MAXGEN = 0
29545 **dble Po statistics.
29546       IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29547
29548       RETURN
29549 *------------------------------------------------------------------
29550 * filling of histogram with event-record
29551     5 CONTINUE
29552       IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29553          IB = IIBAR(IDBAM(IDX))
29554          IC = IICH(IDBAM(IDX))
29555          J  = ISTHKK(IDX)-14
29556          IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29557             NINCST(J,1) = NINCST(J,1)+1
29558          ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29559             NINCST(J,2) = NINCST(J,2)+1
29560          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29561             NINCST(J,3) = NINCST(J,3)+1
29562          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29563             NINCST(J,4) = NINCST(J,4)+1
29564          ENDIF
29565       ELSEIF (ISTHKK(IDX).EQ.17) THEN
29566          NINCWO(1) = NINCWO(1)+1
29567       ELSEIF (ISTHKK(IDX).EQ.18) THEN
29568          NINCWO(2) = NINCWO(2)+1
29569       ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29570          IB = IDRES(IDX)
29571          IC = IDXRES(IDX)
29572          IF (IC.GT.0) THEN
29573             NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29574             NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29575          ENDIF
29576          NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29577       ENDIF
29578
29579       RETURN
29580       END
29581
29582 *$ CREATE DT_NEWHGR.FOR
29583 *COPY DT_NEWHGR
29584 *
29585 *===newhgr=============================================================*
29586 *
29587       SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29588
29589 ************************************************************************
29590 *                                                                      *
29591 *     Histogram initialization.                                        *
29592 *                                                                      *
29593 *     input:  XLIM1/XLIM2  lower/upper edge of histogram-window        *
29594 *             XLIM3        bin size                                    *
29595 *             IBIN    > 0  number of bins in equidistant lin. binning  *
29596 *                     = -1 reset histograms                            *
29597 *                     < -1 |IBIN| number of bins in equidistant log.   *
29598 *                          binning or log. binning in user def. struc. *
29599 *             XLIMB(*)     user defined bin structure                  *
29600 *                                                                      *
29601 *     The bin structure is sensitive to                                *
29602 *             XLIM1, XLIM3, IBIN     if     XLIM3 > 0   (lin.)         *
29603 *             XLIM1, XLIM2, IBIN     if     XLIM3 = 0   (lin. & log.)  *
29604 *             XLIMB, IBIN            if     XLIM3 < 0                  *
29605 *                                                                      *
29606 *                                                                      *
29607 *     output: IREFN        histogram index                             *
29608 *                          (= -1 for inconsistent histogr. request)    *
29609 *                                                                      *
29610 * This subroutine is based on a original version by R. Engel.          *
29611 * This version dated 22.4.95 is written  by S. Roesler.                *
29612 ************************************************************************
29613
29614       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29615       SAVE
29616       PARAMETER ( LINP = 10 ,
29617      &            LOUT = 6 ,
29618      &            LDAT = 9 )
29619
29620       LOGICAL LSTART
29621
29622       PARAMETER (ZERO   =  0.0D0,
29623      &           TINY   =  1.0D-10)
29624
29625       DIMENSION XLIMB(*)
29626
29627 * histograms
29628       PARAMETER (NHIS=150, NDIM=250)
29629       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29630      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29631 * auxiliary common for histograms
29632       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29633
29634       DATA LSTART /.TRUE./
29635
29636 * reset histogram counter
29637       IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29638          IHISL  = 0
29639          IF (IBIN.EQ.-1) RETURN
29640          LSTART = .FALSE.
29641       ENDIF
29642
29643       IHIS  = IHISL+1
29644 * check for maximum number of allowed histograms
29645       IF (IHIS.GT.NHIS) THEN
29646          WRITE(LOUT,1003) IHIS,NHIS,IHIS
29647  1003    FORMAT(1X,'NEWHGR:   warning!  number of histograms (',
29648      &          I4,') exceeds array size (',I4,')',/,21X,
29649      &          'histogram',I3,' skipped!')
29650          GOTO 9999
29651       ENDIF
29652
29653       IREFN = IHIS
29654       IBINS(IHIS) = ABS(IBIN)
29655 * check requested number of bins
29656       IF (IBINS(IHIS).GE.NDIM) THEN
29657          WRITE(LOUT,1000) IBIN,NDIM,NDIM
29658  1000    FORMAT(1X,'NEWHGR:   warning!  number of bins (',
29659      &          I3,') exceeds array size (',I3,')',/,21X,
29660      &          'and will be reset to ',I3)
29661          IBINS(IHIS) = NDIM
29662       ENDIF
29663       IF (IBINS(IHIS).EQ.0) THEN
29664          WRITE(LOUT,1001) IBIN,IHIS
29665  1001    FORMAT(1X,'NEWHGR:   warning!  inconsistent number of',
29666      &          ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29667          GOTO 9999
29668       ENDIF
29669
29670 * initialize arrays
29671       DO 1 I=1,NDIM
29672          DO 2 K=1,3
29673             HIST(K,IHIS,I)   = ZERO
29674             HIST(K+3,IHIS,I) = ZERO
29675             TMPHIS(K,IHIS,I) = ZERO
29676     2    CONTINUE
29677          HIST(7,IHIS,I)   = ZERO
29678     1 CONTINUE
29679       DENTRY(1,IHIS)= ZERO
29680       DENTRY(2,IHIS)= ZERO
29681       OVERF(IHIS)   = ZERO
29682       UNDERF(IHIS)  = ZERO
29683       TMPUFL(IHIS)  = ZERO
29684       TMPOFL(IHIS)  = ZERO
29685
29686 * bin str. sensitive to lower edge, bin size, and numb. of bins
29687       IF (XLIM3.GT.ZERO) THEN
29688          DO 3 K=1,IBINS(IHIS)+1
29689             HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29690     3    CONTINUE
29691          ISWI(IHIS) = 1
29692 * bin str. sensitive to lower/upper edge and numb. of bins
29693       ELSEIF (XLIM3.EQ.ZERO) THEN
29694 *   linear binning
29695          IF (IBIN.GT.0) THEN
29696             XLOW = XLIM1
29697             XHI  = XLIM2
29698             IF (XLIM2.LE.XLIM1) THEN
29699                WRITE(LOUT,1002) XLIM1,XLIM2
29700  1002          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
29701      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29702                GOTO 9999
29703             ENDIF
29704             ISWI(IHIS) = 1
29705          ELSEIF (IBIN.LT.-1) THEN
29706 *   logarithmic binning
29707             IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29708                WRITE(LOUT,1004) XLIM1,XLIM2
29709  1004          FORMAT(1X,'NEWHGR:   warning!  inconsistent log. ',
29710      &                'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29711                GOTO 9999
29712             ENDIF
29713             IF (XLIM2.LE.XLIM1) THEN
29714                WRITE(LOUT,1005) XLIM1,XLIM2
29715  1005          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
29716      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29717                GOTO 9999
29718             ENDIF
29719             XLOW = LOG10(XLIM1)
29720             XHI  = LOG10(XLIM2)
29721             ISWI(IHIS) = 3
29722          ENDIF
29723          DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29724          DO 4 K=1,IBINS(IHIS)+1
29725             HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29726     4    CONTINUE
29727       ELSE
29728 * user defined bin structure
29729          DO 5 K=1,IBINS(IHIS)+1
29730             IF (IBIN.GT.0) THEN
29731                HIST(1,IHIS,K) = XLIMB(K)
29732                ISWI(IHIS) = 2
29733             ELSEIF (IBIN.LT.-1) THEN
29734                HIST(1,IHIS,K) = LOG10(XLIMB(K))
29735                ISWI(IHIS) = 4
29736             ENDIF
29737     5    CONTINUE
29738       ENDIF
29739
29740 * histogram accepted
29741       IHISL = IHIS
29742
29743       RETURN
29744
29745  9999 CONTINUE
29746       IREFN = -1
29747       RETURN
29748       END
29749
29750 *$ CREATE DT_FILHGR.FOR
29751 *COPY DT_FILHGR
29752 *
29753 *===filhgr=============================================================*
29754 *
29755       SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29756
29757 ************************************************************************
29758 *                                                                      *
29759 *     Scoring for histogram IHIS.                                      *
29760 *                                                                      *
29761 * This subroutine is based on a original version by R. Engel.          *
29762 * This version dated 23.4.95 is written  by S. Roesler.                *
29763 ************************************************************************
29764
29765       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29766       SAVE
29767       PARAMETER ( LINP = 10 ,
29768      &            LOUT = 6 ,
29769      &            LDAT = 9 )
29770
29771       PARAMETER (ZERO = 0.0D0,
29772      &           ONE  = 1.0D0,
29773      &           TINY = 1.0D-10)
29774
29775 * histograms
29776       PARAMETER (NHIS=150, NDIM=250)
29777       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29778      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29779 * auxiliary common for histograms
29780       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29781
29782       DATA NCEVT /1/
29783
29784       X = XI
29785       Y = YI
29786
29787 * dump content of temorary arrays into histograms
29788       IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29789          CALL DT_EVTHIS(IDUM)
29790          NCEVT = NEVT
29791       ENDIF
29792
29793 * check histogram index
29794       IF (IHIS.EQ.-1) RETURN
29795       IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29796 C        WRITE(LOUT,1000) IHIS,IHISL
29797  1000    FORMAT(1X,'FILHGR:   warning!  histogram index',I4,
29798      &          ' out of range (1..',I3,')')
29799          RETURN
29800       ENDIF
29801
29802       IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29803 * bin structure not explicitly given
29804          IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29805          DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29806          IF (X.LT.HIST(1,IHIS,1)) THEN
29807             I1 = 0
29808          ELSE
29809             I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29810          ENDIF
29811
29812       ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29813 * user defined bin structure
29814          IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29815          IF (X.LT.HIST(1,IHIS,1)) THEN
29816             I1 = 0
29817          ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29818             I1 = IBINS(IHIS)+1
29819          ELSE
29820 *   binary sort algorithm
29821             KMIN = 0
29822             KMAX = IBINS(IHIS)+1
29823     1       CONTINUE
29824             IF ((KMAX-KMIN).EQ.1) GOTO 2
29825             KK = (KMAX+KMIN)/2
29826             IF (X.LE.HIST(1,IHIS,KK)) THEN
29827                KMAX=KK
29828             ELSE
29829                KMIN=KK
29830             ENDIF
29831             GOTO 1
29832     2       CONTINUE
29833             I1 = KMIN
29834          ENDIF
29835
29836       ELSE
29837          WRITE(LOUT,1001)
29838  1001    FORMAT(1X,'FILHGR:   warning!  histogram not initialized')
29839          RETURN
29840       ENDIF
29841
29842 * scoring
29843       IF (I1.LE.0) THEN
29844          TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29845       ELSEIF (I1.LE.IBINS(IHIS)) THEN
29846          TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29847          IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29848             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29849          ELSE
29850             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29851          ENDIF
29852          TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29853       ELSE
29854          TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29855       ENDIF
29856
29857       RETURN
29858       END
29859
29860 *$ CREATE DT_EVTHIS.FOR
29861 *COPY DT_EVTHIS
29862 *
29863 *===evthis=============================================================*
29864 *
29865       SUBROUTINE DT_EVTHIS(NEVT)
29866
29867 ************************************************************************
29868 * Dump content of temorary histograms into /DTHIS1/. This subroutine   *
29869 * is called after each event and for the last event before any call    *
29870 * to OUTHGR.                                                           *
29871 *         NEVT   number of events dumped, this is only needed to       *
29872 *                get the normalization after the last event            *
29873 * This version dated 23.4.95 is written  by S. Roesler.                *
29874 ************************************************************************
29875
29876       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29877       SAVE
29878       PARAMETER ( LINP = 10 ,
29879      &            LOUT = 6 ,
29880      &            LDAT = 9 )
29881
29882       LOGICAL LNOETY
29883
29884       PARAMETER (ZERO = 0.0D0,
29885      &           ONE  = 1.0D0,
29886      &           TINY = 1.0D-10)
29887
29888 * histograms
29889       PARAMETER (NHIS=150, NDIM=250)
29890       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29891      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29892 * auxiliary common for histograms
29893       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29894
29895       DATA NCEVT /0/
29896
29897       NCEVT = NCEVT+1
29898       NEVT  = NCEVT
29899
29900       DO 1 I=1,IHISL
29901          LNOETY = .TRUE.
29902          DO 2 J=1,IBINS(I)
29903             IF (TMPHIS(1,I,J).GT.ZERO) THEN
29904                LNOETY = .FALSE.
29905                HIST(2,I,J)   = HIST(2,I,J)+ONE
29906                HIST(7,I,J)   = HIST(7,I,J)+TMPHIS(1,I,J)
29907                DENTRY(2,I)   = DENTRY(2,I)+TMPHIS(1,I,J)
29908                AVX           = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29909                HIST(3,I,J)   = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29910                HIST(4,I,J)   = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29911                HIST(5,I,J)   = HIST(5,I,J)+TMPHIS(3,I,J)
29912                HIST(6,I,J)   = HIST(6,I,J)+TMPHIS(3,I,J)**2
29913                TMPHIS(1,I,J) = ZERO
29914                TMPHIS(2,I,J) = ZERO
29915                TMPHIS(3,I,J) = ZERO
29916             ENDIF
29917     2    CONTINUE
29918          IF (LNOETY) THEN
29919             IF (TMPUFL(I).GT.ZERO) THEN
29920                UNDERF(I) = UNDERF(I)+ONE
29921                TMPUFL(I) = ZERO
29922             ELSEIF (TMPOFL(I).GT.ZERO) THEN
29923                OVERF(I)  = OVERF(I)+ONE
29924                TMPOFL(I) = ZERO
29925             ENDIF
29926          ELSE
29927             DENTRY(1,I) = DENTRY(1,I)+ONE
29928          ENDIF
29929     1 CONTINUE
29930
29931       RETURN
29932       END
29933
29934 *$ CREATE DT_OUTHGR.FOR
29935 *COPY DT_OUTHGR
29936 *
29937 *===outhgr=============================================================*
29938 *
29939       SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29940      &                  ILOGY,INORM,NMODE)
29941
29942 ************************************************************************
29943 *                                                                      *
29944 *     Plot histogram(s) to standard output unit                        *
29945 *                                                                      *
29946 *         I1..6         indices of histograms to be plotted            *
29947 *         CHEAD,IHEAD   header string,integer                          *
29948 *         NEVTS         number of events                               *
29949 *         FAC           scaling factor                                 *
29950 *         ILOGY   = 1   logarithmic y-axis                             *
29951 *         INORM         normalization                                  *
29952 *                 = 0   no further normalization (FAC is obsolete)     *
29953 *                 = 1   per event and bin width                        *
29954 *                 = 2   per entry and bin width                        *
29955 *                 = 3   per bin entry                                  *
29956 *                 = 4   per event and "bin width" x1^2...x2^2          *
29957 *                 = 5   per event and "log. bin width" ln x1..ln x2    *
29958 *                 = 6   per event                                      *
29959 *         MODE    = 0   no output but normalization applied            *
29960 *                 = 1   all valid histograms separately (small frame)  *
29961 *                       all valid histograms separately (small frame)  *
29962 *                 = -1  and tables as histograms                       *
29963 *                 = 2   all valid histograms (one plot, wide frame)    *
29964 *                       all valid histograms (one plot, wide frame)    *
29965 *                 = -2  and tables as histograms                       *
29966 *                                                                      *
29967 *                                                                      *
29968 *     Note: All histograms to be plotted with one call to this         *
29969 *           subroutine and |MODE|=2 must have the same bin structure!  *
29970 *           There is no test included ensuring this fact.              *
29971 *                                                                      *
29972 * This version dated 23.4.95 is written  by S. Roesler.                *
29973 ************************************************************************
29974
29975       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29976       SAVE
29977       PARAMETER ( LINP = 10 ,
29978      &            LOUT = 6 ,
29979      &            LDAT = 9 )
29980
29981       CHARACTER*72 CHEAD
29982
29983       PARAMETER (ZERO   =  0.0D0,
29984      &           IZERO  =  0,
29985      &           ONE    =  1.0D0,
29986      &           TWO    =  2.0D0,
29987      &           OHALF  =  0.5D0,
29988      &           EPS    =  1.0D-5,
29989      &           TINY   =  1.0D-8,
29990      &           SMALL  =  -1.0D8,
29991      &           RLARGE =  1.0D8 )
29992
29993 * histograms
29994       PARAMETER (NHIS=150, NDIM=250)
29995       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29996      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29997
29998       PARAMETER (NDIM2 = 2*NDIM)
29999       DIMENSION XX(NDIM2),YY(NDIM2)
30000
30001       PARAMETER (NHISTO = 6)
30002       DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
30003      &          IDX(NHISTO)
30004
30005       CHARACTER*43 CNORM(0:8)
30006       DATA CNORM /'no further normalization                   ',
30007      &            'per event and bin width                    ',
30008      &            'per entry1 and bin width                   ',
30009      &            'per bin entry                              ',
30010      &            'per event and "bin width" x1^2...x2^2      ',
30011      &            'per event and "log. bin width" ln x1..ln x2',
30012      &            'per event                                  ',
30013      &            'per bin entry1                             ',
30014      &            'per entry2 and bin width                   '/
30015
30016       IDX1(1) = I1
30017       IDX1(2) = I2
30018       IDX1(3) = I3
30019       IDX1(4) = I4
30020       IDX1(5) = I5
30021       IDX1(6) = I6
30022
30023       MODE = NMODE
30024
30025 * initialization if "wide frame" is requested
30026       IF (ABS(MODE).EQ.2) THEN
30027          DO 1 I=1,NHISTO
30028             DO 2 J=1,NDIM
30029                XX1(J,I) = ZERO
30030                YY1(J,I) = ZERO
30031     2       CONTINUE
30032     1    CONTINUE
30033       ENDIF
30034
30035 * plot header
30036       WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
30037
30038 * check histogram indices
30039       NHI = 0
30040       DO 3 I=1,NHISTO
30041          IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
30042             IF (ISWI(IDX1(I)).NE.0) THEN
30043                IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
30044                   WRITE(LOUT,1000)
30045      &                 IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
30046  1000             FORMAT(/,1X,'OUTHGR:   warning!  no entries in',
30047      &                   ' histogram ',I3,/,21X,'underflows:',F10.0,
30048      &                   '   overflows:  ',F10.0)
30049                ELSE
30050                   NHI = NHI+1
30051                   IDX(NHI) = IDX1(I)
30052                ENDIF
30053             ENDIF
30054          ENDIF
30055     3 CONTINUE
30056       IF (NHI.EQ.0) THEN
30057          WRITE(LOUT,1001)
30058  1001    FORMAT(/,1X,'OUTHGR:   warning!  histogram indices not valid')
30059          RETURN
30060       ENDIF
30061
30062 * check normalization request
30063       IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30064      &     ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30065      &                        (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30066      &     (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30067          WRITE(LOUT,1002) NEVTS,INORM,FAC
30068  1002    FORMAT(/,1X,'OUTHGR:   warning!  normalization request not ',
30069      &          'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30070      &          'FAC = ',E11.4)
30071          RETURN
30072       ENDIF
30073
30074       WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30075
30076 * apply normalization
30077       DO 4 N=1,NHI
30078
30079          I = IDX(N)
30080
30081          IF (ISWI(I).EQ.1) THEN
30082             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30083  1003       FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30084      &             ' to',2X,E10.4,',',2X,I3,' bins')
30085          ELSEIF (ISWI(I).EQ.2) THEN
30086             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30087             WRITE(LOUT,1007)
30088  1007       FORMAT(1X,'user defined bin structure')
30089          ELSEIF (ISWI(I).EQ.3) THEN
30090             WRITE(LOUT,1004)
30091      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30092  1004       FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30093      &             ' to',2X,E10.4,',',2X,I3,' bins')
30094          ELSEIF (ISWI(I).EQ.4) THEN
30095             WRITE(LOUT,1004)
30096      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30097             WRITE(LOUT,1007)
30098          ELSE
30099             WRITE(LOUT,1008) ISWI(I)
30100  1008       FORMAT(/,1X,'warning!  inconsistent bin structure flag ',I4)
30101          ENDIF
30102          WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30103  1005    FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30104      &          ' overfl.:',F8.0)
30105          WRITE(LOUT,1009) CNORM(INORM)
30106  1009    FORMAT(1X,'normalization: ',A,/)
30107
30108          DO 5 K=1,IBINS(I)
30109             CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30110             YMEAN = FAC*YMEAN
30111             YERR  = FAC*YERR
30112             WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30113             WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30114  1006       FORMAT(1X,5E11.3)
30115 *    small frame
30116             II = 2*K
30117             XX(II-1) = HIST(1,I,K)
30118             XX(II)   = HIST(1,I,K+1)
30119             YY(II-1) = YMEAN
30120             YY(II)   = YMEAN
30121 *    wide frame
30122             XX1(K,N) = XMEAN
30123             IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30124      &         XX1(K,N) = LOG10(XMEAN)
30125             YY1(K,N) = YMEAN
30126     5    CONTINUE
30127
30128 * plot small frame
30129          IF (ABS(MODE).EQ.1) THEN
30130             IBIN2 = 2*IBINS(I)
30131             WRITE(LOUT,'(/,1X,A)') 'Preview:'
30132             IF(ILOGY.EQ.1) THEN
30133               CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30134             ELSE
30135               CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30136             ENDIF
30137          ENDIF
30138
30139     4 CONTINUE
30140
30141 * plot wide frame
30142       IF (ABS(MODE).EQ.2) THEN
30143          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30144          NSIZE = NDIM*NHISTO
30145          DXLOW = HIST(1,IDX(1),1)
30146          DDX   = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30147          YLOW  = RLARGE
30148          YHI   = SMALL
30149          DO 6 I=1,NHISTO
30150             DO 7 J=1,NDIM
30151                IF (YY1(J,I).LT.YLOW) THEN
30152                   IF (ILOGY.EQ.1) THEN
30153                      IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30154                   ELSE
30155                      YLOW = YY1(J,I)
30156                   ENDIF
30157                ENDIF
30158                IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30159     7       CONTINUE
30160     6    CONTINUE
30161          DY = (YHI-YLOW)/DBLE(NDIM)
30162          IF (DY.LE.ZERO) THEN
30163             WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30164      &         'OUTHGR:   warning! zero bin width for histograms ',
30165      &         IDX,': ',YLOW,YHI
30166             RETURN
30167          ENDIF
30168          IF (ILOGY.EQ.1) THEN
30169             YLOW = LOG10(YLOW)
30170             DY   = (LOG10(YHI)-YLOW)/100.0D0
30171             DO 8 I=1,NHISTO
30172                DO 9 J=1,NDIM
30173                   IF (YY1(J,I).LE.ZERO) THEN
30174                      YY1(J,I) = YLOW
30175                   ELSE
30176                      YY1(J,I) = LOG10(YY1(J,I))
30177                   ENDIF
30178     9          CONTINUE
30179     8       CONTINUE
30180          ENDIF
30181          CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30182       ENDIF
30183
30184       RETURN
30185       END
30186
30187 *$ CREATE DT_GETBIN.FOR
30188 *COPY DT_GETBIN
30189 *
30190 *===getbin=============================================================*
30191 *
30192       SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30193      &                  XMEAN,YMEAN,YERR)
30194
30195 ************************************************************************
30196 * This version dated 23.4.95 is written  by S. Roesler.                *
30197 ************************************************************************
30198
30199       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30200       SAVE
30201       PARAMETER ( LINP = 10 ,
30202      &            LOUT = 6 ,
30203      &            LDAT = 9 )
30204
30205       PARAMETER (ZERO   = 0.0D0,
30206      &           ONE    = 1.0D0,
30207      &           TINY35 = 1.0D-35)
30208
30209 * histograms
30210       PARAMETER (NHIS=150, NDIM=250)
30211       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30212      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30213
30214       XLOW = HIST(1,IHIS,IBIN)
30215       XHI  = HIST(1,IHIS,IBIN+1)
30216       IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30217          XLOW = 10**XLOW
30218          XHI  = 10**XHI
30219       ENDIF
30220       IF (NORM.EQ.2) THEN
30221          DX   = XHI-XLOW
30222          NEVT = INT(DENTRY(1,IHIS))
30223       ELSEIF (NORM.EQ.3) THEN
30224          DX   = ONE
30225          NEVT = INT(HIST(2,IHIS,IBIN))
30226       ELSEIF (NORM.EQ.4) THEN
30227          DX   = XHI**2-XLOW**2
30228          NEVT = KEVT
30229       ELSEIF (NORM.EQ.5) THEN
30230          DX   = LOG(ABS(XHI))-LOG(ABS(XLOW))
30231          NEVT = KEVT
30232       ELSEIF (NORM.EQ.6) THEN
30233          DX   = ONE
30234          NEVT = KEVT
30235       ELSEIF (NORM.EQ.7) THEN
30236          DX   = ONE
30237          NEVT = INT(HIST(7,IHIS,IBIN))
30238       ELSEIF (NORM.EQ.8) THEN
30239          DX   = XHI-XLOW
30240          NEVT = INT(DENTRY(2,IHIS))
30241       ELSE
30242          DX   = ABS(XHI-XLOW)
30243          NEVT = KEVT
30244       ENDIF
30245       IF (ABS(DX).LT.TINY35) DX = ONE
30246       NEVT   = MAX(NEVT,1)
30247       YMEAN  = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30248       YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30249       YERR   = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30250       YSUM   = HIST(5,IHIS,IBIN)
30251       IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30252 C     XMEAN  = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30253       XMEAN  = HIST(3,IHIS,IBIN)/YSUM
30254       IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30255
30256       RETURN
30257       END
30258
30259 *$ CREATE DT_JOIHIS.FOR
30260 *COPY DT_JOIHIS
30261 *
30262 *===joihis=============================================================*
30263 *
30264       SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30265
30266 ************************************************************************
30267 *                                                                      *
30268 *     Operation on histograms.                                         *
30269 *                                                                      *
30270 *     input:  IH1,IH2      histogram indices to be joined              *
30271 *             COPER        character defining the requested operation, *
30272 *                          i.e. '+', '-', '*', '/'                     *
30273 *             FAC1,FAC2    factors for joining, i.e.                   *
30274 *                          FAC1*histo1 COPER FAC2*histo2               *
30275 *                                                                      *
30276 * This version dated 23.4.95 is written  by S. Roesler.                *
30277 ************************************************************************
30278
30279       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30280       SAVE
30281       PARAMETER ( LINP = 10 ,
30282      &            LOUT = 6 ,
30283      &            LDAT = 9 )
30284
30285       CHARACTER COPER*1
30286
30287       PARAMETER (ZERO   =  0.0D0,
30288      &           ONE    =  1.0D0,
30289      &           OHALF  =  0.5D0,
30290      &           TINY8  =  1.0D-8,
30291      &           SMALL  =  -1.0D8,
30292      &           RLARGE =  1.0D8 )
30293
30294 * histograms
30295       PARAMETER (NHIS=150, NDIM=250)
30296       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30297      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30298
30299       PARAMETER (NDIM2 = 2*NDIM)
30300       DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30301
30302       CHARACTER*43 CNORM(0:6)
30303       DATA CNORM /'no further normalization                   ',
30304      &            'per event and bin width                    ',
30305      &            'per entry and bin width                    ',
30306      &            'per bin entry                              ',
30307      &            'per event and "bin width" x1^2...x2^2      ',
30308      &            'per event and "log. bin width" ln x1..ln x2',
30309      &            'per event                                  '/
30310
30311 * check histogram indices
30312       IF ((IH1.LT.    1).OR.(IH2.LT.    1).OR.
30313      &    (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30314          WRITE(LOUT,1000) IH1,IH2,IHISL
30315  1000    FORMAT(1X,'JOIHIS:   warning!  inconsistent histogram ',
30316      &          'indices (',I3,',',I3,'),',/,21X,'valid range:  1,',I3)
30317          GOTO 9999
30318       ENDIF
30319
30320 * check bin structure of histograms to be joined
30321       IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30322          WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30323  1001    FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
30324      &          ' and ',I3,' failed',/,21X,
30325      &          'due to different numbers of bins (',I3,',',I3,')')
30326          GOTO 9999
30327       ENDIF
30328       DO 1 K=1,IBINS(IH1)+1
30329          IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30330             WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30331  1002       FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
30332      &             ' and ',I3,' failed at bin edge ',I3,/,21X,
30333      &             'X1,X2 = ',2E11.4)
30334             GOTO 9999
30335          ENDIF
30336     1 CONTINUE
30337
30338       WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30339  1003 FORMAT(1X,'JOIHIS:   joining histograms ',I3,',',I3,' with ',
30340      &       'operation ',A,/,11X,'and factors ',2E11.4)
30341       WRITE(LOUT,1004) CNORM(NORM)
30342  1004 FORMAT(1X,'normalization: ',A,/)
30343
30344       DO 2 K=1,IBINS(IH1)
30345          CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30346          CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30347          XLOW  = XLOW1
30348          XHI   = XHI1
30349          XMEAN = OHALF*(XMEAN1+XMEAN2)
30350          IF (COPER.EQ.'+') THEN
30351             YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30352          ELSEIF (COPER.EQ.'*') THEN
30353             YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30354          ELSEIF (COPER.EQ.'/') THEN
30355             IF (YMEAN2.EQ.ZERO) THEN
30356                YMEAN = ZERO
30357             ELSE
30358                IF (FAC2.EQ.ZERO) FAC2 = ONE
30359                YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30360             ENDIF
30361          ELSE
30362             GOTO 9998
30363          ENDIF
30364          WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30365          WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30366  1006    FORMAT(1X,5E11.3)
30367 *    small frame
30368          II = 2*K
30369          XX(II-1) = HIST(1,IH1,K)
30370          XX(II)   = HIST(1,IH1,K+1)
30371          YY(II-1) = YMEAN
30372          YY(II)   = YMEAN
30373 *    wide frame
30374          XX1(K) = XMEAN
30375          IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30376          YY1(K) = YMEAN
30377     2 CONTINUE
30378
30379 * plot small frame
30380       IF (ABS(MODE).EQ.1) THEN
30381          IBIN2 = 2*IBINS(IH1)
30382          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30383          IF(ILOGY.EQ.1) THEN
30384            CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30385          ELSE
30386            CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30387          ENDIF
30388       ENDIF
30389
30390 * plot wide frame
30391       IF (ABS(MODE).EQ.2) THEN
30392          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30393          NSIZE = NDIM
30394          DXLOW = HIST(1,IH1,1)
30395          DDX   = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30396          YLOW  = RLARGE
30397          YHI   = SMALL
30398          DO 3 I=1,NDIM
30399             IF (YY1(I).LT.YLOW) THEN
30400                IF (ILOGY.EQ.1) THEN
30401                   IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30402                ELSE
30403                   YLOW = YY1(I)
30404                ENDIF
30405             ENDIF
30406             IF (YY1(I).GT.YHI) YHI = YY1(I)
30407     3    CONTINUE
30408          DY = (YHI-YLOW)/DBLE(NDIM)
30409          IF (DY.LE.ZERO) THEN
30410             WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30411      &         'JOIHIS:   warning! zero bin width for histograms ',
30412      &         IH1,IH2,': ',YLOW,YHI
30413             RETURN
30414          ENDIF
30415          IF (ILOGY.EQ.1) THEN
30416             YLOW = LOG10(YLOW)
30417             DY   = (LOG10(YHI)-YLOW)/100.0D0
30418             DO 4 I=1,NDIM
30419                IF (YY1(I).LE.ZERO) THEN
30420                   YY1(I) = YLOW
30421                ELSE
30422                   YY1(I) = LOG10(YY1(I))
30423                ENDIF
30424     4       CONTINUE
30425          ENDIF
30426          CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30427       ENDIF
30428
30429       RETURN
30430
30431  9998 CONTINUE
30432       WRITE(LOUT,1005) COPER
30433  1005 FORMAT(1X,'JOIHIS:   unknown operation ',A)
30434
30435  9999 CONTINUE
30436       RETURN
30437       END
30438
30439 *$ CREATE DT_XGRAPH.FOR
30440 *COPY DT_XGRAPH
30441 *
30442 *===qgraph=============================================================*
30443 *
30444       SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30445 C***********************************************************************
30446 C
30447 C     calculate quasi graphic picture with 25 lines and 79 columns
30448 C     ranges will be chosen automatically
30449 C
30450 C     input     N          dimension of input fields
30451 C               IARG       number of curves (fields) to plot
30452 C               X          field of X
30453 C               Y1         field of Y1
30454 C               Y2         field of Y2
30455 C
30456 C This subroutine is written by R. Engel.
30457 C***********************************************************************
30458       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30459       SAVE
30460
30461       PARAMETER ( LINP = 10 ,
30462      &            LOUT = 6 ,
30463      &            LDAT = 9 )
30464 C
30465       DIMENSION X(N),Y1(N),Y2(N)
30466       PARAMETER (EPS=1.D-30)
30467       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30468       CHARACTER SYMB(5)
30469       CHARACTER COL(0:149,0:49)
30470 C
30471       DATA SYMB /'0','e','z','#','x'/
30472 C
30473       ISPALT=IBREIT-10
30474 C
30475 C***  automatic range fitting
30476 C
30477       XMAX=X(1)
30478       XMIN=X(1)
30479       DO 600 I=1,N
30480          XMAX=MAX(X(I),XMAX)
30481          XMIN=MIN(X(I),XMIN)
30482  600  CONTINUE
30483       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30484 C
30485       ITEST=0
30486       DO 1100 K=0,IZEIL-1
30487          ITEST=ITEST+1
30488          IF (ITEST.EQ.IYRAST) THEN
30489             DO 1010 L=1,ISPALT-1
30490                COL(L,K)='-'
30491 1010        CONTINUE
30492             COL(ISPALT,K)='+'
30493             ITEST=0
30494             DO 1020 L=0,ISPALT-1,IXRAST
30495                COL(L,K)='+'
30496 1020        CONTINUE
30497          ELSE
30498             DO 1030 L=1,ISPALT-1
30499                COL(L,K)=' '
30500 1030        CONTINUE
30501             DO 1040 L=0,ISPALT-1,IXRAST
30502                COL(L,K)='|'
30503 1040        CONTINUE
30504             COL(ISPALT,K)='|'
30505          ENDIF
30506 1100  CONTINUE
30507 C
30508 C***  plot curve Y1
30509 C
30510       YMAX=Y1(1)
30511       YMIN=Y1(1)
30512       DO 500 I=1,N
30513          YMAX=MAX(Y1(I),YMAX)
30514          YMIN=MIN(Y1(I),YMIN)
30515 500   CONTINUE
30516       IF(IARG.GT.1) THEN
30517         DO 550 I=1,N
30518            YMAX=MAX(Y2(I),YMAX)
30519            YMIN=MIN(Y2(I),YMIN)
30520 550     CONTINUE
30521       ENDIF
30522       YMAX=(YMAX-YMIN)/40.0D0+YMAX
30523       YMIN=YMIN-(YMAX-YMIN)/40.0D0
30524       YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30525       IF(YZOOM.LT.EPS) THEN
30526         WRITE(LOUT,'(1X,A)')
30527      &    'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30528         RETURN
30529       ENDIF
30530 C
30531 C***  plot curve Y1
30532 C
30533       ILAST=-1
30534       LLAST=-1
30535       DO 1200 K=1,N
30536          L=NINT((X(K)-XMIN)/XZOOM)
30537          I=NINT((YMAX-Y1(K))/YZOOM)
30538          IF(ILAST.GE.0) THEN
30539            LD = L-LLAST
30540            ID = I-ILAST
30541            DO 55 II=0,LD,SIGN(1,LD)
30542              DO 66 KK=0,ID,SIGN(1,ID)
30543                COL(II+LLAST,KK+ILAST)=SYMB(1)
30544  66          CONTINUE
30545  55        CONTINUE
30546          ELSE
30547            COL(L,I)=SYMB(1)
30548          ENDIF
30549          ILAST = I
30550          LLAST = L
30551 1200  CONTINUE
30552 C
30553       IF(IARG.GT.1) THEN
30554 C
30555 C***  plot curve Y2
30556 C
30557         DO 1250 K=1,N
30558            L=NINT((X(K)-XMIN)/XZOOM)
30559            I=NINT((YMAX-Y2(K))/YZOOM)
30560            COL(L,I)=SYMB(2)
30561 1250    CONTINUE
30562       ENDIF
30563 C
30564 C***  write it
30565 C
30566       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30567 C
30568 C***  write range of X
30569 C
30570       XZOOM = (XMAX-XMIN)/DBLE(7)
30571       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30572 C
30573       DO 1300 K=0,IZEIL-1
30574          YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30575          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30576  110     FORMAT(1X,1PE9.2,70A1)
30577 1300  CONTINUE
30578 C
30579 C***  write range of X
30580 C
30581       XZOOM = (XMAX-XMIN)/DBLE(7)
30582       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30583       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30584  120  FORMAT(6X,7(1PE10.3))
30585       END
30586
30587 *$ CREATE DT_XGLOGY.FOR
30588 *COPY DT_XGLOGY
30589 *
30590 *===qglogy=============================================================*
30591 *
30592       SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30593 C***********************************************************************
30594 C
30595 C     calculate quasi graphic picture with 25 lines and 79 columns
30596 C     logarithmic y axis
30597 C     ranges will be chosen automatically
30598 C
30599 C     input     N          dimension of input fields
30600 C               IARG       number of curves (fields) to plot
30601 C               X          field of X
30602 C               Y1         field of Y1
30603 C               Y2         field of Y2
30604 C
30605 C This subroutine is written by R. Engel.
30606 C***********************************************************************
30607 C
30608       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30609       SAVE
30610
30611       PARAMETER ( LINP = 10 ,
30612      &            LOUT = 6 ,
30613      &            LDAT = 9 )
30614       DIMENSION X(N),Y1(N),Y2(N)
30615       PARAMETER (EPS=1.D-30)
30616       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30617       CHARACTER SYMB(5)
30618       CHARACTER COL(0:149,0:49)
30619       PARAMETER (DEPS = 1.D-10)
30620 C
30621       DATA SYMB /'0','e','z','#','x'/
30622 C
30623       ISPALT=IBREIT-10
30624 C
30625 C***  automatic range fitting
30626 C
30627       XMAX=X(1)
30628       XMIN=X(1)
30629       DO 600 I=1,N
30630          XMAX=MAX(X(I),XMAX)
30631          XMIN=MIN(X(I),XMIN)
30632  600  CONTINUE
30633       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30634 C
30635       ITEST=0
30636       DO 1100 K=0,IZEIL-1
30637          ITEST=ITEST+1
30638          IF (ITEST.EQ.IYRAST) THEN
30639             DO 1010 L=1,ISPALT-1
30640                COL(L,K)='-'
30641 1010        CONTINUE
30642             COL(ISPALT,K)='+'
30643             ITEST=0
30644             DO 1020 L=0,ISPALT-1,IXRAST
30645                COL(L,K)='+'
30646 1020        CONTINUE
30647          ELSE
30648             DO 1030 L=1,ISPALT-1
30649                COL(L,K)=' '
30650 1030        CONTINUE
30651             DO 1040 L=0,ISPALT-1,IXRAST
30652                COL(L,K)='|'
30653 1040        CONTINUE
30654             COL(ISPALT,K)='|'
30655          ENDIF
30656 1100  CONTINUE
30657 C
30658 C***  plot curve Y1
30659 C
30660       YMAX=Y1(1)
30661       YMIN=MAX(Y1(1),EPS)
30662       DO 500 I=1,N
30663          YMAX =MAX(Y1(I),YMAX)
30664          IF(Y1(I).GT.EPS) THEN
30665            IF(YMIN.EQ.EPS) THEN
30666              YMIN = Y1(I)/10.D0
30667            ELSE
30668              YMIN = MIN(Y1(I),YMIN)
30669            ENDIF
30670          ENDIF
30671 500   CONTINUE
30672       IF(IARG.GT.1) THEN
30673         DO 550 I=1,N
30674            YMAX=MAX(Y2(I),YMAX)
30675            IF(Y2(I).GT.EPS) THEN
30676              IF(YMIN.EQ.EPS) THEN
30677                YMIN = Y2(I)
30678              ELSE
30679                YMIN = MIN(Y2(I),YMIN)
30680              ENDIF
30681            ENDIF
30682 550     CONTINUE
30683       ENDIF
30684 C
30685       DO 560 I=1,N
30686         Y1(I) = MAX(Y1(I),YMIN)
30687  560  CONTINUE
30688       IF(IARG.GT.1) THEN
30689         DO 570 I=1,N
30690           Y2(I) = MAX(Y2(I),YMIN)
30691  570    CONTINUE
30692       ENDIF
30693 C
30694       IF(YMAX.LE.YMIN) THEN
30695         WRITE(LOUT,'(/1X,A,2E12.3,/)')
30696      &     'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30697         WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30698         RETURN
30699       ENDIF
30700 C
30701       YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30702       YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30703       YZOOM=(YMA-YMI)/DBLE(IZEIL)
30704       IF(YZOOM.LT.EPS) THEN
30705         WRITE(LOUT,'(1X,A)')
30706      &    'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30707         RETURN
30708       ENDIF
30709 C
30710 C***  plot curve Y1
30711 C
30712       ILAST=-1
30713       LLAST=-1
30714       DO 1200 K=1,N
30715          L=NINT((X(K)-XMIN)/XZOOM)
30716          I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30717          IF(ILAST.GE.0) THEN
30718            LD = L-LLAST
30719            ID = I-ILAST
30720            DO 55 II=0,LD,SIGN(1,LD)
30721              DO 66 KK=0,ID,SIGN(1,ID)
30722                COL(II+LLAST,KK+ILAST)=SYMB(1)
30723  66          CONTINUE
30724  55        CONTINUE
30725          ELSE
30726            COL(L,I)=SYMB(1)
30727          ENDIF
30728          ILAST = I
30729          LLAST = L
30730 1200  CONTINUE
30731 C
30732       IF(IARG.GT.1) THEN
30733 C
30734 C***  plot curve Y2
30735 C
30736         DO 1250 K=1,N
30737            L=NINT((X(K)-XMIN)/XZOOM)
30738            I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30739            COL(L,I)=SYMB(2)
30740 1250    CONTINUE
30741       ENDIF
30742 C
30743 C***  write it
30744 C
30745       WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30746       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30747 C
30748 C***  write range of X
30749 C
30750       XZOOM1 = (XMAX-XMIN)/DBLE(7)
30751       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30752 C
30753       DO 1300 K=0,IZEIL-1
30754          YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30755          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30756  110     FORMAT(1X,1PE9.2,70A1)
30757 1300  CONTINUE
30758 C
30759 C***  write range of X
30760 C
30761       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30762       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30763  120  FORMAT(6X,7(1PE10.3))
30764 C
30765       END
30766
30767 *$ CREATE DT_SRPLOT.FOR
30768 *COPY DT_SRPLOT
30769 *
30770 *===plot===============================================================*
30771 *
30772       SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30773
30774       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30775       SAVE
30776
30777       PARAMETER ( LINP = 10 ,
30778      &            LOUT = 6 ,
30779      &            LDAT = 9 )
30780 *
30781 *     initial version
30782 *     J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30783 *     This is a subroutine of fluka to plot Y across the page
30784 *     as a function of X down the page. Up to 37 curves can be
30785 *     plotted in the same picture with different plotting characters.
30786 *     Output of first 10 overprinted characters addad by FB 88
30787 *  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30788 *
30789 *     Input Variables:
30790 *        X   = array containing the values of X
30791 *        Y   = array containing the values of Y
30792 *        N   = number of values in X and in Y
30793 *              can exceed the fixed number of lines
30794 *        M   = number of different curves X,Y are containing
30795 *        MM  = number of points in each curve i.e. N=M*MM
30796 *        XO  = smallest value of X to be plotted
30797 *        DX  = increment of X between subsequent lines
30798 *        YO  = smallest value of Y to be plotted
30799 *        DY  = increment of Y between subsequent character spaces
30800 *
30801 *        other variables used inside:
30802 *        XX  = numbers along the X-coordinate axis
30803 *        YY  = numbers along the Y-coordinate axis
30804 *        LL  = ten lines temporary storage for the plot
30805 *        L   = character set used to plot different curves
30806 *        LOV = memorizes overprinted symbols
30807 *              the first 10 overprinted symbols are printed on
30808 *              the end of the line to avoid ambiguities
30809 *              (added by FB as considered quite helpful)
30810 *
30811 *********************************************************************
30812 *
30813       DIMENSION XX(61),YY(61),LL(101,10)
30814       DIMENSION X(N),Y(N),L(40),LOV(40,10)
30815       DATA  L/
30816      11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30817      21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30818      31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30819      41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H  /
30820 *
30821 *
30822       MN=51
30823       DO 10 I=1,MN
30824         AI=I-1
30825    10 XX(I)=XO+AI*DX
30826       DO 20 I=1,11
30827         AI=I-1
30828    20 YY(I)=YO+10.0D0*AI*DY
30829       WRITE(LOUT, 500) (YY(I),I=1,11)
30830       MMN=MN-1
30831 *
30832 *
30833       DO 90 JJ=1,MMN,10
30834         JJJ=JJ-1
30835         DO 30 I=1,101
30836           DO 30 J=1,10
30837    30   LL(I,J)=L(40)
30838         DO 40 I=1,101
30839    40   LL(I,1)=L(39)
30840         DO 50 I=1,101,10
30841           DO 50 J=1,10
30842    50   LL(I,J)=L(38)
30843         DO 60 I=1,40
30844           DO 60 J=1,10
30845    60   LOV(I,J)=L(40)
30846 *
30847 *
30848         DO 70 I=1,M
30849           DO 70 J=1,MM
30850             II=J+(I-1)*MM
30851             AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30852             AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30853             AIX=AIX-DBLE(JJJ)
30854 *           changed Sept.88 by FB to avoid INTEGER OVERFLOW
30855             IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30856      +      . AIY .LT. 102.D0) THEN
30857               IX=INT(AIX)
30858               IY=INT(AIY)
30859               IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30860      +        THEN
30861                 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30862      +          =LL(IY,IX)
30863                 LL(IY,IX)=L(I)
30864               ENDIF
30865             ENDIF
30866    70   CONTINUE
30867 *
30868 *
30869         DO 80 I=1,10
30870           II=I+JJJ
30871           III=II+1
30872           WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30873      &                    (LOV(J,I),J=1,10)
30874    80   CONTINUE
30875    90 CONTINUE
30876 *
30877 *
30878       WRITE(LOUT, 520)
30879       WRITE(LOUT, 500) (YY(I),I=1,11)
30880       RETURN
30881 *
30882   500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30883   510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30884   520 FORMAT(20X,10('1---------'),'1')
30885       END
30886
30887 *$ CREATE DT_DEFSET.FOR
30888 *COPY DT_DEFSET
30889 *
30890 *===defset=============================================================*
30891 *
30892       BLOCK DATA DT_DEFSET
30893
30894       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30895       SAVE
30896
30897 * flags for input different options
30898       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30899       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30900      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30901       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30902 * emulsion treatment
30903       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30904      &                NCOMPO,IEMUL
30905
30906 * / DTFLG1 /
30907       DATA IFRAG  / 2, 1 /
30908       DATA IRESCO / 1 /
30909       DATA IMSHL  / 1 /
30910       DATA IRESRJ / 0 /
30911       DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30912       DATA LEMCCK / .FALSE. /
30913       DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30914      &              .TRUE.,.TRUE.,.TRUE./
30915       DATA LSEADI / .TRUE. /
30916       DATA LEVAPO / .TRUE. /
30917       DATA IFRAME / 1 /
30918       DATA ITRSPT / 0 /
30919
30920 * / DTCOMP /
30921       DATA EMUFRA / NCOMPX*0.0D0 /
30922       DATA IEMUMA / NCOMPX*1 /
30923       DATA IEMUCH / NCOMPX*1 /
30924       DATA NCOMPO / 0 /
30925       DATA IEMUL  / 0 /
30926
30927       END
30928
30929 *$ CREATE DT_HADPRP.FOR
30930 *COPY DT_HADPRP
30931 *
30932 *===hadprp=============================================================*
30933 *
30934       BLOCK DATA DT_HADPRP
30935
30936       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30937       SAVE
30938
30939 * auxiliary common for reggeon exchange (DTUNUC 1.x)
30940       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30941      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30942      &                IQTCHR(-6:6),MQUARK(3,39)
30943 * hadron index conversion (BAMJET <--> PDG)
30944       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30945      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
30946      &                IAMCIN(210)
30947 * names of hadrons used in input-cards
30948       CHARACTER*8 BTYPE
30949       COMMON /DTPAIN/ BTYPE(30)
30950
30951 * / DTQUAR /
30952 *----------------------------------------------------------------------*
30953 *                                                                      *
30954 *     Quark content of particles:                                      *
30955 *          index   quark   el. charge  bar. charge  isospin  isospin3  *
30956 *              1 = u          2/3          1/3        1/2       1/2    *
30957 *             -1 = ubar      -2/3         -1/3        1/2      -1/2    *
30958 *              2 = d         -1/3          1/3        1/2      -1/2    *
30959 *             -2 = dbar       1/3         -1/3        1/2       1/2    *
30960 *              3 = s         -1/3          1/3         0         0     *
30961 *             -3 = sbar       1/3         -1/3         0         0     *
30962 *              4 = c          2/3          1/3         0         0     *
30963 *             -4 = cbar      -2/3         -1/3         0         0     *
30964 *              5 = b         -1/3          1/3         0         0     *
30965 *             -5 = bbar       1/3         -1/3         0         0     *
30966 *              6 = t          2/3          1/3         0         0     *
30967 *             -6 = tbar      -2/3         -1/3         0         0     *
30968 *                                                                      *
30969 *         Mquark = particle quark composition (Paprop numbering)       *
30970 *         Iqechr = electric charge ( in 1/3 unit )                     *
30971 *         Iqbchr = baryonic charge ( in 1/3 unit )                     *
30972 *         Iqichr = isospin ( in 1/2 unit ), z component                *
30973 *         Iqschr = strangeness                                         *
30974 *         Iqcchr = charm                                               *
30975 *         Iquchr = beauty                                              *
30976 *         Iqtchr = ......                                              *
30977 *                                                                      *
30978 *----------------------------------------------------------------------*
30979       DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
30980       DATA IQBCHR / 6*-1, 0, 6*1 /
30981       DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
30982       DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
30983       DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
30984       DATA IQUCHR / 0, 1, 9*0, -1, 0 /
30985       DATA IQTCHR / -1, 11*0, 1 /
30986       DATA MQUARK /
30987      &   2, 1, 1,   -2,-1,-1,    0, 0, 0,    0, 0, 0,    0, 0, 0,
30988      &   0, 0, 0,    0, 0, 0,    2, 2, 1,   -2,-2,-1,    0, 0, 0,
30989      &   0, 0, 0,    0, 0, 0,    1,-2, 0,    2,-1, 0,    1,-3, 0,
30990      &   3,-1, 0,    1, 2, 3,   -1,-2,-3,    0, 0, 0,    2, 2, 3,
30991      &   1, 1, 3,    1, 2, 3,    1,-1, 0,    2,-3, 0,    3,-2, 0,
30992      &   2,-2, 0,    3,-3, 0,    0, 0, 0,    0, 0, 0,    0, 0, 0,
30993      &  -1,-1,-3,   -1,-2,-3,   -2,-2,-3,    1, 3, 3,   -1,-3,-3,
30994      &   2, 3, 3,   -2,-3,-3,    3, 3, 3,   -3,-3,-3 /
30995
30996 * / DTHAIC /
30997 * (renamed) (HAdron InDex COnversion)
30998 * translation table version filled up by r.e. 25.01.94                 *
30999       DATA IAMCIN /
31000      &2212,-2212,11,-11,12,              -12,22,2112,-2112,-13,
31001      &13,130,211,-211,321,               -321,3122,-3122,310,3112,
31002      &3222,3212,111,311,-311,            0,0,0,0,0,
31003      &221,213,113,-213,223,              323,313,-323,-313,10323,
31004      &10313,-10323,-10313,30323,30313,   -30323,-30313,3224,3214,3114,
31005      &3216,3218,2224,2214,2114,          1114,12224,12214,12114,11114,
31006      &99999,99999,22212,22112,32124,     31214,-2224,-2214,-2114,-1114,
31007      &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
31008      &5*99999,                           5*99999,
31009      &4*99999,331,                       333,3322,3312,-3222,-3212,
31010      &-3112,-3322,-3312,3224,3214,       3114,3324,3314,3334,-3224,
31011      &-3214,-3114,-3324,-3314,-3334,     421,411,-411,-421,431,
31012      &-431,441,423,413,-413,             -423,433,-433,20443,443,
31013      &-15,15,16,-16,14,                  -14,4122,4232,4132,4222,
31014      &4212,4112,3*99999,                 3*99999,-4122,-4232,
31015      &-4132,-4222,-4212,-4112,99999,     5*99999,
31016      &5*99999,                           5*99999,
31017      &10*99999,
31018      &5*99999 , 20211,20111,-20211,99999,20321,
31019      &-20321,20311,-20311,7*99999 ,
31020      &7*99999,12212,12112,99999/
31021
31022 * / DTHAIC /
31023 * (HAdron InDex COnversion)
31024       DATA (IPDG2(1,K),K=1,7)
31025      &   /   -11,   -12,   -13,   -15,   -16,   -14,     0/
31026       DATA (IBAM2(1,K),K=1,7)
31027      &   /     4,     6,    10,   131,   134,   136,     0/
31028       DATA (IPDG2(2,K),K=1,7)
31029      &   /    11,    12,    22,    13,    15,    16,    14/
31030       DATA (IBAM2(2,K),K=1,7)
31031      &   /     3,     5,     7,    11,   132,   133,   135/
31032       DATA (IPDG3(1,K),K=1,22)
31033      &   /  -211,  -321,  -311,  -213,  -323,  -313,  -411,  -421,
31034      &      -431,  -413,  -423,  -433,     0,     0,     0,     0,
31035      &         0,     0,     0,     0,     0,     0/
31036       DATA (IBAM3(1,K),K=1,22)
31037      &   /    14,    16,    25,    34,    38,    39,   118,   119,
31038      &       121,   125,   126,   128,     0,     0,     0,     0,
31039      &         0,     0,     0,     0,     0,     0/
31040       DATA (IPDG3(2,K),K=1,22)
31041      &   /   130,   211,   321,   310,   111,   311,   221,   213,
31042      &       113,   223,   323,   313,   331,   333,   421,   411,
31043      &       431,   441,   423,   413,   433,   443/
31044       DATA (IBAM3(2,K),K=1,22)
31045      &   /    12,    13,    15,    19,    23,    24,    31,    32,
31046      &        33,    35,    36,    37,    95,    96,   116,   117,
31047      &       120,   122,   123,   124,   127,   130/
31048       DATA (IPDG4(1,K),K=1,29)
31049      &   / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
31050      &     -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31051      &     -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31052      &     -4212, -4112,     0,     0,     0/
31053       DATA (IBAM4(1,K),K=1,29)
31054      &   /     2,     9,    18,    67,    68,    69,    70,    75,
31055      &        76,    99,   100,   101,   102,   103,   110,   111,
31056      &       112,   113,   114,   115,   149,   150,   151,   152,
31057      &       153,   154,     0,     0,     0/
31058       DATA (IPDG4(2,K),K=1,29)
31059      &   /  2212,  2112,  3122,  3112,  3222,  3212,  3224,  3214,
31060      &      3114,  3216,  3218,  2224,  2214,  2114,  1114,  3322,
31061      &      3312,  3224,  3214,  3114,  3324,  3314,  3334,  4122,
31062      &      4232,  4132,  4222,  4212,  4112/
31063       DATA (IBAM4(2,K),K=1,29)
31064      &   /     1,     8,    17,    20,    21,    22,    48,    49,
31065      &        50,    51,    52,    53,    54,    55,    56,    97,
31066      &        98,   104,   105,   106,   107,   108,   109,   137,
31067      &       138,   139,   140,   141,   142/
31068       DATA (IPDG5(1,K),K=1,19)
31069      &   /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31070      &    -20211,-20321,-20311,     0,     0,     0,     0,     0,
31071      &         0,     0,     0/
31072       DATA (IBAM5(1,K),K=1,19)
31073      &   /    42,    43,    46,    47,    71,    72,    73,    74,
31074      &       188,   191,   193,     0,     0,     0,     0,     0,
31075      &         0,     0,     0/
31076       DATA (IPDG5(2,K),K=1,19)
31077      &   / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31078      &     22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31079      &     20311, 12212, 12112/
31080       DATA (IBAM5(2,K),K=1,19)
31081      &   /    40,    41,    44,    45,    57,    58,    59,    60,
31082      &        63,    64,    65,    66,   129,   186,   187,   190,
31083      &       192,   208,   209/
31084
31085 * / DTPAIN /
31086 * internal particle names
31087       DATA BTYPE / 'PROTON  ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31088      &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON  ' , 'NEUTRON ' , 'ANEUTRON' ,
31089      &'MUON+   ' , 'MUON-   ' , 'KAONLONG' , 'PION+   ' , 'PION-   ' ,
31090      &'KAON+   ' , 'KAON-   ' , 'LAMBDA  ' , 'ALAMBDA ' , 'KAONSHRT' ,
31091      &'SIGMA-  ' , 'SIGMA+  ' , 'SIGMAZER' , 'PIZERO  ' , 'KAONZERO' ,
31092      &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31093      &'BLANK   ' /
31094
31095       END
31096
31097 *$ CREATE DT_BLKD46.FOR
31098 *COPY DT_BLKD46
31099 *
31100 *===blkd46=============================================================*
31101 *
31102       BLOCK DATA DT_BLKD46
31103
31104       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31105       SAVE
31106
31107       PARAMETER ( AMELCT = 0.51099906         D-03 )
31108       PARAMETER ( AMMUON = 0.105658389        D+00 )
31109
31110 * particle properties (BAMJET index convention)
31111       CHARACTER*8  ANAME
31112       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31113      &                IICH(210),IIBAR(210),K1(210),K2(210)
31114
31115 * / DTPART /
31116 * Particle  masses Engel version JETSET compatible
31117 C     DATA (AAM(K),K=1,85) /
31118 C    &   .9383D+00, .9383D+00,  AMELCT  ,  AMELCT  , .0000D+00,
31119 C    &   .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON   ,
31120 C    &   AMMUON   , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31121 C    &   .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31122 C    &   .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31123 C    &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31124 C    &   .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31125 C    &   .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31126 C    &   .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31127 C    &   .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31128 C    &   .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31129 C    &   .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31130 C    &   .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31131 C    &   .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31132 C    &   .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31133 C    &   .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31134 C    &   .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01  /
31135 C     DATA (AAM(K),K=86,183) /
31136 C    &   .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31137 C    &   .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31138 C    &   .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31139 C    &   .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31140 C    &   .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31141 C    &   .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31142 C    &   .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31143 C    &   .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31144 C    &   .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31145 C    &   .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31146 C    &   .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31147 C    &   .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31148 C    &   .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31149 C    &   .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31150 C    &   .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31151 C    &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31152 C    &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31153 C    &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31154 C    &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31155 C    &   .1250D+01, .1250D+01, .1250D+01  /
31156 C     DATA (AAM ( I ), I = 184,210 ) /
31157 C    & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31158 C    & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31159 C    & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31160 C    & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31161 C    & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31162 C    & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31163 C    & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31164 C    & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31165 C    & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31166 * sr 25.1.06: particle masses adjusted to Pythia
31167       DATA (AAM(K),K=1,85) /
31168      &   .938270E+00,.938270E+00, AMELCT    , AMELCT    ,.000000E+00,
31169      &   .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON    ,
31170      &    AMMUON    ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31171      &   .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31172      &   .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31173      &     .0000D+00,  .0000D+00,  .0000D+00 , .0000D+00,  .0000D+00,
31174      &   .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31175      &   .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31176      &   .129000E+01,.129000E+01,.129000E+01,  .1421D+01,  .1421D+01,
31177      &     .1421D+01,  .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31178      &     .1820D+01,  .2030D+01,  .1231D+01,  .1232D+01,  .1233D+01,
31179      &     .1234D+01,  .1675D+01,  .1675D+01,  .1675D+01,  .1675D+01,
31180      &     .1500D+01,  .1500D+01,  .1515D+01,  .1515D+01,  .1775D+01,
31181      &     .1775D+01,  .1231D+01,  .1232D+01,  .1233D+01,  .1234D+01,
31182      &     .1675D+01,  .1675D+01,  .1675D+01,  .1675D+01,  .1515D+01,
31183      &     .1515D+01,  .2500D+01,  .4890D+00,  .4890D+00,  .4890D+00,
31184      &     .1300D+01,  .1300D+01,  .1300D+01,  .1300D+01,  .2200D+01  /
31185       DATA (AAM(K),K=86,183) /
31186      &     .2200D+01,  .2200D+01,  .2200D+01,  .1700D+01,  .1700D+01,
31187      &     .1700D+01,  .1700D+01,  .1820D+01,  .2030D+01,.957770E+00,
31188      &   .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31189      &   .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31190      &   .138720E+01,.153180E+01,  .1535D+01,.167245E+01,.138280E+01,
31191      &   .138370E+01,.138720E+01,.153180E+01,  .1535D+01,.167245E+01,
31192      &   .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31193      &   .196850E+01,.297980E+01,.200670E+01,  .2010D+01,  .2010D+01,
31194      &   .200670E+01,.211240E+01,.211240E+01,  .3686D+01,.309688E+01,
31195      &   .177700E+01,.177700E+01,  .0000D+00,  .0000D+00,  .0000D+00,
31196      &     .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31197      &   .245350E+01,.245210E+01,  .2560D+01,  .2560D+01,  .2730D+01,
31198      &     .3610D+01,  .3610D+01,  .3790D+01,.228490E+01,.246560E+01,
31199      &     .2460D+01,.245290E+01,.245350E+01,.245210E+01,  .2560D+01,
31200      &     .2560D+01,  .2730D+01,  .3610D+01,  .3610D+01,  .3790D+01,
31201      &     .2490D+01,  .2490D+01,  .2490D+01,  .2610D+01,  .2610D+01,
31202      &     .2770D+01,  .3670D+01,  .3670D+01,  .3850D+01,  .4890D+01,
31203      &     .2490D+01,  .2490D+01,  .2490D+01,  .2610D+01,  .2610D+01,
31204      &     .2770D+01,  .3670D+01,  .3670D+01,  .3850D+01,  .4890D+01,
31205      &     .1250D+01,  .1250D+01,  .1250D+01  /
31206       DATA (AAM ( I ), I = 184,210 ) /
31207      & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31208      & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31209      & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31210      & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31211      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31212      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31213      & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31214      & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31215      & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31216 * Particle  mean lives
31217       DATA (TAU(K),K=1,183) /
31218      &   .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31219      &   .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31220      &   .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31221      &   .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31222      &   .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31223      &   70*.0000D+00,
31224      &   .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31225      &   .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31226      &   .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31227      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31228      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31229      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31230      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31231      &   .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31232      &   .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31233      &   40*.0000D+00,
31234      &   .0000D+00, .0000D+00, .0000D+00  /
31235       DATA ( TAU ( I ), I = 184,210 ) /
31236      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31237      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31238      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31239      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31240      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31241      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31242      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31243      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31244      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
31245 * Resonance width Gamma in GeV
31246       DATA (GA(K),K=  1,85) /
31247      &    30*.0000D+00,
31248      &   .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31249      &   .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31250      &   .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31251      &   .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31252      &   .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31253      &   .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31254      &   .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31255      &   .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31256      &   .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31257      &   .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31258      &   .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00  /
31259       DATA (GA(K),K= 86,183) /
31260      &   .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31261      &   .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31262      &   .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31263      &   .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31264      &   .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31265      &   .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31266      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31267      &   .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31268      &   .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31269      &   50*.0000D+00,
31270      &   .3000D+00, .3000D+00, .3000D+00  /
31271       DATA ( GA ( I ), I = 184,210 ) /
31272      & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31273      & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31274      & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31275      & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31276      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31277      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31278      & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31279      & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31280      & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31281 * Particle  names
31282 * S+1385+Sigma+(1385)    L02030+Lambda0(2030)
31283 * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31284 * designation N*@@ means N*@1(@2)
31285       DATA (ANAME(K),K=1,85) /
31286      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
31287      &  'ANUE    ','GAM     ','NEU     ','ANEU    ','MUE+    ',
31288      &  'MUE-    ','K0L     ','PI+     ','PI-     ','K+      ',
31289      &  'K-      ','LAM     ','ALAM    ','K0S     ','SIGM-   ',
31290      &  'SIGM+   ','SIGM0   ','PI0     ','K0      ','AK0     ',
31291      &  'BLANK   ','BLANK   ','BLANK   ','BLANK   ','BLANK   ',
31292      &  'ETA550  ','RHO+77  ','RHO077  ','RHO-77  ','OM0783  ',
31293      &  'K*+892  ','K*0892  ','K*-892  ','AK*089  ','KA+125  ',
31294      &  'KA0125  ','KA-125  ','AKA012  ','K*+142  ','K*0142  ',
31295      &  'K*-142  ','AK*014  ','S+1385  ','S01385  ','S-1385  ',
31296      &  'L01820  ','L02030  ','N*++12  ','N*+ 12  ','N*012   ',
31297      &  'N*-12   ','N*++16  ','N*+16   ','N*016   ','N*-16   ',
31298      &  'N*+14   ','N*014   ','N*+15   ','N*015   ','N*+18   ',
31299      &  'N*018   ','AN--12  ','AN*-12  ','AN*012  ','AN*+12  ',
31300      &  'AN--16  ','AN*-16  ','AN*016  ','AN*+16  ','AN*-15  ',
31301      &  'AN*015  ','DE*=24  ','RPI+49  ','RPI049  ','RPI-49  ',
31302      &  'PIN++   ','PIN+0   ','PIN+-   ','PIN-0   ','PPPI    ' /
31303       DATA (ANAME(K),K=86,183) /
31304      &  'PNPI    ','APPPI   ','APNPI   ','K+PPI   ','K-PPI   ',
31305      &  'K+NPI   ','K-NPI   ','S+1820  ','S-2030  ','ETA*    ',
31306      &  'PHI     ','TETA0   ','TETA-   ','ASIG-   ','ASIG0   ',
31307      &  'ASIG+   ','ATETA0  ','ATETA+  ','SIG*+   ','SIG*0   ',
31308      &  'SIG*-   ','TETA*0  ','TETA*   ','OMEGA-  ','ASIG*-  ',
31309      &  'ASIG*0  ','ASIG*+  ','ATET*0  ','ATET*+  ','OMEGA+  ',
31310      &  'D0      ','D+      ','D-      ','AD0     ','F+      ',
31311      &  'F-      ','ETAC    ','D*0     ','D*+     ','D*-     ',
31312      &  'AD*0    ','F*+     ','F*-     ','PSI     ','JPSI    ',
31313      &  'TAU+    ','TAU-    ','NUET    ','ANUET   ','NUEM    ',
31314      &  'ANUEM   ','C0+     ','A+      ','A0      ','C1++    ',
31315      &  'C1+     ','C10     ','S+      ','S0      ','T0      ',
31316      &  'XU++    ','XD+     ','XS+     ','AC0-    ','AA-     ',
31317      &  'AA0     ','AC1--   ','AC1-    ','AC10    ','AS-     ',
31318      &  'AS0     ','AT0     ','AXU--   ','AXD-    ','AXS     ',
31319      &  'C1*++   ','C1*+    ','C1*0    ','S*+     ','S*0     ',
31320      &  'T*0     ','XU*++   ','XD*+    ','XS*+    ','TETA++  ',
31321      &  'AC1*--  ','AC1*-   ','AC1*0   ','AS*-    ','AS*0    ',
31322      &  'AT*0    ','AXU*--  ','AXD*-   ','AXS*-   ','ATET--  ',
31323      &  'RO      ','R+      ','R-      '  /
31324       DATA (    ANAME ( I ), I = 184,210 ) /
31325      &'AN*-14  ','AN*014  ','PI+130  ','PI0130  ','PI-130  ','F01400  ',
31326      &'K*+146  ','K*-146  ','K*0146  ','AK0146  ','L01600  ','AL0160  ',
31327      &'S+1660  ','S01660  ','S-1660  ','AS-166  ','AS0166  ','AS+166  ',
31328      &'X01950  ','X-1950  ','AX0195  ','AX+195  ','OM-225  ','AOM+22  ',
31329      &'N*+14   ','N*014   ','BLANK   '/
31330 * Charge of particles and resonances
31331       DATA (IICH ( I ), I =   1,210 ) /
31332      &  1, -1, -1,  1,  0,  0,  0,  0,  0,  1, -1,  0,  1, -1,  1,
31333      & -1,  0,  0,  0, -1,  1,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31334      &  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0,
31335      & -1,  0,  1,  0, -1,  0,  0,  2,  1,  0, -1,  2,  1,  0, -1,
31336      &  1,  0,  1,  0,  1,  0, -2, -1,  0,  1, -2, -1,  0,  1, -1,
31337      &  0,  1,  1,  0, -1,  2,  1,  0, -1,  2,  1,  0, -1,  2,  0,
31338      &  1, -1,  1, -1,  0,  0,  0, -1, -1,  0,  1,  0,  1,  1,  0,
31339      & -1,  0, -1, -1, -1,  0,  1,  0,  1,  1,  0,  1, -1,  0,  1,
31340      & -1,  0,  0,  1, -1,  0,  1, -1,  0,  0,  1, -1,  0,  0,  0,
31341      &  0,  1,  1,  0,  2,  1,  0,  1,  0,  0,  2,  1,  1, -1, -1,
31342      &  0, -2, -1,  0, -1,  0,  0, -2, -1, -1,  2,  1,  0,  1,  0,
31343      &  0,  2,  1,  1,  2, -2, -1,  0, -1,  0,  0, -2, -1, -1, -2,
31344      &  0,  1, -1, -1,  0,  1,  0, -1,  0,  1, -1,  0,  0,  0,  0,
31345      &  1,  0, -1, -1,  0,  1,  0, -1,  0,  1, -1,  1,  1,  0,  0/
31346 * Particle  baryonic charges
31347       DATA (IIBAR ( I ), I =   1,210 ) /
31348      &  1, -1,  0,  0,  0,  0,  0,  1, -1,  0,  0,  0,  0,  0,  0,
31349      &  0,  1, -1,  0,  1,  1,  1,  0,  0,  0,  0,  0,  0,  0,  0,
31350      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31351      &  0,  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
31352      &  1,  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31353      & -1,  2,  0,  0,  0,  1,  1,  1,  1,  2,  2,  0,  0,  1,  1,
31354      &  1,  1,  1,  1,  0,  0,  1,  1, -1, -1, -1, -1, -1,  1,  1,
31355      &  1,  1,  1,  1, -1, -1, -1, -1, -1, -1,  0,  0,  0,  0,  0,
31356      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31357      &  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1, -1, -1,
31358      & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,  1,  1,  1,  1,  1,
31359      &  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31360      &  0,  0,  0, -1, -1,  0,  0,  0,  0,  0,  0,  0,  0,  1, -1,
31361      &  1,  1,  1, -1, -1, -1,  1,  1, -1, -1,  1, -1,  1,  1,  0/
31362 * First number of decay channels used for resonances
31363 * and decaying particles
31364       DATA K1/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 16, 17,
31365      &  18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31366      &   2*330, 46, 51, 52, 54, 55, 58,
31367 *                                                             50
31368      &  60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31369      & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31370      & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31371 *                                         85
31372      & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31373      & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31374      & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31375      & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31376      & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31377      & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31378      & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31379      & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31380      & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31381      & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31382      & 590, 596, 602 /
31383 * Last number of decay channels used for resonances
31384 * and decaying particles
31385       DATA K2/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 15, 16, 17,
31386      & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31387      & 2* 330, 50, 51, 53, 54, 57,
31388 *                                                                 50
31389      & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31390      & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31391      & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31392 *                                              85
31393      & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31394      & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31395      & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31396      & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31397      & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31398      & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31399      & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31400      & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31401      & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31402      & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31403      & 589, 595, 601, 602 /
31404
31405        END
31406
31407 *$ CREATE DT_BLKD47.FOR
31408 *COPY DT_BLKD47
31409 *
31410 *===blkd47=============================================================*
31411 *
31412       BLOCK DATA DT_BLKD47
31413
31414       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31415       SAVE
31416
31417 * HADRIN: decay channel information
31418       PARAMETER (IDMAX9=602)
31419       CHARACTER*8 ZKNAME
31420       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31421
31422 * Name of decay channel
31423 * Designation N*@ means N*@1(1236)
31424 * @1=# means ++,  @1 = = means --
31425 * Designation  P+/0/- means Pi+/Pi0/Pi- , respectively
31426       DATA (ZKNAME(K),K=  1, 85) /
31427      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
31428      &  'ANUE    ','GAM     ','PE-NUE  ','APEANU  ','EANUNU  ',
31429      &  'E-NUAN  ','3PI0    ','PI+-0   ','PIMUNU  ','PIE-NU  ',
31430      &  'MU+NUE  ','MU-NUE  ','MU+NUE  ','PI+PI0  ','PI++-   ',
31431      &  'PI+00   ','M+P0NU  ','E+P0NU  ','MU-NU   ','PI-0    ',
31432      &  'PI+--   ','PI-00   ','M-P0NU  ','E-P0NU  ','PPI-    ',
31433      &  'NPI0    ','PD-NUE  ','PM-NUE  ','APPI+   ','ANPI0   ',
31434      &  'APE+NU  ','APM+NU  ','PI+PI-  ','PI0PI0  ','NPI-    ',
31435      &  'PPI0    ','NPI+    ','LAGA    ','GAGA    ','GAE+E-  ',
31436      &  'GAGA    ','GAGAP0  ','PI000   ','PI+-0   ','PI+-GA  ',
31437      &  'PI+0    ','PI+-    ','PI00    ','PI-0    ','PI+-0   ',
31438      &  'PI+-    ','PI0GA   ','K+PI0   ','K0PI+   ','KOPI0   ',
31439      &  'K+PI-   ','K-PI0   ','AK0PI-  ','AK0PI0  ','K-PI+   ',
31440      &  'K+PI0   ','K0PI+   ','K0PI0   ','K+PI-   ','K-PI0   ',
31441      &  'K0PI-   ','AK0PI0  ','K-PI+   ','K+PI0   ','K0PI+   ',
31442      &  'K+89P0  ','K08PI+  ','K+RO77  ','K0RO+7  ','K+OM07  ',
31443      &  'K+E055  ','K0PI0   ','K+PI+   ','K089P0  ','K+8PI-  '  /
31444       DATA (ZKNAME(K),K= 86,170) /
31445      &  'K0R077  ','K+R-77  ','K+R-77  ','K0OM07  ','K0E055  ',
31446      &  'K-PI0   ','K0PI-   ','K-89P0  ','AK08P-  ','K-R077  ',
31447      &  'AK0R-7  ','K-OM07  ','K-E055  ','AK0PI0  ','K-PI+   ',
31448      &  'AK08P0  ','K-8PI+  ','AK0R07  ','AK0OM7  ','AK0E05  ',
31449      &  'LA0PI+  ','SI0PI+  ','SI+PI0  ','LA0PI0  ','SI+PI-  ',
31450      &  'SI-PI+  ','LA0PI-  ','SI0PI-  ','NEUAK0  ','PK-     ',
31451      &  'SI+PI-  ','SI0PI0  ','SI-PI+  ','LA0ET0  ','S+1PI-  ',
31452      &  'S-1PI+  ','SO1PI0  ','NEUAK0  ','PK-     ','LA0PI0  ',
31453      &  'LA0OM0  ','LA0RO0  ','SI+RO-  ','SI-RO+  ','SI0RO0  ',
31454      &  'LA0ET0  ','SI0ET0  ','SI+PI-  ','SI-PI+  ','SI0PI0  ',
31455      &  'K0S     ','K0L     ','K0S     ','K0L     ','P PI+   ',
31456      &  'P PI0   ','N PI+   ','P PI-   ','N PI0   ','N PI-   ',
31457      &  'P PI+   ','N*#PI0  ','N*+PI+  ','PRHO+   ','P PI0   ',
31458      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
31459      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
31460      &  'N*-PI+  ','PRHO-   ','NRHO0   ','N PI-   ','N*0PI-  ',
31461      &  'N*-PI0  ','NRHO-   ','PETA0   ','N*#PI-  ','N*+PI0  '  /
31462       DATA (ZKNAME(K),K=171,255) /
31463      &  'N*0PI+  ','PRHO0   ','NRHO+   ','NETA0   ','N*+PI-  ',
31464      &  'N*0PI0  ','N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ',
31465      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
31466      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
31467      &  'N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ','N PI+   ',
31468      &  'PRHO0   ','NRHO+   ','LAMK+   ','S+ K0   ','S0 K+   ',
31469      &  'PETA0   ','P PI-   ','N PI0   ','PRHO-   ','NRHO0   ',
31470      &  'LAMK0   ','S0 K0   ','S- K+   ','NETA/   ','APPI-   ',
31471      &  'APPI0   ','ANPI-   ','APPI+   ','ANPI0   ','ANPI+   ',
31472      &  'APPI-   ','AN*=P0  ','AN*-P-  ','APRHO-  ','APPI0   ',
31473      &  'ANPI-   ','AN*=P+  ','AN*-P0  ','AN*0P-  ','APRHO0  ',
31474      &  'ANRHO-  ','APPI+   ','ANPI0   ','AN*-P+  ','AN*0P0  ',
31475      &  'AN*+P-  ','APRHO+  ','ANRHO0  ','ANPI+   ','AN*0P+  ',
31476      &  'AN*+P0  ','ANRHO+  ','APPI0   ','ANPI-   ','AN*=P+  ',
31477      &  'AN*-P0  ','AN*0P-  ','APRHO0  ','ANRHO-  ','APPI+,  ',
31478      &  'ANPI0   ','AN*-P+  ','AN*0P0  ','AN*+P-  ','APRHO+  ',
31479      &  'ANRHO0  ','PN*014  ','NN*=14  ','PI+0    ','PI+-    '  /
31480       DATA (ZKNAME(K),K=256,340) /
31481      &  'PI-0    ','P+0     ','N++     ','P+-     ','P00     ',
31482      &  'N+0     ','N+-     ','N00     ','P-0     ','N-0     ',
31483      &  'P--     ','PPPI0   ','PNPI+   ','PNPI0   ','PPPI-   ',
31484      &  'NNPI+   ','APPPI0  ','APNPI+  ','ANNPI0  ','ANPPI-  ',
31485      &  'APNPI0  ','APPPI-  ','ANNPI-  ','K+PPI0  ','K+NPI+  ',
31486      &  'K0PPI0  ','K-PPI0  ','K-NPI+  ','AKPPI-  ','AKNPI0  ',
31487      &  'K+NPI0  ','K+PPI-  ','K0PPI0  ','K0NPI+  ','K-NPI0  ',
31488      &  'K-PPI-  ','AKNPI-  ','PAK0    ','SI+PI0  ','SI0PI+  ',
31489      &  'SI+ETA  ','S+1PI0  ','S01PI+  ','NEUK-   ','LA0PI-  ',
31490      &  'SI-OM0  ','LA0RO-  ','SI0RO-  ','SI-RO0  ','SI-ET0  ',
31491      &  'SI0PI-  ','SI-0    ','BLANC   ','BLANC   ','BLANC   ',
31492      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31493      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31494      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31495      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31496      &  'EPI+-   ','EPI00   ','GAPI+-  ','GAGA*   ','K+-     ',
31497      &  'KLKS    ','PI+-0   ','EGA     ','LPI0    ','LPI     '  /
31498       DATA (ZKNAME(K),K=341,425) /
31499      &  'APPI0   ','ANPI-   ','ALAGA   ','ANPI    ','ALPI0   ',
31500      &  'ALPI+   ','LAPI+   ','SI+PI0  ','SI0PI+  ','LAPI0   ',
31501      &  'SI+PI-  ','SI-PI+  ','LAPI-   ','SI-PI0  ','SI0PI-  ',
31502      &  'TE0PI0  ','TE-PI+  ','TE0PI-  ','TE-PI0  ','TE0PI   ',
31503      &  'TE-PI   ','LAK-    ','ALPI-   ','AS-PI0  ','AS0PI-  ',
31504      &  'ALPI0   ','AS+PI-  ','AS-PI+  ','ALPI+   ','AS+PI0  ',
31505      &  'AS0PI+  ','AT0PI0  ','AT+PI-  ','AT0PI+  ','AT+PI0  ',
31506      &  'AT0PI   ','AT+PI   ','ALK+    ','K-PI+   ','K-PI+0  ',
31507      &  'K0PI+-  ','K0PI0   ','K-PI++  ','AK0PI+  ','K+PI--  ',
31508      &  'K0PI-   ','K+PI-   ','K+PI-0  ','AKPI-+  ','AK0PI0  ',
31509      &  'ETAPIF  ','K++-    ','K+AK0   ','ETAPI-  ','K--+    ',
31510      &  'K-K0    ','PI00    ','PI+-    ','GAGA    ','D0PI0   ',
31511      &  'D0GA    ','D0PI+   ','D+PI0   ','DFGA    ','AD0PI-  ',
31512      &  'D-PI0   ','D-GA    ','AD0PI0  ','AD0GA   ','F+GA    ',
31513      &  'F+GA    ','F-GA    ','F-GA    ','PSPI+-  ','PSPI00  ',
31514      &  'PSETA   ','E+E-    ','MUE+-   ','PI+-0   ','M+NN    ',
31515      &  'E+NN    ','RHO+NT  ','PI+ANT  ','K*+ANT  ','M-NN    '  /
31516       DATA (ZKNAME(K),K=426,510) /
31517      &  'E-NN    ','RHO-NT  ','PI-NT   ','K*-NT   ','NUET    ',
31518      &  'ANUET   ','NUEM    ','ANUEM   ','SI+ETA  ','SI+ET*  ',
31519      &  'PAK0    ','TET0K+  ','SI*+ET  ','N*+AK0  ','N*++K-  ',
31520      &  'LAMRO+  ','SI0RO+  ','SI+RO0  ','SI+OME  ','PAK*0   ',
31521      &  'N*+AK*  ','N*++K*  ','SI+AK0  ','TET0PI  ','SI+AK*  ',
31522      &  'TET0RO  ','SI0AK*  ','SI+K*-  ','TET0OM  ','TET-RO  ',
31523      &  'SI*0AK  ','C0+PI+  ','C0+PI0  ','C0+PI-  ','A+GAM   ',
31524      &  'A0GAM   ','TET0AK  ','TET0K*  ','OM-RO+  ','OM-PI+  ',
31525      &  'C1++AK  ','A+PI+   ','C0+AK0  ','A0PI+   ','A+AK0   ',
31526      &  'T0PI+   ','ASI-ET  ','ASI-E*  ','APK0    ','ATET0K  ',
31527      &  'ASI*-E  ','AN*-K0  ','AN*--K  ','ALAMRO  ','ASI0RO  ',
31528      &  'ASI-RO  ','ASI-OM  ','APK*0   ','AN*-K*  ','AN*--K  ',
31529      &  'ASI-K0  ','ATETPI  ','ASI-K*  ','ATETRO  ','ASI0K*  ',
31530      &  'ASI-K*  ','ATE0OM  ','ATE+RO  ','ASI*0K  ','AC-PI-  ',
31531      &  'AC-PI0  ','AC-PI+  ','AA-GAM  ','AA0GAM  ','ATET0K  ',
31532      &  'ATE0K*  ','AOM+RO  ','AOM+PI  ','AC1--K  ','AA-PI-  ',
31533      &  'AC0-K0  ','AA0PI-  ','AA-K0   ','AT0PI-  ','C1++GA  '  /
31534       DATA (ZKNAME(K),K=511,540) /
31535      &  'C1++GA  ','C10GAM  ','S+GAM   ','S0GAM   ','T0GAM   ',
31536      &  'XU++GA  ','XD+GAM  ','XS+GAM  ','A+AKPI  ','T02PI+  ',
31537      &  'C1++2K  ','AC1--G  ','AC1-GA  ','AC10GA  ','AS-GAM  ',
31538      &  'AS0GAM  ','AT0GAM  ','AXU--G  ','AXD-GA  ','AXS-GA  ',
31539      &  'AA-KPI  ','AT02PI  ','AC1--K  ','RH-PI+  ','RH+PI-  ',
31540      &  'RH3PI0  ','RH0PI+  ','RH+PI0  ','RH0PI-  ','RH-PI0  '  /
31541       DATA (ZKNAME(I),I=541,602)/
31542      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31543      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31544      & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31545      & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31546      & 'PI+PI-','K+K-  ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31547      & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31548      & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31549      & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31550      & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31551 * Weight of decay channel
31552       DATA (WT(K),K=  1, 85) /
31553      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31554      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31555      &   .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31556      &   .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31557      &   .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31558      &   .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31559      &   .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31560      &   .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31561      &   .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31562      &   .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31563      &   .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31564      &   .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31565      &   .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31566      &   .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31567      &   .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31568      &   .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31569      &   .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00  /
31570       DATA (WT(K),K= 86,170) /
31571      &   .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31572      &   .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31573      &   .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31574      &   .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31575      &   .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31576      &   .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31577      &   .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31578      &   .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31579      &   .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31580      &   .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31581      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31582      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31583      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31584      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31585      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31586      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31587      &   .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00  /
31588       DATA (WT(K),K=171,255) /
31589      &   .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31590      &   .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31591      &   .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31592      &   .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31593      &   .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31594      &   .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31595      &   .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31596      &   .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31597      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31598      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31599      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31600      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31601      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31602      &   .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31603      &   .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31604      &   .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31605      &   .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01  /
31606       DATA (WT(K),K=256,340) /
31607      &   .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31608      &   .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31609      &   .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31610      &   .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31611      &   .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31612      &   .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31613      &   .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31614      &   .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31615      &   .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31616      &   .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31617      &   .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31618      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31619      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31620      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31621      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31622      &   .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31623      &   .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01  /
31624       DATA (WT(K),K=341,425) /
31625      &   .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31626      &   .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31627      &   .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31628      &   .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31629      &   .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31630      &   .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31631      &   .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31632      &   .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31633      &   .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31634      &   .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31635      &   .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31636      &   .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31637      &   .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31638      &   .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31639      &   .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31640      &   .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31641      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00  /
31642       DATA (WT(K),K=426,510) /
31643      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31644      &   .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31645      &   .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31646      &   .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31647      &   .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31648      &   .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31649      &   .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31650      &   .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31651      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31652      &   .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31653      &   .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31654      &   .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31655      &   .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31656      &   .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31657      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31658      &   .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31659      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01  /
31660       DATA (WT(K),K=511,540) /
31661      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31662      &   .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31663      &   .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31664      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31665      &   .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31666      &   .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00  /
31667 C
31668       DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31669      & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31670      & .125D+00,  0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31671      & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31672      & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31673      & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31674      & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31675 * Particle numbers in decay channel
31676       DATA (NZK(K,1),K=  1,170) /
31677      &     1,   2,   3,   4,   5,   6,   7,   1,   2,   4,
31678      &     3,  23,  13,  13,  13,  10,  11,  10,  13,  13,
31679      &    13,  10,   4,  11,  14,  14,  14,  11,   3,   1,
31680      &     8,   1,   1,   2,   9,   2,   2,  13,  23,   8,
31681      &     1,   8,  17,   7,   7,   7,  23,  23,  13,  13,
31682      &    13,  13,  23,  14,  13,  13,  23,  15,  24,  24,
31683      &    15,  16,  25,  25,  16,  15,  24,  24,  15,  16,
31684      &    24,  25,  16,  15,  24,  36,  37,  15,  24,  15,
31685      &    15,  24,  15,  37,  36,  24,  15,  24,  24,  16,
31686      &    24,  38,  39,  16,  25,  16,  16,  25,  16,  39,
31687      &    38,  25,  16,  25,  25,  17,  22,  21,  17,  21,
31688      &    20,  17,  22,   8,   1,  21,  22,  20,  17,  48,
31689      &    50,  49,   8,   1,  17,  17,  17,  21,  20,  22,
31690      &    17,  22,  21,  20,  22,  19,  12,  19,  12,   1,
31691      &     1,   8,   1,   8,   8,   1,  53,  54,   1,   1,
31692      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
31693      &    56,   1,   8,   8,  55,  56,   8,   1,  53,  54  /
31694       DATA (NZK(K,1),K=171,340) /
31695      &    55,   1,   8,   8,  54,  55,  56,   1,   8,   1,
31696      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
31697      &    56,   1,   8,   1,   8,   1,   8,  17,  21,  22,
31698      &     1,   1,   8,   1,   8,  17,  22,  20,   8,   2,
31699      &     2,   9,   2,   9,   9,   2,  67,  68,   2,   2,
31700      &     9,  67,  68,  69,   2,   9,   2,   9,  68,  69,
31701      &    70,   2,   9,   9,  69,  70,   9,   2,   9,  67,
31702      &    68,  69,   2,   9,   2,   9,  68,  69,  70,   2,
31703      &     9,   1,   8,  13,  13,  14,   1,   8,   1,   1,
31704      &     8,   8,   8,   1,   8,   1,   1,   1,   1,   1,
31705      &     8,   2,   2,   9,   9,   2,   2,   9,  15,  15,
31706      &    24,  16,  16,  25,  25,  15,  15,  24,  24,  16,
31707      &    16,  25,   1,  21,  22,  21,  48,  49,   8,  17,
31708      &    20,  17,  22,  20,  20,  22,  20,   0,   0,   0,
31709      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31710      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31711      &    31,  31,  13,   7,  15,  12,  13,  31,  17,  17  /
31712       DATA (NZK(K,1),K=341,510) /
31713      &     2,   9,  18,   9,  18,  18,  17,  21,  22,  17,
31714      &    21,  20,  17,  20,  22,  97,  98,  97,  98,  97,
31715      &    98,  17,  18,  99, 100,  18, 101,  99,  18, 101,
31716      &   100, 102, 103, 102, 103, 102, 103,  18,  16,  16,
31717      &    24,  24,  16,  25,  15,  24,  15,  15,  25,  25,
31718      &    31,  15,  15,  31,  16,  16,  23,  13,   7, 116,
31719      &   116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31720      &   120, 121, 121, 130, 130, 130,   4,  10,  13,  10,
31721      &     4,  32,  13,  36,  11,   3,  34,  14,  38, 133,
31722      &   134, 135, 136,  21,  21,   1,  97, 104,  54,  53,
31723      &    17,  22,  21,  21,   1,  54,  53,  21,  97,  21,
31724      &    97,  22,  21,  97,  98, 105, 137, 137, 137, 138,
31725      &   139,  97,  97, 109, 109, 140, 138, 137, 139, 138,
31726      &   145,  99,  99,   2, 102, 110,  68,  67,  18, 100,
31727      &    99,  99,   2,  68,  67,  99, 102,  99, 102, 100,
31728      &    99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31729      &   113, 115, 115, 152, 150, 149, 151, 150, 157, 140  /
31730       DATA (NZK(K,1),K=511,540) /
31731      &   141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31732      &   140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31733      &   150, 157, 152,  34,  32,  33,  33,  32,  33,  34  /
31734       DATA (NZK(I,1),I=541,602) /  2, 67, 68, 69,  2,  9,  9, 68, 69,
31735      & 70,  2,  9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31736      & 14, 189, 23, 13, 15, 24,  36,  38,  37,  39, 194, 195, 196, 197,
31737      & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31738      & 55, 8, 1, 8, 8, 54, 55, 210/
31739       DATA (NZK(K,2),K=  1,170) /
31740      &     0,   0,   0,   0,   0,   0,   0,   3,   4,   6,
31741      &     5,  23,  14,  11,   3,   5,   5,   5,  23,  13,
31742      &    23,  23,  23,   5,  23,  13,  23,  23,  23,  14,
31743      &    23,   3,  11,  13,  23,   4,  10,  14,  23,  14,
31744      &    23,  13,   7,   7,   4,   7,   7,  23,  14,  14,
31745      &    23,  14,  23,  23,  14,  14,   7,  23,  13,  23,
31746      &    14,  23,  14,  23,  13,  23,  13,  23,  14,  23,
31747      &    14,  23,  13,  23,  13,  23,  13,  33,  32,  35,
31748      &    31,  23,  14,  23,  14,  33,  34,  35,  31,  23,
31749      &    14,  23,  14,  33,  34,  35,  31,  23,  13,  23,
31750      &    13,  33,  32,  35,  31,  13,  13,  23,  23,  14,
31751      &    13,  14,  14,  25,  16,  14,  23,  13,  31,  14,
31752      &    13,  23,  25,  16,  23,  35,  33,  34,  32,  33,
31753      &    31,  31,  14,  13,  23,   0,   0,   0,   0,  13,
31754      &    23,  13,  14,  23,  14,  13,  23,  13,  78,  23,
31755      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
31756      &    13,  80,  79,  14,  14,  23,  80,  31,  14,  23  /
31757       DATA (NZK(K,2),K=171,340) /
31758      &    13,  79,  78,  31,  14,  23,  13,  80,  79,  23,
31759      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
31760      &    13,  80,  79,  23,  13,  33,  32,  15,  24,  15,
31761      &    31,  14,  23,  34,  33,  24,  24,  15,  31,  14,
31762      &    23,  14,  13,  23,  13,  14,  23,  14,  80,  23,
31763      &    14,  13,  23,  14,  79,  80,  13,  23,  13,  23,
31764      &    14,  78,  79,  13,  13,  23,  78,  23,  14,  13,
31765      &    23,  14,  79,  80,  13,  23,  13,  23,  14,  78,
31766      &    79,  62,  61,  23,  14,  23,  13,  13,  13,  23,
31767      &    13,  13,  23,  14,  14,  14,   1,   8,   8,   1,
31768      &     8,   1,   8,   8,   1,   8,   1,   8,   1,   8,
31769      &     1,   1,   8,   1,   8,   8,   1,   1,   8,   8,
31770      &     1,   8,  25,  23,  13,  31,  23,  13,  16,  14,
31771      &    35,  34,  34,  33,  31,  14,  23,   0,   0,   0,
31772      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31773      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31774      &    13,  23,  14,   7,  16,  19,  14,   7,  23,  14  /
31775       DATA (NZK(K,2),K=341,510) /
31776      &    23,  14,   7,  13,  23,  13,  13,  23,  13,  23,
31777      &    14,  13,  14,  23,  14,  23,  13,  14,  23,  14,
31778      &    23,  16,  14,  23,  14,  23,  14,  13,  13,  23,
31779      &    13,  23,  14,  13,  23,  13,  23,  15,  13,  13,
31780      &    13,  23,  13,  13,  14,  14,  14,  14,  14,  23,
31781      &    13,  16,  25,  14,  15,  24,  23,  14,   7,  23,
31782      &     7,  13,  23,   7,  14,  23,   7,  23,   7,   7,
31783      &     7,   7,   7,  13,  23,  31,   3,  11,  14, 135,
31784      &     5, 134, 134, 134, 136,   6, 133, 133, 133,   0,
31785      &     0,   0,   0,  31,  95,  25,  15,  31,  95,  16,
31786      &    32,  32,  33,  35,  39,  39,  38,  25,  13,  39,
31787      &    32,  39,  38,  35,  32,  39,  13,  23,  14,   7,
31788      &     7,  25,  37,  32,  13,  25,  13,  25,  13,  25,
31789      &    13,  31,  95,  24,  16,  31,  24,  15,  34,  34,
31790      &    33,  35,  37,  37,  36,  24,  14,  37,  34,  37,
31791      &    36,  35,  34,  37,  14,  23,  13,   7,   7,  24,
31792      &    39,  34,  14,  24,  14,  24,  14,  24,  14,   7  /
31793       DATA (NZK(K,2),K=511,540) /
31794      &     7,   7,   7,   7,   7,   7,   7,   7,  25,  13,
31795      &    25,   7,   7,   7,   7,   7,   7,   7,   7,   7,
31796      &    24,  14,  24,  13,  14,  23,  13,  23,  14,  23  /
31797       DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31798      & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31799      & 14, 14, 23, 14, 16, 25,
31800      & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31801      & 23, 13, 14, 23,  0 /
31802       DATA (NZK(K,3),K=  1,170) /
31803      &     0,   0,   0,   0,   0,   0,   0,   5,   6,   5,
31804      &     6,  23,  23,   5,   5,   0,   0,   0,   0,  14,
31805      &    23,   5,   5,   0,   0,  14,  23,   5,   5,   0,
31806      &     0,   5,   5,   0,   0,   5,   5,   0,   0,   0,
31807      &     0,   0,   0,   0,   3,   0,   7,  23,  23,   7,
31808      &     0,   0,   0,   0,  23,   0,   0,   0,   0,   0,
31809      &     110*0   /
31810       DATA (NZK(K,3),K=171,340) /
31811      &     80*0,
31812      &     0,   0,   0,   0,   0,   0,  23,  13,  14,  23,
31813      &    23,  14,  23,  23,  23,  14,  23,  13,  23,  14,
31814      &    13,  23,  13,  23,  14,  23,  14,  14,  23,  13,
31815      &    13,  23,  13,  14,  23,  23,  14,  23,  13,  23,
31816      &    14,  14,   0,   0,   0,   0,   0,   0,   0,   0,
31817      &     30*0,
31818      &    14,  23,   7,   0,   0,   0,  23,   0,   0,   0  /
31819       DATA (NZK(K,3),K=341,510) /
31820      &     30*0,
31821      &     0,   0,   0,   0,   0,   0,   0,   0,   0,  23,
31822      &    14,   0,  13,   0,  14,   0,   0,  23,  13,   0,
31823      &     0,  15,   0,   0,  16,   0,   0,   0,   0,   0,
31824      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31825      &     0,   0,   0,  14,  23,   0,   0,   0,  23, 134,
31826      &   134,   0,   0,   0, 133, 133,   0,   0,   0,   0,
31827      &     80*0  /
31828       DATA (NZK(K,3),K=511,540) /
31829      &     0,   0,   0,   0,   0,   0,   0,   0,  13,  13,
31830      &    25,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31831      &    14,  14,  24,   0,   0,   0,   0,   0,   0,   0  /
31832       DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31833      & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31834
31835       END
31836
31837 *$ CREATE DT_BDEVAP.FOR
31838 *COPY DT_BDEVAP
31839 *
31840 *=== bdevap ===========================================================*
31841 *
31842       BLOCK DATA DT_BDEVAP
31843
31844 C     INCLUDE '(DBLPRC)'
31845 * DBLPRC.ADD
31846       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31847       SAVE
31848 * (original name: GLOBAL)
31849       PARAMETER ( KALGNM = 2 )
31850       PARAMETER ( ANGLGB = 5.0D-16 )
31851       PARAMETER ( ANGLSQ = 2.5D-31 )
31852       PARAMETER ( AXCSSV = 0.2D+16 )
31853       PARAMETER ( ANDRFL = 1.0D-38 )
31854       PARAMETER ( AVRFLW = 1.0D+38 )
31855       PARAMETER ( AINFNT = 1.0D+30 )
31856       PARAMETER ( AZRZRZ = 1.0D-30 )
31857       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
31858       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
31859       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
31860       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
31861       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
31862       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
31863       PARAMETER ( CSNNRM = 2.0D-15 )
31864       PARAMETER ( DMXTRN = 1.0D+08 )
31865       PARAMETER ( ZERZER = 0.D+00 )
31866       PARAMETER ( ONEONE = 1.D+00 )
31867       PARAMETER ( TWOTWO = 2.D+00 )
31868       PARAMETER ( THRTHR = 3.D+00 )
31869       PARAMETER ( FOUFOU = 4.D+00 )
31870       PARAMETER ( FIVFIV = 5.D+00 )
31871       PARAMETER ( SIXSIX = 6.D+00 )
31872       PARAMETER ( SEVSEV = 7.D+00 )
31873       PARAMETER ( EIGEIG = 8.D+00 )
31874       PARAMETER ( ANINEN = 9.D+00 )
31875       PARAMETER ( TENTEN = 10.D+00 )
31876       PARAMETER ( HLFHLF = 0.5D+00 )
31877       PARAMETER ( ONETHI = ONEONE / THRTHR )
31878       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
31879       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
31880       PARAMETER ( THRTWO = THRTHR / TWOTWO )
31881       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
31882       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
31883       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
31884       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
31885       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
31886       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
31887       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
31888       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
31889       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
31890       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
31891       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
31892       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
31893       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
31894       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
31895       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
31896       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
31897       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
31898       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
31899       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
31900       PARAMETER ( CLIGHT = 2.99792458         D+10 )
31901       PARAMETER ( AVOGAD = 6.0221367          D+23 )
31902       PARAMETER ( BOLTZM = 1.380658           D-23 )
31903       PARAMETER ( AMELGR = 9.1093897          D-28 )
31904       PARAMETER ( PLCKBR = 1.05457266         D-27 )
31905       PARAMETER ( ELCCGS = 4.8032068          D-10 )
31906       PARAMETER ( ELCMKS = 1.60217733         D-19 )
31907       PARAMETER ( AMUGRM = 1.6605402          D-24 )
31908       PARAMETER ( AMMUMU = 0.113428913        D+00 )
31909       PARAMETER ( AMPRMU = 1.007276470        D+00 )
31910       PARAMETER ( AMNEMU = 1.008664904        D+00 )
31911       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
31912       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
31913       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
31914       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
31915       PARAMETER ( PLABRC = 0.197327053        D+00 )
31916       PARAMETER ( AMELCT = 0.51099906         D-03 )
31917       PARAMETER ( AMUGEV = 0.93149432         D+00 )
31918       PARAMETER ( AMMUON = 0.105658389        D+00 )
31919       PARAMETER ( AMPRTN = 0.93827231         D+00 )
31920       PARAMETER ( AMNTRN = 0.93956563         D+00 )
31921       PARAMETER ( AMDEUT = 1.87561339         D+00 )
31922       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
31923      &                   * 1.D-09 )
31924       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
31925       PARAMETER ( BLTZMN = 8.617385           D-14 )
31926       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
31927       PARAMETER ( GFOHB3 = 1.16639            D-05 )
31928       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
31929       PARAMETER ( SIN2TW = 0.2319             D+00 )
31930       PARAMETER ( GEVMEV = 1.0                D+03 )
31931       PARAMETER ( EMVGEV = 1.0                D-03 )
31932       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
31933       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
31934       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
31935       LOGICAL LGBIAS, LGBANA
31936       COMMON /FKGLOB/ LGBIAS, LGBANA
31937 C     INCLUDE '(DIMPAR)'
31938 * DIMPAR.ADD
31939       PARAMETER ( MXXRGN = 5000 )
31940       PARAMETER ( MXXMDF = 82   )
31941       PARAMETER ( MXXMDE = 54   )
31942       PARAMETER ( MFSTCK = 1000 )
31943       PARAMETER ( MESTCK = 100  )
31944       PARAMETER ( NELEMX = 80   )
31945       PARAMETER ( MPDPDX = 8    )
31946       PARAMETER ( ICOMAX = 180  )
31947       PARAMETER ( NSTBIS = 304  )
31948       PARAMETER ( IDMAXP = 220  )
31949       PARAMETER ( IDMXDC = 640  )
31950       PARAMETER ( MKBMX1 = 1    )
31951       PARAMETER ( MKBMX2 = 1    )
31952 C     INCLUDE '(IOUNIT)'
31953 * IOUNIT.ADD
31954       PARAMETER ( LUNIN  =  5 )
31955       PARAMETER ( LUNOUT =  6 )
31956 **sr 19.5. set error output-unit from 15 to 6
31957       PARAMETER ( LUNERR = 6  )
31958       PARAMETER ( LUNBER = 14 )
31959       PARAMETER ( LUNECH =  8 )
31960       PARAMETER ( LUNFLU = 13 )
31961       PARAMETER ( LUNGEO = 16 )
31962       PARAMETER ( LUNPMF = 12 )
31963       PARAMETER ( LUNRAN =  2 )
31964       PARAMETER ( LUNXSC =  9 )
31965       PARAMETER ( LUNDET = 17 )
31966       PARAMETER ( LUNRAY = 10 )
31967       PARAMETER ( LUNRDB =  1 )
31968       PARAMETER ( LUNPGO =  7 )
31969       PARAMETER ( LUNPGS =  4 )
31970       PARAMETER ( LUNSCR =  3 )
31971 *
31972 *----------------------------------------------------------------------*
31973 *                                                                      *
31974 *     Block Data for the EVAPoration routines:                         *
31975 *                                                                      *
31976 *     Created on    20 may 1990    by    Alfredo Ferrari & Paola Sala  *
31977 *                                                   Infn - Milan       *
31978 *                                                                      *
31979 *     Modified from the original version of J.M.Zazula                 *
31980 *     and, for cookcm, from a LAHET block data kindly provided by      *
31981 *     R.E.Prael-LANL                                                   *
31982 *                                                                      *
31983 *     Last change on  20-feb-95    by    Alfredo Ferrari               *
31984 *                                                                      *
31985 *                                                                      *
31986 *----------------------------------------------------------------------*
31987 *
31988 * (original name: COOKCM)
31989       PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
31990       LOGICAL LDEFOZ, LDEFON
31991       PARAMETER ( INCOOK = 150, IZCOOK = 98 )
31992       COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
31993      &                SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
31994      &                PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
31995 * (original name: EVA0)
31996       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
31997      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
31998      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
31999      *                T (4,7), RMASS (297), ALPH (297), BET (297),
32000      *                APRIME (250), IA (6), IZ (6)
32001 * (original name: HETTP)
32002       COMMON /FKHETP/  NHSTP,NBERTP,IOSUB,INSRS
32003 * (original name: HETC7)
32004       COMMON /FKHET7/ COSKS,SINKS, COSTH,SINTH, COSPHI,SINPHI
32005 * (original name: INPFLG)
32006       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
32007 *
32008       DATA B0   / 8.D+00 /, Y0 / 1.5D+00 /
32009       DATA IANG / 1 /, IFISS / 1 /,  IB0 / 2 /, IGEOM / 0 /
32010       DATA ISTRAG /0/, KEYDK /0/
32011       DATA NBERTP /LUNBER/
32012       DATA COSTH /ONEONE/, SINTH /ZERZER/, COSPHI /ONEONE/,
32013      &     SINPHI/ZERZER/
32014 *  /cookcm/
32015        DATA ( PZCOOK(I),I =  1, IZCOOK ) /
32016      & 0.000D+00, 5.440D+00, 0.000D+00, 2.760D+00, 0.000D+00, 3.340D+00,
32017      & 0.000D+00, 2.700D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.460D+00,
32018      & 0.000D+00, 2.090D+00, 0.000D+00, 1.620D+00, 0.000D+00, 1.620D+00,
32019      & 0.000D+00, 1.830D+00, 0.000D+00, 1.730D+00, 0.000D+00, 1.350D+00,
32020      & 0.000D+00, 1.540D+00, 0.000D+00, 1.280D+00, 2.600D-01, 8.800D-01,
32021      & 1.900D-01, 1.350D+00,-5.000D-02, 1.520D+00,-9.000D-02, 1.170D+00,
32022      & 4.000D-02, 1.240D+00, 2.900D-01, 1.090D+00, 2.600D-01, 1.170D+00,
32023      & 2.300D-01, 1.150D+00,-8.000D-02, 1.350D+00, 3.400D-01, 1.050D+00,
32024      & 2.800D-01, 1.270D+00, 0.000D+00, 1.050D+00, 0.000D+00, 1.000D+00,
32025      & 9.000D-02, 1.200D+00, 2.000D-01, 1.400D+00, 9.300D-01, 1.000D+00,
32026      &-2.000D-01, 1.190D+00, 9.000D-02, 9.700D-01, 0.000D+00, 9.200D-01,
32027      & 1.100D-01, 6.800D-01, 5.000D-02, 6.800D-01,-2.200D-01, 7.900D-01,
32028      & 9.000D-02, 6.900D-01, 1.000D-02, 7.200D-01, 0.000D+00, 4.000D-01,
32029      & 1.600D-01, 7.300D-01, 0.000D+00, 4.600D-01, 1.700D-01, 8.900D-01,
32030      & 0.000D+00, 7.900D-01, 0.000D+00, 8.900D-01, 0.000D+00, 8.100D-01,
32031      &-6.000D-02, 6.900D-01,-2.000D-01, 7.100D-01,-1.200D-01, 7.200D-01,
32032      & 0.000D+00, 7.700D-01/
32033        DATA ( PNCOOK(I),I =  1, 90 ) /
32034      & 0.000D+00, 5.980D+00, 0.000D+00, 2.770D+00, 0.000D+00, 3.160D+00,
32035      & 0.000D+00, 3.010D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.670D+00,
32036      & 0.000D+00, 1.800D+00, 0.000D+00, 1.670D+00, 0.000D+00, 1.860D+00,
32037      & 0.000D+00, 2.040D+00, 0.000D+00, 1.640D+00, 0.000D+00, 1.440D+00,
32038      & 0.000D+00, 1.540D+00, 0.000D+00, 1.300D+00, 0.000D+00, 1.270D+00,
32039      & 0.000D+00, 1.290D+00, 8.000D-02, 1.410D+00,-8.000D-02, 1.500D+00,
32040      &-5.000D-02, 2.240D+00,-4.700D-01, 1.430D+00,-1.500D-01, 1.440D+00,
32041      & 6.000D-02, 1.560D+00, 2.500D-01, 1.570D+00,-1.600D-01, 1.460D+00,
32042      & 0.000D+00, 9.300D-01, 1.000D-02, 6.200D-01,-5.000D-01, 1.420D+00,
32043      & 1.300D-01, 1.520D+00,-6.500D-01, 8.000D-01,-8.000D-02, 1.290D+00,
32044      &-4.700D-01, 1.250D+00,-4.400D-01, 9.700D-01, 8.000D-02, 1.650D+00,
32045      &-1.100D-01, 1.260D+00,-4.600D-01, 1.060D+00, 2.200D-01, 1.550D+00,
32046      &-7.000D-02, 1.370D+00, 1.000D-01, 1.200D+00,-2.700D-01, 9.200D-01,
32047      &-3.500D-01, 1.190D+00, 0.000D+00, 1.050D+00,-2.500D-01, 1.610D+00,
32048      &-2.100D-01, 9.000D-01,-2.100D-01, 7.400D-01,-3.800D-01, 7.200D-01/
32049        DATA ( PNCOOK(I),I = 91, INCOOK ) /
32050      &-3.400D-01, 9.200D-01,-2.600D-01, 9.400D-01, 1.000D-02, 6.500D-01,
32051      &-3.600D-01, 8.300D-01, 1.100D-01, 6.700D-01, 5.000D-02, 1.000D+00,
32052      & 5.100D-01, 1.040D+00, 3.300D-01, 6.800D-01,-2.700D-01, 8.100D-01,
32053      & 9.000D-02, 7.500D-01, 1.700D-01, 8.600D-01, 1.400D-01, 1.100D+00,
32054      &-2.200D-01, 8.400D-01,-4.700D-01, 4.800D-01, 2.000D-02, 8.800D-01,
32055      & 2.400D-01, 5.200D-01, 2.700D-01, 4.100D-01,-5.000D-02, 3.800D-01,
32056      & 1.500D-01, 6.700D-01, 0.000D+00, 6.100D-01, 0.000D+00, 7.800D-01,
32057      & 0.000D+00, 6.700D-01, 0.000D+00, 6.700D-01, 0.000D+00, 7.900D-01,
32058      & 0.000D+00, 6.000D-01, 4.000D-02, 6.400D-01,-6.000D-02, 4.500D-01,
32059      & 5.000D-02, 2.600D-01,-2.200D-01, 3.900D-01, 0.000D+00, 3.900D-01/
32060        DATA ( SZCOOK(I),I =  1, 98) /
32061      & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32062      & 0.000D+00, 0.000D+00,-1.100D-01,-8.100D-01,-2.910D+00,-4.170D+00,
32063      &-5.720D+00,-7.800D+00,-8.970D+00,-9.700D+00,-1.010D+01,-1.070D+01,
32064      &-1.138D+01,-1.207D+01,-1.255D+01,-1.324D+01,-1.393D+01,-1.471D+01,
32065      &-1.553D+01,-1.637D+01,-1.736D+01,-1.860D+01,-1.870D+01,-1.801D+01,
32066      &-1.787D+01,-1.708D+01,-1.660D+01,-1.675D+01,-1.650D+01,-1.635D+01,
32067      &-1.622D+01,-1.641D+01,-1.689D+01,-1.643D+01,-1.668D+01,-1.673D+01,
32068      &-1.745D+01,-1.729D+01,-1.744D+01,-1.782D+01,-1.862D+01,-1.827D+01,
32069      &-1.939D+01,-1.991D+01,-1.914D+01,-1.826D+01,-1.740D+01,-1.642D+01,
32070      &-1.577D+01,-1.437D+01,-1.391D+01,-1.310D+01,-1.311D+01,-1.143D+01,
32071      &-1.089D+01,-1.075D+01,-1.062D+01,-1.041D+01,-1.021D+01,-9.850D+00,
32072      &-9.470D+00,-9.030D+00,-8.610D+00,-8.130D+00,-7.460D+00,-7.480D+00,
32073      &-7.200D+00,-7.130D+00,-7.060D+00,-6.780D+00,-6.640D+00,-6.640D+00,
32074      &-7.680D+00,-7.890D+00,-8.410D+00,-8.490D+00,-7.880D+00,-6.300D+00,
32075      &-5.470D+00,-4.780D+00,-4.370D+00,-4.170D+00,-4.130D+00,-4.320D+00,
32076      &-4.550D+00,-5.040D+00,-5.280D+00,-6.060D+00,-6.280D+00,-6.870D+00,
32077      &-7.200D+00,-7.740D+00/
32078        DATA ( SNCOOK(I),I =  1, 90 ) /
32079      & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32080      & 0.000D+00, 0.000D+00, 1.030D+01, 5.660D+00, 6.800D+00, 7.530D+00,
32081      & 7.550D+00, 7.210D+00, 7.440D+00, 8.070D+00, 8.940D+00, 9.810D+00,
32082      & 1.060D+01, 1.139D+01, 1.254D+01, 1.368D+01, 1.434D+01, 1.419D+01,
32083      & 1.383D+01, 1.350D+01, 1.300D+01, 1.213D+01, 1.260D+01, 1.326D+01,
32084      & 1.413D+01, 1.492D+01, 1.552D+01, 1.638D+01, 1.716D+01, 1.755D+01,
32085      & 1.803D+01, 1.759D+01, 1.903D+01, 1.871D+01, 1.880D+01, 1.899D+01,
32086      & 1.846D+01, 1.825D+01, 1.776D+01, 1.738D+01, 1.672D+01, 1.562D+01,
32087      & 1.438D+01, 1.288D+01, 1.323D+01, 1.381D+01, 1.490D+01, 1.486D+01,
32088      & 1.576D+01, 1.620D+01, 1.762D+01, 1.773D+01, 1.816D+01, 1.867D+01,
32089      & 1.969D+01, 1.951D+01, 2.017D+01, 1.948D+01, 1.998D+01, 1.983D+01,
32090      & 2.020D+01, 1.972D+01, 1.987D+01, 1.924D+01, 1.844D+01, 1.761D+01,
32091      & 1.710D+01, 1.616D+01, 1.590D+01, 1.533D+01, 1.476D+01, 1.354D+01,
32092      & 1.263D+01, 1.065D+01, 1.010D+01, 8.890D+00, 1.025D+01, 9.790D+00,
32093      & 1.139D+01, 1.172D+01, 1.243D+01, 1.296D+01, 1.343D+01, 1.337D+01/
32094        DATA ( SNCOOK(I),I = 91, INCOOK ) /
32095      & 1.296D+01, 1.211D+01, 1.192D+01, 1.100D+01, 1.080D+01, 1.042D+01,
32096      & 1.039D+01, 9.690D+00, 9.270D+00, 8.930D+00, 8.570D+00, 8.020D+00,
32097      & 7.590D+00, 7.330D+00, 7.230D+00, 7.050D+00, 7.420D+00, 6.750D+00,
32098      & 6.600D+00, 6.380D+00, 6.360D+00, 6.490D+00, 6.250D+00, 5.850D+00,
32099      & 5.480D+00, 4.530D+00, 4.300D+00, 3.390D+00, 2.350D+00, 1.660D+00,
32100      & 8.100D-01, 4.600D-01,-9.600D-01,-1.690D+00,-2.530D+00,-3.160D+00,
32101      &-1.870D+00,-4.100D-01, 7.100D-01, 1.660D+00, 2.620D+00, 3.220D+00,
32102      & 3.760D+00, 4.100D+00, 4.460D+00, 4.830D+00, 5.090D+00, 5.180D+00,
32103      & 5.170D+00, 5.100D+00, 5.010D+00, 4.970D+00, 5.090D+00, 5.030D+00,
32104      & 4.930D+00, 5.280D+00, 5.490D+00, 5.500D+00, 5.370D+00, 5.300D+00/
32105       DATA LDEFOZ / 53*.FALSE.,25*.TRUE.,7*.FALSE.,13*.TRUE. /
32106       DATA LDEFON / 85*.FALSE.,37*.TRUE.,7*.FALSE.,21*.TRUE. /
32107 *=== End of Block Data Bdevap =========================================*
32108       END
32109
32110 *$ CREATE DT_BDNOPT.FOR
32111 *COPY DT_BDNOPT
32112 *
32113 *=== bdnopt ===========================================================*
32114 *==                                                                    *
32115       BLOCK DATA DT_BDNOPT
32116
32117 C     INCLUDE '(DBLPRC)'
32118 * DBLPRC.ADD
32119       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32120       SAVE
32121 * (original name: GLOBAL)
32122       PARAMETER ( KALGNM = 2 )
32123       PARAMETER ( ANGLGB = 5.0D-16 )
32124       PARAMETER ( ANGLSQ = 2.5D-31 )
32125       PARAMETER ( AXCSSV = 0.2D+16 )
32126       PARAMETER ( ANDRFL = 1.0D-38 )
32127       PARAMETER ( AVRFLW = 1.0D+38 )
32128       PARAMETER ( AINFNT = 1.0D+30 )
32129       PARAMETER ( AZRZRZ = 1.0D-30 )
32130       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32131       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32132       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32133       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32134       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
32135       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
32136       PARAMETER ( CSNNRM = 2.0D-15 )
32137       PARAMETER ( DMXTRN = 1.0D+08 )
32138       PARAMETER ( ZERZER = 0.D+00 )
32139       PARAMETER ( ONEONE = 1.D+00 )
32140       PARAMETER ( TWOTWO = 2.D+00 )
32141       PARAMETER ( THRTHR = 3.D+00 )
32142       PARAMETER ( FOUFOU = 4.D+00 )
32143       PARAMETER ( FIVFIV = 5.D+00 )
32144       PARAMETER ( SIXSIX = 6.D+00 )
32145       PARAMETER ( SEVSEV = 7.D+00 )
32146       PARAMETER ( EIGEIG = 8.D+00 )
32147       PARAMETER ( ANINEN = 9.D+00 )
32148       PARAMETER ( TENTEN = 10.D+00 )
32149       PARAMETER ( HLFHLF = 0.5D+00 )
32150       PARAMETER ( ONETHI = ONEONE / THRTHR )
32151       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32152       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32153       PARAMETER ( THRTWO = THRTHR / TWOTWO )
32154       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32155       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32156       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32157       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32158       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32159       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32160       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32161       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
32162       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
32163       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
32164       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
32165       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32166       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32167       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32168       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32169       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32170       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32171       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32172       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32173       PARAMETER ( CLIGHT = 2.99792458         D+10 )
32174       PARAMETER ( AVOGAD = 6.0221367          D+23 )
32175       PARAMETER ( BOLTZM = 1.380658           D-23 )
32176       PARAMETER ( AMELGR = 9.1093897          D-28 )
32177       PARAMETER ( PLCKBR = 1.05457266         D-27 )
32178       PARAMETER ( ELCCGS = 4.8032068          D-10 )
32179       PARAMETER ( ELCMKS = 1.60217733         D-19 )
32180       PARAMETER ( AMUGRM = 1.6605402          D-24 )
32181       PARAMETER ( AMMUMU = 0.113428913        D+00 )
32182       PARAMETER ( AMPRMU = 1.007276470        D+00 )
32183       PARAMETER ( AMNEMU = 1.008664904        D+00 )
32184       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32185       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32186       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32187       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32188       PARAMETER ( PLABRC = 0.197327053        D+00 )
32189       PARAMETER ( AMELCT = 0.51099906         D-03 )
32190       PARAMETER ( AMUGEV = 0.93149432         D+00 )
32191       PARAMETER ( AMMUON = 0.105658389        D+00 )
32192       PARAMETER ( AMPRTN = 0.93827231         D+00 )
32193       PARAMETER ( AMNTRN = 0.93956563         D+00 )
32194       PARAMETER ( AMDEUT = 1.87561339         D+00 )
32195       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32196      &                   * 1.D-09 )
32197       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32198       PARAMETER ( BLTZMN = 8.617385           D-14 )
32199       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32200       PARAMETER ( GFOHB3 = 1.16639            D-05 )
32201       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32202       PARAMETER ( SIN2TW = 0.2319             D+00 )
32203       PARAMETER ( GEVMEV = 1.0                D+03 )
32204       PARAMETER ( EMVGEV = 1.0                D-03 )
32205       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
32206       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32207       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32208       LOGICAL LGBIAS, LGBANA
32209       COMMON /FKGLOB/ LGBIAS, LGBANA
32210 C     INCLUDE '(DIMPAR)'
32211 * DIMPAR.ADD
32212       PARAMETER ( MXXRGN = 5000 )
32213       PARAMETER ( MXXMDF = 82   )
32214       PARAMETER ( MXXMDE = 54   )
32215       PARAMETER ( MFSTCK = 1000 )
32216       PARAMETER ( MESTCK = 100  )
32217       PARAMETER ( NELEMX = 80   )
32218       PARAMETER ( MPDPDX = 8    )
32219       PARAMETER ( ICOMAX = 180  )
32220       PARAMETER ( NSTBIS = 304  )
32221       PARAMETER ( IDMAXP = 220  )
32222       PARAMETER ( IDMXDC = 640  )
32223       PARAMETER ( MKBMX1 = 1    )
32224       PARAMETER ( MKBMX2 = 1    )
32225 C     INCLUDE '(IOUNIT)'
32226 * IOUNIT.ADD
32227       PARAMETER ( LUNIN  =  5 )
32228       PARAMETER ( LUNOUT =  6 )
32229 **sr 19.5. set error output-unit from 15 to 6
32230       PARAMETER ( LUNERR = 6  )
32231       PARAMETER ( LUNBER = 14 )
32232       PARAMETER ( LUNECH =  8 )
32233       PARAMETER ( LUNFLU = 13 )
32234       PARAMETER ( LUNGEO = 16 )
32235       PARAMETER ( LUNPMF = 12 )
32236       PARAMETER ( LUNRAN =  2 )
32237       PARAMETER ( LUNXSC =  9 )
32238       PARAMETER ( LUNDET = 17 )
32239       PARAMETER ( LUNRAY = 10 )
32240       PARAMETER ( LUNRDB =  1 )
32241       PARAMETER ( LUNPGO =  7 )
32242       PARAMETER ( LUNPGS =  4 )
32243       PARAMETER ( LUNSCR =  3 )
32244 *
32245 *----------------------------------------------------------------------*
32246 *                                                                      *
32247 *   Created on  20 september 1989    by  Alfredo Ferrari - Infn Milan  *
32248 *                                                                      *
32249 *         Last change on 20-apr-95   by  Alfredo Ferrari               *
32250 *                                                                      *
32251 *----------------------------------------------------------------------*
32252 *
32253 C     INCLUDE '(BLNKCM)'
32254 * BLNKCM.ADD
32255 **sr 17.5. commented since not used here
32256 C     PARAMETER ( NBLNMX = 1100000 )
32257 C     DIMENSION GMSTOR ( NBLNMX ), BRMBRR ( NBLNMX ), BRMEXP ( NBLNMX ),
32258 C    &          BRMSIG ( NBLNMX ), SIGGTT ( KALGNM*NBLNMX ),
32259 C    &          COMSCO ( NBLNMX ), LBSTOR ( KALGNM*NBLNMX )
32260 C     REAL SIGGTT
32261 C     LOGICAL LBSTOR
32262 C     COMMON   NSTOR  ( KALGNM*NBLNMX )
32263 **
32264 **sr 18.5. commented since not used for evap.
32265 C     COMMON / ADDRCM / MBLNMX, KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST,
32266 C    &                  KISBGN, KISLST, KDTBGN, KDTLST, KUBBGN, KUBLST,
32267 C    &                  KUXBGN, KUXLST, KTCBGN, KTCLST, KRNBGN, KRNLST,
32268 C    &                  KYLBGN, KYLLST, KXSBGN, KXSLST, KIHBGN, KIHLST,
32269 C    &                  KINBGN, KINLST, KIEBGN, KIELST, KETBGN, KETLST,
32270 C    &                  KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32271 C    &                  KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST,
32272 C    &                  KWLBGN, KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST,
32273 C    &                  KWSBGN, KWSLST, KNDBGN, KNDLST, KDPBGN, KDPLST,
32274 C    &                  KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN, KBRLST,
32275 C    &                  KTMBGN
32276 **
32277
32278 C     EQUIVALENCE ( NSTOR (1), GMSTOR (1) )
32279 C     EQUIVALENCE ( NSTOR (1), BRMBRR (1) )
32280 C     EQUIVALENCE ( NSTOR (1), BRMEXP (1) )
32281 C     EQUIVALENCE ( NSTOR (1), BRMSIG (1) )
32282 C     EQUIVALENCE ( NSTOR (1), COMSCO (1) )
32283 C     EQUIVALENCE ( NSTOR (1), SIGGTT (1) )
32284 C     EQUIVALENCE ( NSTOR (1), LBSTOR (1) )
32285 C     INCLUDE '(BLNTMP)'
32286 * BLNTMP.ADD
32287 **sr 18.5. commented since not used for evap.
32288 C     COMMON / BLNTMP / KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM,
32289 C    &                  KGCBTM, KGDWTM, KBDWTM, KWLOTM, KWHITM, KWMUTM,
32290 C    &                  KWSHTM, KEXTTM, KSTXTM, KSTNTM, KECTTM, KPCTTM,
32291 C    &                  KLPBTM, NXXRGN
32292 **
32293 C     INCLUDE '(CMMDNR)'
32294 * CMMDNR.ADD
32295 **sr 18.5. commented since not used for evap.
32296 C     LOGICAL LFLDNR
32297 C     COMMON / CMMDNR / DDNEAR, LFLDNR
32298 **
32299 C     INCLUDE '(CTITLE)'
32300 * CTITLE.ADD
32301 **sr 18.5. commented since not used for evap.
32302 C     CHARACTER RUNTIT*80, RUNTIM*32, RUNKEY*10
32303 C     COMMON / CTITLE / RUNTIT, RUNTIM, RUNKEY
32304 C     COMMON / CEXPCK / ITEXPI, ITEXMX
32305 **
32306 C     INCLUDE '(DETECT)'
32307 * DETECT.ADD
32308 **sr 18.5. commented since not used for evap.
32309 C     PARAMETER (NRGNMX = 10)
32310 C     PARAMETER (NDTCMX = 10)
32311 C     PARAMETER (NSCRMX = 10)
32312 C     PARAMETER (NDTBIN = 1024)
32313 C     CHARACTER*10 TITDET,TITSCO
32314 C     LOGICAL LDTCTR
32315 C     COMMON /DETCT/  EDTMIN(NDTCMX), EDTBIN(NDTCMX), EDTCUT(NDTCMX),
32316 C    &                KDTREG(NRGNMX,NDTCMX), KDTDET(NDTCMX,NSCRMX),
32317 C    &                NDTSCO, NDTDET, LDTCTR, IDTREG(MXXRGN),
32318 C    &                KDTSCD(NSCRMX)
32319 C     COMMON /DETCH/  TITDET(NDTCMX), TITSCO(NSCRMX)
32320 **
32321 C     INCLUDE '(DETLOC)'
32322 * DETLOC.ADD
32323 **sr 18.5. commented since not used for evap.
32324 C     PARAMETER (NDTCM2 = 10)
32325 C     COMMON /DETLOC/ ACCUMP (NDTCM2), ACCUMN (NDTCM2),
32326 C    &                ICOINC(NDTCM2), NCLAS
32327 **
32328 C     INCLUDE '(EMGTRN)'
32329 * EMGTRN.ADD
32330 **sr 18.5. commented since not used for evap.
32331 C     LOGICAL LMCSMG
32332 C     COMMON / EMGTRN / UMCSMG, VMCSMG, WMCSMG, LMCSMG
32333 **
32334 C     INCLUDE '(EMSHO)'
32335 * EMSHO.ADD
32336 **sr 18.5. commented since not used for evap.
32337 C     LOGICAL EMFLO, EMFHLO, EMFELO, LIMPRE, LEXPTE
32338 C     COMMON /EMSHO/ EMFETH, EMFPTH, EMFHET, EMFHPT, EMFBIA, EMFLO,
32339 C    &               EMFHLO, EMFELO, LIMPRE, LEXPTE
32340 **
32341 C     INCLUDE '(EPISOR)'
32342 * EPISOR.ADD
32343 **sr 18.5. commented since not used for evap.
32344 C     LOGICAL LUSSRC
32345 C     COMMON/EPISOR/TKESUM,LUSSRC
32346 **
32347 * (original name: FHEAVY,FHEAVC)
32348       PARAMETER ( MXHEAV = 100 )
32349       CHARACTER*8 ANHEAV
32350       COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
32351      &                CZHEAV (MXHEAV), TKHEAV (MXHEAV),
32352      &                PHEAVY (MXHEAV), WHEAVY (MXHEAV),
32353      &                AMHEAV  ( 12 ) , AMNHEA  ( 12 ) ,
32354      &                KHEAVY (MXHEAV), ICHEAV  ( 12 ) ,
32355      &                IBHEAV  ( 12 ) , NPHEAV
32356       COMMON /FKFHVC/ ANHEAV  ( 12 )
32357 * (original name: FINUC)
32358       PARAMETER (MXP=999)
32359       COMMON /FKFINU/ CXR    (MXP), CYR    (MXP), CZR    (MXP),
32360      &                CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
32361      &                TKI    (MXP), PLR    (MXP), WEI    (MXP),
32362      &                TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
32363      &                KPART  (MXP)
32364 C     INCLUDE '(GENTHR)'
32365 * GENTHR.ADD
32366 **sr 18.5. commented since not used for evap.
32367 C     COMMON / GENTHR / PEANCT, PEAPIT, PLDNCT, PTHRSH (NALLWP),
32368 C    &                  PTHDFF (NALLWP), IJNUCR (NALLWP)
32369 **
32370 C     INCLUDE '(LOWNEU)'
32371 * LOWNEU.ADD
32372 **sr 18.5. commented since not used for evap.
32373 C     PARAMETER ( MXGTHN =  15 )
32374 C     PARAMETER ( MXGLWN = 200 )
32375 C     PARAMETER ( MXSHPP =   5 )
32376 C     LOGICAL LCOMPN, LIMPRN, LBIASN, LDOWNN, LRECPR, LLOWWW, LLOWET
32377 C     CHARACTER*10 TITLOW
32378 C     COMMON / LOWNEU / ATOLOW (MXXMDF), WSHPLN (MXGLWN,MXSHPP), EXTWWL,
32379 C    &                  SHPIMP (MXGLWN), EXTETL (MXGLWN), WWAMFL,
32380 C    &                  VLLNTH (MXGTHN,MXXMDF), ABLNTH (MXGTHN,MXXMDF),
32381 C    &                  STLNTH (MXGTHN,MXXMDF), TMRTLN (MXXMDF),
32382 C    &                  TMNMLN (MXXMDF), ICHCPT (MXXMDF),
32383 C    &                  IGTMRT (MXXMDF), NEUMED (MXXMDF),
32384 C    &                  ID1MED (MXXMDF), ID2MED (MXXMDF),
32385 C    &                  ID3MED (MXXMDF), MGTMED (MXXMDF),
32386 C    &                  LCOMPN (MXXMDF), LRECPR (MXXMDF), KPRLOW, NMGP,
32387 C    &                  NMTG  , IGRTHN, LIMPRN, LBIASN, LDOWNN, LLOWWW,
32388 C    &                  LLOWET, ICLMED, IKRBGN, INABGN, IDWBGN, IETBGN,
32389 C    &                  I0XSEC, IDXSEC, ISENAV, ISVELN, ISPNAV, IWWLWB,
32390 C    &                  IWWLWT, IPXBGN, NPXSEC
32391 C     COMMON / CHLWNT / TITLOW (MXXMDF)
32392 **
32393 C     INCLUDE '(LTCLCM)'
32394 * LTCLCM.ADD
32395 **sr 18.5. commented since not used for evap.
32396 C     COMMON / LTCLCM / MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1
32397 **
32398 C     INCLUDE '(MULBOU)'
32399 * MULBOU.ADD
32400 **sr 18.5. commented since not used for evap.
32401 C     LOGICAL LLDA  , LAGAIN, LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32402 C     COMMON / MULBOU / UOLD  , VOLD  , WOLD  , UMAG  , VMAG  , WMAG  ,
32403 C    &                  UNORML, VNORML, WNORML, USENSE, VSENSE, WSENSE,
32404 C    &                  TSENSE, DDSENS, DSMALL, NSSENS, LLDA  , LAGAIN,
32405 C    &                  LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32406 **
32407 C     INCLUDE '(MULHD)'
32408 * MULHD.ADD
32409 **sr 18.5. commented since not used for evap.
32410 C     PARAMETER ( MXXPT1 = 1 )
32411 C     PARAMETER ( TIMESS = 2.00D+00 )
32412 C     PARAMETER ( TMSRLX = 1.50D+00 )
32413 C     PARAMETER ( EPSINS = 0.15D+00 )
32414 C     PARAMETER ( EPSRLX = 0.50D+00 )
32415 C     PARAMETER ( SQEPSN = 0.3872983346207417 D+00 )
32416 C     PARAMETER ( SQEPSR = 0.7071067811865475 D+00 )
32417 C     PARAMETER ( PARNSI = 1.732050807568877 D+00 * SQEPSN )
32418 C     PARAMETER ( PRNSR0 = 1.732050807568877 D+00 * SQEPSR )
32419 C     PARAMETER ( R0NCMS = 1.20 D+00 )
32420 C     LOGICAL LTOPT, LSRCRH, LNSCRH
32421 C     COMMON / MULHD / BLCC   ( MXXMDF ), BLCCRA ( MXXMDF ),
32422 C    &                 XCC    ( MXXMDF ), ZTILDE ( MXXMDF, 0:MXXPT1 ),
32423 C    &                 ALPZTL ( MXXMDF, 0:MXXPT1 ), RLDU   ( MXXMDF ),
32424 C    &                 ALPZT2 ( MXXMDF, 0:MXXPT1 ), TEFF0  ( MXXMDF ),
32425 C    &                 XR0    ( MXXMDF ), ECUTM  ( MXXMDF, 39, 2 ),
32426 C    &                 ESTEPF ( MXXMDF ), HTHNSZ ( MXXMDF, 39 ),
32427 C    &                 AE1O3  ( MXXMDF ), PARNSR ( MXXMDF ),
32428 C    &                 HEESLI ( MXXMDF ), THMSPR, THMSSC, HMSAMP,
32429 C    &                 HMREJE, LSRCRH ( MXXMDF ), LNSCRH ( MXXMDF ),
32430 C    &                 LTOPT  ( MXXMDF ), NFSCAT
32431 **
32432 * (original name: PAREVT)
32433       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
32434      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
32435       PARAMETER ( NALLWP = 39   )
32436       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
32437      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
32438      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
32439      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
32440 * (original name: RESNUC)
32441       LOGICAL LRNFSS, LFRAGM
32442       COMMON /FKRESN/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
32443      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
32444      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
32445      &                  PYRES,  PZRES, PTRES2,  KTARP,  KTARN, IGREYP,
32446      &                 IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
32447      &                  ICRES,  IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
32448      &                 IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
32449      &                  IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
32450      &                 LFRAGM
32451 C     INCLUDE '(SCOHLP)'
32452 * SCOHLP.ADD
32453 **sr 18.5. commented since not used for evap.
32454 C     LOGICAL LSCZER
32455 C     COMMON / SCOHLP / ISCRNG, JSCRNG, LSCZER
32456 **
32457 C     INCLUDE '(TRACKR)'
32458 * TRACKR.ADD
32459 **sr 18.5. commented since not used for evap.
32460 C     PARAMETER ( MXTRCK = 2500 )
32461 C     LOGICAL LFSSSC
32462 C     COMMON / TRACKR /  XTRACK ( 0:MXTRCK ), YTRACK ( 0:MXTRCK ),
32463 C    &                   ZTRACK ( 0:MXTRCK ), TTRACK   ( MXTRCK ),
32464 C    &                   DTRACK   ( MXTRCK ), ETRACK, PTRACK, WTRACK,
32465 C    &                   ATRACK, CTRACK, AKSHRT, AKLONG, WSCRNG,
32466 C    &                   NTRACK, MTRACK, JTRACK, KTRACK, MMTRCK,
32467 C    &                   LT1TRK, LT2TRK, LTRACK, LLOUSE, LFSSSC
32468 **
32469 C     INCLUDE '(USRBDX)'
32470 * USRBDX.ADD
32471 **sr 18.5. commented since not used for evap.
32472 C     PARAMETER ( MXUSBX = 600 )
32473 C     LOGICAL LUSBDX, LFUSBX, LWUSBX, LLNUSX
32474 C     CHARACTER*10 TITUSX
32475 C     COMMON /USRBX/  EBXLOW(MXUSBX), EBXHGH(MXUSBX), ABXLOW(MXUSBX),
32476 C    &                ABXHGH(MXUSBX), DEBXBN(MXUSBX), DABXBN(MXUSBX),
32477 C    &                AUSBDX(MXUSBX),
32478 C    &                NEBXBN(MXUSBX), NABXBN(MXUSBX), NR1USX(MXUSBX),
32479 C    &                NR2USX(MXUSBX), ITUSBX(MXUSBX), IDUSBX(MXUSBX),
32480 C    &                KBUSBX(MXUSBX), IPUSBX(MXUSBX), IGMUSX(MXUSBX),
32481 C    &                LFUSBX(MXUSBX), LWUSBX(MXUSBX), LLNUSX(MXUSBX),
32482 C    &                NUSRBX, LUSBDX
32483 C     COMMON /USXCH/  TITUSX(MXUSBX)
32484 **
32485 C     INCLUDE '(USRBIN)'
32486 * USRBIN.ADD
32487 **sr 18.5. commented since not used for evap.
32488 C     PARAMETER ( MXUSBN = 100 )
32489 C     LOGICAL LUSBIN, LEVTBN, LNTZER, LUSEVT, LUSTKB, LTRKBN
32490 C     CHARACTER*10 TITUSB
32491 C     COMMON /USRBN/  XLOW  (MXUSBN), XHIGH (MXUSBN), YLOW  (MXUSBN),
32492 C    &                YHIGH (MXUSBN), ZLOW  (MXUSBN), ZHIGH (MXUSBN),
32493 C    &                DXUSBN(MXUSBN), DYUSBN(MXUSBN), DZUSBN(MXUSBN),
32494 C    &                TCUSBN(MXUSBN), BKUSBN(MXUSBN), B2USBN(MXUSBN),
32495 C    &                NXBIN (MXUSBN), NYBIN (MXUSBN), NZBIN (MXUSBN),
32496 C    &                ITUSBN(MXUSBN), IDUSBN(MXUSBN), KBUSBN(MXUSBN),
32497 C    &                IPUSBN(MXUSBN), LEVTBN(MXUSBN), LNTZER(MXUSBN),
32498 C    &                LTRKBN(MXUSBN), NUSRBN, LUSBIN, LUSEVT, LUSTKB
32499 C     COMMON /USRCH/  TITUSB(MXUSBN)
32500 **
32501 C     INCLUDE '(USRSNC)'
32502 * USRSNC.ADD
32503 **sr 18.5. commented since not used for evap.
32504 C     PARAMETER ( MXRSNC = 400 )
32505 C     PARAMETER ( NMZMIN =  -5 )
32506 C     LOGICAL LURSNC
32507 C     CHARACTER*10 TIURSN
32508 C     COMMON /USRSNC/  VURSNC(MXRSNC), IZRHGH(MXRSNC), IMRHGH(MXRSNC),
32509 C    &                 NRURSN(MXRSNC), ITURSN(MXRSNC), KBURSN(MXRSNC),
32510 C    &                 IPURSN(MXRSNC), NURSNC, LURSNC
32511 C     COMMON /USRSCH/  TIURSN(MXRSNC)
32512 C     INCLUDE '(USRTRC)'
32513 * USRTRC.ADD
32514 **sr 18.5. commented since not used for evap.
32515 C     PARAMETER ( MXUSTC = 400 )
32516 C     LOGICAL LUSRTC, LUSTRK, LUSCLL, LLNUTC
32517 C     CHARACTER*10 TITUTC
32518 C     COMMON /USRTC/  ETCLOW(MXUSTC), ETCHGH(MXUSTC), DETCBN(MXUSTC),
32519 C    &                VUSRTC(MXUSTC),
32520 C    &                IUSTRK(MXUSTC), IUSCLL(MXUSTC), NETCBN(MXUSTC),
32521 C    &                NRUSTC(MXUSTC), ITUSTC(MXUSTC), IDUSTC(MXUSTC),
32522 C    &                KBUSTC(MXUSTC), IPUSTC(MXUSTC), IGMUTC(MXUSTC),
32523 C    &                LLNUTC(MXUSTC), NUSRTC, NUSTRK, NUSCLL, LUSRTC,
32524 C    &                LUSTRK, LUSCLL
32525 C     COMMON /USTCH/  TITUTC(MXUSTC)
32526 **
32527 C     INCLUDE '(USRYLD)'
32528 * USRYLD.ADD
32529 **sr 18.5. commented since not used for evap.
32530 C     PARAMETER ( MXUSYL = 500 )
32531 C     LOGICAL LUSRYL, LLNUYL, LSCUYL
32532 C     CHARACTER*10 TITUYL
32533 C     COMMON /USRYL/  EYLLOW(MXUSYL), EYLHGH(MXUSYL), DEYLBN(MXUSYL),
32534 C    &                USNRYL(MXUSYL), SGUSYL(MXUSYL), AYLLOW(MXUSYL),
32535 C    &                AYLHGH(MXUSYL), PUSRYL, UUSRYL, VUSRYL, WUSRYL,
32536 C    &                ETXUYL, ETYUYL, ETZUYL, GAMUYL, SQSUYL, UCMUYL,
32537 C    &                VCMUYL, WCMUYL, IJUSYL, JTUSYL,
32538 C    &                NEYLBN(MXUSYL), NR1UYL(MXUSYL), NR2UYL(MXUSYL),
32539 C    &                IXUSYL(MXUSYL), ITUSYL(MXUSYL), IDUSYL(MXUSYL),
32540 C    &                KBUSYL(MXUSYL), IPUSYL(MXUSYL), IGMUYL(MXUSYL),
32541 C    &                IEUSYL(MXUSYL), IAUSYL(MXUSYL), LLNUYL(MXUSYL),
32542 C    &                NUSRYL, LUSRYL, LSCUYL
32543 C     COMMON /USYCH/  TITUYL(MXUSYL)
32544 **
32545 C     INCLUDE '(WWINDW)'
32546 * WWINDW.ADD
32547 **sr 18.5. commented since not used for evap.
32548 C     PARAMETER ( MXWWSP = 3 )
32549 C     PARAMETER ( WWSPMX = 50.D+00 )
32550 C     LOGICAL LWWNDW, LWWPRM
32551 C     COMMON / WWINDW / ETHWW1 (NALLWP), ETHWW2 (NALLWP),
32552 C    &                  WWEXWD (NALLWP), EXTWWN (NALLWP),
32553 C    &                  IWLBGN, IWHBGN, IWMBGN, LWWNDW, LWWPRM
32554 **
32555
32556 * /blnkcm/
32557 * *** If blank common dimension has to be superseded substitute in the
32558 * *** following two lines the new dimension in real*8 units to Nblnmx
32559 **sr 18.5. commented since not used for evap.
32560 C     PARAMETER (MXDUMM = KALGNM * NBLNMX)
32561 C     DATA KTMBGN / NBLNMX /
32562 C     DATA MBLNMX / MXDUMM /
32563 C     DATA KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST, KISBGN, KISLST,
32564 C    &     KDTBGN, KDTLST, KUBBGN, KUBLST, KUXBGN, KUXLST, KTCBGN,
32565 C    &     KTCLST, KRNBGN, KRNLST, KYLBGN, KYLLST, KXSBGN, KXSLST,
32566 C    &     KIHBGN, KIHLST, KINBGN, KINLST, KIEBGN, KIELST, KETBGN,
32567 C    &     KETLST, KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32568 C    &     KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST, KWLBGN,
32569 C    &     KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST, KWSBGN, KWSLST,
32570 C    &     KDPBGN, KDPLST, KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN,
32571 C    &     KBRLST / 57*0 /
32572
32573 * /blntmp/
32574 **sr 18.5. commented since not used for evap.
32575 C     DATA KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM, KGDWTM,
32576 C    &     KBDWTM, KGCBTM, KWLOTM, KWHITM, KWMUTM, KWSHTM, KEXTTM,
32577 C    &     KSTXTM, KSTNTM, KECTTM, KPCTTM, KLPBTM / 19*0 /
32578
32579 * /cmmdnr/
32580 **sr 18.5. commented since not used for evap.
32581 C     DATA DDNEAR / 0.D+00 /, LFLDNR / .FALSE. /
32582
32583 * /ctitle/
32584 **sr 18.5. commented since not used for evap.
32585 C     DATA RUNTIT (1:40) / '****************************************' /
32586 C     DATA RUNTIT(41:80) / '****************************************' /
32587 C     DATA ITEXPI, ITEXMX / 100000000, 150 /
32588 * /detect/
32589 **sr 18.5. commented since not used for evap.
32590 C     PARAMETER (NNN1 = NRGNMX*NDTCMX)
32591 C     PARAMETER (NNN2 = NSCRMX*NDTCMX)
32592 C     DATA LDTCTR /.FALSE./, NDTSCO /0/, NDTDET /0/
32593 C     DATA EDTMIN/NDTCMX*0.D0/, EDTBIN/NDTCMX*0.D0/, EDTCUT/NDTCMX*0.D0/
32594 C     DATA KDTREG/NNN1*0/, KDTDET/NNN2*0/, KDTSCD/NSCRMX*0/
32595 C     DATA TITDET/NDTCMX*'          '/, TITSCO/NSCRMX*'          '/
32596
32597 * /detloc/
32598 **sr 18.5. commented since not used for evap.
32599 C     DATA ACCUMP /NDTCM2*0.D0/, ACCUMN /NDTCM2*0.D0/, ICOINC /NDTCM2*0/
32600 C     DATA NCLAS /0/
32601
32602 * /emgtrn/
32603 **sr 18.5. commented since not used for evap.
32604 C     DATA LMCSMG / .FALSE. /
32605
32606 * /emsho/
32607 **sr 18.5. commented since not used for evap.
32608 C     DATA LIMPRE, LEXPTE / 2 * .FALSE. /
32609
32610 * /episor/
32611 **sr 18.5. commented since not used for evap.
32612 C     DATA TKESUM / 0.D+00 /, LUSSRC / .FALSE. /
32613
32614 * /fheavy/
32615       DATA AMHEAV / 12 * 0.D+00 /
32616       DATA ANHEAV / 'NEUTRON ', 'PROTON  ', 'DEUTERON', '3-H     ',
32617      &              '3-He    ', '4-He    ', 'H-FRAG-1', 'H-FRAG-2',
32618      &              'H-FRAG-3', 'H-FRAG-4', 'H-FRAG-5', 'H-FRAG-6'/
32619       DATA ICHEAV / 0, 1, 1, 1, 2, 2, 6*0 /,
32620      &     IBHEAV / 1, 1, 2, 3, 3, 4, 6*0 /
32621       DATA NPHEAV / 0 /
32622
32623 * /finuc/
32624       DATA NP / 0 /, TV / 0.D+00 /, TVCMS / 0.D+00 /, TVRECL / 0.D+00/,
32625      &     TVHEAV / 0.D+00 /, TVBIND / 0.D+00 /
32626
32627 * /genthr/
32628 * Up to 20-apr-'95
32629 *     DATA PEANCT, PEAPIT / 2*1.D+00 /
32630 *     DATA PTHRSH / 16*5.D+00,2*2.5D+00,5.D+00,3*2.5D+00,8*5.D+00,
32631 *    &              9*2.5D+00 /
32632 *     DATA PTHDFF / 39*5.D+00 /
32633 *    &              9*2.5D+00 /
32634 * New values:
32635 **sr 18.5. commented since not used for evap.
32636 C     DATA PEANCT, PEAPIT / 1.3D+00, 1.1D+00 /
32637 C     DATA PTHRSH / 12*5.D+00, 2*3.5D+00, 2*5.D+00, 2*2.5D+00, 5.D+00,
32638 C    &              3*2.5D+00, 3.5D+00, 2*5.D+00, 3.5D+00, 4*5.D+00,
32639 C    &              9*2.5D+00 /
32640 C     DATA PTHDFF / 12*5.D+00, 2*3.5D+00, 8*5.D+00, 3.5D+00, 2*5.D+00,
32641 C    &              3.5D+00, 13*5.D+00 /
32642 C     DATA PLDNCT / 0.26D+00 /
32643 C     DATA IJNUCR / 16*1, 2*0, 1, 3*0, 8*1, 9*0 /
32644
32645 * /lowneu/
32646 **sr 18.5. commented since not used for evap.
32647 C     DATA WWAMFL / 10.D+00 /, EXTWWL / 1.D+00 /
32648 C     DATA IWWLWB, IWWLWT / 2 * 100000000 /
32649 C     DATA ICLMED, INABGN, IDWBGN, IETBGN / 4*0 /
32650 C     DATA IGRTHN / 1 /
32651 C     DATA LIMPRN / .FALSE. /, LBIASN / .FALSE. /, LDOWNN / .FALSE. /,
32652 C    &     LLOWWW / .FALSE. /, LLOWET / .FALSE. /
32653
32654 * /ltclcm/
32655 **sr 18.5. commented since not used for evap.
32656 C     DATA MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1 / 6*0 /
32657
32658 * /mulbou/
32659 **sr 18.5. commented since not used for evap.
32660 C     DATA LLDA, LAGAIN, LSTNEW, LARTEF, LSENSE, LNORML, LMGNOR
32661 C    &     / 7 * .FALSE. /
32662 C     DATA TSENSE / AINFNT /, NSSENS / -1 /
32663 C     DATA DSMALL / ANGLGB /
32664
32665 * /mulhd/
32666 **sr 18.5. commented since not used for evap.
32667 C     DATA LTOPT  / MXXMDF * .FALSE. /, NFSCAT / 0 /
32668 C     DATA ESTEPF / MXXMDF * 0.1D+00 /
32669 C     DATA LSRCRH / MXXMDF * .FALSE. /, LNSCRH / MXXMDF * .FALSE. /
32670 C     DATA THMSPR / 0.02D+00 /, THMSSC / 1.D+00 /
32671
32672 * /parevt/
32673       DATA DPOWER /-13.D+00 /, FSPRD0 / 0.6D+00 /, FSHPFN / 0.0D+00 /,
32674      &     RN1GSC /-1.0D+00 /, RN2GSC /-1.0D+00 /
32675       DATA LDIFFR /  .TRUE., .TRUE., 6 * .TRUE., .TRUE., 8 * .TRUE.,
32676      &               .TRUE., 4 * .TRUE., .TRUE., 3 * .TRUE.,
32677      &              4 * .FALSE., 9 * .TRUE./
32678 **sr 17.5.95
32679 * default value for LEVPRT changed (reset sr 25.7.97)
32680 * default value for LHEAVY changed 25.7.97
32681 C     DATA LPOWER / .TRUE.  /, LINCTV / .TRUE.  /, LEVPRT / .TRUE.  /,
32682 C    &     LHEAVY / .FALSE. /, LDEEXG / .TRUE.  /, LGDHPR / .TRUE.  /,
32683 C    &     LPREEX / .TRUE.  /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32684 C    &     LPARWV / .TRUE.  /, LSNGCH / .TRUE.  /, LSCHDF / .TRUE.  /
32685       DATA LPOWER / .TRUE.  /, LINCTV / .TRUE.  /, LEVPRT / .TRUE.  /,
32686      &     LHEAVY / .TRUE.  /, LDEEXG / .TRUE.  /, LGDHPR / .TRUE.  /,
32687      &     LPREEX / .TRUE.  /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32688      &     LPARWV / .TRUE.  /, LSNGCH / .TRUE.  /, LSCHDF / .TRUE.  /
32689 **
32690 **sr 27.5.97
32691 * default value for ILVMOD changed
32692 C     DATA ILVMOD / 0 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32693       DATA ILVMOD / 1 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32694 **
32695
32696 * /resnuc/
32697       DATA IPREEH / 0 /, IPRTRI / 0 /, IPRDEU / 0 /, IPR3HE / 0 /,
32698      &     IPR4HE / 0 /
32699       DATA IEVAPL / 0 /, IEVAPH / 0 /, IEVNEU / 0 /, IEVPRO / 0 /,
32700      &     IEVTRI / 0 /, IEVDEU / 0 /, IEV3HE / 0 /, IEV4HE / 0 /,
32701      &     IDEEXG / 0 /
32702       DATA LRNFSS / .FALSE. /
32703
32704 * /scohlp/
32705 **sr 18.5. commented since not used for evap.
32706 C     DATA ISCRNG, JSCRNG / 2*0 /, LSCZER / .FALSE. /
32707
32708 * /trackr/
32709 **sr 18.5. commented since not used for evap.
32710 C     DATA ETRACK /0.D+00/, WTRACK /0.D+00/, ATRACK /0.D+00/,
32711 C    &     CTRACK /0.D+00/, NTRACK /0/, MTRACK /0/, JTRACK /0/
32712
32713 * /usrbin/
32714 **sr 18.5. commented since not used for evap.
32715 C     DATA LUSBIN, LUSEVT, LUSTKB /3*.FALSE./, NUSRBN /0/
32716
32717 * /usrbdx/
32718 **sr 18.5. commented since not used for evap.
32719 C     DATA LUSBDX /.FALSE./, NUSRBX /0/
32720
32721 * /usrsnc/
32722 **sr 18.5. commented since not used for evap.
32723 C     DATA LURSNC /.FALSE./, NURSNC /0/
32724
32725 * /usrtrc/
32726 **sr 18.5. commented since not used for evap.
32727 C     DATA LUSRTC, LUSTRK, LUSCLL / 3*.FALSE. /
32728 C     DATA NUSRTC, NUSTRK, NUSCLL / 3*0 /
32729
32730 * /usryld/
32731 **sr 18.5. commented since not used for evap.
32732 C     DATA LUSRYL / .FALSE./, LSCUYL / .FALSE. /, NUSRYL /0/,
32733 C    &     IJUSYL /0/, JTUSYL /0/
32734 C     DATA PUSRYL, UUSRYL, VUSRYL, WUSRYL / 4*ZERZER /
32735
32736 * /wwindw/
32737 **sr 18.5. commented since not used for evap.
32738 C     DATA IWLBGN, IWHBGN, IWMBGN / 3*0 /
32739 C     DATA LWWPRM / .TRUE. /
32740
32741 *=                                               end*block.bdnopt      *
32742       END
32743
32744 *$ CREATE DT_BDPREE.FOR
32745 *COPY DT_BDPREE
32746 *
32747 *=== bdpree ===========================================================*
32748 *
32749       BLOCK DATA DT_BDPREE
32750
32751 C     INCLUDE '(DBLPRC)'
32752 * DBLPRC.ADD
32753       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32754       SAVE
32755 * (original name: GLOBAL)
32756       PARAMETER ( KALGNM = 2 )
32757       PARAMETER ( ANGLGB = 5.0D-16 )
32758       PARAMETER ( ANGLSQ = 2.5D-31 )
32759       PARAMETER ( AXCSSV = 0.2D+16 )
32760       PARAMETER ( ANDRFL = 1.0D-38 )
32761       PARAMETER ( AVRFLW = 1.0D+38 )
32762       PARAMETER ( AINFNT = 1.0D+30 )
32763       PARAMETER ( AZRZRZ = 1.0D-30 )
32764       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32765       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32766       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32767       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32768       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
32769       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
32770       PARAMETER ( CSNNRM = 2.0D-15 )
32771       PARAMETER ( DMXTRN = 1.0D+08 )
32772       PARAMETER ( ZERZER = 0.D+00 )
32773       PARAMETER ( ONEONE = 1.D+00 )
32774       PARAMETER ( TWOTWO = 2.D+00 )
32775       PARAMETER ( THRTHR = 3.D+00 )
32776       PARAMETER ( FOUFOU = 4.D+00 )
32777       PARAMETER ( FIVFIV = 5.D+00 )
32778       PARAMETER ( SIXSIX = 6.D+00 )
32779       PARAMETER ( SEVSEV = 7.D+00 )
32780       PARAMETER ( EIGEIG = 8.D+00 )
32781       PARAMETER ( ANINEN = 9.D+00 )
32782       PARAMETER ( TENTEN = 10.D+00 )
32783       PARAMETER ( HLFHLF = 0.5D+00 )
32784       PARAMETER ( ONETHI = ONEONE / THRTHR )
32785       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32786       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32787       PARAMETER ( THRTWO = THRTHR / TWOTWO )
32788       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32789       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32790       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32791       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32792       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32793       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32794       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32795       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
32796       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
32797       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
32798       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
32799       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32800       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32801       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32802       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32803       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32804       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32805       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32806       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32807       PARAMETER ( CLIGHT = 2.99792458         D+10 )
32808       PARAMETER ( AVOGAD = 6.0221367          D+23 )
32809       PARAMETER ( BOLTZM = 1.380658           D-23 )
32810       PARAMETER ( AMELGR = 9.1093897          D-28 )
32811       PARAMETER ( PLCKBR = 1.05457266         D-27 )
32812       PARAMETER ( ELCCGS = 4.8032068          D-10 )
32813       PARAMETER ( ELCMKS = 1.60217733         D-19 )
32814       PARAMETER ( AMUGRM = 1.6605402          D-24 )
32815       PARAMETER ( AMMUMU = 0.113428913        D+00 )
32816       PARAMETER ( AMPRMU = 1.007276470        D+00 )
32817       PARAMETER ( AMNEMU = 1.008664904        D+00 )
32818       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32819       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32820       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32821       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32822       PARAMETER ( PLABRC = 0.197327053        D+00 )
32823       PARAMETER ( AMELCT = 0.51099906         D-03 )
32824       PARAMETER ( AMUGEV = 0.93149432         D+00 )
32825       PARAMETER ( AMMUON = 0.105658389        D+00 )
32826       PARAMETER ( AMPRTN = 0.93827231         D+00 )
32827       PARAMETER ( AMNTRN = 0.93956563         D+00 )
32828       PARAMETER ( AMDEUT = 1.87561339         D+00 )
32829       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32830      &                   * 1.D-09 )
32831       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32832       PARAMETER ( BLTZMN = 8.617385           D-14 )
32833       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32834       PARAMETER ( GFOHB3 = 1.16639            D-05 )
32835       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32836       PARAMETER ( SIN2TW = 0.2319             D+00 )
32837       PARAMETER ( GEVMEV = 1.0                D+03 )
32838       PARAMETER ( EMVGEV = 1.0                D-03 )
32839       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
32840       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32841       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32842       LOGICAL LGBIAS, LGBANA
32843       COMMON /FKGLOB/ LGBIAS, LGBANA
32844 C     INCLUDE '(DIMPAR)'
32845 * DIMPAR.ADD
32846       PARAMETER ( MXXRGN = 5000 )
32847       PARAMETER ( MXXMDF = 82   )
32848       PARAMETER ( MXXMDE = 54   )
32849       PARAMETER ( MFSTCK = 1000 )
32850       PARAMETER ( MESTCK = 100  )
32851       PARAMETER ( NALLWP = 39   )
32852       PARAMETER ( NELEMX = 80   )
32853       PARAMETER ( MPDPDX = 8    )
32854       PARAMETER ( ICOMAX = 180  )
32855       PARAMETER ( NSTBIS = 304  )
32856       PARAMETER ( IDMAXP = 220  )
32857       PARAMETER ( IDMXDC = 640  )
32858       PARAMETER ( MKBMX1 = 1    )
32859       PARAMETER ( MKBMX2 = 1    )
32860 C     INCLUDE '(IOUNIT)'
32861 * IOUNIT.ADD
32862       PARAMETER ( LUNIN  =  5 )
32863       PARAMETER ( LUNOUT =  6 )
32864 **sr 19.5. set error output-unit from 15 to 6
32865       PARAMETER ( LUNERR = 6  )
32866       PARAMETER ( LUNBER = 14 )
32867       PARAMETER ( LUNECH =  8 )
32868       PARAMETER ( LUNFLU = 13 )
32869       PARAMETER ( LUNGEO = 16 )
32870       PARAMETER ( LUNPMF = 12 )
32871       PARAMETER ( LUNRAN =  2 )
32872       PARAMETER ( LUNXSC =  9 )
32873       PARAMETER ( LUNDET = 17 )
32874       PARAMETER ( LUNRAY = 10 )
32875       PARAMETER ( LUNRDB =  1 )
32876       PARAMETER ( LUNPGO =  7 )
32877       PARAMETER ( LUNPGS =  4 )
32878       PARAMETER ( LUNSCR =  3 )
32879 *
32880 *----------------------------------------------------------------------*
32881 *                                                                      *
32882 *     Created on 16 september 1991 by    Alfredo Ferrari & Paola Sala  *
32883 *                                                   Infn - Milan       *
32884 *                                                                      *
32885 *     Last change on 03-feb-94     by    Alfredo Ferrari               *
32886 *                                                                      *
32887 *                                                                      *
32888 *----------------------------------------------------------------------*
32889 *
32890 * (original name: CMPISG,CHPISG)
32891       PARAMETER ( TPPPI0 = 0.279656044337515D+00 )
32892       PARAMETER ( TNNPI0 = 0.279642680857450D+00 )
32893       PARAMETER ( TPPPIP = 0.292295207182790D+00 )
32894       PARAMETER ( TPPDEP = 0.287514778898469D+00 )
32895       PARAMETER ( TNNPIM = 0.286723140900975D+00 )
32896       PARAMETER ( TNNDEM = 0.281949292916434D+00 )
32897       PARAMETER ( TPNPI0 = 0.279456888147740D+00 )
32898       PARAMETER ( TPNDE0 = 0.274693916135245D+00 )
32899       PARAMETER ( TPNPIP = 0.292086756473890D+00 )
32900       PARAMETER ( TNPPI0 = 0.279842093144975D+00 )
32901       PARAMETER ( TNPDE0 = 0.275072555824202D+00 )
32902       PARAMETER ( TNPPIP = 0.292489370554958D+00 )
32903       PARAMETER ( PIRSMX = 1.2D+00 )
32904       PARAMETER ( NPIREA = 10 )
32905       PARAMETER ( NPIRTA = 68 )
32906       PARAMETER ( NPIRLN = 21 )
32907       PARAMETER ( NPIRLG = NPIRTA - NPIRLN )
32908       PARAMETER ( NPISIS = NPIRLN + 20 )
32909       PARAMETER ( NPISEX = NPIRLN + 21 )
32910       PARAMETER ( NPIIMN = 14 )
32911       PARAMETER ( NPIIRC =  6 )
32912       PARAMETER ( DELWLL = 0.035D+00 )
32913       CHARACTER CHPIRE*8
32914       LOGICAL LDLRES
32915       COMMON /FKCMPI/ PMNPIS, PMMPIS, PISPIS, PEXPIS, PMXPIS, DPPISG,
32916      &                RTPISG, AMNPIS, AMMPIS, AISPIS, AEXPIS, AMXPIS,
32917      &                ARPISG, BPISLO (NPIRLN:NPIRTA,NPIREA),
32918      &                CPISLO (NPIRLN:NPIRTA,NPIREA), PPITHR (NPIREA),
32919      &                SPISLO (NPIRLN:NPIRTA,NPIREA), APITHR (NPIREA),
32920      &                SGPIIN (NPIIMN:NPIRTA,NPIIRC), RHPICR (1:5)   ,
32921      &                SGPICU (0:20,NPIRTA,NPIREA)  , SGRTRS (NPIREA),
32922      &                SGPIDF (0:20,NPIRTA,NPIREA)  , BRREIN (NPIREA),
32923      &                SGPIIS (NPIRTA,NPIREA)       , BRREOU (NPIREA),
32924      &                BRD3OU (2,2,-1:2), BRDEOU (2,-1:2),
32925      &                SGABSR (2,2,4)   , PRRSDL,
32926      &                IPIREA (2,2,3:5) , IPIINE (2,3:5)    , NPIRVR ,
32927      &                KPIIRE (2,NPIREA), KPIORE (2,NPIREA) ,
32928      &                JSTOKP (5), KPTOJS (23), ITTRRS (3:5), LDLRES
32929       COMMON /FKCHPI/ CHPIRE (NPIREA)
32930       DIMENSION SG2BRS (2,2), SGABSW (2,2), SG3BRS (2,2,2)
32931       EQUIVALENCE ( SG2BRS   (1,1), SGABSR (1,1,1) )
32932       EQUIVALENCE ( SGABSW   (1,1), SGABSR (1,1,2) )
32933       EQUIVALENCE ( SG3BRS (1,1,1), SGABSR (1,1,3) )
32934 * (original name: FRBKCM)
32935       PARAMETER ( MXFFBK =     6 )
32936       PARAMETER ( MXZFBK =     9 )
32937       PARAMETER ( MXNFBK =    10 )
32938       PARAMETER ( MXAFBK =    16 )
32939       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
32940       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
32941       PARAMETER ( NXAFBK = MXAFBK + 1 )
32942       PARAMETER ( MXPSST =   300 )
32943       PARAMETER ( MXPSFB = 41000 )
32944       LOGICAL LFRMBK, LNCMSS
32945       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
32946      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
32947      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
32948      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
32949      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
32950      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
32951      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
32952      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
32953      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
32954 * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
32955       PARAMETER ( PI     = PIPIPI )
32956       PARAMETER ( PISQ   = PIPISQ )
32957       PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
32958       PARAMETER ( RZNUCL = 1.12        D+00 )
32959       PARAMETER ( RMSPRO = 0.8         D+00 )
32960       PARAMETER ( R0PROT = RMSPRO / SQRT12  )
32961       PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
32962      &          / R0PROT )
32963       PARAMETER ( RLLE04 = RZNUCL )
32964       PARAMETER ( RLLE16 = RZNUCL )
32965       PARAMETER ( RLGT16 = RZNUCL )
32966       PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
32967       PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
32968       PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
32969       PARAMETER ( SKLE04 = 1.4D+00 )
32970       PARAMETER ( SKLE16 = 1.9D+00 )
32971       PARAMETER ( SKGT16 = 2.4D+00 )
32972       PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
32973       PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
32974       PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
32975       PARAMETER ( ALPHA0 = 0.1D+00 )
32976       PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
32977       PARAMETER ( GAMSK0 = 0.9D+00 )
32978       PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
32979       PARAMETER ( POTME0 = 0.6666666666666667D+00 )
32980       PARAMETER ( POTBA0 = 1.D+00 )
32981       PARAMETER ( PNFRAT = 1.533D+00 )
32982       PARAMETER ( RADPIM = 0.035D+00 )
32983       PARAMETER ( RDPMHL = 14.D+00   )
32984       PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
32985       PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
32986       PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
32987       PARAMETER ( AP0PFS = 0.5D+00 )
32988       PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
32989       PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
32990       PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
32991       PARAMETER ( MXSCIN = 50     )
32992       LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
32993      &        LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
32994       COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
32995      &                RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
32996      &                SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
32997      &                CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
32998      &                PFRTAB (2:260)
32999       COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
33000      &                ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
33001      &                RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
33002      &                YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
33003      &                RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
33004      &                PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
33005      &                PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
33006      &                BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
33007      &                YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
33008      &                XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
33009      &                SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
33010      &                R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
33011      &                PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
33012      &                EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
33013      &                PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
33014      &                EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
33015      &                PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
33016      &                BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
33017       COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
33018      &                RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
33019      &                EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
33020      &                BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
33021      &                WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
33022      &                POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
33023      &                BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
33024      &                SIGPAB (3), SIGNAB (3), HHLP   (2), FORTOT (2),
33025      &                FPNBLC, DPNBLC, FFTFLG, IFTFLG,
33026      &                IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
33027      &                KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
33028      &                NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
33029      &                IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
33030      &                LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
33031       COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
33032       COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
33033      &                YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
33034      &                AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
33035      &                NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
33036      &                NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
33037      &                ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
33038      &                LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
33039      &                LNCDCY, LNUSCT
33040       DIMENSION AWSTAB (2:260), SIGMAB (3)
33041       EQUIVALENCE ( DEFPRO, DEFNUC (1) )
33042       EQUIVALENCE ( DEFNEU, DEFNUC (2) )
33043       EQUIVALENCE ( RHOIPP, RHONCP (1) )
33044       EQUIVALENCE ( RHOINP, RHONCP (2) )
33045       EQUIVALENCE ( RHOIP2, RHONC2 (1) )
33046       EQUIVALENCE ( RHOIN2, RHONC2 (2) )
33047       EQUIVALENCE ( RHOIP3, RHONC3 (1) )
33048       EQUIVALENCE ( RHOIN3, RHONC3 (2) )
33049       EQUIVALENCE ( RHOIPT, RHONCT (1) )
33050       EQUIVALENCE ( RHOINT, RHONCT (2) )
33051       EQUIVALENCE ( OMALHL, SK3PAR )
33052       EQUIVALENCE ( ALPHAL, HABPAR )
33053       EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
33054       EQUIVALENCE ( SIGMPE, SIGMPR (1) )
33055       EQUIVALENCE ( SIGMPC, SIGMPR (2) )
33056       EQUIVALENCE ( SIGMPI, SIGMPR (3) )
33057       EQUIVALENCE ( SIGMPA, SIGMPR (4) )
33058       EQUIVALENCE ( SIGMNE, SIGMNU (1) )
33059       EQUIVALENCE ( SIGMNC, SIGMNU (2) )
33060       EQUIVALENCE ( SIGMNI, SIGMNU (3) )
33061       EQUIVALENCE ( SIGMNA, SIGMNU (4) )
33062       EQUIVALENCE ( SIGMA2, SIGPAB (1) )
33063       EQUIVALENCE ( SIGMA3, SIGPAB (2) )
33064       EQUIVALENCE ( SIGMAS, SIGPAB (3) )
33065       EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
33066 * (original name: NUCLEV)
33067       LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
33068       COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
33069      &                DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
33070      &                CUMRAD (0:160,2), RUSNUC (2),
33071      &                ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
33072      &                NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
33073      &                NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
33074      &                JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
33075      &                MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
33076      &                NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
33077      &                LFLVSL, LRLVSL, LEQSBL
33078       DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
33079      &          MGSSPR (19) , MGSSNE (25)
33080       EQUIVALENCE ( RUSNUC (1), RUSPRO )
33081       EQUIVALENCE ( RUSNUC (2), RUSNEU )
33082       EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
33083       EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
33084       EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
33085       EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
33086       EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
33087       EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
33088       EQUIVALENCE ( NTANUC (1), NTAPRO )
33089       EQUIVALENCE ( NTANUC (2), NTANEU )
33090       EQUIVALENCE ( NAVNUC (1), NAVPRO )
33091       EQUIVALENCE ( NAVNUC (2), NAVNEU )
33092       EQUIVALENCE ( NLSNUC (1), NLSPRO )
33093       EQUIVALENCE ( NLSNUC (2), NLSNEU )
33094       EQUIVALENCE ( NCONUC (1), NCOPRO )
33095       EQUIVALENCE ( NCONUC (2), NCONEU )
33096       EQUIVALENCE ( NSKNUC (1), NSKPRO )
33097       EQUIVALENCE ( NSKNUC (2), NSKNEU )
33098       EQUIVALENCE ( NHANUC (1), NHAPRO )
33099       EQUIVALENCE ( NHANUC (2), NHANEU )
33100       EQUIVALENCE ( NUSNUC (1), NUSPRO )
33101       EQUIVALENCE ( NUSNUC (2), NUSNEU )
33102       EQUIVALENCE ( NACNUC (1), NACPRO )
33103       EQUIVALENCE ( NACNUC (2), NACNEU )
33104       EQUIVALENCE ( JMXNUC (1), JMXPRO )
33105       EQUIVALENCE ( JMXNUC (2), JMXNEU )
33106       EQUIVALENCE ( MAGNUC (1), MAGPRO )
33107       EQUIVALENCE ( MAGNUC (2), MAGNEU )
33108 * (original name: PARNUC)
33109       PARAMETER ( PIGRK  = PIPIPI )
33110       PARAMETER ( ALEVEL = 8.D-03 )
33111       PARAMETER ( RCNUCL = 1.12D+00 )
33112       PARAMETER ( R0SIG  = 1.3D+00 )
33113       PARAMETER ( R0SIGK = 1.5D+00 )
33114       PARAMETER ( RCOULB = 1.5D+00 )
33115       PARAMETER ( COULBH = 0.88235D-03 )
33116       PARAMETER ( RHONU0 = 0.75D+00 / PIGRK / RCNUCL / RCNUCL / RCNUCL )
33117       PARAMETER ( TAUFO0 = 10.0D+00 )
33118       PARAMETER ( EKEEXP = 0.03D+00 )
33119       PARAMETER ( EKREXP = 0.05D+00 )
33120       PARAMETER ( EKEMNM = 0.01D+00 )
33121       PARAMETER ( NCPMX = 120 )
33122       COMMON /FKPARN/ EKORI , PXORI , PYORI , PZORI , PTORI , TAUFOR,
33123      &                ENNUC  (NCPMX), PNUCL  (NCPMX), EKFNUC (NCPMX),
33124      &                XSTNUC (NCPMX), YSTNUC (NCPMX), ZSTNUC (NCPMX),
33125      &                PXNUCL (NCPMX), PYNUCL (NCPMX), PZNUCL (NCPMX),
33126      &                RSTNUC (NCPMX), FREEPA (NCPMX), CRRPAN (NCPMX),
33127      &                CRRPAP (NCPMX), BSTNUC (NCPMX), AGENUC (NCPMX),
33128      &                TAUFPA (NCPMX), RHNUCL(NCPMX,2), BNDGAV, DEFMIN,
33129      &                KPNUCL (NCPMX), KRFNUC (NCPMX), ILINUC (NCPMX),
33130      &                INUCTS (NCPMX), ISFNUC (NCPMX), KPORI , IBORI ,
33131      &                IBNUCL, NPNUC , NNUCTS
33132 *
33133       DATA LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH / 6*.FALSE. /
33134       DATA POTBAR / POTBA0 /, POTMES / POTME0 /, WLLRES / 0.D+00 /
33135       DATA JUSNUC / 320 * 0 /, INUCLV / 1 /, IEVPRE / 0 /
33136       DATA MAGNUM / 2, 8, 20, 28, 50, 82, 126, 160 /
33137       DATA LPREEQ / .FALSE. /
33138 * /cmpisg/
33139       DATA JSTOKP / 1, 8, 13, 14, 23 /
33140       DATA KPTOJS / 1, 6*0, 2, 4*0, 3, 4, 8*0, 5 /
33141       DATA CHPIRE / 'PI+PPI+P','PI-PPI-P','PI-PPI0N','PI0PPI0P',
33142      &              'PI0PPI+N','PI-NPI-N','PI+NPI+N','PI+NPI0P',
33143      &              'PI0NPI0N','PI0NPI-P' /
33144       DATA KPIIRE / 13, 1, 14, 1, 14, 1, 23, 1, 23, 1, 14, 8,
33145      &              13, 8, 13, 8, 23, 8, 23, 8 /
33146       DATA KPIORE / 13, 1, 14, 1, 23, 8, 23, 1, 13, 8, 14, 8,
33147      &              13, 8, 23, 1, 23, 8, 14, 1 /
33148       DATA IPIREA / 1, 0, 7, 8, 2, 3, 6, 0, 4, 5, 9, 10 /
33149       DATA IPIINE / 1, 2, 3, 4, 5, 6 /
33150 * /frbkcm/
33151       DATA LFRMBK / .FALSE. /
33152       DATA NBUFBK /   500  /
33153       DATA EXMXFB / 80.0 D+00 /
33154       DATA R0FRBK / 1.18 D+00 /
33155       DATA R0CFBK / 2.173D+00 /
33156       DATA C1CFBK / 6.103D-03 /
33157       DATA C2CFBK / 9.443D-03 /
33158 * /parnuc/
33159       DATA TAUFOR / TAUFO0 /
33160 *=== End of Block Data Bdpree =========================================*
33161       END
33162
33163 *$ CREATE DT_XHOINI.FOR
33164 *COPY DT_XHOINI
33165 *
33166 *====phoini============================================================*
33167 *
33168       SUBROUTINE DT_XHOINI
33169 C     SUBROUTINE DT_PHOINI
33170
33171       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33172       SAVE
33173       PARAMETER ( LINP = 10 ,
33174      &            LOUT = 6 ,
33175      &            LDAT = 9 )
33176
33177       RETURN
33178       END
33179
33180 *$ CREATE DT_XVENTB.FOR
33181 *COPY DT_XVENTB
33182 *
33183 *====eventb============================================================*
33184 *
33185       SUBROUTINE DT_XVENTB(NCSY,IREJ)
33186 C     SUBROUTINE DT_EVENTB(NCSY,IREJ)
33187
33188       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33189       SAVE
33190       PARAMETER ( LINP = 10 ,
33191      &            LOUT = 6 ,
33192      &            LDAT = 9 )
33193
33194       WRITE(LOUT,1000)
33195  1000 FORMAT(1X,'EVENTB:   PHOJET-package requested but not linked!')
33196       STOP
33197
33198       END
33199
33200 *$ CREATE DT_XVENT.FOR
33201 *COPY DT_XVENT
33202 *
33203 *===event==============================================================*
33204 *
33205       SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
33206 C     SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
33207
33208       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33209       SAVE
33210
33211       DIMENSION PP(4),PT(4)
33212
33213       RETURN
33214       END
33215
33216 *$ CREATE DT_XOHISX.FOR
33217 *COPY DT_XOHISX
33218 *
33219 *===pohisx=============================================================*
33220 *
33221       SUBROUTINE DT_XOHISX(I,X)
33222 C     SUBROUTINE POHISX(I,X)
33223
33224       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33225       SAVE
33226
33227       RETURN
33228       END
33229
33230 *$ CREATE PHO_LHIST.FOR
33231 *COPY PHO_LHIST
33232 *
33233 *===poluhi=============================================================*
33234 *
33235       SUBROUTINE PHO_LHIST(I,X)
33236 **
33237
33238       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33239       SAVE
33240
33241       RETURN
33242       END
33243
33244 *$ CREATE PDFSET.FOR
33245 *COPY PDFSET
33246 *
33247 C**********************************************************************
33248 C
33249 C   dummy subroutines, remove to link PDFLIB
33250 C
33251 C**********************************************************************
33252       SUBROUTINE PDFSET(PARAM,VALUE)
33253       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33254       DIMENSION PARAM(20),VALUE(20)
33255       CHARACTER*20 PARAM
33256       END
33257
33258 *$ CREATE STRUCTM.FOR
33259 *COPY STRUCTM
33260 *
33261       SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33262       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33263       END
33264
33265 *$ CREATE STRUCTP.FOR
33266 *COPY STRUCTP
33267 *
33268       SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33269       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33270       END
33271
33272 *$ CREATE DT_DIQBRK.FOR
33273 *COPY DT_DIQBRK
33274 *
33275 *===diqbrk=============================================================*
33276 *
33277       SUBROUTINE DT_XIQBRK
33278 C     SUBROUTINE DT_DIQBRK
33279
33280       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33281       SAVE
33282
33283       STOP 'diquark-breaking not implemeted !'
33284
33285       RETURN
33286       END
33287
33288 *$ CREATE DT_ELHAIN.FOR
33289 *COPY DT_ELHAIN
33290 *
33291 *===elhain=============================================================*
33292 *
33293       SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
33294
33295 ************************************************************************
33296 * Elastic hadron-hadron scattering.                                    *
33297 * This is a revised version of the original.                           *
33298 * This version dated 03.04.98 is written by S. Roesler                 *
33299 ************************************************************************
33300
33301       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33302       SAVE
33303       PARAMETER ( LINP = 10 ,
33304      &            LOUT = 6 ,
33305      &            LDAT = 9 )
33306       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33307      &           TINY10=1.0D-10)
33308
33309       PARAMETER (ENNTHR = 3.5D0)
33310       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
33311      &           BLOWB=0.05D0,BHIB=0.2D0,
33312      &           BLOWM=0.1D0, BHIM=2.0D0)
33313
33314 * particle properties (BAMJET index convention)
33315       CHARACTER*8  ANAME
33316       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33317      &                IICH(210),IIBAR(210),K1(210),K2(210)
33318 * final state from HADRIN interaction
33319       PARAMETER (MAXFIN=10)
33320       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33321      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33322
33323 C     DATA TSLOPE /10.0D0/
33324
33325       IREJ = 0
33326
33327     1 CONTINUE
33328
33329       PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
33330       EKIN = ELAB-AAM(IP)
33331 *   kinematical quantities in cms of the hadrons
33332       AMP2 = AAM(IP)**2
33333       AMT2 = AAM(IT)**2
33334       S    = AMP2+AMT2+TWO*ELAB*AAM(IT)
33335       ECM  = SQRT(S)
33336       ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
33337       PCM  = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
33338
33339 * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
33340       IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
33341      &     ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
33342 *   TSAMCS treats pp and np only, therefore change pn into np and
33343 *   nn into pp
33344          IF (IT.EQ.1) THEN
33345             KPROJ = IP
33346          ELSE
33347             KPROJ = 8
33348             IF (IP.EQ.8) KPROJ = 1
33349          ENDIF
33350          CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
33351          T = TWO*PCM**2*(CTCMS-ONE)
33352
33353 * very crude treatment otherwise: sample t from exponential dist.
33354       ELSE
33355 *   momentum transfer t
33356          TMAX = TWO*TWO*PCM**2
33357          RR = (PLAB-PLOWH)/(PHIH-PLOWH)
33358          IF (IIBAR(IP).NE.0) THEN
33359             TSLOPE = BLOWB+RR*(BHIB-BLOWB)
33360          ELSE
33361             TSLOPE = BLOWM+RR*(BHIM-BLOWM)
33362          ENDIF
33363          FMAX = EXP(-TSLOPE*TMAX)-ONE
33364          R = DT_RNDM(RR)
33365          T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
33366          IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
33367       ENDIF
33368
33369 *   target hadron in Lab after scattering
33370       ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
33371       PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
33372       IF (PLRH(2).LE.TINY10) THEN
33373 C        WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
33374          GOTO 1
33375       ENDIF
33376 *   projectile hadron in Lab after scattering
33377       ELRH(1) = ELAB+AAM(IT)-ELRH(2)
33378       PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
33379 *   scattering angle of projectile in Lab
33380       CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
33381       STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
33382       CALL DT_DSFECF(SPLABP,CPLABP)
33383 *   direction cosines of projectile in Lab
33384       CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
33385      &                          CXRH(1),CYRH(1),CZRH(1))
33386 *   scattering angle of target in Lab
33387       PLLABT = PLAB-CTLABP*PLRH(1)
33388       CTLABT = PLLABT/PLRH(2)
33389       STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
33390 *   direction cosines of target in Lab
33391       CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
33392      &                            CXRH(2),CYRH(2),CZRH(2))
33393 *   fill /HNFSPA/
33394       IRH = 2
33395       ITRH(1) = IP
33396       ITRH(2) = IT
33397
33398       RETURN
33399       END
33400
33401 *$ CREATE DT_TSAMCS.FOR
33402 *COPY DT_TSAMCS
33403 *
33404 *===tsamcs=============================================================*
33405 *
33406       SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
33407
33408 ************************************************************************
33409 * Sampling of cos(theta) for nucleon-proton scattering according to    *
33410 * hetkfa2/bertini parametrization.                                     *
33411 * This is a revised version of the original (HJM 24/10/88)             *
33412 * This version dated 28.10.95 is written by S. Roesler                 *
33413 ************************************************************************
33414
33415       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33416       SAVE
33417       PARAMETER ( LINP = 10 ,
33418      &            LOUT = 6 ,
33419      &            LDAT = 9 )
33420       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33421      &           TINY10=1.0D-10)
33422
33423       DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
33424       DIMENSION PDCI(60),PDCH(55)
33425
33426       DATA (DCLIN(I),I=1,80) /
33427      &     5.000D-01,  1.000D+00,  0.000D+00,  1.000D+00,  0.000D+00,
33428      &     4.993D-01,  9.881D-01,  5.963D-02,  9.851D-01,  5.945D-02,
33429      &     4.936D-01,  8.955D-01,  5.224D-01,  8.727D-01,  5.091D-01,
33430      &     4.889D-01,  8.228D-01,  8.859D-01,  7.871D-01,  8.518D-01,
33431      &     4.874D-01,  7.580D-01,  1.210D+00,  7.207D-01,  1.117D+00,
33432      &     4.912D-01,  6.969D-01,  1.516D+00,  6.728D-01,  1.309D+00,
33433      &     5.075D-01,  6.471D-01,  1.765D+00,  6.667D-01,  1.333D+00,
33434      &     5.383D-01,  6.054D-01,  1.973D+00,  7.059D-01,  1.176D+00,
33435      &     5.397D-01,  5.990D-01,  2.005D+00,  7.023D-01,  1.191D+00,
33436      &     5.336D-01,  6.083D-01,  1.958D+00,  6.959D-01,  1.216D+00,
33437      &     5.317D-01,  6.075D-01,  1.962D+00,  6.897D-01,  1.241D+00,
33438      &     5.300D-01,  6.016D-01,  1.992D+00,  6.786D-01,  1.286D+00,
33439      &     5.281D-01,  6.063D-01,  1.969D+00,  6.786D-01,  1.286D+00,
33440      &     5.280D-01,  5.960D-01,  2.020D+00,  6.667D-01,  1.333D+00,
33441      &     5.273D-01,  5.920D-01,  2.040D+00,  6.604D-01,  1.358D+00,
33442      &     5.273D-01,  5.862D-01,  2.069D+00,  6.538D-01,  1.385D+00/
33443       DATA (DCLIN(I),I=81,160) /
33444      &     5.223D-01,  5.980D-01,  2.814D+00,  6.538D-01,  1.385D+00,
33445      &     5.202D-01,  5.969D-01,  2.822D+00,  6.471D-01,  1.412D+00,
33446      &     5.183D-01,  5.881D-01,  2.883D+00,  6.327D-01,  1.469D+00,
33447      &     5.159D-01,  5.866D-01,  2.894D+00,  6.250D-01,  1.500D+00,
33448      &     5.133D-01,  5.850D-01,  2.905D+00,  6.170D-01,  1.532D+00,
33449      &     5.106D-01,  5.833D-01,  2.917D+00,  6.087D-01,  1.565D+00,
33450      &     5.084D-01,  5.801D-01,  2.939D+00,  6.000D-01,  1.600D+00,
33451      &     5.063D-01,  5.763D-01,  2.966D+00,  5.909D-01,  1.636D+00,
33452      &     5.036D-01,  5.730D-01,  2.989D+00,  5.814D-01,  1.674D+00,
33453      &     5.014D-01,  5.683D-01,  3.022D+00,  5.714D-01,  1.714D+00,
33454      &     4.986D-01,  5.641D-01,  3.051D+00,  5.610D-01,  1.756D+00,
33455      &     4.964D-01,  5.580D-01,  3.094D+00,  5.500D-01,  1.800D+00,
33456      &     4.936D-01,  5.573D-01,  3.099D+00,  5.431D-01,  1.827D+00,
33457      &     4.909D-01,  5.509D-01,  3.144D+00,  5.313D-01,  1.875D+00,
33458      &     4.885D-01,  5.512D-01,  3.142D+00,  5.263D-01,  1.895D+00,
33459      &     4.857D-01,  5.437D-01,  3.194D+00,  5.135D-01,  1.946D+00/
33460       DATA (DCLIN(I),I=161,195) /
33461      &     4.830D-01,  5.353D-01,  3.253D+00,  5.000D-01,  2.000D+00,
33462      &     4.801D-01,  5.323D-01,  3.274D+00,  4.915D-01,  2.034D+00,
33463      &     4.770D-01,  5.228D-01,  3.341D+00,  4.767D-01,  2.093D+00,
33464      &     4.738D-01,  5.156D-01,  3.391D+00,  4.643D-01,  2.143D+00,
33465      &     4.701D-01,  5.010D-01,  3.493D+00,  4.444D-01,  2.222D+00,
33466      &     4.672D-01,  4.990D-01,  3.507D+00,  4.375D-01,  2.250D+00,
33467      &     4.634D-01,  4.856D-01,  3.601D+00,  4.194D-01,  2.323D+00/
33468
33469       DATA PDCI /
33470      &     4.400D+02,  1.896D-01,  1.931D-01,  1.982D-01,  1.015D-01,
33471      &     1.029D-01,  4.180D-02,  4.228D-02,  4.282D-02,  4.350D-02,
33472      &     2.204D-02,  2.236D-02,  5.900D+02,  1.433D-01,  1.555D-01,
33473      &     1.774D-01,  1.000D-01,  1.128D-01,  5.132D-02,  5.600D-02,
33474      &     6.158D-02,  6.796D-02,  3.660D-02,  3.820D-02,  6.500D+02,
33475      &     1.192D-01,  1.334D-01,  1.620D-01,  9.527D-02,  1.141D-01,
33476      &     5.283D-02,  5.952D-02,  6.765D-02,  7.878D-02,  4.796D-02,
33477      &     6.957D-02,  8.000D+02,  4.872D-02,  6.694D-02,  1.152D-01,
33478      &     9.348D-02,  1.368D-01,  6.912D-02,  7.953D-02,  9.577D-02,
33479      &     1.222D-01,  7.755D-02,  9.525D-02,  1.000D+03,  3.997D-02,
33480      &     5.456D-02,  9.804D-02,  8.084D-02,  1.208D-01,  6.520D-02,
33481      &     8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,  1.093D-01/
33482
33483       DATA PDCH /
33484      &     1.000D+03,  9.453D-02,  9.804D-02,  8.084D-02,  1.208D-01,
33485      &     6.520D-02,  8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,
33486      &     1.093D-01,  1.400D+03,  1.072D-01,  7.450D-02,  6.645D-02,
33487      &     1.136D-01,  6.750D-02,  8.580D-02,  1.110D-01,  1.530D-01,
33488      &     1.010D-01,  1.350D-01,  2.170D+03,  4.004D-02,  3.013D-02,
33489      &     2.664D-02,  5.511D-02,  4.240D-02,  7.660D-02,  1.364D-01,
33490      &     2.300D-01,  1.670D-01,  2.010D-01,  2.900D+03,  1.870D-02,
33491      &     1.804D-02,  1.320D-02,  2.970D-02,  2.860D-02,  5.160D-02,
33492      &     1.020D-01,  2.400D-01,  2.250D-01,  3.370D-01,  4.400D+03,
33493      &     1.196D-03,  8.784D-03,  1.517D-02,  2.874D-02,  2.488D-02,
33494      &     4.464D-02,  8.330D-02,  2.008D-01,  2.360D-01,  3.567D-01/
33495
33496       DATA (DCHN(I),I=1,90) /
33497      &     4.770D-01,  4.750D-01,  4.715D-01,  4.685D-01,  4.650D-01,
33498      &     4.610D-01,  4.570D-01,  4.550D-01,  4.500D-01,  4.450D-01,
33499      &     4.405D-01,  4.350D-01,  4.300D-01,  4.250D-01,  4.200D-01,
33500      &     4.130D-01,  4.060D-01,  4.000D-01,  3.915D-01,  3.840D-01,
33501      &     3.760D-01,  3.675D-01,  3.580D-01,  3.500D-01,  3.400D-01,
33502      &     3.300D-01,  3.200D-01,  3.100D-01,  3.000D-01,  2.900D-01,
33503      &     2.800D-01,  2.700D-01,  2.600D-01,  2.500D-01,  2.400D-01,
33504      &     2.315D-01,  2.240D-01,  2.150D-01,  2.060D-01,  2.000D-01,
33505      &     1.915D-01,  1.850D-01,  1.780D-01,  1.720D-01,  1.660D-01,
33506      &     1.600D-01,  1.550D-01,  1.500D-01,  1.450D-01,  1.400D-01,
33507      &     1.360D-01,  1.320D-01,  1.280D-01,  1.250D-01,  1.210D-01,
33508      &     1.180D-01,  1.150D-01,  1.120D-01,  1.100D-01,  1.070D-01,
33509      &     1.050D-01,  1.030D-01,  1.010D-01,  9.900D-02,  9.700D-02,
33510      &     9.550D-02,  9.480D-02,  9.400D-02,  9.200D-02,  9.150D-02,
33511      &     9.100D-02,  9.000D-02,  8.990D-02,  8.900D-02,  8.850D-02,
33512      &     8.750D-02,  8.700D-02,  8.650D-02,  8.550D-02,  8.500D-02,
33513      &     8.499D-02,  8.450D-02,  8.350D-02,  8.300D-02,  8.250D-02,
33514      &     8.150D-02,  8.100D-02,  8.030D-02,  8.000D-02,  7.990D-02/
33515       DATA (DCHN(I),I=91,143) /
33516      &     7.980D-02,  7.950D-02,  7.900D-02,  7.860D-02,  7.800D-02,
33517      &     7.750D-02,  7.650D-02,  7.620D-02,  7.600D-02,  7.550D-02,
33518      &     7.530D-02,  7.500D-02,  7.499D-02,  7.498D-02,  7.480D-02,
33519      &     7.450D-02,  7.400D-02,  7.350D-02,  7.300D-02,  7.250D-02,
33520      &     7.230D-02,  7.200D-02,  7.100D-02,  7.050D-02,  7.020D-02,
33521      &     7.000D-02,  6.999D-02,  6.995D-02,  6.993D-02,  6.991D-02,
33522      &     6.990D-02,  6.870D-02,  6.850D-02,  6.800D-02,  6.780D-02,
33523      &     6.750D-02,  6.700D-02,  6.650D-02,  6.630D-02,  6.600D-02,
33524      &     6.550D-02,  6.525D-02,  6.510D-02,  6.500D-02,  6.499D-02,
33525      &     6.498D-02,  6.496D-02,  6.494D-02,  6.493D-02,  6.490D-02,
33526      &     6.488D-02,  6.485D-02,  6.480D-02/
33527
33528       DATA DCHNA /
33529      &     6.300D+02,  7.810D-02,  1.421D-01,  1.979D-01,  2.479D-01,
33530      &     3.360D-01,  5.400D-01,  7.236D-01,  1.000D+00,  1.540D+03,
33531      &     2.225D-01,  3.950D-01,  5.279D-01,  6.298D-01,  7.718D-01,
33532      &     9.405D-01,  9.835D-01,  1.000D+00,  2.560D+03,  2.625D-01,
33533      &     4.550D-01,  5.963D-01,  7.020D-01,  8.380D-01,  9.603D-01,
33534      &     9.903D-01,  1.000D+00,  3.520D+03,  4.250D-01,  6.875D-01,
33535      &     8.363D-01,  9.163D-01,  9.828D-01,  1.000D+00,  1.000D+00,
33536      &     1.000D+00/
33537
33538       DATA DCHNB /
33539      &     6.300D+02,  3.800D-02,  7.164D-02,  1.275D-01,  2.171D-01,
33540      &     3.227D-01,  4.091D-01,  5.051D-01,  6.061D-01,  7.074D-01,
33541      &     8.434D-01,  1.000D+00,  2.040D+03,  1.200D-01,  2.115D-01,
33542      &     3.395D-01,  5.295D-01,  7.251D-01,  8.511D-01,  9.487D-01,
33543      &     9.987D-01,  1.000D+00,  1.000D+00,  1.000D+00,  2.200D+03,
33544      &     1.344D-01,  2.324D-01,  3.754D-01,  5.674D-01,  7.624D-01,
33545      &     8.896D-01,  9.808D-01,  1.000D+00,  1.000D+00,  1.000D+00,
33546      &     1.000D+00,  2.850D+03,  2.330D-01,  4.130D-01,  6.610D-01,
33547      &     9.010D-01,  9.970D-01,  1.000D+00,  1.000D+00,  1.000D+00,
33548      &     1.000D+00,  1.000D+00,  1.000D+00,  3.500D+03,  3.300D-01,
33549      &     5.450D-01,  7.950D-01,  1.000D+00,  1.000D+00,  1.000D+00,
33550      &     1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00/
33551
33552       CST = ONE
33553       IF (EKIN.GT.3.5D0) RETURN
33554 C
33555       IF(KPROJ.EQ.8) GOTO 101
33556       IF(KPROJ.EQ.1) GOTO 102
33557 C*                                             INVALID REACTION
33558       WRITE(LOUT,'(A,I5/A)')
33559      &        ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
33560      &        ' COS(THETA) = 1D0 RETURNED'
33561       RETURN
33562 C-------------------------------- NP ELASTIC SCATTERING----------
33563 101   CONTINUE
33564       IF (EKIN.GT.0.740D0)GOTO 1000
33565       IF (EKIN.LT.0.300D0)THEN
33566 C                                 EKIN .LT. 300 MEV
33567          IDAT=1
33568       ELSE
33569 C                                 300 MEV < EKIN < 740 MEV
33570          IDAT=6
33571       END IF
33572 C
33573       ENER=EKIN
33574       IE=INT(ABS(ENER/0.020D0))
33575       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33576 C                                            FORWARD/BACKWARD DECISION
33577       K=IDAT+5*IE
33578       BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33579       IF (DT_RNDM(CST).LT.BWFW)THEN
33580          VALUE2=-1D0
33581          K=K+1
33582       ELSE
33583          VALUE2=1D0
33584          K=K+3
33585       END IF
33586 C
33587       COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33588       RND=DT_RNDM(COEF)
33589 C
33590       IF(RND.LT.COEF)THEN
33591          CST=DT_RNDM(RND)
33592          CST=CST*VALUE2
33593       ELSE
33594          R1=DT_RNDM(CST)
33595          R2=DT_RNDM(R1)
33596          R3=DT_RNDM(R2)
33597          R4=DT_RNDM(R3)
33598 C
33599          IF(VALUE2.GT.0.0)THEN
33600             CST=MAX(R1,R2,R3,R4)
33601             GOTO 1500
33602          ELSE
33603             R5=DT_RNDM(R4)
33604 C
33605             IF (IDAT.EQ.1)THEN
33606                CST=-MAX(R1,R2,R3,R4,R5)
33607             ELSE
33608                R6=DT_RNDM(R5)
33609                R7=DT_RNDM(R6)
33610                CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
33611             END IF
33612 C
33613          END IF
33614 C
33615       END IF
33616 C
33617       GOTO 1500
33618 C
33619 C********                                EKIN  .GT.  0.74 GEV
33620 C
33621 1000  ENER=EKIN - 0.66D0
33622 C     IE=ABS(ENER/0.02)
33623       IE=INT(ENER/0.02D0)
33624       EMEV=EKIN*1D3
33625 C
33626       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33627       K=IE
33628       BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
33629       RND=DT_RNDM(BWFW)
33630 C                                        FORWARD NEUTRON
33631       IF (RND.GE.BWFW)THEN
33632          DO 1200 K=10,36,9
33633            IF (DCHNA(K).GT.EMEV) THEN
33634               UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
33635               UNIV=DT_RNDM(UNIVE)
33636               DO 1100 I=1,8
33637                  II=K+I
33638                  P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
33639 C
33640                  IF (P.GT.UNIV)THEN
33641                     UNIV=DT_RNDM(UNIVE)
33642                     FLTI=DBLE(I)-UNIV
33643                     GOTO(290,290,290,290,330,340,350,360) I
33644                  END IF
33645  1100         CONTINUE
33646            END IF
33647  1200    CONTINUE
33648 C
33649       ELSE
33650 C                                        BACKWARD NEUTRON
33651          DO 1400 K=13,60,12
33652             IF (DCHNB(K).GT.EMEV) THEN
33653                UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
33654                UNIV=DT_RNDM(UNIVE)
33655                DO 1300 I=1,11
33656                  II=K+I
33657                  P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
33658 C
33659                  IF (P.GT.UNIV)THEN
33660                    UNIV=DT_RNDM(P)
33661                    FLTI=DBLE(I)-UNIV
33662                    GOTO(120,120,140,150,160,160,180,190,200,210,220) I
33663                  END IF
33664  1300          CONTINUE
33665             END IF
33666  1400    CONTINUE
33667       END IF
33668 C
33669 120   CST=1.0D-2*FLTI-1.0D0
33670       GOTO 1500
33671 140   CST=2.0D-2*UNIV-0.98D0
33672       GOTO 1500
33673 150   CST=4.0D-2*UNIV-0.96D0
33674       GOTO 1500
33675 160   CST=6.0D-2*FLTI-1.16D0
33676       GOTO 1500
33677 180   CST=8.0D-2*UNIV-0.80D0
33678       GOTO 1500
33679 190   CST=1.0D-1*UNIV-0.72D0
33680       GOTO 1500
33681 200   CST=1.2D-1*UNIV-0.62D0
33682       GOTO 1500
33683 210   CST=2.0D-1*UNIV-0.50D0
33684       GOTO 1500
33685 220   CST=3.0D-1*(UNIV-1.0D0)
33686       GOTO 1500
33687 C
33688 290   CST=1.0D0-2.5d-2*FLTI
33689       GOTO 1500
33690 330   CST=0.85D0+0.5D-1*UNIV
33691       GOTO 1500
33692 340   CST=0.70D0+1.5D-1*UNIV
33693       GOTO 1500
33694 350   CST=0.50D0+2.0D-1*UNIV
33695       GOTO 1500
33696 360   CST=0.50D0*UNIV
33697 C
33698 1500  RETURN
33699 C
33700 C-----------------------------------  PP ELASTIC SCATTERING -------
33701 C
33702  102  CONTINUE
33703       EMEV=EKIN*1D3
33704 C
33705       IF (EKIN.LE.0.500D0) THEN
33706          RND=DT_RNDM(EMEV)
33707          CST=2.0D0*RND-1.0D0
33708          RETURN
33709 C
33710       ELSEIF (EKIN.LT.1.0D0) THEN
33711          DO 2200 K=13,60,12
33712             IF (PDCI(K).GT.EMEV) THEN
33713                UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
33714                UNIV=DT_RNDM(UNIVE)
33715                SUM=0
33716                DO 2100 I=1,11
33717                  II=K+I
33718                  SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
33719 C
33720                  IF (UNIV.LT.SUM)THEN
33721                    UNIV=DT_RNDM(SUM)
33722                    FLTI=DBLE(I)-UNIV
33723                    GOTO(55,55,55,60,60,65,65,65,65,70,70) I
33724                  END IF
33725  2100          CONTINUE
33726             END IF
33727  2200    CONTINUE
33728       ELSE
33729          DO 2400 K=12,55,11
33730             IF (PDCH(K).GT.EMEV) THEN
33731               UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
33732               UNIV=DT_RNDM(UNIVE)
33733               SUM=0.0D0
33734               DO 2300 I=1,10
33735                 II=K+I
33736                 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
33737 C
33738                 IF (UNIV.LT.SUM)THEN
33739                   UNIV=DT_RNDM(SUM)
33740                   FLTI=UNIV+DBLE(I)
33741                   GOTO(50,55,60,60,65,65,65,65,70,70) I
33742                 END IF
33743  2300         CONTINUE
33744             END IF
33745  2400    CONTINUE
33746       END IF
33747 C
33748 50    CST=0.4D0*UNIV
33749       GOTO 2500
33750 55    CST=0.2D0*FLTI
33751       GOTO 2500
33752 60    CST=0.3D0+0.1D0*FLTI
33753       GOTO 2500
33754 65    CST=0.6D0+0.04D0*FLTI
33755       GOTO 2500
33756 70    CST=0.78D0+0.02D0*FLTI
33757 C
33758 2500  CONTINUE
33759       IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
33760 C
33761       RETURN
33762       END
33763
33764 *$ CREATE DT_DHADRI.FOR
33765 *COPY DT_DHADRI
33766 *
33767 *===dhadri=============================================================*
33768 *
33769       SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
33770
33771       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33772       SAVE
33773
33774       PARAMETER ( LINP = 10 ,
33775      &            LOUT = 6 ,
33776      &            LDAT = 9 )
33777 C
33778 C-----------------------------
33779 C*** INPUT VARIABLES LIST:
33780 C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
33781 C*** GEV/C LABORATORY MOMENTUM REGION
33782 C*** N    - PROJECTILE HADRON INDEX
33783 C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
33784 C*** ELAB - LABORATORY ENERGY OF N (GEV)
33785 C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
33786 C*** ITTA - TARGET NUCLEON INDEX
33787 C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
33788 C  IR COUNTS THE NUMBER OF PRODUCED PARTICLES
33789 C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
33790 C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
33791 C*** RESPECT., UNITS (GEV/C AND GEV)
33792 C----------------------------
33793
33794       COMMON /HNGAMR/ REDU,AMO,AMM(15)
33795       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33796       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33797      &                NRK(2,268),NURE(30,2)
33798 * particle properties (BAMJET index convention),
33799 * (dublicate of DTPART for HADRIN)
33800       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33801      &                K1H(110),K2H(110)
33802       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33803       COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
33804      &                ITS(149),IS
33805       COMMON /HNDRUN/ RUNTES,EFTES
33806 * particle properties (BAMJET index convention)
33807       CHARACTER*8  ANAME
33808       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33809      &                IICH(210),IIBAR(210),K1(210),K2(210)
33810 * final state from HADRIN interaction
33811       PARAMETER (MAXFIN=10)
33812       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33813      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33814
33815       DIMENSION ITPRF(110)
33816       DATA NNN/0/
33817       DATA UMODA/0./
33818       DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
33819       LOWP=0
33820       IF (N.LE.0.OR.N.GE.111)N=1
33821       IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
33822         GOTO 280
33823 *       WRITE (6,1000)
33824 *    +  ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
33825 *       STOP
33826 *1000   FORMAT (3(5H ****/),A,2I4,3(5H ****/))
33827 *    +  45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
33828       ENDIF
33829       IATMPT=0
33830       IF (ABS(PLAB-5.0D0).LT.4.99999D0)                        GO TO 20
33831 C     IF(IPRI.GE.1) WRITE (6,1010) PLAB
33832 C     STOP
33833  1010 FORMAT ( '  PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
33834      + ALLOWED REGION, PLAB=',1E15.5)
33835
33836    20 CONTINUE
33837       UMODAT=N*1.11111D0+ITTA*2.19291D0
33838       IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
33839       UMODA=UMODAT
33840    30 IATMPT=0
33841       LOWP=LOWP+1
33842    40 CONTINUE
33843       IMACH=0
33844       REDU=2.0D0
33845       IF (LOWP.GT.20) THEN
33846 C        WRITE(LOUT,*) ' jump 1'
33847          GO TO 280
33848       ENDIF
33849       NNN=N
33850       IF (NNN.EQ.N)                                             GO TO 50
33851       RUNTES=0.0D0
33852       EFTES=0.0D0
33853    50 CONTINUE
33854       IS=1
33855       IRH=0
33856       IST=1
33857       NSTAB=23
33858       IRE=NURE(N,1)
33859       IF(ITTA.GT.1) IRE=NURE(N,2)
33860 C
33861 C-----------------------------
33862 C*** IE,AMT,ECM,SI DETERMINATION
33863 C----------------------------
33864       CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
33865       IANTH=-1
33866 **sr
33867 C     IF (AMH(1).NE.0.93828D0) IANTH=1
33868       IF (AMH(1).NE.0.9383D0) IANTH=1
33869 **
33870       IF (IANTH.GE.0) SI=1.0D0
33871       ECMMH=ECM
33872 C
33873 C-----------------------------
33874 C    ENERGY INDEX
33875 C  IRE CHARACTERIZES THE REACTION
33876 C  IE IS THE ENERGY INDEX
33877 C----------------------------
33878       IF (SI.LT.1.D-6) THEN
33879 C        WRITE(LOUT,*) ' jump 2'
33880          GO TO 280
33881       ENDIF
33882       IF (N.LE.NSTAB)                                           GO TO 60
33883       RUNTES=RUNTES+1.0D0
33884       IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
33885  1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
33886       IF(IBARH(N).EQ.1) N=8
33887       IF(IBARH(N).EQ.-1)  N=9
33888    60 CONTINUE
33889       IMACH=IMACH+1
33890 **sr 19.2.97: loop for direct channel suppression
33891 C     IF (IMACH.GT.10) THEN
33892       IF (IMACH.GT.1000) THEN
33893 **
33894 C        WRITE(LOUT,*) ' jump 3'
33895          GO TO 280
33896       ENDIF
33897       ECM =ECMMH
33898       AMN2=AMN**2
33899       AMT2=AMT**2
33900       ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM    )
33901       IF(ECMN.LE.AMN) ECMN=AMN
33902       PCMN=SQRT(ECMN**2-AMN2)
33903       GAM=(ELAB+AMT)/ECM
33904       BGAM=PLAB/ECM
33905       IF (IANTH.GE.0) ECM=2.1D0
33906 C
33907 C-----------------------------
33908 C*** RANDOM CHOICE OF REACTION CHANNEL
33909 C----------------------------
33910       IST=0
33911       VV=DT_RNDM(AMN2)
33912       VV=VV-1.D-17
33913 C
33914 C-----------------------------
33915 C***  PLACE REDUCED VERSION
33916 C----------------------------
33917       IIEI=IEII(IRE)
33918       IDWK=IEII(IRE+1)-IIEI
33919       IIWK=IRII(IRE)
33920       IIKI=IKII(IRE)
33921 C
33922 C-----------------------------
33923 C***  SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
33924 C----------------------------
33925       HECM=ECM
33926       HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
33927       IF (HUMO.LT.ECM) ECM=HUMO
33928 C
33929 C-----------------------------
33930 C*** INTERPOLATION PREPARATION
33931 C----------------------------
33932       ECMO=UMO(IE)
33933       ECM1=UMO(IE-1)
33934       DECM=ECMO-ECM1
33935       DEC=ECMO-ECM
33936 C
33937 C-----------------------------
33938 C*** RANDOM LOOP
33939 C----------------------------
33940       IK=0
33941       WKK=0.0D0
33942       WICOR=0.0D0
33943    70 IK=IK+1
33944       IWK=IIWK+(IK-1)*IDWK+IE-IIEI
33945       WOK=WK(IWK)
33946       WDK=WOK-WK(IWK-1)
33947 C
33948 C-----------------------------
33949 C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
33950 C    GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
33951 C    CONTRIBUTE
33952 C----------------------------
33953       IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
33954       WICO=WOK*1.23459876D0+WDK*1.735218469D0
33955       IF (WICO.EQ.WICOR)                                        GO TO 70
33956       IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
33957       WICOR=WICO
33958 C
33959 C-----------------------------
33960 C*** INTERPOLATION IN CHANNEL WEIGHTS
33961 C----------------------------
33962       EKLIM=-THRESH(IIKI+IK)
33963       IELIM=IDT_IEFUND(EKLIM,IRE)
33964       DELIM=UMO(IELIM)+EKLIM
33965      *+1.D-16
33966       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
33967       IF (DELIM*DELIM-DETE*DETE) 90,90,80
33968    80 DECC=DELIM
33969                                                                GO TO 100
33970    90 DECC=DECM
33971   100 CONTINUE
33972       WKK=WOK-WDK*DEC/(DECC+1.D-9)
33973 C
33974 C-----------------------------
33975 C*** RANDOM CHOICE
33976 C----------------------------
33977 C
33978       IF (VV.GT.WKK)                                            GO TO 70
33979 C
33980 C***IK IS THE REACTION CHANNEL
33981 C----------------------------
33982       INRK=IKII(IRE)+IK
33983       ECM=HECM
33984       I1001 =0
33985 C
33986   110 CONTINUE
33987       IT1=NRK(1,INRK)
33988       AM1=DT_DAMG(IT1)
33989       IT2=NRK(2,INRK)
33990       AM2=DT_DAMG(IT2)
33991       AMS=AM1+AM2
33992       I1001=I1001+1
33993       IF (I1001.GT.50)                                          GO TO 60
33994 C
33995       IF (IT2*AMS.GT.IT2*ECM)                                  GO TO 110
33996       IT11=IT1
33997       IT22=IT2
33998       IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
33999       AM11=AM1
34000       AM22=AM2
34001       IF (IT2.GT.0)                                            GO TO 120
34002 **sr 19.2.97: supress direct channel for pp-collisions
34003       IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
34004          RR = DT_RNDM(AM11)
34005          IF (RR.LE.0.75D0) GOTO 60
34006       ENDIF
34007 **
34008 C
34009 C-----------------------------
34010 C  INCLUSION OF DIRECT RESONANCES
34011 C  RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE  IT1
34012 C------------------------
34013       KZ1=K1H(IT1)
34014       IST=IST+1
34015       IECO=0
34016       ECO=ECM
34017       GAM=(ELAB+AMT)/ECO
34018       BGAM=PLAB/ECO
34019       CXS(1)=CX
34020       CYS(1)=CY
34021       CZS(1)=CZ
34022                                                                GO TO 170
34023   120 CONTINUE
34024       WW=DT_RNDM(ECO)
34025       IF(WW.LT. 0.5D0)                                         GO TO 130
34026       IT1=IT22
34027       IT2=IT11
34028       AM1=AM22
34029       AM2=AM11
34030   130 CONTINUE
34031 C
34032 C-----------------------------
34033 C   THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
34034       IBN=IBARH(N)
34035       IB1=IBARH(IT1)
34036       IT11=IT1
34037       IT22=IT2
34038       AM11=AM1
34039       AM22=AM2
34040       IF(IB1.EQ.IBN)                                           GO TO 140
34041       IT1=IT22
34042       IT2=IT11
34043       AM1=AM22
34044       AM2=AM11
34045   140 CONTINUE
34046 C-----------------------------
34047 C***IT1,IT2 ARE THE CREATED PARTICLES
34048 C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
34049 C------------------------
34050       CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34051      *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
34052       IST=IST+1
34053       ITS(IST)=IT1
34054       AMM(IST)=AM1
34055 C
34056 C-----------------------------
34057 C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
34058 C----------------------------
34059       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
34060      &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34061       IST=IST+1
34062       ITS(IST)=IT2
34063       AMM(IST)=AM2
34064       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
34065      *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34066   150 CONTINUE
34067 C
34068 C-----------------------------
34069 C***TEST   STABLE OR UNSTABLE
34070 C----------------------------
34071       IF(ITS(IST).GT.NSTAB)                                    GO TO 160
34072       IRH=IRH+1
34073 C
34074 C-----------------------------
34075 C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
34076 C----------------------------
34077 C*    IF (REDU.LT.0.D0) GO TO 1009
34078       ITRH(IRH)=ITS(IST)
34079       PLRH(IRH)=PLS(IST)
34080       CXRH(IRH)=CXS(IST)
34081       CYRH(IRH)=CYS(IST)
34082       CZRH(IRH)=CZS(IST)
34083       ELRH(IRH)=ELS(IST)
34084       IST=IST-1
34085       IF(IST.GE.1)                                             GO TO 150
34086                                                                GO TO 260
34087   160 CONTINUE
34088 C
34089 C  RANDOM CHOICE OF DECAY CHANNELS
34090 C----------------------------
34091 C
34092       IT=ITS(IST)
34093       ECO=AMM(IST)
34094       GAM=ELS(IST)/ECO
34095       BGAM=PLS(IST)/ECO
34096       IECO=0
34097       KZ1=K1H(IT)
34098   170 CONTINUE
34099       IECO=IECO+1
34100       VV=DT_RNDM(GAM)
34101       VV=VV-1.D-17
34102       IIK=KZ1-1
34103   180 IIK=IIK+1
34104       IF (VV.GT.WTI(IIK))                                      GO TO 180
34105 C
34106 C  IIK IS THE DECAY CHANNEL
34107 C----------------------------
34108       IT1=NZKI(IIK,1)
34109       I310=0
34110   190 CONTINUE
34111       I310=I310+1
34112       AM1=DT_DAMG(IT1)
34113       IT2=NZKI(IIK,2)
34114       AM2=DT_DAMG(IT2)
34115       IF (IT2-1.LT.0)                                          GO TO 240
34116       IT3=NZKI(IIK,3)
34117       AM3=DT_DAMG(IT3)
34118       AMS=AM1+AM2+AM3
34119 C
34120 C  IF  IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
34121 C----------------------------
34122       IF (IECO.LE.10)                                          GO TO 200
34123       IATMPT=IATMPT+1
34124       IF(IATMPT.GT.3) THEN
34125 C        WRITE(LOUT,*) ' jump 4'
34126          GO TO 280
34127       ENDIF
34128                                                                 GO TO 40
34129   200 CONTINUE
34130       IF (I310.GT.50)                                          GO TO 170
34131       IF (AMS.GT.ECO)                                          GO TO 190
34132 C
34133 C  FOR THE DECAY CHANNEL
34134 C  IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM  IT
34135 C----------------------------
34136       IF (REDU.LT.0.D0)                                        GO TO 30
34137       ITWTHC=0
34138       REDU=2.0D0
34139       IF(IT3.EQ.0)                                             GO TO 220
34140   210 CONTINUE
34141       ITWTH=1
34142       CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
34143      *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
34144                                                                GO TO 230
34145   220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
34146      &COD2,COF2,SIF2,AM1,AM2)
34147       ITWTH=-1
34148       IT3=0
34149   230 CONTINUE
34150       ITWTHC=ITWTHC+1
34151       IF (REDU.GT.0.D0)                                        GO TO 240
34152       REDU=2.0D0
34153       IF (ITWTHC.GT.100)                                        GO TO 30
34154       IF (ITWTH) 220,220,210
34155   240 CONTINUE
34156       ITS(IST  )=IT1
34157       IF (IT2-1.LT.0)                                          GO TO 250
34158       ITS(IST+1)  =IT2
34159       ITS(IST+2)=IT3
34160       RX=CXS(IST)
34161       RY=CYS(IST)
34162       RZ=CZS(IST)
34163       AMM(IST)=AM1
34164       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
34165      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34166       IST=IST+1
34167       AMM(IST)=AM2
34168       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
34169      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34170       IF (IT3.LE.0)                                            GO TO 250
34171       IST=IST+1
34172       AMM(IST)=AM3
34173       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
34174      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34175   250 CONTINUE
34176                                                                GO TO 150
34177   260 CONTINUE
34178   270 CONTINUE
34179       RETURN
34180   280 CONTINUE
34181 C
34182 C----------------------------
34183 C
34184 C   ZERO CROSS SECTION CASE
34185 C----------------------------
34186 C
34187       IRH=1
34188       ITRH(1)=N
34189       CXRH(1)=CX
34190       CYRH(1)=CY
34191       CZRH(1)=CZ
34192       ELRH(1)=ELAB
34193       PLRH(1)=PLAB
34194       RETURN
34195       END
34196
34197 *$ CREATE DT_RUNTT.FOR
34198 *COPY DT_RUNTT
34199 *
34200 *===runtt==============================================================*
34201 *
34202       BLOCK DATA DT_RUNTT
34203
34204       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34205       SAVE
34206
34207       COMMON /HNDRUN/ RUNTES,EFTES
34208
34209       DATA RUNTES,EFTES /100.D0,100.D0/
34210
34211       END
34212
34213 *$ CREATE DT_NONAME.FOR
34214 *COPY DT_NONAME
34215 *
34216 *===noname=============================================================*
34217 *
34218       BLOCK DATA DT_NONAME
34219
34220       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34221       SAVE
34222
34223 * slope parameters for HADRIN interactions
34224       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34225       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34226
34227 C     DATAS     DATAS    DATAS      DATAS     DATAS
34228 C******          *********
34229       DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
34230      &           207, 224, 241, 252, 268 /
34231       DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
34232      &           220, 241, 262, 279, 296 /
34233       DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
34234      &           3364, 3507, 4011, 4368, 4725, 4912, 5184/
34235
34236 C
34237 C     MASSES FOR THE SLOPE B(M) IN GEV
34238 C     SLOPE B(M) FOR AN MESONIC SYSTEM
34239 C     SLOPE B(M) FOR A BARYONIC SYSTEM
34240
34241 *
34242       DATA SM,BBM,BBB/  0.8D0, 0.85D0,  0.9D0, 0.95D0, 1.D0,
34243      &     1.05D0,  1.1D0, 1.15D0,  1.2D0, 1.25D0,
34244      &      1.3D0,  1.35D0, 1.4D0,  1.45D0,  1.5D0,
34245      &     1.55D0,  1.6D0,  1.65D0, 1.7D0,   1.75D0,
34246      &      1.8D0,  1.85D0, 1.9D0,  1.95D0,  2.D0,
34247      &     15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
34248      &    12.35D0, 11.7D0, 10.85D0, 10.D0,  9.15D0,
34249      &      8.3D0,  7.8D0,  7.3D0,  7.25D0,  7.2D0,
34250      &     6.95D0,  6.7D0,  6.6D0,  6.5D0,   6.3D0,
34251      &      6.1D0,  5.85D0, 5.6D0,  5.35D0,  5.1D0,
34252      &      15.D0,   15.D0, 15.D0,  15.D0,   15.D0, 15.D0, 15.D0,
34253      &     14.2D0,  13.4D0, 12.6D0,
34254      &     11.8D0, 11.2D0, 10.6D0,  9.8D0,    9.D0,
34255      &     8.25D0,  7.5D0, 6.25D0,  5.D0,    4.5D0, 5*4.D0 /
34256 *
34257       END
34258
34259 *$ CREATE DT_DAMG.FOR
34260 *COPY DT_DAMG
34261 *
34262 *===damg===============================================================*
34263 *
34264       DOUBLE PRECISION FUNCTION DT_DAMG(IT)
34265
34266       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34267       SAVE
34268
34269 * particle properties (BAMJET index convention),
34270 * (dublicate of DTPART for HADRIN)
34271       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34272      &                K1H(110),K2H(110)
34273
34274       DIMENSION GASUNI(14)
34275       DATA GASUNI/
34276      *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
34277      *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
34278       DATA GAUNO/2.352D0/
34279       DATA GAUNON/2.4D0/
34280       DATA IO/14/
34281       DATA NSTAB/23/
34282
34283       I=1
34284       IF (IT.LE.0)                                              GO TO 30
34285       IF (IT.LE.NSTAB)                                          GO TO 20
34286       DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
34287       VV=DT_RNDM(DGAUNI)
34288       VV=VV*2.0D0-1.0D0+1.D-16
34289    10 CONTINUE
34290       VO=GASUNI(I)
34291       I=I+1
34292       V1=GASUNI(I)
34293       IF (VV.GT.V1)                                             GO TO 10
34294       UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
34295      &      (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
34296       DAM=GAH(IT)*UNIGA/GAUNO
34297       AAM=AMH(IT)+DAM
34298       DT_DAMG=AAM
34299       RETURN
34300    20 CONTINUE
34301       DT_DAMG=AMH(IT)
34302       RETURN
34303    30 CONTINUE
34304       DT_DAMG=0.0D0
34305       RETURN
34306       END
34307
34308 *$ CREATE DT_DCALUM.FOR
34309 *COPY DT_DCALUM
34310 *
34311 *===dcalum=============================================================*
34312 *
34313       SUBROUTINE DT_DCALUM(N,ITTA)
34314
34315       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34316       SAVE
34317
34318 C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
34319
34320 * particle properties (BAMJET index convention),
34321 * (dublicate of DTPART for HADRIN)
34322       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34323      &                K1H(110),K2H(110)
34324       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34325       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34326       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34327      &                NRK(2,268),NURE(30,2)
34328
34329       IRE=NURE(N,ITTA/8+1)
34330       IEO=IEII(IRE)+1
34331       IEE=IEII(IRE +1)
34332       AM1=AMH(N   )
34333       AM12=AM1**2
34334       AM2=AMH(ITTA)
34335       AM22=AM2**2
34336       DO 10 IE=IEO,IEE
34337         PLAB2=PLABF(IE)**2
34338         ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
34339         UMO(IE)=ELAB
34340    10 CONTINUE
34341       IKO=IKII(IRE)+1
34342       IKE=IKII(IRE +1)
34343       UMOO=UMO(IEO)
34344       DO 30 IK=IKO,IKE
34345         IF(NRK(2,IK).GT.0)                                      GO TO 30
34346         IKI=NRK(1,IK)
34347         AMSS=5.0D0
34348         K11=K1H(IKI)
34349         K22=K2H(IKI)
34350         DO 20 IK1=K11,K22
34351           IN=NZKI(IK1,1)
34352           AMS=AMH(IN)
34353           IN=NZKI(IK1,2)
34354           IF(IN.GT.0)AMS=AMS+AMH(IN)
34355           IN=NZKI(IK1,3)
34356           IF(IN.GT.0) AMS=AMS+AMH(IN)
34357           IF (AMS.LT.AMSS) AMSS=AMS
34358    20   CONTINUE
34359         IF(UMOO.LT.AMSS) UMOO=AMSS
34360         THRESH(IK)=UMOO
34361    30 CONTINUE
34362       RETURN
34363       END
34364
34365 *$ CREATE DT_DCHANH.FOR
34366 *COPY DT_DCHANH
34367 *
34368 *===dchanh=============================================================*
34369 *
34370       SUBROUTINE DT_DCHANH
34371
34372       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34373       SAVE
34374
34375       PARAMETER ( LINP = 10 ,
34376      &            LOUT = 6 ,
34377      &            LDAT = 9 )
34378 * particle properties (BAMJET index convention),
34379 * (dublicate of DTPART for HADRIN)
34380       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34381      &                K1H(110),K2H(110)
34382       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34383       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34384       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34385      &                NRK(2,268),NURE(30,2)
34386
34387       DIMENSION HWT(460),HWK(40),SI(5184)
34388       EQUIVALENCE (WK(1),SI(1))
34389 C--------------------
34390 C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
34391 C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
34392 C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
34393 C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
34394 C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
34395 C--------------------------
34396       IREG=16
34397       DO 90 IRE=1,IREG
34398         IWKO=IRII(IRE)
34399         IEE=IEII(IRE+1)-IEII(IRE)
34400         IKE=IKII(IRE+1)-IKII(IRE)
34401         IEO=IEII(IRE)+1
34402         IIKA=IKII(IRE)
34403 *   modifications to suppress elestic scattering  24/07/91
34404         DO 80 IE=1,IEE
34405           SIS=1.D-14
34406           SINORC=0.0D0
34407           DO 10 IK=1,IKE
34408             IWK=IWKO+IEE*(IK-1)+IE
34409             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34410             SIS=SIS+SI(IWK)*SINORC
34411    10     CONTINUE
34412           SIIN(IEO+IE-1)=SIS
34413           SIO=0.D0
34414           IF (SIS.GE.1.D-12)                                    GO TO 20
34415           SIS=1.D0
34416           SIO=1.D0
34417    20     CONTINUE
34418           SINORC=0.0D0
34419           DO 30 IK=1,IKE
34420             IWK=IWKO+IEE*(IK-1)+IE
34421             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34422             SIO=SIO+SI(IWK)*SINORC/SIS
34423             HWK(IK)=SIO
34424    30     CONTINUE
34425           DO 40 IK=1,IKE
34426             IWK=IWKO+IEE*(IK-1)+IE
34427    40     WK(IWK)=HWK(IK)
34428           IIKI=IKII(IRE)
34429           DO 70 IK=1,IKE
34430             AM111=0.D0
34431             INRK1=NRK(1,IIKI+IK)
34432             IF (INRK1.GT.0) AM111=AMH(INRK1)
34433             AM222=0.D0
34434             INRK2=NRK(2,IIKI+IK)
34435             IF (INRK2.GT.0) AM222=AMH(INRK2)
34436             THRESH(IIKI+IK)=AM111 +AM222
34437             IF (INRK2-1.GE.0)                                   GO TO 60
34438             INRKK=K1H(INRK1)
34439             AMSS=5.D0
34440             INRKO=K2H(INRK1)
34441             DO 50 INRK1=INRKK,INRKO
34442               INZK1=NZKI(INRK1,1)
34443               INZK2=NZKI(INRK1,2)
34444               INZK3=NZKI(INRK1,3)
34445               IF (INZK1.LE.0.OR.INZK1.GT.110)                   GO TO 50
34446               IF (INZK2.LE.0.OR.INZK2.GT.110)                   GO TO 50
34447               IF (INZK3.LE.0.OR.INZK3.GT.110)                   GO TO 50
34448 C     WRITE (6,310)INRK1,INZK1,INZK2,INZK3
34449  1000 FORMAT (4I10)
34450               AMS=AMH(INZK1)+AMH(INZK2)
34451               IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
34452               IF (AMSS.GT.AMS) AMSS=AMS
34453    50       CONTINUE
34454             AMS=AMSS
34455             IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
34456             THRESH(IIKI+IK)=AMS
34457    60       CONTINUE
34458    70     CONTINUE
34459    80   CONTINUE
34460    90 CONTINUE
34461       DO 100 J=1,460
34462   100 HWT(J)=0.D0
34463       DO 120 I=1,110
34464         IK1=K1H(I)
34465         IK2=K2H(I)
34466         HV=0.D0
34467         IF (IK2.GT.460)IK2=460
34468         IF (IK1.LE.0)IK1=1
34469         DO 110 J=IK1,IK2
34470           HV=HV+WTI(J)
34471           HWT(J)=HV
34472           JI=J
34473   110   CONTINUE
34474         IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
34475  1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
34476   120 CONTINUE
34477       DO 130 J=1,460
34478   130 WTI(J)=HWT(J)
34479       RETURN
34480       END
34481
34482 *$ CREATE DT_DHADDE.FOR
34483 *COPY DT_DHADDE
34484 *
34485 *===dhadde=============================================================*
34486 *
34487       SUBROUTINE DT_DHADDE
34488
34489       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34490       SAVE
34491
34492 * particle properties (BAMJET index convention)
34493       CHARACTER*8  ANAME
34494       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
34495      &                IICH(210),IIBAR(210),K1(210),K2(210)
34496 * HADRIN: decay channel information
34497       PARAMETER (IDMAX9=602)
34498       CHARACTER*8 ZKNAME
34499       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
34500 * particle properties (BAMJET index convention),
34501 * (dublicate of DTPART for HADRIN)
34502       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34503      &                K1H(110),K2H(110)
34504       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34505 * decay channel information for HADRIN
34506       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34507      &                K1Z(16),K2Z(16),WTZ(153),II22,
34508      &                NZK1(153),NZK2(153),NZK3(153)
34509
34510       DATA IRETUR/0/
34511
34512       IRETUR=IRETUR+1
34513       AMH(31)=0.48D0
34514       IF (IRETUR.GT.1) RETURN
34515       DO 10 I=1,94
34516         AMH(I)   = AAM(I)
34517         GAH(I)   = GA(I)
34518         TAUH(I)  = TAU(I)
34519         ICHH(I)  = IICH(I)
34520         IBARH(I) = IIBAR(I)
34521         K1H(I)   = K1(I)
34522         K2H(I)   = K2(I)
34523    10 CONTINUE
34524 **sr
34525 C     AMH(1)=0.93828D0
34526       AMH(1)=0.9383D0
34527 **
34528       AMH(2)=AMH(1)
34529       DO 20 I=26,30
34530         K1H(I)=452
34531         K2H(I)=452
34532    20 CONTINUE
34533       DO 30 I=1,307
34534         WTI(I)    = WT(I)
34535         NZKI(I,1) = NZK(I,1)
34536         NZKI(I,2) = NZK(I,2)
34537         NZKI(I,3) = NZK(I,3)
34538    30 CONTINUE
34539       DO 40 I=1,16
34540         L=I+94
34541         AMH(L)=AMZ(I)
34542         GAH( L)=GAZ(I)
34543         TAUH( L)=TAUZ(I)
34544         ICHH( L)=ICHZ(I)
34545         IBARH( L)=IBARZ(I)
34546         K1H( L)=K1Z(I)
34547         K2H( L)=K2Z(I)
34548    40 CONTINUE
34549       DO 50 I=1,153
34550         L=I+307
34551         WTI(L)    = WTZ(I)
34552         NZKI(L,3) = NZK3(I)
34553         NZKI(L,2) = NZK2(I)
34554         NZKI(L,1) = NZK1(I)
34555    50 CONTINUE
34556       RETURN
34557       END
34558
34559 *$ CREATE IDT_IEFUND.FOR
34560 *COPY IDT_IEFUND
34561 *
34562 *===iefund=============================================================*
34563 *
34564       INTEGER FUNCTION IDT_IEFUND(PL,IRE)
34565
34566       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34567       SAVE
34568
34569 C*****IEFUN CALCULATES A MOMENTUM INDEX
34570
34571       PARAMETER ( LINP = 10 ,
34572      &            LOUT = 6 ,
34573      &            LDAT = 9 )
34574       COMMON /HNDRUN/ RUNTES,EFTES
34575       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34576       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34577      &                NRK(2,268),NURE(30,2)
34578
34579       IPLA=IEII(IRE)+1
34580      *+1
34581       IPLE=IEII(IRE+1)
34582       IF (PL.LT.0.)                                             GO TO 30
34583       DO 10 I=IPLA,IPLE
34584         J=I-IPLA+1
34585         IF (PL.LE.PLABF(I))                                     GO TO 60
34586    10 CONTINUE
34587       I=IPLE
34588       IF ( EFTES.GT.40.D0)                                      GO TO 20
34589       EFTES=EFTES+1.0D0
34590       WRITE(LOUT,1000)PL,J
34591    20 CONTINUE
34592                                                                 GO TO 70
34593    30 CONTINUE
34594       DO 40 I=IPLA,IPLE
34595         J=I-IPLA+1
34596         IF (-PL.LE.UMO(I))                                      GO TO 60
34597    40 CONTINUE
34598       I=IPLE
34599       IF ( EFTES.GT.40.D0)                                      GO TO 50
34600       EFTES=EFTES+1.0D0
34601       WRITE(LOUT,1000)PL,I
34602    50 CONTINUE
34603    60 CONTINUE
34604    70 CONTINUE
34605       IDT_IEFUND=I
34606       RETURN
34607  1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
34608      +7H IEFUN=,I5)
34609       END
34610
34611 *$ CREATE DT_DSIGIN.FOR
34612 *COPY DT_DSIGIN
34613 *
34614 *===dsigin=============================================================*
34615 *
34616       SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
34617
34618       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34619       SAVE
34620
34621 * particle properties (BAMJET index convention),
34622 * (dublicate of DTPART for HADRIN)
34623       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34624      &                K1H(110),K2H(110)
34625       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34626       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34627      &                NRK(2,268),NURE(30,2)
34628
34629       IE=IDT_IEFUND(PLAB,IRE)
34630       IF (IE.LE.IEII(IRE)) IE=IE+1
34631       AMT=AMH(ITAR)
34632       AMN=AMH(N)
34633       AMN2=AMN*AMN
34634       AMT2=AMT*AMT
34635       ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
34636 C*** INTERPOLATION PREPARATION
34637       ECMO=UMO(IE)
34638       ECM1=UMO(IE-1)
34639       DECM=ECMO-ECM1
34640       DEC=ECMO-ECM
34641       IIKI=IKII(IRE)+1
34642       EKLIM=-THRESH(IIKI)
34643       WOK=SIIN(IE)
34644       WDK=WOK-SIIN(IE-1)
34645       IF (ECM.GT.ECMO) WDK=0.0D0
34646 C*** INTERPOLATION IN CHANNEL WEIGHTS
34647       IELIM=IDT_IEFUND(EKLIM,IRE)
34648       DELIM=UMO(IELIM)+EKLIM
34649      *+1.D-16
34650       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
34651       IF (DELIM*DELIM-DETE*DETE) 20,20,10
34652    10 DECC=DELIM
34653                                                                 GO TO 30
34654    20 DECC=DECM
34655    30 CONTINUE
34656       WKK=WOK-WDK*DEC/(DECC+1.D-9)
34657       IF (WKK.LT.0.0D0) WKK=0.0D0
34658       SI=WKK+1.D-12
34659       IF (-EKLIM.GT.ECM) SI=1.D-14
34660       RETURN
34661       END
34662
34663 *$ CREATE DT_DTCHOI.FOR
34664 *COPY DT_DTCHOI
34665 *
34666 *===dtchoi=============================================================*
34667 *
34668       SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
34669
34670       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34671       SAVE
34672
34673 C     ****************************
34674 C     TCHOIC CALCULATES A RANDOM VALUE
34675 C     FOR THE FOUR-MOMENTUM-TRANSFER T
34676 C     ****************************
34677
34678 * particle properties (BAMJET index convention),
34679 * (dublicate of DTPART for HADRIN)
34680       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34681      &                K1H(110),K2H(110)
34682 * slope parameters for HADRIN interactions
34683       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34684
34685       AMA=AM1
34686       AMB=AM2
34687       IF (I.GT.30.AND.II.GT.30)                                 GO TO 20
34688       III=II
34689       AM3=AM2
34690       IF (I.LE.30)                                              GO TO 10
34691       III=I
34692       AM3=AM1
34693    10 CONTINUE
34694                                                                 GO TO 30
34695    20 CONTINUE
34696       III=II
34697       AM3=AM2
34698       IF (AMA.LE.AMB)                                           GO TO 30
34699       III=I
34700       AM3=AM1
34701    30 CONTINUE
34702       IB=IBARH(III)
34703       AMA=AM3
34704       K=INT((AMA-0.75D0)/0.05D0)
34705       IF (K-2.LT.0) K=1
34706       IF (K-26.GE.0) K=25
34707       IF (IB)50,40,50
34708    40 BM=BBM(K)
34709                                                                 GO TO 60
34710    50 BM=BBB(K)
34711    60 CONTINUE
34712 C     NORMALIZATION
34713       TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1  **2
34714       TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1  **2
34715       VB=DT_RNDM(TMIN)
34716 **sr test
34717 C     IF (VB.LT.0.2D0) BM=BM*0.1
34718 C    **0.5
34719       BM = BM*5.05D0
34720 **
34721       TMI=BM*TMIN
34722       TMA=BM*TMAX
34723       ETMA=0.D0
34724       IF (ABS(TMA).GT.120.D0)                                   GO TO 70
34725       ETMA=EXP(TMA)
34726    70 CONTINUE
34727       AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
34728 C*** RANDOM CHOICE OF THE T - VALUE
34729       R=DT_RNDM(TMI)
34730       T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
34731       RETURN
34732       END
34733
34734 *$ CREATE DT_DTWOPA.FOR
34735 *COPY DT_DTWOPA
34736 *
34737 *===dtwopa=============================================================*
34738 *
34739       SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34740      &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
34741
34742       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34743       SAVE
34744
34745 C     ******************************************************
34746 C     QUASI TWO PARTICLE PRODUCTION
34747 C     TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
34748 C     FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
34749 C     IN THE CM - SYSTEM
34750 C     COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
34751 C     SPHERICAL COORDINATES
34752 C     ******************************************************
34753
34754 * particle properties (BAMJET index convention),
34755 * (dublicate of DTPART for HADRIN)
34756       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34757      &                K1H(110),K2H(110)
34758
34759       AMA=AM1
34760       AMB=AM2
34761       AMA2=AMA*AMA
34762       E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
34763       E2=UMOO - E1
34764       IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
34765       AMTE=(E1-AMA)*(E1+AMA)
34766       AMTE=AMTE+1.D-18
34767       P1=SQRT(AMTE)
34768       P2=P1
34769 C     / P2 / = / P1 /  BUT OPPOSITE DIRECTIONS
34770 C     DETERMINATION  OF  THE ANGLES
34771 C     COS(THETA1)=COD1      COS(THETA2)=COD2
34772 C     SIN(PHI1)=SIF1        SIN(PHI2)=SIF2
34773 C     COS(PHI1)=COF1        COS(PHI2)=COF2
34774 C     PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
34775       CALL DT_DSFECF(COF1,SIF1)
34776       COF2=-COF1
34777       SIF2=-SIF1
34778 C     CALCULATION OF THETA1
34779       CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
34780       COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
34781       IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
34782       COD2=-COD1
34783       RETURN
34784       END
34785
34786 *$ CREATE DT_ZK.FOR
34787 *COPY DT_ZK
34788 *
34789 *===zk=================================================================*
34790 *
34791       BLOCK DATA DT_ZK
34792
34793       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34794       SAVE
34795
34796 * decay channel information for HADRIN
34797       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34798      &                K1Z(16),K2Z(16),WTZ(153),II22,
34799      &                NZK1(153),NZK2(153),NZK3(153)
34800 * decay channel information for HADRIN
34801       CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
34802       COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
34803
34804 *     Particle masses in GeV                                           *
34805       DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
34806      &          2*1.7D0, 3*0.D0/
34807 *     Resonance width Gamma in GeV                                     *
34808       DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
34809 *     Mean life time in seconds                                        *
34810       DATA TAUZ / 16*0.D0 /
34811 *     Charge of particles and resonances                               *
34812       DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
34813 *     Baryonic charge                                                  *
34814       DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
34815 *     First number of decay channels used for resonances               *
34816 *     and decaying particles                                           *
34817       DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
34818      &          3*460/
34819 *     Last number of decay channels used for resonances                *
34820 *     and decaying particles                                           *
34821       DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
34822      &          3*460/
34823 *     Weight of decay channel                                          *
34824       DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
34825      & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
34826      & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
34827      & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
34828      & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
34829      & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
34830      & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
34831      & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
34832      & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
34833      & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
34834      & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
34835      & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
34836      & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
34837      & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
34838      & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
34839      & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
34840      & .05D0, .65D0, 9*1.D0 /
34841 *     Particle numbers in decay channel                                *
34842       DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
34843      & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
34844      & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
34845      & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
34846      & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
34847      & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
34848      & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
34849      & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
34850       DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
34851      & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
34852      & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
34853      & 4*33, 32, 3*35,  2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
34854      & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
34855      & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
34856      & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
34857      & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
34858      & 1, 8, 1, 8, 1, 9*0 /
34859       DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
34860      & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
34861      & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
34862      & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
34863      & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
34864      & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
34865 *     Particle  names                                                  *
34866       DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS  ',' PAP  ',' PAN  ',
34867      & 'APN', 'DEO   ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
34868      & 3*'BLANK' /
34869 *     Name of decay channel                                            *
34870       DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
34871      & 'ANNPI0','APPPI0','ANPPI-'/
34872       DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K-  ','K0AK0 ',
34873      & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET  ','&0R0  ','P-R+  ',
34874      & 'P+R-  ','POOM  ',' ETET ','ETSP0 ','R0ET  ',' R0R0 ','R+R-  ',
34875      & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
34876      & 'P+R-R0','R0OM  ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
34877      & 'P+R-OM','OMOM  ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
34878      & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
34879      & 'OMOMOM',
34880      & ' P+PO ','P+POPO','P+P+P-','P+ET  ','P0R+  ','P+R0  ','ETSP+ ',
34881      & 'R+ET  ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
34882      & 'P+R-R+','R+OM  ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
34883      & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
34884      & 'P-PO  ','P-POPO','P-P-P+','P-ET  ','POR-  ','P-R0  ','ETSP- ',
34885      & 'R-ET  ','R-R0  ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
34886       DATA ZKNAM6/'P+R-R-','R-OM  ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
34887      & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
34888      & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO  ','LPI+  ',
34889      & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
34890      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
34891      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
34892      & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
34893      & 9*'BLANK'/
34894 *=                                               end*block.zk      *
34895       END
34896
34897 *$ CREATE DT_BLKD43.FOR
34898 *COPY DT_BLKD43
34899 *
34900 *===blkd43=============================================================*
34901 *
34902       BLOCK DATA DT_BLKD43
34903
34904       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34905       SAVE
34906
34907 *
34908 *=== reac =============================================================*
34909 *
34910 *----------------------------------------------------------------------*
34911 *                                                                      *
34912 *     Created on 10 december 1991  by    Alfredo Ferrari & Paola Sala  *
34913 *                                                   Infn - Milan       *
34914 *                                                                      *
34915 *     Last change on 10-dec-91     by    Alfredo Ferrari               *
34916 *                                                                      *
34917 *     This is the original common reac of Hadrin                       *
34918 *                                                                      *
34919 *----------------------------------------------------------------------*
34920 *
34921       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34922      &                NRK(2,268),NURE(30,2)
34923
34924       DIMENSION
34925      & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
34926      & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
34927      & SPIKP1(315), SPIKPU(278), SPIKPV(372),
34928      & SPIKPW(278), SPIKPX(372), SPIKP4(315),
34929      & SPIKP5(187), SPIKP6(289),
34930      & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
34931      & SPIKP9(143), SPIKP0(169), SPKPV(143),
34932      & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
34933      & SANPEL(84) , SPIKPF(273),
34934      & SPKP15(187), SPKP16(272),
34935      & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
34936      & NURELN(60)
34937 *
34938        DIMENSION NRKLIN(532)
34939        EQUIVALENCE (NRK(1,1), NRKLIN(1))
34940        EQUIVALENCE (   UMO(  1),  UMOPI(1)), (   UMO( 93),  UMOKC(1))
34941        EQUIVALENCE (   UMO(161),   UMOP(1)), (   UMO(200),   UMON(1))
34942        EQUIVALENCE (   UMO(263),  UMOK0(1))
34943        EQUIVALENCE ( PLABF(  1),  PLAPI(1)), ( PLABF( 93),  PLAKC(1))
34944        EQUIVALENCE ( PLABF(161),   PLAP(1)), ( PLABF(200),   PLAN(1))
34945        EQUIVALENCE ( PLABF(263),  PLAK0(1))
34946        EQUIVALENCE (   WK(   1), SPIKP1(1)), (   WK( 316), SPIKPU(1))
34947        EQUIVALENCE (   WK( 594), SPIKPV(1)), (   WK( 966), SPIKPW(1))
34948        EQUIVALENCE (   WK(1244), SPIKPX(1)), (   WK(1616), SPIKP4(1))
34949        EQUIVALENCE (   WK(1931), SPIKP5(1)), (   WK(2118), SPIKP6(1))
34950        EQUIVALENCE (   WK(2407), SKMPEL(1)), (   WK(2509), SPIKP7(1))
34951        EQUIVALENCE (   WK(2798), SKMNEL(1)), (   WK(2866), SPIKP8(1))
34952        EQUIVALENCE (   WK(3053), SPIKP9(1)), (   WK(3196), SPIKP0(1))
34953        EQUIVALENCE (   WK(3365),  SPKPV(1)), (   WK(3508), SAPPEL(1))
34954        EQUIVALENCE (   WK(3613), SPIKPE(1)), (   WK(4012), SAPNEL(1))
34955        EQUIVALENCE (   WK(4096), SPIKPZ(1)), (   WK(4369), SANPEL(1))
34956        EQUIVALENCE (   WK(4453), SPIKPF(1)), (   WK(4726), SPKP15(1))
34957        EQUIVALENCE (   WK(4913), SPKP16(1))
34958        EQUIVALENCE (NRK(1,1), NRKLIN(1))
34959        EQUIVALENCE (NRKLIN(   1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
34960        EQUIVALENCE (NRKLIN( 297),  NRKP(1)), (NRKLIN( 367),  NRKN(1))
34961        EQUIVALENCE (NRKLIN( 483), NRKK0(1))
34962        EQUIVALENCE (NURE(1,1), NURELN(1))
34963 *
34964 **** pi- p data                                                        *
34965 **** pi+ n data                                                        *
34966       DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
34967      & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
34968      & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
34969      & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
34970      & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
34971      & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
34972      & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
34973      & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
34974      & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
34975      & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
34976       DATA PLAKC /
34977      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34978      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34979      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
34980      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34981      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34982      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
34983      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34984      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34985      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
34986      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34987      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34988      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
34989       DATA PLAK0 /
34990      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34991      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34992      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
34993      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34994      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34995      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
34996 *                 pp   pn   np   nn                                    *
34997       DATA PLAP /
34998      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
34999      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35000      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35001      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35002      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35003      & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
35004 *    app   apn   anp   ann                                             *
35005       DATA PLAN /
35006      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
35007      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35008      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35009      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
35010      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35011      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35012      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
35013      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35014      & 3.43D0, 3.75D0, 4.07D0, 4.43D0  /
35015       DATA SIIN / 296*0.D0 /
35016       DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35017      & 1.557D0,1.615D0,1.6435D0,
35018      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35019      & 2.286D0,2.366D0,2.482D0,2.56D0,
35020      & 2.735D0,2.90D0,
35021      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35022      & 1.496D0,1.527D0,1.557D0,
35023      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35024      & 2.071D0,2.159D0,2.286D0,2.366D0,
35025      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35026      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35027      & 1.496D0,1.527D0,1.557D0,
35028      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35029      & 2.071D0,2.159D0,2.286D0,2.366D0,
35030      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35031      &                   1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35032      & 1.557D0,1.615D0,1.6435D0,
35033      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35034      & 2.286D0,2.366D0,2.482D0,2.56D0,
35035      &  2.735D0, 2.90D0/
35036       DATA UMOKC/ 1.44D0,
35037      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35038      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35039      & 3.1D0,1.44D0,
35040      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35041      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35042      & 3.1D0,1.44D0,
35043      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35044      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35045      & 3.1D0,1.44D0,
35046      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35047      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35048      &  3.1D0/
35049       DATA UMOK0/ 1.44D0,
35050      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35051      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35052      & 3.1D0,1.44D0,
35053      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35054      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35055      &  3.1D0/
35056 *                 pp   pn   np   nn                                    *
35057       DATA UMOP/
35058      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35059      & 3.D0,3.1D0,3.2D0,
35060      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35061      & 3.D0,3.1D0,3.2D0,
35062      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35063      & 3.D0,3.1D0,3.2D0/
35064 *    app   apn   anp   ann                                             *
35065       DATA UMON /
35066      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35067      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35068      & 3.D0,3.1D0,3.2D0,
35069      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35070      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35071      & 3.D0,3.1D0,3.2D0,
35072      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35073      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35074      &  3.D0,3.1D0,3.2D0/
35075 **** reaction channel state particles                                  *
35076       DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
35077      & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
35078      & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
35079      & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
35080      & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
35081      & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
35082      & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
35083      & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
35084      & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
35085      & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
35086       DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
35087      & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
35088      & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
35089      & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
35090      & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
35091      & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
35092      & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
35093      & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
35094 *                                                                      *
35095 *   k0 p   k0 n   ak0 p   ak/ n                                        *
35096 *                                                                      *
35097       DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
35098      & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13,   22, 13, 21, 23,
35099      & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
35100      & 53, 47, 1, 103, 0, 93, 0/
35101 *   pp  pn   np   nn                                                   *
35102       DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
35103      & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
35104      & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
35105      & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
35106 *     app   apn   anp   ann                                            *
35107       DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
35108      & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
35109      & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
35110      & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
35111      & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
35112      & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
35113      & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
35114 **** channel cross section                                             *
35115       DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
35116      & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
35117      & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
35118      & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
35119      & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
35120      &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
35121      & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
35122      & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
35123      &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
35124      & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
35125      & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
35126      & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
35127      & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
35128      & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
35129      & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
35130      & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
35131      & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
35132      & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
35133      & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
35134      & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
35135 **** pi+ n data                                                        *
35136       DATA SPIKPU/   0.D0, 25.D0, 13.D0,  11.D0, 10.5D0, 14.D0,  20.D0,
35137      & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35138      & 10.D0, 10.D0, 9.5D0,  9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35139      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0,   5.5D0,  4.8D0,
35140      & 4.2D0, 7.5D0, 3.4D0,  2.5D0, 2.5D0, 2.1D0, 1.4D0,   1.D0,   .8D0,
35141      &  .6D0, .46D0,  .3D0, .2D0, .15D0, .13D0, 11*0.D0,  .95D0,  .65D0,
35142      & .48D0, .35D0,  .2D0, .18D0, .17D0, .16D0,  .15D0,   .1D0,  .09D0,
35143      & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0,  .2D0,   .1D0,
35144      & .08D0, .06D0, .045D0,   .03D0, .02D0, .01D0,      .005D0, .003D0,
35145      & 12*0.D0, .3D0, .24D0,   .18D0, .15D0, .13D0,  .12D0, .11D0, .1D0,
35146      & .09D0,  .08D0, .05D0,   .04D0, .03D0,  0.D0, 0.16D0, .7D0, 1.3D0,
35147      & 3.1D0,  4.5D0,  2.D0, 18*0.D0, 3*.0D0,  0.D0, 0.D0, 4.0D0, 11.D0,
35148      & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0,  1.5D0, .9D0, .55D0,
35149      &  .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0,   2.25D0, 3.3D0,
35150      & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
35151      & .64D0,  1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0,  4.4D0,   3.D0, 1.8D0,
35152      &  .9D0, .53D0, .28D0,      10*0.D0, 2*0.D0,  .25D0,  .82D0,
35153      & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0,  5.7D0, 3.9D0, 2.35D0, 1.15D0,
35154      & .69D0, .37D0, 10*0.D0,     7*0.D0,   .0D0, .34D0,  1.5D0, 3.47D0,
35155      & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0,  .3D0,  .15D0, 6*0.D0/
35156 *
35157       DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35158      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
35159      & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
35160      & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
35161      & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
35162      & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
35163      & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
35164      & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
35165      & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
35166      & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
35167      & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
35168      & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
35169      & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
35170      & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
35171      & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
35172      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35173      & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
35174      & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
35175      & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
35176      & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
35177 **** pi- p data                                                        *
35178       DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
35179      & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35180      & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35181      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
35182      & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
35183      & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
35184      & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
35185      & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
35186      & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
35187      & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
35188      & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
35189      & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
35190      & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
35191      & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
35192      & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
35193      & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
35194      & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
35195      & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
35196      & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
35197 *
35198       DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35199      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
35200      & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
35201      & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
35202      & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
35203      & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
35204      & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
35205      & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
35206      & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
35207      & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
35208      & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
35209      & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
35210      & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
35211      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35212      & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
35213      & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
35214      & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
35215      & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
35216      & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
35217      & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
35218 **** pi- n data                                                        *
35219       DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
35220      & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
35221      & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
35222      & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
35223      & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
35224      & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
35225      & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
35226      & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
35227      & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
35228      & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
35229      & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
35230      & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
35231      & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
35232      & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
35233      & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
35234      & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
35235      & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
35236      & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
35237      & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
35238      & 3.3D0, 5.4D0, 7.D0 /
35239 **** k+  p data                                                        *
35240       DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
35241      & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35242      & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
35243      & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
35244      & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35245      & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35246      & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
35247      & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
35248      & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
35249      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35250      & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
35251      & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
35252      & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
35253 **** k+  n data                                                        *
35254       DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
35255      & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
35256      & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
35257      & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
35258      & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35259      & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
35260      & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
35261      & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
35262      & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
35263      & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
35264      & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
35265      & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
35266      & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
35267      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35268      & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
35269      & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
35270      & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
35271      & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
35272      & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
35273 **** k-  p data                                                        *
35274       DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
35275      &     7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
35276      &    0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
35277      &    .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
35278      &    0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
35279      &    .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
35280      &    0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
35281      &    .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
35282      &    0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
35283      &    .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
35284      &    0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
35285      &    .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
35286       DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
35287      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35288      & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
35289      & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
35290      & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,  3*0.D0, 1.0D0, 3.03D0,
35291      & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
35292      & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
35293      & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
35294      & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35295      & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
35296      & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
35297      & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
35298      & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35299      & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
35300      & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
35301      & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
35302      & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
35303      & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
35304      & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
35305      & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
35306      & 10*0.D0/
35307 ***** k- n data                                                        *
35308       DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35309      &        3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
35310      &        0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
35311      &        1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
35312      &        0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
35313      &        .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
35314      &        0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
35315      &       .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
35316       DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35317      &  14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35318      &  1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
35319      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35320      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35321      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35322      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35323      &  7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
35324      &  .39D0, .22D0, .07D0, 0.D0,
35325      &  6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35326      &  4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
35327      &  10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
35328      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35329      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35330      &  9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
35331      &  5.10D0, 5.44D0, 5.3D0,
35332      &  4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
35333 *****  p p data                                                        *
35334       DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35335      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35336      &              0.D0, 3.6D0, 1.7D0, 10*0.D0,
35337      &              .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
35338      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35339      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35340      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35341      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35342      &              16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
35343      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
35344      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
35345      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35346      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35347      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35348      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35349 *****  p n data                                                        *
35350       DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35351      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35352      &              0.D0, 1.8D0, .2D0,  12*0.D0,
35353      &              3.2D0, 6.05D0, 9.9D0, 5.1D0,
35354      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35355      &              2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
35356      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35357      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35358      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35359      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35360      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35361      &              10*0.D0, .7D0, 5.1D0, 8.D0,
35362      &              10*0.D0, .7D0, 5.1D0, 8.D0,
35363      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
35364      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
35365      &              7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
35366      &              7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
35367      &              5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
35368 *   nn - data                                                          *
35369 *                                                                      *
35370       DATA SPKPV/  0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35371      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35372      &              0.D0, 3.6D0, 1.7D0, 12*0.D0,
35373      &              8.7D0, 17.7D0, 18.8D0, 15.9D0,
35374      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35375      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35376      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35377      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
35378      &              11.D0, 5.5D0, 3.5D0,
35379      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
35380      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
35381      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35382      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35383      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35384      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35385 ****************   ap - p - data                                       *
35386       DATA SAPPEL/ 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
35387      &  50.D0,  50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35388      &  25.D0,  22.D0, 21.D0, 20.D0, 18.D0, 17.D0,  11*0.D0,
35389      &  .05D0,  .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
35390      &  0.D0,  1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
35391      &  .1D0,  .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35392      &  0.D0,  55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
35393      &  10.D0,  7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
35394      &  1.55D0,  1.3D0, .95D0, .75D0,
35395      &  0.D0,  3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
35396      &  .25D0,  .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35397      & .01D0,  .008D0, .006D0, .005D0/
35398       DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35399      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35400      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
35401      & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
35402      & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
35403      & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
35404      & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
35405      & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
35406      & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
35407      & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
35408      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35409      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35410      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35411      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
35412      & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
35413      & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
35414      & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
35415      & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
35416      & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
35417      & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
35418 ****************   ap - n - data                                       *
35419       DATA SAPNEL/
35420      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0,  68.D0, 65.D0,
35421      & 50.D0, 50.D0,  43.D0,  42.D0,  40.5D0, 35.D0, 30.D0,  28.D0,
35422      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0,  17.D0, 11*0.D0,
35423      & .05D0, .15D0, .18D0,  .2D0,    .2D0,  .3D0,  .4D0,   .6D0,  .7D0,
35424      & .85D0,  0.D0,  1.D0,  .9D0,    .46D0, .3D0,  .23D0, .18D0, .16D0,
35425      & .14D0,  .1D0, .08D0, .05D0,    .02D0, .015D0, 4*.011D0, 3*.005D0,
35426      & 0.D0,  3.3D0,  3.D0, 1.5D0,     1.D0, .7D0,  .4D0,  .35D0, .4D0,
35427      & .25D0, .18D0, .08D0, .04D0,    .03D0, .023D0, .016D0, .014D0,
35428      & .01D0, .008D0, .006D0, .005D0 /
35429        DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35430      &  84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35431      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35432      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35433      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35434      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35435      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35436      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35437      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35438      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35439      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35440      & 4.9D0, 8.5D0,  15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35441      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35442      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35443 *                                                                      *
35444 *                                                                      *
35445 ****************   an - p - data                                       *
35446 *                                                                      *
35447       DATA SANPEL/
35448      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
35449      & 50.D0, 43.D0,  42.D0,  40.5D0, 35.D0, 30.D0, 28.D0,
35450      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0, 17.D0, 11*0.D0, .05D0,
35451      & .15D0, .18D0,   .2D0,   .2D0,   .3D0,  .4D0, .6D0,   .7D0, .85D0,
35452      & 0.D0,   1.D0,   .9D0,  .46D0,  .3D0,  .23D0, .18D0, .16D0, .14D0,
35453      & .1D0,  .08D0,  .05D0,  .02D0, .015D0, 4*.011D0, 3*.005D0,
35454      & 0.D0,  3.3D0,  3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
35455      & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35456      & .01D0, .008D0, .006D0, .005D0 /
35457       DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35458      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35459      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35460      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35461      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35462      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35463      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35464      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35465      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35466      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35467      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35468      & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35469      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35470      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35471 ****  ko - n - data                                                    *
35472       DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
35473      &      6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35474      &      0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
35475      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35476      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35477      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35478      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35479      &    4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
35480      &     1.4D0, 1.2D0, 1.05D0, .9D0, .66D0,  .5D0,
35481      &    7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
35482      &   11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
35483      &    4.85D0, 4.9D0,
35484      &   10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
35485      &    6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
35486      &    2.85D0, 2.35D0, 2.01D0, 1.8D0,
35487      &   12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
35488      &   12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0  /
35489 **** ako - p - data                                                    *
35490       DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35491      & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
35492      & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
35493      & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
35494      & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
35495      & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
35496      & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
35497      & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35498      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
35499      & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
35500      & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
35501      & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
35502      & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
35503      & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35504      & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
35505      & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
35506      & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
35507      & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
35508      & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
35509      & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
35510      & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
35511       DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
35512      & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
35513 *=                                               end*block.blkdt3      *
35514       END
35515
35516 *$ CREATE DT_QEL_POL.FOR
35517 *COPY DT_QEL_POL
35518 *
35519 *===qel_pol============================================================*
35520 *
35521       SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
35522
35523       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35524       SAVE
35525
35526       CALL DT_MASS_INI
35527       CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35528
35529       RETURN
35530       END
35531
35532 *$ CREATE DT_GEN_QEL.FOR
35533 *COPY DT_GEN_QEL
35534 C==================================================================
35535 C   Generation of  a Quasi-Elastic neutrino scattering
35536 C==================================================================
35537 *
35538 *===gen_qel============================================================*
35539 *
35540       SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35541
35542 C...Generate a quasi-elastic   neutrino/antineutrino
35543 C.  Interaction on a nuclear target
35544 C.  INPUT  : LTYP = neutrino type (1,...,6)
35545 C.           ENU (GeV) = neutrino energy
35546 C----------------------------------------------------
35547
35548       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35549       SAVE
35550
35551       PARAMETER ( LINP = 10 ,
35552      &            LOUT = 6 ,
35553      &            LDAT = 9 )
35554       PARAMETER (MAXLND=4000)
35555       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35556 * nuclear potential
35557       LOGICAL LFERMI
35558       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
35559      &                EBINDP(2),EBINDN(2),EPOT(2,210),
35560      &                ETACOU(2),ICOUL,LFERMI
35561 * steering flags for qel neutrino scattering modules
35562       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
35563 **sr - removed (not needed)
35564 C     COMMON /CBAD/  LBAD, NBAD
35565 C     COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
35566 **
35567
35568       DIMENSION PI(3),PO(3)
35569 CJR+
35570       DATA ININU/0/
35571 CJR-
35572 C     REAL*8 DBETA(3)
35573 C     REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
35574       DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
35575       DATA AMN  /0.93827231D0, 0.93956563D0/
35576       DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
35577       DATA INIPRI/0/
35578
35579 C     DATA PFERMI/0.22D0/
35580 CGB+...Binding Energy
35581       DATA EBIND/0.008D0/
35582 CGB-...
35583
35584       ININU=ININU+1
35585       IF(ININU.EQ.1)NDSIG=0
35586       LBAD = 0
35587       enu0=enu
35588 c      write(*,*) enu0
35589 C...Lepton mass
35590       AML = AML0(LTYP)       !  massa leptoni
35591       AML2 = AML**2          !  massa leptoni **2
35592 C...Particle labels (LUND)
35593       N = 5
35594       K(1,1) = 21
35595       K(2,1) = 21
35596       K(3,1) = 21
35597       K(3,3) = 1
35598       K(4,1) = 1
35599       K(4,3) = 1
35600       K(5,1) = 1
35601       K(5,3) = 2
35602       K0 = (LTYP-1)/2          !  2
35603       K1 = LTYP/2              !  2
35604       KA = 12 + 2*K0           !  16
35605       IS = -1 + 2*LTYP - 4*K1  !  -1 +10 -8 = 1
35606       K(1,2) = IS*KA
35607       K(4,2) = IS*(KA-1)
35608       K(3,2) = IS*24
35609       LNU = 2 - LTYP + 2*K1    !  2 - 5 + 2 = - 1
35610       IF (LNU .EQ. 2)  THEN
35611         K(2,2) = 2212
35612         K(5,2) = 2112
35613         AMI = AMN(1)
35614         AMF = AMN(2)
35615 CJR+
35616         PFERMI=PFERMN(2)
35617 CJR-
35618       ELSE
35619         K(2,2) = 2112
35620         K(5,2) = 2212
35621         AMI = AMN(2)
35622         AMF = AMN(1)
35623 CJR+
35624         PFERMI=PFERMP(2)
35625 CJR-
35626       ENDIF
35627       AMI2 = AMI**2
35628       AMF2 = AMF**2
35629
35630       DO IGB=1,5
35631         P(3,IGB) = 0.
35632         P(4,IGB) = 0.
35633         P(5,IGB) = 0.
35634       END DO
35635
35636       NTRY = 0
35637 CGB+...
35638       EFMAX  = SQRT(PFERMI**2 + AMI2) -AMI             ! max. Fermi Energy
35639       ENWELL = EFMAX + EBIND ! depth of nuclear potential well
35640 CGB-...
35641
35642   100 CONTINUE
35643
35644 C...4-momentum initial lepton
35645       P(1,5) = 0.     ! massa
35646       P(1,4) = ENU0    ! energia
35647       P(1,1) = 0.     ! px
35648       P(1,2) = 0.     ! py
35649       P(1,3) = ENU0    ! pz
35650
35651 C     PF = PFERMI*PYR(0)**(1./3.)
35652 c       write(23,*) PYR(0)
35653 c      write(*,*) 'Pfermi=',PF
35654 c      PF = 0.
35655       NTRY=NTRY+1
35656 C     IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
35657       IF (NTRY .GT. 500)  THEN
35658         LBAD = 1
35659         WRITE (LOUT,1001)  NBAD, ENU
35660         RETURN
35661       ENDIF
35662 C     CT = -1. + 2.*PYR(0)
35663 c      CT = -1.
35664 C     ST =  SQRT(1.-CT*CT)
35665 C     F = 2.*3.1415926*PYR(0)
35666 c      F = 0.
35667
35668 C     P(2,4) = SQRT(PF*PF + MI2) - EBIND  ! energia
35669 C     P(2,1) = PF*ST*COS(F)               ! px
35670 C     P(2,2) = PF*ST*SIN(F)               ! py
35671 C     P(2,3) = PF*CT                      ! pz
35672 C     P(2,5) = SQRT(P(2,4)**2-PF*PF)      ! massa
35673        P(2,1) = P21
35674        P(2,2) = P22
35675        P(2,3) = P23
35676        P(2,4) = P24
35677        P(2,5) = P25
35678       beta1=-p(2,1)/p(2,4)
35679       beta2=-p(2,2)/p(2,4)
35680       beta3=-p(2,3)/p(2,4)
35681       N=2
35682 C      WRITE(6,*)' before transforming into target rest frame'
35683       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35684 C      print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35685       N=5
35686
35687       phi11=atan(p(1,2)/p(1,3))
35688       pi(1)=p(1,1)
35689       pi(2)=p(1,2)
35690       pi(3)=p(1,3)
35691
35692       CALL DT_TESTROT(PI,Po,PHI11,1)
35693       DO ll=1,3
35694         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35695       END DO
35696 c        WRITE(*,*) po
35697       p(1,1)=po(1)
35698       p(1,2)=po(2)
35699       p(1,3)=po(3)
35700       phi12=atan(p(1,1)/p(1,3))
35701
35702       pi(1)=p(1,1)
35703       pi(2)=p(1,2)
35704       pi(3)=p(1,3)
35705       CALL DT_TESTROT(Pi,Po,PHI12,2)
35706       DO ll=1,3
35707         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35708       END DO
35709 c        WRITE(*,*) po
35710       p(1,1)=po(1)
35711       p(1,2)=po(2)
35712       p(1,3)=po(3)
35713
35714       enu=p(1,4)
35715
35716 C...Kinematical limits in Q**2
35717 c      S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) !            ????
35718       S = P(2,5)**2 + 2.*ENU*P(2,5)
35719       SQS = SQRT(S)                          ! E centro massa
35720       IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
35721       ELF = (S-AMF2+AML2)/(2.*SQS)           ! energia leptone finale p
35722       PSTAR = (S-P(2,5)**2)/(2.*SQS)       ! p* neutrino nel c.m.
35723       PLF = SQRT(ELF**2-AML2)               ! 3-momento leptone finale
35724       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)    ! + o -
35725       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)    ! according con cos(theta)
35726       IF (Q2MIN .LT. 0.)   Q2MIN = 0.      ! ??? non fisico
35727
35728 C...Generate Q**2
35729       DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
35730   200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35731       DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
35732       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
35733       CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
35734       NDSIG=NDSIG+1
35735 C     WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
35736 C    &Q2,Q2min,Q2MAX,DSIGEV
35737
35738 C...c.m. frame. Neutrino along z axis
35739       DETOT = (P(1,4)) + (P(2,4)) ! e totale
35740       DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
35741       DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
35742       DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
35743 c      WRITE(*,*)
35744 c      WRITE(*,*)
35745 C      WRITE(*,*) 'Input values laboratory frame'
35746       N=2
35747
35748       CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
35749
35750       N=5
35751 c      STHETA = ULANGL(P(1,3),P(1,1))
35752 c      write(*,*) 'stheta' ,stheta
35753 c      stheta=0.
35754 c      CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
35755 c      WRITE(*,*)
35756 c      WRITE(*,*)
35757 C      WRITE(*,*) 'Output values cm frame'
35758 C...Kinematic in c.m. frame
35759       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
35760       STSTAR = SQRT(1.-CTSTAR**2)
35761       PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
35762       P(4,5) = AML                  ! massa leptone
35763       P(4,4) = ELF                 ! e leptone
35764       P(4,3) = PLF*CTSTAR          ! px
35765       P(4,1) = PLF*STSTAR*COS(PHI) ! py
35766       P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
35767
35768       P(5,5) = AMF                  ! barione
35769       P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
35770       P(5,3) = -P(4,3)             ! px
35771       P(5,1) = -P(4,1)             ! py
35772       P(5,2) = -P(4,2)             ! pz
35773
35774       P(3,5) = -Q2
35775       P(3,1) = P(1,1)-P(4,1)
35776       P(3,2) = P(1,2)-P(4,2)
35777       P(3,3) = P(1,3)-P(4,3)
35778       P(3,4) = P(1,4)-P(4,4)
35779
35780 C...Transform back to laboratory  frame
35781 C      WRITE(*,*) 'before going back to nucl rest frame'
35782 c      CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
35783       N=5
35784
35785       CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
35786
35787 C      WRITE(*,*) 'Now back in nucl rest frame'
35788       IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
35789
35790 c********************************************
35791
35792       DO kw=1,5
35793         pi(1)=p(kw,1)
35794         pi(2)=p(kw,2)
35795         pi(3)=p(kw,3)
35796         CALL DT_TESTROT(Pi,Po,PHI12,3)
35797         DO ll=1,3
35798           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35799         END DO
35800         p(kw,1)=po(1)
35801         p(kw,2)=po(2)
35802         p(kw,3)=po(3)
35803       END DO
35804 c********************************************
35805
35806       DO kw=1,5
35807         pi(1)=p(kw,1)
35808         pi(2)=p(kw,2)
35809         pi(3)=p(kw,3)
35810         CALL DT_TESTROT(Pi,Po,PHI11,4)
35811         DO ll=1,3
35812           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35813         END DO
35814         p(kw,1)=po(1)
35815         p(kw,2)=po(2)
35816         p(kw,3)=po(3)
35817       END DO
35818
35819 c********************************************
35820
35821 C      WRITE(*,*) 'Now back in lab frame'
35822
35823       CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35824
35825 CGB+...
35826 C...test (on final momentum of nucleon) if Fermi-blocking
35827 C...is operating
35828       ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
35829      &  - P(5,5)
35830       IF (ENUCL.LT. EFMAX) THEN
35831         IF(INIPRI.LT.10)THEN
35832           INIPRI=INIPRI+1
35833 C         WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
35834 C...the interaction is not possible due to Pauli-Blocking and
35835 C...it must be resampled
35836         ENDIF
35837         GOTO 100
35838       ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
35839         IF(INIPRI.LT.10)THEN
35840           INIPRI=INIPRI+1
35841 C     WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
35842         ENDIF
35843 C                      Reject (J:R) here all these events
35844 C                      are otherwise rejected in dpmjet
35845         GOTO 100
35846 C...the interaction is possible, but the nucleon remains inside
35847 C...the nucleus. The nucleus is therefore left excited.
35848 C...We treat this case as a nucleon with 0 kinetic energy.
35849 C       P(5,5) = AMF
35850 C       P(5,4) = AMF
35851 C       P(5,1) = 0.
35852 C       P(5,2) = 0.
35853 C       P(5,3) = 0.
35854       ELSE IF (ENUCL.GE.ENWELL) THEN
35855 C     WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
35856 C...the interaction is possible, the nucleon can exit the nucleus
35857 C...but the nuclear well depth must be subtracted. The nucleus could be
35858 C...left in an excited state.
35859         Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
35860 C       P(5,4) = ENUCL-ENWELL + AMF
35861         Pnucl = SQRT(P(5,4)**2-AMF**2)
35862 C...The 3-momentum is scaled assuming that the direction remains
35863 C...unaffected
35864         P(5,1) = P(5,1) * Pnucl/Pstart
35865         P(5,2) = P(5,2) * Pnucl/Pstart
35866         P(5,3) = P(5,3) * Pnucl/Pstart
35867 C     WRITE(6,*)' qel new P(5,4) ',P(5,4)
35868       ENDIF
35869 CGB-...
35870       DSIGSU=DSIGSU+DSIGEV
35871
35872          GA=P(4,4)/P(4,5)
35873          BGX=P(4,1)/P(4,5)
35874          BGY=P(4,2)/P(4,5)
35875          BGZ=P(4,3)/P(4,5)
35876 *
35877          DBETB(1)=BGX/GA
35878          DBETB(2)=BGY/GA
35879          DBETB(3)=BGZ/GA
35880          IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
35881
35882             CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
35883
35884          ENDIF
35885 c
35886 C      PRINT*,' FINE   EVENTO '
35887       enu=enu0
35888       RETURN
35889
35890  1001 FORMAT(2X, 'DT_GEN_QEL   : event rejected ', I5,  G10.3)
35891       END
35892
35893 *$ CREATE DT_MASS_INI.FOR
35894 *COPY DT_MASS_INI
35895 C====================================================================
35896 C.  Masses
35897 C====================================================================
35898 *
35899 *===mass_ini===========================================================*
35900 *
35901       SUBROUTINE DT_MASS_INI
35902 C...Initialize  the kinematics for the quasi-elastic cross section
35903
35904       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35905       SAVE
35906
35907 * particle masses used in qel neutrino scattering modules
35908       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
35909      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
35910      &                EMPROTSQ,EMNEUTSQ,EMNSQ
35911
35912       EML(1) = 0.51100D-03   ! e-
35913       EML(2) = EML(1)        ! e+
35914       EML(3) = 0.105659D0      ! mu-
35915       EML(4) = EML(3)        ! mu+
35916       EML(5) = 1.7777D0        ! tau-
35917       EML(6) = EML(5)        ! tau+
35918       EMPROT = 0.93827231D0    ! p
35919       EMNEUT = 0.93956563D0    ! n
35920       EMPROTSQ = EMPROT**2
35921       EMNEUTSQ = EMNEUT**2
35922       EMN = (EMPROT + EMNEUT)/2.
35923       EMNSQ = EMN**2
35924       DO J=1,3
35925         J0 = 2*(J-1)
35926         EMN1(J0+1) = EMNEUT
35927         EMN1(J0+2) = EMPROT
35928         EMN2(J0+1) = EMPROT
35929         EMN2(J0+2) = EMNEUT
35930       ENDDO
35931       DO J=1,6
35932         EMLSQ(J) = EML(J)**2
35933         ETQE(J)  = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
35934       ENDDO
35935       RETURN
35936       END
35937
35938 *$ CREATE DT_DSQEL_Q2.FOR
35939 *COPY DT_DSQEL_Q2
35940 *
35941 *===dsqel_q2===========================================================*
35942 *
35943       DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
35944
35945 C...differential cross section for  Quasi-Elastic scattering
35946 C.       nu + N -> l + N'
35947 C.  From Llewellin Smith  Phys.Rep.  3C, 261, (1971).
35948 C.
35949 C.  INPUT :  JTYP = 1,...,6    nu_e, ...., nubar_tau
35950 C.           ENU (GeV) =  Neutrino energy
35951 C.           Q2  (GeV**2) =  (Transfer momentum)**2
35952 C.
35953 C.  OUTPUT : DSQEL_Q2  = differential  cross section :
35954 C.                       dsigma/dq**2  (10**-38 cm+2/GeV**2)
35955 C------------------------------------------------------------------
35956
35957       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35958       SAVE
35959
35960 * particle masses used in qel neutrino scattering modules
35961       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
35962      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
35963      &                EMPROTSQ,EMNEUTSQ,EMNSQ
35964 **sr - removed (not needed)
35965 C     COMMON /CAXIAL/ FA0, AXIAL2
35966 **
35967
35968       DIMENSION SS(6)
35969       DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
35970       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
35971       DATA AXIAL2 /1.03D0/  ! to be checked
35972
35973       FA0=-1.253D0
35974       CSI = 3.71D0                   !  ???
35975       GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2   ! G_e(q**2)
35976       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
35977       X = Q2/(EMN*EMN)     ! emn=massa barione
35978       XA = X/4.D0
35979       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
35980       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
35981       FA = FA0/(1.D0 + Q2/AXIAL2)**2
35982       FFA = FA*FA
35983       FFV1 = FV1*FV1
35984       FFV2 = FV2*FV2
35985       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
35986       A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
35987       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
35988       AA = (XA+0.25D0*RM)*(A1 + A2)
35989       BB = -X*FA*(FV1 + FV2)
35990       CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
35991       SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
35992       DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU)  !
35993       IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
35994
35995       RETURN
35996       END
35997
35998 *$ CREATE DT_PREPOLA.FOR
35999 *COPY DT_PREPOLA
36000 *
36001 *===prepola============================================================*
36002 *
36003       SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
36004
36005       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36006       SAVE
36007 c
36008 c By G. Battistoni and E. Scapparone (sept. 1997)
36009 c According to:
36010 c     Albright & Jarlskog, Nucl Phys B84 (1975) 467
36011 c
36012 c
36013       PARAMETER (MAXLND=4000)
36014       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36015       COMMON /QNPOL/ POLARX(4),PMODUL
36016 * particle masses used in qel neutrino scattering modules
36017       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
36018      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
36019      &                EMPROTSQ,EMNEUTSQ,EMNSQ
36020 * steering flags for qel neutrino scattering modules
36021       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
36022 **sr - removed (not needed)
36023 C     COMMON /CAXIAL/ FA0, AXIAL2
36024 C     COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
36025 C    &        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
36026 **
36027       REAL*8 POL(4,4),BB2(3)
36028       DIMENSION SS(6)
36029 C     DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
36030       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
36031 **sr uncommented since common block CAXIAL is now commented
36032       DATA AXIAL2 /1.03D0/  ! to be checked
36033 **
36034
36035       RML=P(4,5)
36036       RMM=0.93960D+00
36037       FM2 = RMM**2
36038       MPI = 0.135D+00
36039       OLDQ2=Q2
36040       FA0=-1.253D+00
36041       CSI = 3.71D+00                      !
36042       GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2   ! G_e(q**2)
36043       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
36044       X = Q2/(EMN*EMN)     ! emn=massa barione
36045       XA = X/4.D0
36046       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
36047       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
36048       FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
36049       FFA = FA*FA
36050       FFV1 = FV1*FV1
36051       FFV2 = FV2*FV2
36052       FP=2.D0*FA*RMM/(MPI**2 + Q2)
36053       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
36054       A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
36055       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
36056       AA = (XA+0.25D+00*RM)*(A1 + A2)
36057       BB = -X*FA*(FV1 + FV2)
36058       CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
36059       SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
36060
36061       OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2   )  ! articolo di ll...-smith
36062       OMEGA2=4.D+00*CC
36063       OMEGA3=2.D+00*FA*(FV1+FV2)
36064       OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
36065      1     (Q2/FM2))*FP**2)
36066       OMEGA5=OMEGA2
36067       OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
36068       WW1=2.D+00*OMEGA1*EMN**2
36069       WW2=2.D+00*OMEGA2*EMN**2
36070       WW3=2.D+00*OMEGA3*EMN**2
36071       WW4=2.D+00*OMEGA4*EMN**2
36072       WW5=2.D+00*OMEGA5*EMN**2
36073
36074       DO I=1,3
36075         BB2(I)=-P(4,I)/P(4,4)
36076       END DO
36077 c      WRITE(*,*)
36078 c      WRITE(*,*)
36079 c      WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
36080       N=5
36081       CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
36082 * NOW PARTICLES ARE IN THE SCATTERED LEPTON  REST FRAME
36083 c      WRITE(*,*)
36084 c      WRITE(*,*)
36085 c      WRITE(*,*) 'Prepola: now in lepton rest frame'
36086       EE=ENU
36087       QM2=Q2+RML**2
36088       U=Q2/(2.*RMM)
36089       FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
36090      +     (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
36091      +     ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
36092
36093       FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
36094      +     - ((RML**2)/FM2)*WW4                        !<=FM2 inv di RMM!!
36095
36096       FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
36097
36098       DO I=1,3
36099         POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
36100         POLARX(I)=POL(4,I)
36101       END DO
36102
36103       PMODUL=0.D0
36104       DO I=1,3
36105         PMODUL=PMODUL+POL(4,I)**2
36106       END DO
36107
36108       IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
36109          IF(NEUDEC.EQ.1) THEN
36110             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
36111      +        ETL,PXL,PYL,PZL,
36112      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36113 c
36114 c     Tau has decayed in muon
36115 c
36116          ENDIF
36117          IF(NEUDEC.EQ.2) THEN
36118             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
36119      +        ETL,PXL,PYL,PZL,
36120      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36121 c
36122 c     Tau has decayed in electron
36123 c
36124          ENDIF
36125          K(4,1)=15
36126          K(4,4) = 6
36127          K(4,5) = 8
36128          N=N+3
36129 c
36130 c     fill common for muon(electron)
36131 c
36132          P(6,1)=PXL
36133          P(6,2)=PYL
36134          P(6,3)=PZL
36135          P(6,4)=ETL
36136          K(6,1)=1
36137          IF(JTYP.EQ.5) THEN
36138             IF(NEUDEC.EQ.1) THEN
36139                P(6,5)=EML(JTYP-2)
36140                K(6,2)=13
36141             ELSEIF(NEUDEC.EQ.2) THEN
36142                P(6,5)=EML(JTYP-4)
36143                K(6,2)=11
36144             ENDIF
36145          ELSEIF(JTYP.EQ.6) THEN
36146             IF(NEUDEC.EQ.1) THEN
36147                K(6,2)=-13
36148             ELSEIF(NEUDEC.EQ.2) THEN
36149                K(6,2)=-11
36150             ENDIF
36151          END IF
36152          K(6,3)=4
36153          K(6,4)=0
36154          K(6,5)=0
36155 c
36156 c     fill common for tau_(anti)neutrino
36157 c
36158          P(7,1)=PXB
36159          P(7,2)=PYB
36160          P(7,3)=PZB
36161          P(7,4)=ETB
36162          P(7,5)=0.
36163          K(7,1)=1
36164          IF(JTYP.EQ.5) THEN
36165             K(7,2)=16
36166          ELSEIF(JTYP.EQ.6) THEN
36167             K(7,2)=-16
36168          END IF
36169          K(7,3)=4
36170          K(7,4)=0
36171          K(7,5)=0
36172 c
36173 c     Fill common for muon(electron)_(anti)neutrino
36174 c
36175          P(8,1)=PXN
36176          P(8,2)=PYN
36177          P(8,3)=PZN
36178          P(8,4)=ETN
36179          P(8,5)=0.
36180          K(8,1)=1
36181          IF(JTYP.EQ.5) THEN
36182             IF(NEUDEC.EQ.1) THEN
36183                K(8,2)=-14
36184             ELSEIF(NEUDEC.EQ.2) THEN
36185                K(8,2)=-12
36186             ENDIF
36187          ELSEIF(JTYP.EQ.6) THEN
36188             IF(NEUDEC.EQ.1) THEN
36189                K(8,2)=14
36190             ELSEIF(NEUDEC.EQ.2) THEN
36191                K(8,2)=12
36192             ENDIF
36193          END IF
36194          K(8,3)=4
36195          K(8,4)=0
36196          K(8,5)=0
36197       ENDIF
36198 c      WRITE(*,*)
36199 c      WRITE(*,*)
36200
36201 c      IF(PMODUL.GE.1.D+00) THEN
36202 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36203 c        write(*,*) pmodul
36204 c        DO I=1,3
36205 c          POL(4,I)=POL(4,I)/PMODUL
36206 c          POLARX(I)=POL(4,I)
36207 c        END DO
36208 c        PMODUL=0.
36209 c        DO I=1,3
36210 c          PMODUL=PMODUL+POL(4,I)**2
36211 c        END DO
36212 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36213 c
36214 c      ENDIF
36215
36216 c      WRITE(*,*) 'PMODUL = ',PMODUL
36217
36218 c      WRITE(*,*)
36219 c      WRITE(*,*)
36220 c      WRITE(*,*) 'prepola: Now back to nucl rest frame'
36221       CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
36222
36223       XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
36224       YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
36225       ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
36226       DO NDC =6,8
36227          V(NDC,1) = XDC
36228          V(NDC,2) = YDC
36229          V(NDC,3) = ZDC
36230       END DO
36231
36232       RETURN
36233       END
36234
36235 *$ CREATE DT_TESTROT.FOR
36236 *COPY DT_TESTROT
36237 *
36238 *===testrot============================================================*
36239 *
36240       SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
36241
36242       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36243       SAVE
36244
36245       DIMENSION ROT(3,3),PI(3),PO(3)
36246
36247       IF (MODE.EQ.1) THEN
36248          ROT(1,1) = 1.D0
36249          ROT(1,2) = 0.D0
36250          ROT(1,3) = 0.D0
36251          ROT(2,1) = 0.D0
36252          ROT(2,2) = COS(PHI)
36253          ROT(2,3) = -SIN(PHI)
36254          ROT(3,1) = 0.D0
36255          ROT(3,2) = SIN(PHI)
36256          ROT(3,3) = COS(PHI)
36257       ELSEIF (MODE.EQ.2) THEN
36258          ROT(1,1) = 0.D0
36259          ROT(1,2) = 1.D0
36260          ROT(1,3) = 0.D0
36261          ROT(2,1) = COS(PHI)
36262          ROT(2,2) = 0.D0
36263          ROT(2,3) = -SIN(PHI)
36264          ROT(3,1) = SIN(PHI)
36265          ROT(3,2) = 0.D0
36266          ROT(3,3) = COS(PHI)
36267       ELSEIF (MODE.EQ.3) THEN
36268          ROT(1,1) = 0.D0
36269          ROT(2,1) = 1.D0
36270          ROT(3,1) = 0.D0
36271          ROT(1,2) = COS(PHI)
36272          ROT(2,2) = 0.D0
36273          ROT(3,2) = -SIN(PHI)
36274          ROT(1,3) = SIN(PHI)
36275          ROT(2,3) = 0.D0
36276          ROT(3,3) = COS(PHI)
36277       ELSEIF (MODE.EQ.4) THEN
36278          ROT(1,1) = 1.D0
36279          ROT(2,1) = 0.D0
36280          ROT(3,1) = 0.D0
36281          ROT(1,2) = 0.D0
36282          ROT(2,2) = COS(PHI)
36283          ROT(3,2) = -SIN(PHI)
36284          ROT(1,3) = 0.D0
36285          ROT(2,3) = SIN(PHI)
36286          ROT(3,3) = COS(PHI)
36287       ELSE
36288          STOP ' TESTROT: mode not supported!'
36289       ENDIF
36290       DO 1 J=1,3
36291         PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
36292     1 CONTINUE
36293
36294       RETURN
36295       END
36296
36297 *$ CREATE DT_LEPDCYP.FOR
36298 *COPY DT_LEPDCYP
36299 *
36300 *===lepdcyp============================================================*
36301 *
36302       SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
36303      &                      ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36304 C
36305 C-----------------------------------------------------------------
36306 C
36307 C   Author   :- G. Battistoni         10-NOV-1995
36308 C
36309 C=================================================================
36310 C
36311 C   Purpose   : performs decay of polarized lepton in
36312 C               its rest frame: a => b + l + anti-nu
36313 C               (Example: mu- => nu-mu + e- + anti-nu-e)
36314 C               Polarization is assumed along Z-axis
36315 C               WARNING:
36316 C               1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
36317 C                  OF NEGLIGIBLE MASS
36318 C               2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
36319 C                  IN THIS VERSION
36320 C
36321 C   Method    : modifies phase space distribution obtained
36322 C               by routine EXPLOD using a rejection against the
36323 C               matrix element for unpolarized lepton decay
36324 C
36325 C   Inputs    : Mass of a :  AMA
36326 C               Mass of l :  AML
36327 C               Polar. of a: POL
36328 C               (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
36329 C                                                 POL = -1)
36330 C
36331 C   Outputs   : kinematic variables in the rest frame of decaying lepton
36332 C               ETL,PXL,PYL,PZL 4-moment of l
36333 C               ETB,PXB,PYB,PZB 4-moment of b
36334 C               ETN,PXN,PYN,PZN 4-moment of anti-nu
36335 C
36336 C============================================================
36337 C +
36338 C Declarations.
36339 C -
36340       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36341       SAVE
36342
36343       PARAMETER ( LINP = 10 ,
36344      &            LOUT = 6 ,
36345      &            LDAT = 9 )
36346       PARAMETER ( KALGNM = 2 )
36347       PARAMETER ( ANGLGB = 5.0D-16 )
36348       PARAMETER ( ANGLSQ = 2.5D-31 )
36349       PARAMETER ( AXCSSV = 0.2D+16 )
36350       PARAMETER ( ANDRFL = 1.0D-38 )
36351       PARAMETER ( AVRFLW = 1.0D+38 )
36352       PARAMETER ( AINFNT = 1.0D+30 )
36353       PARAMETER ( AZRZRZ = 1.0D-30 )
36354       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
36355       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
36356       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
36357       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
36358       PARAMETER ( CSNNRM = 2.0D-15 )
36359       PARAMETER ( DMXTRN = 1.0D+08 )
36360       PARAMETER ( ZERZER = 0.D+00 )
36361       PARAMETER ( ONEONE = 1.D+00 )
36362       PARAMETER ( TWOTWO = 2.D+00 )
36363       PARAMETER ( THRTHR = 3.D+00 )
36364       PARAMETER ( FOUFOU = 4.D+00 )
36365       PARAMETER ( FIVFIV = 5.D+00 )
36366       PARAMETER ( SIXSIX = 6.D+00 )
36367       PARAMETER ( SEVSEV = 7.D+00 )
36368       PARAMETER ( EIGEIG = 8.D+00 )
36369       PARAMETER ( ANINEN = 9.D+00 )
36370       PARAMETER ( TENTEN = 10.D+00 )
36371       PARAMETER ( HLFHLF = 0.5D+00 )
36372       PARAMETER ( ONETHI = ONEONE / THRTHR )
36373       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
36374       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
36375       PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
36376       PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
36377       PARAMETER ( CLIGHT = 2.99792458         D+10 )
36378       PARAMETER ( AVOGAD = 6.0221367          D+23 )
36379       PARAMETER ( AMELGR = 9.1093897          D-28 )
36380       PARAMETER ( PLCKBR = 1.05457266         D-27 )
36381       PARAMETER ( ELCCGS = 4.8032068          D-10 )
36382       PARAMETER ( ELCMKS = 1.60217733         D-19 )
36383       PARAMETER ( AMUGRM = 1.6605402          D-24 )
36384       PARAMETER ( AMMUMU = 0.113428913        D+00 )
36385       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
36386       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
36387       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
36388       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
36389       PARAMETER ( PLABRC = 0.197327053        D+00 )
36390       PARAMETER ( AMELCT = 0.51099906         D-03 )
36391       PARAMETER ( AMUGEV = 0.93149432         D+00 )
36392       PARAMETER ( AMMUON = 0.105658389        D+00 )
36393       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
36394       PARAMETER ( GEVMEV = 1.0                D+03 )
36395       PARAMETER ( EMVGEV = 1.0                D-03 )
36396       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
36397       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
36398       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
36399 C +
36400 C    variables for EXPLOD
36401 C -
36402       PARAMETER ( KPMX = 10 )
36403       DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
36404      &          PZEXPL (KPMX), ETEXPL (KPMX)
36405 C +
36406 C      test variables
36407 C -
36408 **sr - removed (not needed)
36409 C     COMMON /GBATNU/ ELERAT,NTRY
36410 **
36411 C +
36412 C     Initializes test variables
36413 C -
36414       NTRY = 0
36415       ELERAT = 0.D+00
36416 C +
36417 C     Maximum value for matrix element
36418 C -
36419       ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
36420      &  SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
36421 C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
36422 C     Inputs for EXPLOD
36423 C part. no. 1 is l       (e- in mu- decay)
36424 C part. no. 2 is b       (nu-mu in mu- decay)
36425 C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
36426 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
36427       NPEXPL = 3
36428       ETOTEX = AMA
36429       AMEXPL(1) = AML
36430       AMEXPL(2) = 0.D+00
36431       AMEXPL(3) = 0.D+00
36432 C +
36433 C     phase space distribution
36434 C -
36435   100 CONTINUE
36436       NTRY = NTRY + 1
36437
36438       CALL DT_EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
36439      &                 PYEXPL, PZEXPL )
36440
36441 C +
36442 C  Calculates matrix element:
36443 C  64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
36444 C  Here CTH is the cosine of the angle between anti-nu and Z axis
36445 C -
36446       CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
36447      &  PZEXPL(3)**2 )
36448       PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
36449       PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
36450      &     PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
36451       ELEMAT = 16.D+00 * PROD1 * PROD2
36452       IF(ELEMAT.GT.ELEMAX) THEN
36453         WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
36454         STOP
36455       ENDIF
36456 C +
36457 C     Here performs the rejection
36458 C -
36459       TEST = DT_RNDM(ETOTEX) * ELEMAX
36460       IF ( TEST .GT. ELEMAT ) GO TO 100
36461 C +
36462 C     final assignment of variables
36463 C -
36464       ELERAT = ELEMAT/ELEMAX
36465       ETL = ETEXPL(1)
36466       PXL = PXEXPL(1)
36467       PYL = PYEXPL(1)
36468       PZL = PZEXPL(1)
36469       ETB = ETEXPL(2)
36470       PXB = PXEXPL(2)
36471       PYB = PYEXPL(2)
36472       PZB = PZEXPL(2)
36473       ETN = ETEXPL(3)
36474       PXN = PXEXPL(3)
36475       PYN = PYEXPL(3)
36476       PZN = PZEXPL(3)
36477   999 RETURN
36478       END
36479
36480 *$ CREATE DT_GEN_DELTA.FOR
36481 *COPY DT_GEN_DELTA
36482 C==================================================================
36483 C.  Generation of  Delta resonance events
36484 C==================================================================
36485 *
36486 *===gen_delta==========================================================*
36487 *
36488       SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
36489
36490       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36491       SAVE
36492
36493       PARAMETER ( LINP = 10 ,
36494      &            LOUT = 6 ,
36495      &            LDAT = 9 )
36496 C...Generate a Delta-production neutrino/antineutrino
36497 C.  CC-interaction on a nucleon
36498 C
36499 C.  INPUT  ENU (GeV) = Neutrino Energy
36500 C.         LLEP = neutrino type
36501 C.         LTARG = nucleon target type 1=p, 2=n.
36502 C.         JINT = 1:CC, 2::NC
36503 C.
36504 C.  OUTPUT PPL(4)  4-monentum of final lepton
36505 C----------------------------------------------------
36506       PARAMETER (MAXLND=4000)
36507       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36508 **sr - removed (not needed)
36509 C     COMMON /CBAD/  LBAD, NBAD
36510 **
36511
36512       DIMENSION PI(3),PO(3)
36513 C     REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
36514       DIMENSION AML0(6),AMN(2)
36515       DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
36516       DATA AMN  /0.93827231, 0.93956563/
36517       DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
36518
36519 c     WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
36520       LBAD = 0
36521 C...Final lepton mass
36522       IF (JINT.EQ.1) THEN
36523         AML = AML0(LLEP)
36524       ELSE
36525         AML = 0.
36526       ENDIF
36527       AML2 = AML**2
36528
36529 C...Particle labels (LUND)
36530       N = 5
36531       K(1,1) = 21
36532       K(2,1) = 21
36533       K(3,1) = 21
36534       K(4,1) = 1
36535       K(3,3) = 1
36536       K(4,3) = 1
36537       IF (LTARG .EQ. 1)  THEN
36538          K(2,2) = 2212
36539       ELSE
36540          K(2,2) = 2112
36541       ENDIF
36542       K0 = (LLEP-1)/2
36543       K1 = LLEP/2
36544       KA = 12 + 2*K0
36545       IS = -1 + 2*LLEP - 4*K1
36546       LNU = 2 - LLEP + 2*K1
36547       K(1,2) = IS*KA
36548       K(5,1) = 1
36549       K(5,3) = 2
36550       IF (JINT .EQ. 1)  THEN                    ! CC interactions
36551          K(3,2) = IS*24
36552          K(4,2) = IS*(KA-1)
36553         IF(LNU.EQ.1) THEN
36554           IF (LTARG .EQ. 1)  THEN
36555               K(5,2) = 2224
36556           ELSE
36557               K(5,2) = 2214
36558           ENDIF
36559         ELSE
36560           IF (LTARG .EQ. 1)  THEN
36561               K(5,2) = 2114
36562           ELSE
36563               K(5,2) = 1114
36564           ENDIF
36565         ENDIF
36566       ELSE
36567          K(3,2) = 23                           ! NC (Z0) interactions
36568          K(4,2) = K(1,2)
36569 **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
36570 *                                Delta0 for neutron (LTARG=2)
36571 C        IF (LTARG .EQ. 1)  THEN
36572 C           K(5,2) = 2114
36573 C        ELSE
36574 C           K(5,2) = 2214
36575 C        ENDIF
36576          IF (LTARG .EQ. 1)  THEN
36577             K(5,2) = 2214
36578          ELSE
36579             K(5,2) = 2114
36580          ENDIF
36581 **
36582       ENDIF
36583
36584 C...4-momentum initial lepton
36585       P(1,5) = 0.
36586       P(1,4) = ENU
36587       P(1,1) = 0.
36588       P(1,2) = 0.
36589       P(1,3) = ENU
36590 C...4-momentum initial nucleon
36591       P(2,5) = AMN(LTARG)
36592 C     P(2,4) = P(2,5)
36593 C     P(2,1) = 0.
36594 C     P(2,2) = 0.
36595 C     P(2,3) = 0.
36596        P(2,1) = P21
36597        P(2,2) = P22
36598        P(2,3) = P23
36599        P(2,4) = P24
36600        P(2,5) = P25
36601       N=2
36602       beta1=-p(2,1)/p(2,4)
36603       beta2=-p(2,2)/p(2,4)
36604       beta3=-p(2,3)/p(2,4)
36605       N=2
36606
36607       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
36608
36609 C     print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
36610
36611       phi11=atan(p(1,2)/p(1,3))
36612       pi(1)=p(1,1)
36613       pi(2)=p(1,2)
36614       pi(3)=p(1,3)
36615
36616       CALL DT_TESTROT(PI,Po,PHI11,1)
36617       DO ll=1,3
36618        IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36619       END DO
36620       p(1,1)=po(1)
36621       p(1,2)=po(2)
36622       p(1,3)=po(3)
36623       phi12=atan(p(1,1)/p(1,3))
36624
36625       pi(1)=p(1,1)
36626       pi(2)=p(1,2)
36627       pi(3)=p(1,3)
36628       CALL DT_TESTROT(Pi,Po,PHI12,2)
36629       DO ll=1,3
36630         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36631       END DO
36632       p(1,1)=po(1)
36633       p(1,2)=po(2)
36634       p(1,3)=po(3)
36635
36636       ENUU=P(1,4)
36637
36638 C...Generate the Mass of the Delta
36639       NTRY = 0
36640 100   R = PYR(0)
36641       AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
36642       NTRY = NTRY + 1
36643       IF (NTRY .GT. 1000)  THEN
36644          LBAD = 1
36645          WRITE (LOUT,1001)  NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
36646          RETURN
36647       ENDIF
36648       IF (AMD .LT. AMDMIN)  GOTO 100
36649       ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
36650       IF (ENUU .LT. ET) GOTO 100
36651
36652 C...Kinematical  limits in Q**2
36653       S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
36654       SQS = SQRT(S)
36655       PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
36656       ELF = (S - AMD**2 + AML2)/(2.*SQS)
36657       PLF = SQRT(ELF**2 - AML2)
36658       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
36659       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
36660       IF (Q2MIN .LT. 0.)   Q2MIN = 0.
36661
36662       DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
36663 200   Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
36664       DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
36665       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
36666
36667 C...Generate the kinematics of the final particles
36668       EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
36669       GAM = EISTAR/AMN(LTARG)
36670       BET = PSTAR/EISTAR
36671       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
36672       EL  = GAM*(ELF + BET*PLF*CTSTAR)
36673       PLZ = GAM*(PLF*CTSTAR + BET*ELF)
36674       PL  = SQRT(EL**2 - AML2)
36675       PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
36676       PHI = 6.28319*PYR(0)
36677       P(4,1) = PLT*COS(PHI)
36678       P(4,2) = PLT*SIN(PHI)
36679       P(4,3) = PLZ
36680       P(4,4) = EL
36681       P(4,5) = AML
36682
36683 C...4-momentum of Delta
36684       P(5,1) = -P(4,1)
36685       P(5,2) = -P(4,2)
36686       P(5,3) = ENUU-P(4,3)
36687       P(5,4) = ENUU+AMN(LTARG)-P(4,4)
36688       P(5,5) = AMD
36689
36690 C...4-momentum  of intermediate boson
36691       P(3,5) = -Q2
36692       P(3,4) = P(1,4)-P(4,4)
36693       P(3,1) = P(1,1)-P(4,1)
36694       P(3,2) = P(1,2)-P(4,2)
36695       P(3,3) = P(1,3)-P(4,3)
36696       N=5
36697
36698       DO kw=1,5
36699         pi(1)=p(kw,1)
36700         pi(2)=p(kw,2)
36701         pi(3)=p(kw,3)
36702         CALL DT_TESTROT(Pi,Po,PHI12,3)
36703         DO ll=1,3
36704           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36705         END DO
36706         p(kw,1)=po(1)
36707         p(kw,2)=po(2)
36708         p(kw,3)=po(3)
36709       END DO
36710
36711 c********************************************
36712
36713         DO kw=1,5
36714           pi(1)=p(kw,1)
36715           pi(2)=p(kw,2)
36716           pi(3)=p(kw,3)
36717           CALL DT_TESTROT(Pi,Po,PHI11,4)
36718           DO ll=1,3
36719             IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36720           END DO
36721           p(kw,1)=po(1)
36722           p(kw,2)=po(2)
36723           p(kw,3)=po(3)
36724        END DO
36725 c********************************************
36726 C         transform back into Lab.
36727
36728       CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
36729
36730 C     WRITE(6,*)' Lab fram ( fermi incl.) '
36731       N=5
36732       CALL PYEXEC
36733
36734       RETURN
36735 1001  FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5,  6G10.3)
36736       END
36737
36738 *$ CREATE DT_DSIGMA_DELTA.FOR
36739 *COPY DT_DSIGMA_DELTA
36740 *
36741 *===dsigma_delta=======================================================*
36742 *
36743       DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
36744
36745       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36746       SAVE
36747
36748 C...Reaction nu + N -> lepton + Delta
36749 C.  returns the  cross section
36750 C.  dsigma/dt
36751 C.  INPUT  LNU = 1, 2  (neutrino-antineutrino)
36752 C.         QQ = t (always negative)  GeV**2
36753 C.         S  = (c.m energy)**2      GeV**2
36754 C.  OUTPUT =  10**-38 cm+2/GeV**2
36755 C-----------------------------------------------------
36756       REAL*8 MN, MN2, MN4, MD,MD2, MD4
36757       DATA MN /0.938/
36758       DATA PI /3.1415926/
36759
36760       GF = (1.1664 * 1.97)
36761       GF2 = GF*GF
36762       MN2 = MN*MN
36763       MN4 = MN2*MN2
36764       MD2 = MD*MD
36765       MD4 = MD2*MD2
36766       AML2 = AML*AML
36767       AML4 = AML2*AML2
36768       VQ  = (MN2 - MD2 - QQ)/2.
36769       VPI = (MN2 + MD2 - QQ)/2.
36770       VK  = (S + QQ - MN2 - AML2)/2.
36771       PIK = (S - MN2)/2.
36772       QK = (AML2 - QQ)/2.
36773       PIQ = (QQ + MN2 - MD2)/2.
36774       Q = SQRT(-QQ)
36775       C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
36776       C3 = SQRT(3.)*C3V/MN
36777       C4 = -C3/MD             ! attenzione al segno
36778       C5A = 1.18/(1.-QQ/0.4225)**2
36779       C32 = C3**2
36780       C42 = C4**2
36781       C5A2 = C5A**2
36782
36783       IF (LNU .EQ. 1)  THEN
36784       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36785      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36786      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36787      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36788       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36789      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36790      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36791      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36792      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36793      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
36794      . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36795      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36796      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36797      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36798      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
36799      . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
36800      . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
36801      . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
36802      . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
36803      . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36804      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36805      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36806      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36807       ELSE
36808       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36809      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36810      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36811      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36812       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36813      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36814      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36815      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36816      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36817      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
36818      . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36819      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36820      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36821      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36822      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
36823      . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
36824      . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
36825      . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
36826      . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
36827      . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36828      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36829      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36830      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36831       ENDIF
36832       ANS1=32.*ANS2
36833       ANS=ANS1/(3.*MD2)
36834       P1CM = (S-MN2)/(2.*SQRT(S))
36835       DT_DSIGMA_DELTA  = GF2/2. * ANS/(64.*PI*S*P1CM**2)
36836
36837       RETURN
36838       END
36839
36840 *$ CREATE DT_QGAUS.FOR
36841 *COPY DT_QGAUS
36842 *
36843 *===qgaus==============================================================*
36844 *
36845       SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
36846
36847       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36848       SAVE
36849
36850       DIMENSION X(5),W(5)
36851       DATA X/.1488743389D0,.4333953941D0,
36852      & .6794095682D0,.8650633666D0,.9739065285D0
36853      */
36854       DATA W/.2955242247D0,.2692667193D0,
36855      & .2190863625D0,.1494513491D0,.0666713443D0
36856      */
36857       XM=0.5D0*(B+A)
36858       XR=0.5D0*(B-A)
36859       SS=0
36860       DO 11 J=1,5
36861         DX=XR*X(J)
36862         SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
36863      *  DT_DSQEL_Q2(LTYP,ENU,XM-DX))
36864 11    CONTINUE
36865       SS=XR*SS
36866
36867       RETURN
36868       END
36869
36870 *$ CREATE DT_DIQBRK.FOR
36871 *COPY DT_DIQBRK
36872 *
36873 *===diqbrk=============================================================*
36874 *
36875       SUBROUTINE DT_DIQBRK
36876
36877       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36878       SAVE
36879
36880 * event history
36881       PARAMETER (NMXHKK=200000)
36882       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36883      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36884      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36885 * extended event history
36886       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36887      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36888      &                IHIST(2,NMXHKK)
36889 * event flag
36890       COMMON /DTEVNO/ NEVENT,ICASCA
36891
36892 C     IF(DT_RNDM(VV).LE.0.5D0)THEN
36893 C       CALL GSQBS1(NHKK)
36894 C       CALL GSQBS2(NHKK)
36895 C       CALL USQBS1(NHKK)
36896 C       CALL USQBS2(NHKK)
36897 C       CALL GSABS1(NHKK)
36898 C       CALL GSABS2(NHKK)
36899 C       CALL USABS1(NHKK)
36900 C       CALL USABS2(NHKK)
36901 C     ELSE
36902 C       CALL GSQBS2(NHKK)
36903 C       CALL GSQBS1(NHKK)
36904 C       CALL USQBS2(NHKK)
36905 C       CALL USQBS1(NHKK)
36906 C       CALL GSABS2(NHKK)
36907 C       CALL GSABS1(NHKK)
36908 C       CALL USABS2(NHKK)
36909 C       CALL USABS1(NHKK)
36910 C     ENDIF
36911
36912       IF(DT_RNDM(VV).LE.0.5D0) THEN
36913         CALL DT_DBREAK(1)
36914         CALL DT_DBREAK(2)
36915         CALL DT_DBREAK(3)
36916         CALL DT_DBREAK(4)
36917         CALL DT_DBREAK(5)
36918         CALL DT_DBREAK(6)
36919         CALL DT_DBREAK(7)
36920         CALL DT_DBREAK(8)
36921       ELSE
36922         CALL DT_DBREAK(2)
36923         CALL DT_DBREAK(1)
36924         CALL DT_DBREAK(4)
36925         CALL DT_DBREAK(3)
36926         CALL DT_DBREAK(6)
36927         CALL DT_DBREAK(5)
36928         CALL DT_DBREAK(8)
36929         CALL DT_DBREAK(7)
36930       ENDIF
36931
36932       RETURN
36933       END
36934
36935 *$ CREATE MUSQBS2.FOR
36936 *COPY MUSQBS2
36937 C
36938 C
36939 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36940       SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36941      *              IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
36942 C
36943 C                  USQBS-2 diagram (split target diquark)
36944 C
36945       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36946       SAVE
36947
36948       PARAMETER ( LINP = 10 ,
36949      &            LOUT = 6 ,
36950      &            LDAT = 9 )
36951 * event history
36952       PARAMETER (NMXHKK=200000)
36953       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36954      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36955      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36956 * extended event history
36957       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36958      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36959      &                IHIST(2,NMXHKK)
36960 * Lorentz-parameters of the current interaction
36961       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
36962      &                UMO,PPCM,EPROJ,PPROJ
36963 * diquark-breaking mechanism
36964       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36965
36966 C
36967       PARAMETER (NTMHKK= 300)
36968       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36969      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36970      +(4,NTMHKK)
36971 *KEEP,XSEADI.
36972       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
36973      +SSMIMQ,VVMTHR
36974 *KEEP,DPRIN.
36975       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
36976       COMMON /EVFLAG/ NUMEV
36977 C
36978 C                  USQBS-2 diagram (split target diquark)
36979 C
36980 C
36981 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
36982 C     Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
36983 C
36984 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
36985 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36986 C
36987 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
36988 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36989 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36990 C
36991 C
36992 C       Put new chains into COMMON /HKKTMP/
36993 C
36994       IIGLU1=NC1T-NC1P-1
36995       IIGLU2=NC2T-NC2P-1
36996       IGCOUN=0
36997 C     WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
36998       CVQ=1.D0
36999       IREJ=0
37000       IF(IPIP.EQ.2)THEN
37001 C     IF(NUMEV.EQ.-324)THEN
37002 C     WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37003 C    *             'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
37004 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37005 C    *              IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
37006       ENDIF
37007 C
37008 C
37009 C
37010 C     determine x-values of NC1T diquark
37011       XDIQT=PHKK(4,NC1T)*2.D0/UMO
37012       XVQP=PHKK(4,NC1P)*2.D0/UMO
37013 C
37014 C     determine x-values of sea quark pair
37015 C
37016       IPCO=1
37017       ICOU=0
37018  2234 CONTINUE
37019       ICOU=ICOU+1
37020       IF(ICOU.GE.500)THEN
37021         IREJ=1
37022         IF(ISQ.EQ.3)IREJ=3
37023         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
37024         IPCO=0
37025         RETURN
37026       ENDIF
37027       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
37028      * UMO, XDIQT,XVQP
37029       XSQ=0.D0
37030       XSAQ=0.D0
37031 **NEW
37032 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37033       IF (IPIP.EQ.1) THEN
37034          XQMAX  = XDIQT/2.0D0
37035          XAQMAX = 2.D0*XVQP/3.0D0
37036       ELSE
37037          XQMAX  = 2.D0*XVQP/3.0D0
37038          XAQMAX = XDIQT/2.0D0
37039       ENDIF
37040       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37041       ISAQ = 6+ISQ
37042 C     write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37043 **
37044         IF(IPCO.GE.3)
37045      &     WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37046       IF(IREJ.GE.1)THEN
37047         IF(IPCO.GE.3)
37048      &     WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37049         IPCO=0
37050         RETURN
37051       ENDIF
37052       IF(IPIP.EQ.1)THEN
37053         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37054       ELSEIF(IPIP.EQ.2)THEN
37055         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37056       ENDIF
37057       IF(IPCO.GE.3)THEN
37058         WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37059      *  XDIQT,XVQP,XSQ,XSAQ
37060       ENDIF
37061 C
37062 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
37063 C
37064 C     XSQ=0.D0
37065       IF(IPIP.EQ.1)THEN
37066         XDIQT=XDIQT-XSQ
37067         XVQP =XVQP -XSAQ
37068       ELSEIF(IPIP.EQ.2)THEN
37069         XDIQT=XDIQT-XSAQ
37070         XVQP =XVQP -XSQ
37071       ENDIF
37072       IF(IPCO.GE.3)
37073      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37074 C
37075 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37076 C
37077       XVTHRO=CVQ/UMO
37078       IVTHR=0
37079  3466 CONTINUE
37080       IF(IVTHR.EQ.10)THEN
37081         IREJ=1
37082         IF(ISQ.EQ.3)IREJ=3
37083         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
37084       IPCO=0
37085         RETURN
37086       ENDIF
37087       IVTHR=IVTHR+1
37088       XVTHR=XVTHRO/(201-IVTHR)
37089       UNOPRV=UNON
37090  380  CONTINUE
37091       IF(XVTHR.GT.0.66D0*XDIQT)THEN
37092         IREJ=1
37093         IF(ISQ.EQ.3)IREJ=3
37094         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR  large ',
37095      *  XVTHR
37096       IPCO=0
37097         RETURN
37098       ENDIF
37099       IF(DT_RNDM(V).LT.0.5D0)THEN
37100         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37101         XVTQII=XDIQT-XVTQI
37102       ELSE
37103         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37104         XVTQI=XDIQT-XVTQII
37105       ENDIF
37106       IF(IPCO.GE.3)THEN
37107         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37108       ENDIF
37109 C
37110 C     Prepare 4 momenta of new chains and chain ends
37111 C
37112 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37113 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37114 C    +(4,NTMHKK)
37115 C
37116 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37117 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37118 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37119 C
37120 C     SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37121 C    *              IP1,IP21,IP22,IPP1,IPP2)
37122 C
37123       IF(IPIP.EQ.1)THEN
37124         XSQ1=XSQ
37125         XSAQ1=XSAQ
37126         ISQ1=ISQ
37127         ISAQ1=ISAQ
37128       ELSEIF(IPIP.EQ.2)THEN
37129         XSQ1=XSAQ
37130         XSAQ1=XSQ
37131         ISQ1=ISAQ
37132         ISAQ1=ISQ
37133       ENDIF
37134       IDHKT(1)   =IPP1
37135       ISTHKT(1)  =951
37136       JMOHKT(1,1)=NC2P
37137       JMOHKT(2,1)=0
37138       JDAHKT(1,1)=3+IIGLU1
37139       JDAHKT(2,1)=0
37140 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37141       PHKT(1,1)  =PHKK(1,NC2P)
37142       PHKT(2,1)  =PHKK(2,NC2P)
37143       PHKT(3,1)  =PHKK(3,NC2P)
37144       PHKT(4,1)  =PHKK(4,NC2P)
37145 C     PHKT(5,1)  =PHKK(5,NC2P)
37146       XMIST  =(PHKT(4,1)**2-
37147      * PHKT(3,1)**2-PHKT(2,1)**2-
37148      *PHKT(1,1)**2)
37149       IF(XMIST.GT.0.D0)THEN
37150       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37151      *PHKT(1,1)**2)
37152       ELSE
37153 C     WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
37154       PHKT(5,1)=0.D0
37155       ENDIF
37156       VHKT(1,1)  =VHKK(1,NC2P)
37157       VHKT(2,1)  =VHKK(2,NC2P)
37158       VHKT(3,1)  =VHKK(3,NC2P)
37159       VHKT(4,1)  =VHKK(4,NC2P)
37160       WHKT(1,1)  =WHKK(1,NC2P)
37161       WHKT(2,1)  =WHKK(2,NC2P)
37162       WHKT(3,1)  =WHKK(3,NC2P)
37163       WHKT(4,1)  =WHKK(4,NC2P)
37164 C     Add here IIGLU1 gluons to this chaina
37165       PG1=0.D0
37166       PG2=0.D0
37167       PG3=0.D0
37168       PG4=0.D0
37169       IF(IIGLU1.GE.1)THEN
37170       JJG=NC1P
37171       DO 61 IIG=2,2+IIGLU1-1
37172         KKG=JJG+IIG-1
37173         IDHKT(IIG)   =IDHKK(KKG)
37174         ISTHKT(IIG)  =921
37175         JMOHKT(1,IIG)=KKG
37176         JMOHKT(2,IIG)=0
37177         JDAHKT(1,IIG)=3+IIGLU1
37178         JDAHKT(2,IIG)=0
37179         PHKT(1,IIG)=PHKK(1,KKG)
37180         PG1=PG1+ PHKT(1,IIG)
37181         PHKT(2,IIG)=PHKK(2,KKG)
37182         PG2=PG2+ PHKT(2,IIG)
37183         PHKT(3,IIG)=PHKK(3,KKG)
37184         PG3=PG3+ PHKT(3,IIG)
37185         PHKT(4,IIG)=PHKK(4,KKG)
37186         PG4=PG4+ PHKT(4,IIG)
37187         PHKT(5,IIG)=PHKK(5,KKG)
37188         VHKT(1,IIG)  =VHKK(1,KKG)
37189         VHKT(2,IIG)  =VHKK(2,KKG)
37190         VHKT(3,IIG)  =VHKK(3,KKG)
37191         VHKT(4,IIG)  =VHKK(4,KKG)
37192         WHKT(1,IIG) =WHKK(1,KKG)
37193         WHKT(2,IIG) =WHKK(2,KKG)
37194         WHKT(3,IIG) =WHKK(3,KKG)
37195         WHKT(4,IIG) =WHKK(4,KKG)
37196    61 CONTINUE
37197       ENDIF
37198       IDHKT(2+IIGLU1)   =IP21
37199       ISTHKT(2+IIGLU1)  =952
37200       JMOHKT(1,2+IIGLU1)=NC1T
37201       JMOHKT(2,2+IIGLU1)=0
37202       JDAHKT(1,2+IIGLU1)=3+IIGLU1
37203       JDAHKT(2,2+IIGLU1)=0
37204       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
37205       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
37206       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
37207       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
37208 C     PHKT(5,2)  =PHKK(5,NC1T)
37209       XMIST  =(PHKT(4,2+IIGLU1)**2-
37210      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37211      *PHKT(1,2+IIGLU1)**2)
37212       IF(XMIST.GT.0.D0)THEN
37213       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
37214      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37215      *PHKT(1,2+IIGLU1)**2)
37216       ELSE
37217 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37218         PHKT(5,5+IIGLU1)=0.D0
37219       ENDIF
37220       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
37221       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
37222       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
37223       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
37224       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
37225       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
37226       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
37227       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
37228       IDHKT(3+IIGLU1)   =88888
37229       ISTHKT(3+IIGLU1)  =95
37230       JMOHKT(1,3+IIGLU1)=1
37231       JMOHKT(2,3+IIGLU1)=2+IIGLU1
37232       JDAHKT(1,3+IIGLU1)=0
37233       JDAHKT(2,3+IIGLU1)=0
37234       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37235       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37236       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37237       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37238       XMIST
37239      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37240      *            -PHKT(3,3+IIGLU1)**2)
37241       IF(XMIST.GT.0.D0)THEN
37242       PHKT(5,3+IIGLU1)
37243      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37244      *            -PHKT(3,3+IIGLU1)**2)
37245       ELSE
37246 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37247         PHKT(5,5+IIGLU1)=0.D0
37248       ENDIF
37249       IF(IPIP.GE.2)THEN
37250 C     IF(NUMEV.EQ.-324)THEN
37251 C     WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
37252 C    * JDAHKT(1,1),
37253 C    *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37254       DO 71 IIG=2,2+IIGLU1-1
37255 C     WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37256 C    &             JMOHKT(1,IIG),JMOHKT(2,IIG),
37257 C    * JDAHKT(1,IIG),
37258 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37259    71 CONTINUE
37260 C     WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37261 C    * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37262 C    *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37263 C     WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37264 C    * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37265 C    *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37266       ENDIF
37267       CHAMAL=CHAM1
37268       IF(IPIP.EQ.1)THEN
37269         IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
37270       ELSEIF(IPIP.EQ.2)THEN
37271         IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
37272       ENDIF
37273       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37274 C       IREJ=1
37275         IPCO=0
37276 C       RETURN
37277 C       WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
37278         GO TO 3466
37279       ENDIF
37280       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
37281       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
37282       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
37283       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
37284       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
37285       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
37286       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
37287       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
37288       IF(IPIP.EQ.1)THEN
37289         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
37290       ELSEIF(IPIP.EQ.2)THEN
37291         IDHKT(4+IIGLU1)   =ISAQ1
37292       ENDIF
37293       ISTHKT(4+IIGLU1)  =951
37294       JMOHKT(1,4+IIGLU1)=NC1P
37295       JMOHKT(2,4+IIGLU1)=0
37296       JDAHKT(1,4+IIGLU1)=6+IIGLU1
37297       JDAHKT(2,4+IIGLU1)=0
37298 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37299       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37300       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37301       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37302       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37303 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
37304       XMIST  =(PHKT(4,4+IIGLU1)**2-
37305      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37306      *PHKT(1,4+IIGLU1)**2)
37307       IF(XMIST.GT.0.D0)THEN
37308       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
37309      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37310      *PHKT(1,4+IIGLU1)**2)
37311       ELSE
37312 C     WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
37313       PHKT(5,4+IIGLU1)=0.D0
37314       ENDIF
37315       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
37316       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
37317       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
37318       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
37319       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
37320       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
37321       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
37322       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
37323       IDHKT(5+IIGLU1)   =IP22
37324       ISTHKT(5+IIGLU1)  =952
37325       JMOHKT(1,5+IIGLU1)=NC1T
37326       JMOHKT(2,5+IIGLU1)=0
37327       JDAHKT(1,5+IIGLU1)=6+IIGLU1
37328       JDAHKT(2,5+IIGLU1)=0
37329       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37330       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37331       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37332       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37333 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
37334       XMIST  =(PHKT(4,5+IIGLU1)**2-
37335      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37336      *PHKT(1,5+IIGLU1)**2)
37337       IF(XMIST.GT.0.D0)THEN
37338       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
37339      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37340      *PHKT(1,5+IIGLU1)**2)
37341       ELSE
37342 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37343         PHKT(5,5+IIGLU1)=0.D0
37344       ENDIF
37345       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
37346       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
37347       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
37348       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
37349       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
37350       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
37351       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
37352       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
37353       IDHKT(6+IIGLU1)   =88888
37354       ISTHKT(6+IIGLU1)  =95
37355       JMOHKT(1,6+IIGLU1)=4+IIGLU1
37356       JMOHKT(2,6+IIGLU1)=5+IIGLU1
37357       JDAHKT(1,6+IIGLU1)=0
37358       JDAHKT(2,6+IIGLU1)=0
37359       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37360       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37361       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37362       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37363       XMIST
37364      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37365      *            -PHKT(3,6+IIGLU1)**2)
37366       IF(XMIST.GT.0.D0)THEN
37367       PHKT(5,6+IIGLU1)
37368      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37369      *            -PHKT(3,6+IIGLU1)**2)
37370       ELSE
37371 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37372         PHKT(5,5+IIGLU1)=0.D0
37373       ENDIF
37374 C     IF(IPIP.GE.2)THEN
37375 C     IF(NUMEV.EQ.-324)THEN
37376 C     WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37377 C    * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37378 C    *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37379 C     WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37380 C    * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37381 C    *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37382 C     WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37383 C    * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37384 C    *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37385 C     ENDIF
37386       CHAMAL=CHAM1
37387       IF(IPIP.EQ.1)THEN
37388         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37389       ELSEIF(IPIP.EQ.2)THEN
37390         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37391       ENDIF
37392       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37393 C       IREJ=1
37394         IPCO=0
37395 C       RETURN
37396 C       WRITE(6,*)' MUSQBS1 jump back from chain 6',
37397 C    *  CHAMAL,PHKT(5,6+IIGLU1)
37398         GO TO 3466
37399       ENDIF
37400       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
37401       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
37402       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
37403       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
37404       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
37405       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
37406       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
37407       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
37408 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
37409       IDHKT(7+IIGLU1)   =IP1
37410       ISTHKT(7+IIGLU1)  =951
37411       JMOHKT(1,7+IIGLU1)=NC1P
37412       JMOHKT(2,7+IIGLU1)=0
37413 **NEW
37414 C     JDAHKT(1,7+IIGLU1)=9+IIGLU1
37415       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37416 **
37417       JDAHKT(2,7+IIGLU1)=0
37418       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
37419       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
37420       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
37421       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
37422 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
37423       XMIST  =(PHKT(4,7+IIGLU1)**2-
37424      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37425      *PHKT(1,7+IIGLU1)**2)
37426       IF(XMIST.GT.0.D0)THEN
37427       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
37428      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37429      *PHKT(1,7+IIGLU1)**2)
37430       ELSE
37431 C     WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
37432       PHKT(5,7+IIGLU1)=0.D0
37433       ENDIF
37434       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
37435       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
37436       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
37437       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
37438       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
37439       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
37440       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
37441       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
37442 C     Insert here the IIGLU2 gluons
37443       PG1=0.D0
37444       PG2=0.D0
37445       PG3=0.D0
37446       PG4=0.D0
37447       IF(IIGLU2.GE.1)THEN
37448       JJG=NC2P
37449       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37450         KKG=JJG+IIG-7-IIGLU1
37451         IDHKT(IIG)   =IDHKK(KKG)
37452         ISTHKT(IIG)  =921
37453         JMOHKT(1,IIG)=KKG
37454         JMOHKT(2,IIG)=0
37455         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37456         JDAHKT(2,IIG)=0
37457         PHKT(1,IIG)=PHKK(1,KKG)
37458         PG1=PG1+ PHKT(1,IIG)
37459         PHKT(2,IIG)=PHKK(2,KKG)
37460         PG2=PG2+ PHKT(2,IIG)
37461         PHKT(3,IIG)=PHKK(3,KKG)
37462         PG3=PG3+ PHKT(3,IIG)
37463         PHKT(4,IIG)=PHKK(4,KKG)
37464         PG4=PG4+ PHKT(4,IIG)
37465         PHKT(5,IIG)=PHKK(5,KKG)
37466         VHKT(1,IIG)  =VHKK(1,KKG)
37467         VHKT(2,IIG)  =VHKK(2,KKG)
37468         VHKT(3,IIG)  =VHKK(3,KKG)
37469         VHKT(4,IIG)  =VHKK(4,KKG)
37470         WHKT(1,IIG)  =WHKK(1,KKG)
37471         WHKT(2,IIG) =WHKK(2,KKG)
37472         WHKT(3,IIG) =WHKK(3,KKG)
37473         WHKT(4,IIG) =WHKK(4,KKG)
37474    81 CONTINUE
37475       ENDIF
37476       IF(IPIP.EQ.1)THEN
37477         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
37478         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
37479         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
37480         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
37481       ELSEIF(IPIP.EQ.2)THEN
37482         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
37483         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
37484         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
37485         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
37486       ENDIF
37487       ISTHKT(8+IIGLU1+IIGLU2)  =952
37488       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
37489       JMOHKT(2,8+IIGLU1+IIGLU2)=0
37490       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37491       JDAHKT(2,8+IIGLU1+IIGLU2)=0
37492       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC2T)+
37493      * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
37494       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC2T)+
37495      * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
37496       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC2T)+
37497      * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
37498       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC2T)+
37499      * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
37500 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
37501 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
37502       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
37503 C       IREJ=1
37504 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
37505 C    *  ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
37506         IPCO=0
37507 C       RETURN
37508         GO TO 3466
37509       ENDIF
37510 C     PHKT(5,8)  =PHKK(5,NC2T)
37511       XMIST  =(PHKT(4,8+IIGLU1+IIGLU2)**2-
37512      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37513      *PHKT(1,8+IIGLU1+IIGLU2)**2)
37514       IF(XMIST.GT.0.D0)THEN
37515       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37516      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37517      *PHKT(1,8+IIGLU1+IIGLU2)**2)
37518       ELSE
37519 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37520         PHKT(5,5+IIGLU1)=0.D0
37521       ENDIF
37522       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
37523       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
37524       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
37525       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
37526       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
37527       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
37528       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
37529       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
37530       IDHKT(9+IIGLU1+IIGLU2)   =88888
37531       ISTHKT(9+IIGLU1+IIGLU2)  =95
37532       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37533       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37534       JDAHKT(1,9+IIGLU1+IIGLU2)=0
37535       JDAHKT(2,9+IIGLU1+IIGLU2)=0
37536 **NEW
37537 C     PHKT(1,9+IIGLU1+IIGLU2)
37538 C    * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37539 C     PHKT(2,9+IIGLU1+IIGLU2)
37540 C    * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37541 C     PHKT(3,9+IIGLU1+IIGLU2)
37542 C    * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37543 C     PHKT(4,9+IIGLU1+IIGLU2)
37544 C    * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37545       PHKT(1,9+IIGLU1+IIGLU2)
37546      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37547       PHKT(2,9+IIGLU1+IIGLU2)
37548      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37549       PHKT(3,9+IIGLU1+IIGLU2)
37550      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37551       PHKT(4,9+IIGLU1+IIGLU2)
37552      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37553 **
37554       XMIST
37555      * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37556      * -PHKT(2,9+IIGLU1+IIGLU2)**2
37557      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
37558       IF(XMIST.GT.0.D0)THEN
37559       PHKT(5,9+IIGLU1+IIGLU2)
37560      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37561      * -PHKT(2,9+IIGLU1+IIGLU2)**2
37562      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
37563       ELSE
37564 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37565         PHKT(5,5+IIGLU1)=0.D0
37566       ENDIF
37567       IF(IPIP.GE.2)THEN
37568 C     IF(NUMEV.EQ.-324)THEN
37569 C     WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37570 C    * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37571 C    *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37572 C     DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37573 C     WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
37574 C    * JDAHKT(1,IIG),
37575 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37576 C  91 CONTINUE
37577 C     WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
37578 C    * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
37579 C    *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
37580 C    *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37581 C     WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37582 C    * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37583 C    *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37584 C    *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37585       ENDIF
37586       CHAMAL=CHAB1
37587       IF(IPIP.EQ.1)THEN
37588         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37589       ELSEIF(IPIP.EQ.2)THEN
37590         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37591       ENDIF
37592       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37593 C       IREJ=1
37594         IPCO=0
37595 C       RETURN
37596 C       WRITE(6,*)' MUSQBS1 jump back from chain 9',
37597 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37598         GO TO 3466
37599       ENDIF
37600       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
37601       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
37602       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
37603       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
37604       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
37605       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
37606       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
37607       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
37608 C
37609       IPCO=0
37610       IGCOUN=9+IIGLU1+IIGLU2
37611        RETURN
37612        END
37613
37614 *$ CREATE MGSQBS2.FOR
37615 *COPY MGSQBS2
37616 C
37617 C
37618 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37619       SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37620      *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
37621 C
37622 C                  GSQBS-2 diagram (split target diquark)
37623 C
37624       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37625       SAVE
37626
37627       PARAMETER ( LINP = 10 ,
37628      &            LOUT = 6 ,
37629      &            LDAT = 9 )
37630 * event history
37631       PARAMETER (NMXHKK=200000)
37632       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37633      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37634      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37635 * extended event history
37636       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37637      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37638      &                IHIST(2,NMXHKK)
37639 * Lorentz-parameters of the current interaction
37640       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37641      &                UMO,PPCM,EPROJ,PPROJ
37642 * diquark-breaking mechanism
37643       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37644
37645 C
37646       PARAMETER (NTMHKK= 300)
37647       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37648      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37649      +(4,NTMHKK)
37650
37651 *KEEP,XSEADI.
37652       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37653      +SSMIMQ,VVMTHR
37654 *KEEP,DPRIN.
37655       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37656 C
37657 C                  GSQBS-2 diagram (split target diquark)
37658 C
37659 C
37660 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
37661 C     Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
37662 C
37663 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
37664 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37665 C
37666 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37667 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37668 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37669 C
37670 C
37671 C
37672 C       Put new chains into COMMON /HKKTMP/
37673 C
37674       IIGLU1=NC1T-NC1P-1
37675       IIGLU2=NC2T-NC2P-1
37676       IGCOUN=0
37677 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37678       CVQ=1.D0
37679       IREJ=0
37680 C     IF(IPIP.EQ.2)THEN
37681 C     WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37682 C    *             'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
37683 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37684 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
37685 C     ENDIF
37686 C
37687 C
37688 C
37689 C     determine x-values of NC1T diquark
37690       XDIQT=PHKK(4,NC1T)*2.D0/UMO
37691       XVQP=PHKK(4,NC1P)*2.D0/UMO
37692 C
37693 C     determine x-values of sea quark pair
37694 C
37695       IPCO=1
37696       ICOU=0
37697  2234 CONTINUE
37698       ICOU=ICOU+1
37699       IF(ICOU.GE.500)THEN
37700         IREJ=1
37701         IF(ISQ.EQ.3)IREJ=3
37702         IF(IPCO.GE.3)
37703      &     WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
37704         IPCO=0
37705         RETURN
37706       ENDIF
37707       IF(IPCO.GE.3)
37708      &     WRITE(LOUT,*)'MGSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
37709      * UMO, XDIQT,XVQP
37710       XSQ=0.D0
37711       XSAQ=0.D0
37712 **NEW
37713 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37714       IF (IPIP.EQ.1) THEN
37715          XQMAX  = XDIQT/2.0D0
37716          XAQMAX = 2.D0*XVQP/3.0D0
37717       ELSE
37718          XQMAX  = 2.D0*XVQP/3.0D0
37719          XAQMAX = XDIQT/2.0D0
37720       ENDIF
37721       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37722       ISAQ = 6+ISQ
37723 C     write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37724 **
37725         IF(IPCO.GE.3)
37726      &     WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37727       IF(IREJ.GE.1)THEN
37728         IF(IPCO.GE.3)
37729      &     WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37730         IPCO=0
37731         RETURN
37732       ENDIF
37733       IF(IPIP.EQ.1)THEN
37734         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37735       ELSEIF(IPIP.EQ.2)THEN
37736         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37737       ENDIF
37738       IF(IPCO.GE.3)THEN
37739         WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37740      *  XDIQT,XVQP,XSQ,XSAQ
37741       ENDIF
37742 C
37743 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
37744 C
37745 C     XSQ=0.D0
37746       IF(IPIP.EQ.1)THEN
37747         XDIQT=XDIQT-XSQ
37748         XVQP =XVQP -XSAQ
37749       ELSEIF(IPIP.EQ.2)THEN
37750         XDIQT=XDIQT-XSAQ
37751         XVQP =XVQP -XSQ
37752       ENDIF
37753       IF(IPCO.GE.3)
37754      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37755 C
37756 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37757 C
37758       XVTHRO=CVQ/UMO
37759       IVTHR=0
37760  3466 CONTINUE
37761       IF(IVTHR.EQ.10)THEN
37762         IREJ=1
37763         IF(ISQ.EQ.3)IREJ=3
37764         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
37765         IPCO=0
37766         RETURN
37767       ENDIF
37768       IVTHR=IVTHR+1
37769       XVTHR=XVTHRO/(201-IVTHR)
37770       UNOPRV=UNON
37771  380  CONTINUE
37772       IF(XVTHR.GT.0.66D0*XDIQT)THEN
37773         IREJ=1
37774         IF(ISQ.EQ.3)IREJ=3
37775         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR  large ',
37776      *  XVTHR
37777         IPCO=0
37778         RETURN
37779       ENDIF
37780       IF(DT_RNDM(V).LT.0.5D0)THEN
37781         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37782         XVTQII=XDIQT-XVTQI
37783       ELSE
37784         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37785         XVTQI=XDIQT-XVTQII
37786       ENDIF
37787       IF(IPCO.GE.3)THEN
37788         WRITE(LOUT,'(A,2E12.4)')'  MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37789       ENDIF
37790 C
37791 C     Prepare 4 momenta of new chains and chain ends
37792 C
37793 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37794 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37795 C    +(4,NTMHKK)
37796 C
37797 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37798 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37799 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37800 C
37801 C     SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37802 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
37803 C
37804       IF(IPIP.EQ.1)THEN
37805         XSQ1=XSQ
37806         XSAQ1=XSAQ
37807         ISQ1=ISQ
37808         ISAQ1=ISAQ
37809       ELSEIF(IPIP.EQ.2)THEN
37810         XSQ1=XSAQ
37811         XSAQ1=XSQ
37812         ISQ1=ISAQ
37813         ISAQ1=ISQ
37814       ENDIF
37815       KK11=IP21
37816 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
37817       KK21=IPP11
37818       KK22=IPP12
37819       XGIVE=0.D0
37820       IF(IPIP.EQ.1)THEN
37821         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
37822       ELSEIF(IPIP.EQ.2)THEN
37823         IDHKT(4+IIGLU1)   =ISAQ1
37824       ENDIF
37825       ISTHKT(4+IIGLU1)  =961
37826       JMOHKT(1,4+IIGLU1)=NC1P
37827       JMOHKT(2,4+IIGLU1)=0
37828       JDAHKT(1,4+IIGLU1)=6+IIGLU1
37829       JDAHKT(2,4+IIGLU1)=0
37830 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37831       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37832       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37833       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37834       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37835 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
37836       XXMIST=(PHKT(4,4+IIGLU1)**2-
37837      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37838      *PHKT(1,4+IIGLU1)**2)
37839       IF(XXMIST.GT.0.D0)THEN
37840         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
37841       ELSE
37842         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
37843         XXMIST=ABS(XXMIST)
37844         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
37845       ENDIF
37846       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
37847       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
37848       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
37849       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
37850       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
37851       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
37852       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
37853       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
37854       IDHKT(5+IIGLU1)   =IP22
37855       ISTHKT(5+IIGLU1)  =962
37856       JMOHKT(1,5+IIGLU1)=NC1T
37857       JMOHKT(2,5+IIGLU1)=0
37858       JDAHKT(1,5+IIGLU1)=6+IIGLU1
37859       JDAHKT(2,5+IIGLU1)=0
37860       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37861       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37862       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37863       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37864 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
37865       XXMIST=(PHKT(4,5+IIGLU1)**2-
37866      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37867      *PHKT(1,5+IIGLU1)**2)
37868       IF(XXMIST.GT.0.D0)THEN
37869         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
37870       ELSE
37871         WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
37872         XXMIST=ABS(XXMIST)
37873         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
37874       ENDIF
37875       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
37876       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
37877       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
37878       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
37879       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
37880       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
37881       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
37882       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
37883       IDHKT(6+IIGLU1)   =88888
37884       ISTHKT(6+IIGLU1)  =96
37885       JMOHKT(1,6+IIGLU1)=4+IIGLU1
37886       JMOHKT(2,6+IIGLU1)=5+IIGLU1
37887       JDAHKT(1,6+IIGLU1)=0
37888       JDAHKT(2,6+IIGLU1)=0
37889       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37890       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37891       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37892       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37893       PHKT(5,6+IIGLU1)
37894      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37895      *            -PHKT(3,6+IIGLU1)**2)
37896       CHAMAL=CHAM1
37897       IF(IPIP.EQ.1)THEN
37898         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37899       ELSEIF(IPIP.EQ.2)THEN
37900         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37901       ENDIF
37902 C---------------------------------------------------
37903       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37904         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37905 C                    we drop chain 6 and give the energy to chain 3
37906           IDHKT(6+IIGLU1)=22888
37907           XGIVE=1.D0
37908 C         WRITE(6,*)' drop chain 6 xgive=1'
37909           GO TO 7788
37910         ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
37911 C                    we drop chain 6 and give the energy to chain 3
37912 C                    and change KK11 to IDHKT(5)
37913           IDHKT(6+IIGLU1)=22888
37914           XGIVE=1.D0
37915 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
37916           KK11=IDHKT(5+IIGLU1)
37917           GO TO 7788
37918         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
37919 C                    we drop chain 6 and give the energy to chain 3
37920 C                    and change KK21 to IDHKT(5+IIGLU1)
37921 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
37922           IDHKT(6+IIGLU1)=22888
37923           XGIVE=1.D0
37924 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
37925           KK21=IDHKT(5+IIGLU1)
37926           GO TO 7788
37927         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
37928 C                    we drop chain 6 and give the energy to chain 3
37929 C                    and change KK22 to IDHKT(5)
37930 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
37931           IDHKT(6+IIGLU1)=22888
37932           XGIVE=1.D0
37933 C         WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
37934           KK22=IDHKT(5+IIGLU1)
37935           GO TO 7788
37936         ENDIF
37937 C       IREJ=1
37938         IPCO=0
37939 C       RETURN
37940         GO TO 3466
37941       ENDIF
37942  7788 CONTINUE
37943 C---------------------------------------------------
37944       IF(IPIP.GE.3)THEN
37945       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37946      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37947      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37948       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37949      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37950      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37951       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37952      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37953      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37954       ENDIF
37955       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
37956       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
37957       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
37958       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
37959       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
37960       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
37961       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
37962       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
37963 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
37964       IF(IPIP.EQ.1)THEN
37965         IDHKT(1)   =1000*KK21+100*KK22+3
37966         IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
37967         IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
37968         IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
37969       ELSEIF(IPIP.EQ.2)THEN
37970         IDHKT(1)   =1000*KK21+100*KK22-3
37971         IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
37972         IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
37973         IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
37974       ENDIF
37975       ISTHKT(1)  =961
37976       JMOHKT(1,1)=NC2P
37977       JMOHKT(2,1)=0
37978       JDAHKT(1,1)=3+IIGLU1
37979       JDAHKT(2,1)=0
37980 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37981       PHKT(1,1)  =PHKK(1,NC2P)
37982      *+XGIVE*PHKT(1,4+IIGLU1)
37983       PHKT(2,1)  =PHKK(2,NC2P)
37984      *+XGIVE*PHKT(2,4+IIGLU1)
37985       PHKT(3,1)  =PHKK(3,NC2P)
37986      *+XGIVE*PHKT(3,4+IIGLU1)
37987       PHKT(4,1)  =PHKK(4,NC2P)
37988      *+XGIVE*PHKT(4,4+IIGLU1)
37989 C     PHKT(5,1)  =PHKK(5,NC2P)
37990       XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37991      *PHKT(1,1)**2
37992       IF(XXMIST.GT.0.D0)THEN
37993         PHKT(5,1)  =SQRT(XXMIST)
37994       ELSE
37995         WRITE(LOUT,*)'MGSQBS2',XXMIST
37996         XXMIST=ABS(XXMIST)
37997         PHKT(5,1)  =SQRT(XXMIST)
37998       ENDIF
37999       VHKT(1,1)  =VHKK(1,NC2P)
38000       VHKT(2,1)  =VHKK(2,NC2P)
38001       VHKT(3,1)  =VHKK(3,NC2P)
38002       VHKT(4,1)  =VHKK(4,NC2P)
38003       WHKT(1,1)  =WHKK(1,NC2P)
38004       WHKT(2,1)  =WHKK(2,NC2P)
38005       WHKT(3,1)  =WHKK(3,NC2P)
38006       WHKT(4,1)  =WHKK(4,NC2P)
38007 C     Add here IIGLU1 gluons to this chaina
38008       PG1=0.D0
38009       PG2=0.D0
38010       PG3=0.D0
38011       PG4=0.D0
38012       IF(IIGLU1.GE.1)THEN
38013       JJG=NC1P
38014       DO 61 IIG=2,2+IIGLU1-1
38015         KKG=JJG+IIG-1
38016         IDHKT(IIG)   =IDHKK(KKG)
38017         ISTHKT(IIG)  =921
38018         JMOHKT(1,IIG)=KKG
38019         JMOHKT(2,IIG)=0
38020         JDAHKT(1,IIG)=3+IIGLU1
38021         JDAHKT(2,IIG)=0
38022         PHKT(1,IIG)=PHKK(1,KKG)
38023         PG1=PG1+ PHKT(1,IIG)
38024         PHKT(2,IIG)=PHKK(2,KKG)
38025         PG2=PG2+ PHKT(2,IIG)
38026         PHKT(3,IIG)=PHKK(3,KKG)
38027         PG3=PG3+ PHKT(3,IIG)
38028         PHKT(4,IIG)=PHKK(4,KKG)
38029         PG4=PG4+ PHKT(4,IIG)
38030         PHKT(5,IIG)=PHKK(5,KKG)
38031         VHKT(1,IIG)  =VHKK(1,KKG)
38032         VHKT(2,IIG)  =VHKK(2,KKG)
38033         VHKT(3,IIG)  =VHKK(3,KKG)
38034         VHKT(4,IIG)  =VHKK(4,KKG)
38035         WHKT(1,IIG)  =WHKK(1,KKG)
38036         WHKT(2,IIG)  =WHKK(2,KKG)
38037         WHKT(3,IIG)  =WHKK(3,KKG)
38038         WHKT(4,IIG)  =WHKK(4,KKG)
38039    61 CONTINUE
38040       ENDIF
38041 C     IDHKT(2)   =IP21
38042       IDHKT(2+IIGLU1)   =KK11
38043       ISTHKT(2+IIGLU1)  =962
38044       JMOHKT(1,2+IIGLU1)=NC1T
38045       JMOHKT(2,2+IIGLU1)=0
38046       JDAHKT(1,2+IIGLU1)=3+IIGLU1
38047       JDAHKT(2,2+IIGLU1)=0
38048       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
38049 C    * +0.5D0*PHKK(1,NC2T)
38050      *+XGIVE*PHKT(1,5+IIGLU1)
38051       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
38052 C    *+0.5D0*PHKK(2,NC2T)
38053      *+XGIVE*PHKT(2,5+IIGLU1)
38054       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
38055 C    *+0.5D0*PHKK(3,NC2T)
38056      *+XGIVE*PHKT(3,5+IIGLU1)
38057       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
38058 C    *+0.5D0*PHKK(4,NC2T)
38059      *+XGIVE*PHKT(4,5+IIGLU1)
38060 C     PHKT(5,2)  =PHKK(5,NC1T)
38061       XXMIST=(PHKT(4,2+IIGLU1)**2-
38062      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38063      *PHKT(1,2+IIGLU1)**2)
38064       IF(XXMIST.GT.0.D0)THEN
38065         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
38066       ELSE
38067         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
38068         XXMIST=ABS(XXMIST)
38069         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
38070       ENDIF
38071       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
38072       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
38073       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
38074       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
38075       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
38076       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
38077       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
38078       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
38079       IDHKT(3+IIGLU1)   =88888
38080       ISTHKT(3+IIGLU1)  =96
38081       JMOHKT(1,3+IIGLU1)=1
38082       JMOHKT(2,3+IIGLU1)=2+IIGLU1
38083       JDAHKT(1,3+IIGLU1)=0
38084       JDAHKT(2,3+IIGLU1)=0
38085       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38086       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38087       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38088       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38089       PHKT(5,3+IIGLU1)
38090      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38091      *            -PHKT(3,3+IIGLU1)**2)
38092       IF(IPIP.EQ.3)THEN
38093       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38094      * JDAHKT(1,1),
38095      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38096       DO 71 IIG=2,2+IIGLU1-1
38097       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38098      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38099      * JDAHKT(1,IIG),
38100      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38101    71 CONTINUE
38102       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38103      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38104      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38105       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38106      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38107      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38108       ENDIF
38109       CHAMAL=CHAB1
38110       IF(IPIP.EQ.1)THEN
38111         IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
38112       ELSEIF(IPIP.EQ.2)THEN
38113         IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
38114       ENDIF
38115       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38116 C       IREJ=1
38117         IPCO=0
38118 C       RETURN
38119         GO TO 3466
38120       ENDIF
38121       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
38122       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
38123       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
38124       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
38125       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
38126       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
38127       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
38128       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
38129 C     IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+1
38130       IDHKT(7+IIGLU1)   =IP1
38131       ISTHKT(7+IIGLU1)  =961
38132       JMOHKT(1,7+IIGLU1)=NC1P
38133       JMOHKT(2,7+IIGLU1)=0
38134       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38135       JDAHKT(2,7+IIGLU1)=0
38136       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
38137       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
38138       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
38139       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
38140 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
38141       XXMIST=(PHKT(4,7+IIGLU1)**2-
38142      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38143      *PHKT(1,7+IIGLU1)**2)
38144       IF(XXMIST.GT.0.D0)THEN
38145         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
38146       ELSE
38147         WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
38148         XXMIST=ABS(XXMIST)
38149         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
38150       ENDIF
38151       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
38152       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
38153       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
38154       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
38155       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
38156       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
38157       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
38158       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
38159 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
38160 C     Insert here the IIGLU2 gluons
38161       PG1=0.D0
38162       PG2=0.D0
38163       PG3=0.D0
38164       PG4=0.D0
38165       IF(IIGLU2.GE.1)THEN
38166       JJG=NC2P
38167       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38168         KKG=JJG+IIG-7-IIGLU1
38169         IDHKT(IIG)   =IDHKK(KKG)
38170         ISTHKT(IIG)  =921
38171         JMOHKT(1,IIG)=KKG
38172         JMOHKT(2,IIG)=0
38173         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38174         JDAHKT(2,IIG)=0
38175         PHKT(1,IIG)=PHKK(1,KKG)
38176         PG1=PG1+ PHKT(1,IIG)
38177         PHKT(2,IIG)=PHKK(2,KKG)
38178         PG2=PG2+ PHKT(2,IIG)
38179         PHKT(3,IIG)=PHKK(3,KKG)
38180         PG3=PG3+ PHKT(3,IIG)
38181         PHKT(4,IIG)=PHKK(4,KKG)
38182         PG4=PG4+ PHKT(4,IIG)
38183         PHKT(5,IIG)=PHKK(5,KKG)
38184         VHKT(1,IIG)  =VHKK(1,KKG)
38185         VHKT(2,IIG)  =VHKK(2,KKG)
38186         VHKT(3,IIG)  =VHKK(3,KKG)
38187         VHKT(4,IIG)  =VHKK(4,KKG)
38188         WHKT(1,IIG)  =WHKK(1,KKG)
38189         WHKT(2,IIG)  =WHKK(2,KKG)
38190         WHKT(3,IIG)  =WHKK(3,KKG)
38191         WHKT(4,IIG)  =WHKK(4,KKG)
38192    81 CONTINUE
38193       ENDIF
38194       IF(IPIP.EQ.1)THEN
38195         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
38196         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
38197         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
38198         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
38199       ELSEIF(IPIP.EQ.2)THEN
38200 **NEW
38201 C       IDHKT(8)   =1000*IPP2+100*(-ISQ1+6)-3
38202         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
38203 **
38204         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
38205         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
38206         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
38207       ENDIF
38208       ISTHKT(8+IIGLU1+IIGLU2)  =962
38209       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
38210       JMOHKT(2,8+IIGLU1+IIGLU2)=0
38211       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38212       JDAHKT(2,8+IIGLU1+IIGLU2)=0
38213 C     PHKT(1,8)  =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
38214 C     PHKT(2,8)  =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
38215 C     PHKT(3,8)  =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
38216 C     PHKT(4,8)  =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
38217       PHKT(1,8+IIGLU1+IIGLU2)  =
38218      * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
38219       PHKT(2,8+IIGLU1+IIGLU2)  =
38220      * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
38221       PHKT(3,8+IIGLU1+IIGLU2)  =
38222      * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
38223       PHKT(4,8+IIGLU1+IIGLU2)  =
38224      * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
38225 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
38226 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
38227       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
38228 C       IREJ=1
38229 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
38230         IPCO=0
38231 C       RETURN
38232         GO TO 3466
38233       ENDIF
38234 C     PHKT(5,8)  =PHKK(5,NC2T)
38235       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38236      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38237      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38238       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
38239       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
38240       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
38241       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
38242       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
38243       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
38244       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
38245       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
38246       IDHKT(9+IIGLU1+IIGLU2)   =88888
38247       ISTHKT(9+IIGLU1+IIGLU2)  =96
38248       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38249       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38250       JDAHKT(1,9+IIGLU1+IIGLU2)=0
38251       JDAHKT(2,9+IIGLU1+IIGLU2)=0
38252       PHKT(1,9+IIGLU1+IIGLU2)
38253      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38254       PHKT(2,9+IIGLU1+IIGLU2)
38255      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38256       PHKT(3,9+IIGLU1+IIGLU2)
38257      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38258       PHKT(4,9+IIGLU1+IIGLU2)
38259      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38260       PHKT(5,9+IIGLU1+IIGLU2)
38261      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38262      * PHKT(2,9+IIGLU1+IIGLU2)**2
38263      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38264       IF(IPIP.GE.3)THEN
38265       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38266      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38267      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38268       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38269       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38270      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38271      * JDAHKT(1,IIG),
38272      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38273    91 CONTINUE
38274       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38275      * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
38276      *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
38277      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38278       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38279      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38280      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38281      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38282       ENDIF
38283       CHAMAL=CHAB1
38284       IF(IPIP.EQ.1)THEN
38285         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38286       ELSEIF(IPIP.EQ.2)THEN
38287         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38288       ENDIF
38289       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38290 C       IREJ=1
38291         IPCO=0
38292 C       RETURN
38293         GO TO 3466
38294       ENDIF
38295       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
38296       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
38297       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
38298       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
38299       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
38300       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
38301       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
38302       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
38303 C
38304       IPCO=0
38305       IGCOUN=9+IIGLU1+IIGLU2
38306        RETURN
38307        END
38308
38309 *$ CREATE MUSQBS1.FOR
38310 *COPY MUSQBS1
38311 C
38312 C
38313 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38314       SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38315      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
38316 C
38317 C                  USQBS-1 diagram (split projectile diquark)
38318 C
38319       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38320       SAVE
38321
38322       PARAMETER ( LINP = 10 ,
38323      &            LOUT = 6 ,
38324      &            LDAT = 9 )
38325 * event history
38326       PARAMETER (NMXHKK=200000)
38327       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38328      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38329      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38330 * extended event history
38331       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38332      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38333      &                IHIST(2,NMXHKK)
38334 * Lorentz-parameters of the current interaction
38335       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38336      &                UMO,PPCM,EPROJ,PPROJ
38337 * diquark-breaking mechanism
38338       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38339
38340 C
38341       PARAMETER (NTMHKK= 300)
38342       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38343      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38344      +(4,NTMHKK)
38345 *KEEP,XSEADI.
38346       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
38347      +SSMIMQ,VVMTHR
38348 *KEEP,DPRIN.
38349       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
38350       COMMON /EVFLAG/ NUMEV
38351 C
38352 C                  USQBS-1 diagram (split projectile diquark)
38353 C
38354 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
38355 C     Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
38356 C
38357 C     Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
38358 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38359 C
38360 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38361 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38362 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38363 C
38364 C       Put new chains into COMMON /HKKTMP/
38365 C
38366       IIGLU1=NC1T-NC1P-1
38367       IIGLU2=NC2T-NC2P-1
38368       IGCOUN=0
38369 C     WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
38370       CVQ=1.D0
38371       IREJ=0
38372       IF(IPIP.EQ.3)THEN
38373 C     IF(NUMEV.EQ.-324)THEN
38374       WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
38375      *             ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
38376      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38377      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
38378       ENDIF
38379 C
38380 C
38381 C
38382 C     determine x-values of NC1P diquark
38383       XDIQP=PHKK(4,NC1P)*2.D0/UMO
38384       XVQT=PHKK(4,NC1T)*2.D0/UMO
38385 C
38386 C     determine x-values of sea quark pair
38387 C
38388       IPCO=1
38389       ICOU=0
38390  2234 CONTINUE
38391       ICOU=ICOU+1
38392       IF(ICOU.GE.500)THEN
38393         IREJ=1
38394         IF(ISQ.EQ.3)IREJ=3
38395         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
38396         IPCO=0
38397         RETURN
38398       ENDIF
38399       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
38400      * UMO, XDIQP,XVQT
38401       XSQ=0.D0
38402       XSAQ=0.D0
38403 **NEW
38404 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
38405       IF (IPIP.EQ.1) THEN
38406          XQMAX  = XDIQP/2.0D0
38407          XAQMAX = 2.D0*XVQT/3.0D0
38408       ELSE
38409          XQMAX  = 2.D0*XVQT/3.0D0
38410          XAQMAX = XDIQP/2.0D0
38411       ENDIF
38412       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
38413       ISAQ = 6+ISQ
38414 C     write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
38415 **
38416       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38417       IF(IREJ.GE.1)THEN
38418         IF(IPCO.GE.3)
38419      &     WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38420         IPCO=0
38421         RETURN
38422       ENDIF
38423       IF(IPIP.EQ.1)THEN
38424         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38425       ELSEIF(IPIP.EQ.2)THEN
38426         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38427       ENDIF
38428       IF(IPCO.GE.3)THEN
38429         WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
38430      *  XDIQP,XVQT,XSQ,XSAQ
38431       ENDIF
38432 C
38433 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
38434 C
38435 C     XSQ=0.D0
38436       IF(IPIP.EQ.1)THEN
38437         XDIQP=XDIQP-XSQ
38438         XVQT =XVQT -XSAQ
38439       ELSEIF(IPIP.EQ.2)THEN
38440         XDIQP=XDIQP-XSAQ
38441         XVQT =XVQT -XSQ
38442       ENDIF
38443       IF(IPCO.GE.3)
38444      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
38445 C
38446 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38447 C
38448       XVTHRO=CVQ/UMO
38449       IVTHR=0
38450  3466 CONTINUE
38451       IF(IVTHR.EQ.10)THEN
38452         IREJ=1
38453         IF(ISQ.EQ.3)IREJ=3
38454         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
38455         IPCO=0
38456         RETURN
38457       ENDIF
38458       IVTHR=IVTHR+1
38459       XVTHR=XVTHRO/(201-IVTHR)
38460       UNOPRV=UNON
38461  380  CONTINUE
38462       IF(XVTHR.GT.0.66D0*XDIQP)THEN
38463         IREJ=1
38464         IF(ISQ.EQ.3)IREJ=3
38465         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR  large ',
38466      *  XVTHR
38467         IPCO=0
38468         RETURN
38469       ENDIF
38470       IF(DT_RNDM(V).LT.0.5D0)THEN
38471         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38472         XVPQII=XDIQP-XVPQI
38473       ELSE
38474         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38475         XVPQI=XDIQP-XVPQII
38476       ENDIF
38477       IF(IPCO.GE.3)THEN
38478         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
38479       ENDIF
38480 C
38481 C     Prepare 4 momenta of new chains and chain ends
38482 C
38483 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38484 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38485 C    +(4,NTMHKK)
38486 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38487 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38488 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38489       IF(IPIP.EQ.1)THEN
38490         XSQ1=XSQ
38491         XSAQ1=XSAQ
38492         ISQ1=ISQ
38493         ISAQ1=ISAQ
38494       ELSEIF(IPIP.EQ.2)THEN
38495         XSQ1=XSAQ
38496         XSAQ1=XSQ
38497         ISQ1=ISAQ
38498         ISAQ1=ISQ
38499       ENDIF
38500       IDHKT(1)   =IP11
38501       ISTHKT(1)  =931
38502       JMOHKT(1,1)=NC1P
38503       JMOHKT(2,1)=0
38504       JDAHKT(1,1)=3+IIGLU1
38505       JDAHKT(2,1)=0
38506 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38507       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38508       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38509       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38510       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38511 C     PHKT(5,1)  =PHKK(5,NC1P)
38512       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38513      *PHKT(1,1)**2)
38514       IF(XMIST.GE.0.D0)THEN
38515       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38516      *PHKT(1,1)**2)
38517       ELSE
38518 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38519        PHKT(5,1)=0.D0
38520       ENDIF
38521       VHKT(1,1)  =VHKK(1,NC1P)
38522       VHKT(2,1)  =VHKK(2,NC1P)
38523       VHKT(3,1)  =VHKK(3,NC1P)
38524       VHKT(4,1)  =VHKK(4,NC1P)
38525       WHKT(1,1)  =WHKK(1,NC1P)
38526       WHKT(2,1)  =WHKK(2,NC1P)
38527       WHKT(3,1)  =WHKK(3,NC1P)
38528       WHKT(4,1)  =WHKK(4,NC1P)
38529 C     Add here IIGLU1 gluons to this chaina
38530       PG1=0.D0
38531       PG2=0.D0
38532       PG3=0.D0
38533       PG4=0.D0
38534       IF(IIGLU1.GE.1)THEN
38535       JJG=NC1P
38536       DO 61 IIG=2,2+IIGLU1-1
38537         KKG=JJG+IIG-1
38538         IDHKT(IIG)   =IDHKK(KKG)
38539         ISTHKT(IIG)  =921
38540         JMOHKT(1,IIG)=KKG
38541         JMOHKT(2,IIG)=0
38542         JDAHKT(1,IIG)=3+IIGLU1
38543         JDAHKT(2,IIG)=0
38544         PHKT(1,IIG)=PHKK(1,KKG)
38545         PG1=PG1+ PHKT(1,IIG)
38546         PHKT(2,IIG)=PHKK(2,KKG)
38547         PG2=PG2+ PHKT(2,IIG)
38548         PHKT(3,IIG)=PHKK(3,KKG)
38549         PG3=PG3+ PHKT(3,IIG)
38550         PHKT(4,IIG)=PHKK(4,KKG)
38551         PG4=PG4+ PHKT(4,IIG)
38552         PHKT(5,IIG)=PHKK(5,KKG)
38553         VHKT(1,IIG)  =VHKK(1,KKG)
38554         VHKT(2,IIG)  =VHKK(2,KKG)
38555         VHKT(3,IIG)  =VHKK(3,KKG)
38556         VHKT(4,IIG)  =VHKK(4,KKG)
38557         WHKT(1,IIG) =WHKK(1,KKG)
38558         WHKT(2,IIG) =WHKK(2,KKG)
38559         WHKT(3,IIG) =WHKK(3,KKG)
38560         WHKT(4,IIG) =WHKK(4,KKG)
38561    61 CONTINUE
38562       ENDIF
38563       IDHKT(2+IIGLU1)   =IPP2
38564       ISTHKT(2+IIGLU1)  =932
38565       JMOHKT(1,2+IIGLU1)=NC2T
38566       JMOHKT(2,2+IIGLU1)=0
38567       JDAHKT(1,2+IIGLU1)=3+IIGLU1
38568       JDAHKT(2,2+IIGLU1)=0
38569       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
38570       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
38571       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
38572       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
38573 C     PHKT(5,2+IIGLU1)  =PHKK(5,NC2T)
38574       XMIST=(PHKT(4,2+IIGLU1)**2-
38575      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38576      *PHKT(1,2+IIGLU1)**2)
38577       IF(XMIST.GT.0.D0)THEN
38578       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
38579      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38580      *PHKT(1,2+IIGLU1)**2)
38581       ELSE
38582 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38583         PHKT(5,2+IIGLU1)=0.D0
38584       ENDIF
38585       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
38586       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
38587       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
38588       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
38589       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
38590       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
38591       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
38592       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
38593       IDHKT(3+IIGLU1)   =88888
38594       ISTHKT(3+IIGLU1)  =94
38595       JMOHKT(1,3+IIGLU1)=1
38596       JMOHKT(2,3+IIGLU1)=2+IIGLU1
38597       JDAHKT(1,3+IIGLU1)=0
38598       JDAHKT(2,3+IIGLU1)=0
38599       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38600       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38601       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38602       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38603       XMIST
38604      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38605      *            -PHKT(3,3+IIGLU1)**2)
38606       IF(XMIST.GE.0.D0)THEN
38607       PHKT(5,3+IIGLU1)
38608      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38609      *            -PHKT(3,3+IIGLU1)**2)
38610       ELSE
38611 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38612        PHKT(5,1)=0.D0
38613       ENDIF
38614       IF(IPIP.GE.3)THEN
38615 C     IF(NUMEV.EQ.-324)THEN
38616       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
38617      * JMOHKT(2,1),JDAHKT(1,1),
38618      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38619       DO 71 IIG=2,2+IIGLU1-1
38620       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38621      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38622      * JDAHKT(1,IIG),
38623      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38624    71 CONTINUE
38625       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38626      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38627      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38628       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38629      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38630      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38631       ENDIF
38632       CHAMAL=CHAM1
38633       IF(IPIP.EQ.1)THEN
38634         IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
38635       ELSEIF(IPIP.EQ.2)THEN
38636         IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
38637       ENDIF
38638       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38639 C       IREJ=1
38640         IPCO=0
38641 C       RETURN
38642 C       WRITE(6,*)' MUSQBS1 jump back from chain 3'
38643         GO TO 3466
38644       ENDIF
38645       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
38646       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
38647       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
38648       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
38649       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
38650       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
38651       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
38652       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
38653       IDHKT(4+IIGLU1)   =IP12
38654       ISTHKT(4+IIGLU1)  =931
38655       JMOHKT(1,4+IIGLU1)=NC1P
38656       JMOHKT(2,4+IIGLU1)=0
38657       JDAHKT(1,4+IIGLU1)=6+IIGLU1
38658       JDAHKT(2,4+IIGLU1)=0
38659 C   create  chain   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38660       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
38661       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
38662       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
38663       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
38664 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
38665       XMIST  =(PHKT(4,4+IIGLU1)**2-
38666      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38667      *PHKT(1,4+IIGLU1)**2)
38668       IF(XMIST.GT.0.D0)THEN
38669       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
38670      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38671      *PHKT(1,4+IIGLU1)**2)
38672       ELSE
38673 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38674         PHKT(5,4+IIGLU1)=0.D0
38675       ENDIF
38676       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
38677       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
38678       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
38679       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
38680       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
38681       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
38682       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
38683       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
38684       IF(IPIP.EQ.1)THEN
38685         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
38686       ELSEIF(IPIP.EQ.2)THEN
38687         IDHKT(5+IIGLU1)   =ISAQ1
38688       ENDIF
38689       ISTHKT(5+IIGLU1)  =932
38690       JMOHKT(1,5+IIGLU1)=NC1T
38691       JMOHKT(2,5+IIGLU1)=0
38692       JDAHKT(1,5+IIGLU1)=6+IIGLU1
38693       JDAHKT(2,5+IIGLU1)=0
38694       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
38695       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
38696       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
38697       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
38698 C     IF( PHKT(4,5).EQ.0.D0)THEN
38699 C       IREJ=1
38700 CIPCO=0
38701 CRETURN
38702 C     ENDIF
38703 C     PHKT(5,5)  =PHKK(5,NC1T)
38704       XMIST=(PHKT(4,5+IIGLU1)**2-
38705      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38706      *PHKT(1,5+IIGLU1)**2)
38707       IF(XMIST.GT.0.D0)THEN
38708       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
38709      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38710      *PHKT(1,5+IIGLU1)**2)
38711       ELSE
38712 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38713         PHKT(5,5+IIGLU1)=0.D0
38714       ENDIF
38715       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
38716       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
38717       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
38718       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
38719       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
38720       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
38721       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
38722       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
38723       IDHKT(6+IIGLU1)   =88888
38724       ISTHKT(6+IIGLU1)  =94
38725       JMOHKT(1,6+IIGLU1)=4+IIGLU1
38726       JMOHKT(2,6+IIGLU1)=5+IIGLU1
38727       JDAHKT(1,6+IIGLU1)=0
38728       JDAHKT(2,6+IIGLU1)=0
38729       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
38730       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
38731       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
38732       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
38733       XMIST
38734      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38735      *            -PHKT(3,6+IIGLU1)**2)
38736       IF(XMIST.GE.0.D0)THEN
38737       PHKT(5,6+IIGLU1)
38738      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38739      *            -PHKT(3,6+IIGLU1)**2)
38740       ELSE
38741 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38742        PHKT(5,1)=0.D0
38743       ENDIF
38744 C     IF(IPIP.EQ.3)THEN
38745       CHAMAL=CHAM1
38746       IF(IPIP.EQ.1)THEN
38747         IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
38748       ELSEIF(IPIP.EQ.2)THEN
38749         IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
38750       ENDIF
38751       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
38752 C       IREJ=1
38753         IPCO=0
38754 C       RETURN
38755 C       WRITE(6,*)' MGSQBS1 jump back from chain 6',
38756 C    *  CHAMAL,PHKT(5,6+IIGLU1)
38757         GO TO 3466
38758       ENDIF
38759       IF(IPIP.GE.3)THEN
38760 C     IF(NUMEV.EQ.-324)THEN
38761       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38762      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38763      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38764       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38765      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38766      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38767       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38768      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38769      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38770       ENDIF
38771       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
38772       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
38773       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
38774       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
38775       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
38776       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
38777       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
38778       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
38779       IF(IPIP.EQ.1)THEN
38780         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+3
38781         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
38782         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
38783         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
38784       ELSEIF(IPIP.EQ.2)THEN
38785         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
38786         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38787         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38788         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38789 C       WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
38790       ENDIF
38791       ISTHKT(7+IIGLU1)  =931
38792       JMOHKT(1,7+IIGLU1)=NC2P
38793       JMOHKT(2,7+IIGLU1)=0
38794       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38795       JDAHKT(2,7+IIGLU1)=0
38796 C    create chain     9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38797       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38798       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38799       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38800       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38801 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38802 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38803       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38804 C       IREJ=1
38805 C       WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
38806         IPCO=0
38807 C       RETURN
38808         GO TO 3466
38809       ENDIF
38810 C     PHKT(5,7)  =PHKK(5,NC2P)
38811       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
38812      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38813      *PHKT(1,7+IIGLU1)**2)
38814       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
38815       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
38816       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
38817       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
38818       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
38819       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
38820       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
38821       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
38822 C     Insert here the IIGLU2 gluons
38823       PG1=0.D0
38824       PG2=0.D0
38825       PG3=0.D0
38826       PG4=0.D0
38827       IF(IIGLU2.GE.1)THEN
38828       JJG=NC2P
38829       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38830         KKG=JJG+IIG-7-IIGLU1
38831         IDHKT(IIG)   =IDHKK(KKG)
38832         ISTHKT(IIG)  =921
38833         JMOHKT(1,IIG)=KKG
38834         JMOHKT(2,IIG)=0
38835         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38836         JDAHKT(2,IIG)=0
38837         PHKT(1,IIG)=PHKK(1,KKG)
38838         PG1=PG1+ PHKT(1,IIG)
38839         PHKT(2,IIG)=PHKK(2,KKG)
38840         PG2=PG2+ PHKT(2,IIG)
38841         PHKT(3,IIG)=PHKK(3,KKG)
38842         PG3=PG3+ PHKT(3,IIG)
38843         PHKT(4,IIG)=PHKK(4,KKG)
38844         PG4=PG4+ PHKT(4,IIG)
38845         PHKT(5,IIG)=PHKK(5,KKG)
38846         VHKT(1,IIG)  =VHKK(1,KKG)
38847         VHKT(2,IIG)  =VHKK(2,KKG)
38848         VHKT(3,IIG)  =VHKK(3,KKG)
38849         VHKT(4,IIG)  =VHKK(4,KKG)
38850         WHKT(1,IIG)  =WHKK(1,KKG)
38851         WHKT(2,IIG) =WHKK(2,KKG)
38852         WHKT(3,IIG) =WHKK(3,KKG)
38853         WHKT(4,IIG) =WHKK(4,KKG)
38854    81 CONTINUE
38855       ENDIF
38856       IDHKT(8+IIGLU1+IIGLU2)   =IP2
38857       ISTHKT(8+IIGLU1+IIGLU2)  =932
38858       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38859       JMOHKT(2,8+IIGLU1+IIGLU2)=0
38860       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38861       JDAHKT(2,8+IIGLU1+IIGLU2)=0
38862       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38863       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38864       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38865       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38866 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
38867       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38868      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38869      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38870       IF(XMIST.GT.0.D0)THEN
38871       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38872      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38873      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38874       ELSE
38875 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38876         PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38877       ENDIF
38878       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
38879       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
38880       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
38881       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
38882       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
38883       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
38884       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
38885       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
38886       IDHKT(9+IIGLU1+IIGLU2)   =88888
38887       ISTHKT(9+IIGLU1+IIGLU2)  =94
38888       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38889       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38890       JDAHKT(1,9+IIGLU1+IIGLU2)=0
38891       JDAHKT(2,9+IIGLU1+IIGLU2)=0
38892       PHKT(1,9+IIGLU1+IIGLU2)
38893      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38894       PHKT(2,9+IIGLU1+IIGLU2)
38895      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38896       PHKT(3,9+IIGLU1+IIGLU2)
38897      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38898       PHKT(4,9+IIGLU1+IIGLU2)
38899      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38900       XMIST
38901      *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38902      * -PHKT(2,9+IIGLU1+IIGLU2)**2
38903      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38904       IF(XMIST.GE.0.D0)THEN
38905       PHKT(5,9+IIGLU1+IIGLU2)
38906      *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38907      * -PHKT(2,9+IIGLU1+IIGLU2)**2
38908      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38909       ELSE
38910 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38911        PHKT(5,1)=0.D0
38912       ENDIF
38913       IF(IPIP.GE.3)THEN
38914 C     IF(NUMEV.EQ.-324)THEN
38915       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38916      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38917      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38918       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38919       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38920      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38921      * JDAHKT(1,IIG),
38922      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38923    91 CONTINUE
38924       WRITE(LOUT,*)8+IIGLU1+IIGLU2,
38925      * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
38926      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38927      *JDAHKT(1,8+IIGLU1+IIGLU2),
38928      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38929       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38930      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38931      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38932      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38933       ENDIF
38934       CHAMAL=CHAB1
38935       IF(IPIP.EQ.1)THEN
38936         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38937       ELSEIF(IPIP.EQ.2)THEN
38938         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38939       ENDIF
38940       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38941 C       IREJ=1
38942         IPCO=0
38943 C       RETURN
38944 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
38945 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
38946         GO TO 3466
38947       ENDIF
38948       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
38949       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
38950       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
38951       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
38952       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
38953       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
38954       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
38955       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
38956 C
38957       IPCO=0
38958       IGCOUN=9+IIGLU1+IIGLU2
38959        RETURN
38960        END
38961
38962 *$ CREATE MGSQBS1.FOR
38963 *COPY MGSQBS1
38964 C
38965 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38966       SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38967      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
38968 C
38969 C                  GSQBS-1 diagram (split projectile diquark)
38970 C
38971       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38972       SAVE
38973
38974       PARAMETER ( LINP = 10 ,
38975      &            LOUT = 6 ,
38976      &            LDAT = 9 )
38977 * event history
38978       PARAMETER (NMXHKK=200000)
38979       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38980      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38981      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38982 * extended event history
38983       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38984      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38985      &                IHIST(2,NMXHKK)
38986 * Lorentz-parameters of the current interaction
38987       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38988      &                UMO,PPCM,EPROJ,PPROJ
38989 * diquark-breaking mechanism
38990       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38991
38992 C
38993       PARAMETER (NTMHKK= 300)
38994       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38995      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38996      +(4,NTMHKK)
38997 *KEEP,XSEADI.
38998       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
38999      +SSMIMQ,VVMTHR
39000 *KEEP,DPRIN.
39001       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
39002 C
39003 C                  GSQBS-1 diagram (split projectile diquark)
39004 C
39005 C
39006 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
39007 C     Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
39008 C
39009 C     Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
39010 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39011 C
39012 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39013 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39014 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39015 C
39016 C       Put new chains into COMMON /HKKTMP/
39017 C
39018       IIGLU1=NC1T-NC1P-1
39019       IIGLU2=NC2T-NC2P-1
39020       IGCOUN=0
39021 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
39022       CVQ=1.D0
39023       NNNC1=IDHKK(NC1)/1000
39024       MMMC1=IDHKK(NC1)-NNNC1*1000
39025       KKKC1=ISTHKK(NC1)
39026       NNNC2=IDHKK(NC2)/1000
39027       MMMC2=IDHKK(NC2)-NNNC2*1000
39028       KKKC2=ISTHKK(NC2)
39029       IREJ=0
39030       IF(IPIP.EQ.3)THEN
39031       WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
39032      *             ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
39033      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
39034      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
39035       ENDIF
39036 C
39037 C
39038 C
39039 C     determine x-values of NC1P diquark
39040       XDIQP=PHKK(4,NC1P)*2.D0/UMO
39041       XVQT=PHKK(4,NC1T)*2.D0/UMO
39042 C
39043 C     determine x-values of sea quark pair
39044 C
39045       IPCO=1
39046       ICOU=0
39047  2234 CONTINUE
39048       ICOU=ICOU+1
39049       IF(ICOU.GE.500)THEN
39050         IREJ=1
39051         IF(ISQ.EQ.3)IREJ=3
39052         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
39053       IPCO=0
39054         RETURN
39055       ENDIF
39056       IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
39057      * UMO, XDIQP,XVQT
39058       XSQ=0.D0
39059       XSAQ=0.D0
39060 **NEW
39061 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
39062       IF (IPIP.EQ.1) THEN
39063          XQMAX  = XDIQP/2.0D0
39064          XAQMAX = 2.D0*XVQT/3.0D0
39065       ELSE
39066          XQMAX  = 2.D0*XVQT/3.0D0
39067          XAQMAX = XDIQP/2.0D0
39068       ENDIF
39069       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
39070       ISAQ = 6+ISQ
39071 C     write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
39072 **
39073         IF(IPCO.GE.3)
39074      &     WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39075       IF(IREJ.GE.1)THEN
39076         IF(IPCO.GE.3)
39077      &     WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39078       IPCO=0
39079         RETURN
39080       ENDIF
39081       IF(IPIP.EQ.1)THEN
39082         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39083       ELSEIF(IPIP.EQ.2)THEN
39084         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39085       ENDIF
39086       IF(IPCO.GE.3)THEN
39087         WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
39088      *  XDIQP,XVQT,XSQ,XSAQ
39089       ENDIF
39090 C
39091 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
39092 C
39093 C     XSQ=0.D0
39094       IF(IPIP.EQ.1)THEN
39095         XDIQP=XDIQP-XSQ
39096 **NEW
39097 C       IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
39098 **
39099         XVQT =XVQT -XSAQ
39100       ELSEIF(IPIP.EQ.2)THEN
39101         XDIQP=XDIQP-XSAQ
39102         XVQT =XVQT -XSQ
39103       ENDIF
39104       IF(IPCO.GE.3)
39105      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
39106 C
39107 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39108 C
39109       XVTHRO=CVQ/UMO
39110       IVTHR=0
39111  3466 CONTINUE
39112       IF(IVTHR.EQ.10)THEN
39113         IREJ=1
39114         IF(ISQ.EQ.3)IREJ=3
39115         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
39116       IPCO=0
39117         RETURN
39118       ENDIF
39119       IVTHR=IVTHR+1
39120       XVTHR=XVTHRO/(201-IVTHR)
39121       UNOPRV=UNON
39122  380  CONTINUE
39123       IF(XVTHR.GT.0.66D0*XDIQP)THEN
39124         IREJ=1
39125         IF(ISQ.EQ.3)IREJ=3
39126         IF(IPCO.GE.3)
39127      &     WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR  large ',
39128      *  XVTHR
39129       IPCO=0
39130         RETURN
39131       ENDIF
39132       IF(DT_RNDM(V).LT.0.5D0)THEN
39133         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39134         XVPQII=XDIQP-XVPQI
39135       ELSE
39136         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39137         XVPQI=XDIQP-XVPQII
39138       ENDIF
39139       IF(IPCO.GE.3)THEN
39140         WRITE(LOUT,'(A,4E12.4)')'  MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
39141      *  XVTHR,XDIQP,XVPQI,XVPQII
39142       ENDIF
39143 C
39144 C     Prepare 4 momenta of new chains and chain ends
39145 C
39146 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39147 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39148 C    +(4,NTMHKK)
39149 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39150 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39151 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39152       IF(IPIP.EQ.1)THEN
39153         XSQ1=XSQ
39154         XSAQ1=XSAQ
39155         ISQ1=ISQ
39156         ISAQ1=ISAQ
39157       ELSEIF(IPIP.EQ.2)THEN
39158         XSQ1=XSAQ
39159         XSAQ1=XSQ
39160         ISQ1=ISAQ
39161         ISAQ1=ISQ
39162       ENDIF
39163       KK11=IP11
39164 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39165       KK21= IPP21
39166       KK22= IPP22
39167       XGIVE=0.D0
39168       IDHKT(4+IIGLU1)   =IP12
39169       ISTHKT(4+IIGLU1)  =921
39170       JMOHKT(1,4+IIGLU1)=NC1P
39171       JMOHKT(2,4+IIGLU1)=0
39172       JDAHKT(1,4+IIGLU1)=6+IIGLU1
39173       JDAHKT(2,4+IIGLU1)=0
39174 **NEW
39175       IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
39176      &    (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
39177 **
39178       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
39179       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
39180       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
39181       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
39182 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
39183       XXMIST=(PHKT(4,4+IIGLU1)**2-
39184      *              PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
39185      *              PHKT(1,4+IIGLU1)**2)
39186       IF(XXMIST.GT.0.D0)THEN
39187         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
39188       ELSE
39189         WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
39190         XXMIST=ABS(XXMIST)
39191         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
39192       ENDIF
39193       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
39194       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
39195       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
39196       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
39197       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
39198       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
39199       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
39200       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
39201       IF(IPIP.EQ.1)THEN
39202         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
39203       ELSEIF(IPIP.EQ.2)THEN
39204         IDHKT(5+IIGLU1)   =ISAQ1
39205       ENDIF
39206       ISTHKT(5+IIGLU1)  =922
39207       JMOHKT(1,5+IIGLU1)=NC1T
39208       JMOHKT(2,5+IIGLU1)=0
39209       JDAHKT(1,5+IIGLU1)=6+IIGLU1
39210       JDAHKT(2,5+IIGLU1)=0
39211 **NEW
39212       IF ((XSAQ1.LT.0.0D0).OR.(XVQT  .LT.0.0D0))
39213      &    WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
39214 **
39215       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
39216       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
39217       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
39218       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
39219 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
39220       XMIST=(PHKT(4,5+IIGLU1)**2-
39221      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39222      *PHKT(1,5+IIGLU1)**2)
39223       IF(XMIST.GT.0.D0)THEN
39224       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
39225      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39226      *PHKT(1,5+IIGLU1)**2)
39227       ELSE
39228 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
39229         PHKT(5,5+IIGLU1)=0.D0
39230       ENDIF
39231       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
39232       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
39233       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
39234       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
39235       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
39236       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
39237       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
39238       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
39239       IDHKT(6+IIGLU1)   =88888
39240 C     IDHKT(6)   =1000*NNNC1+MMMC1
39241       ISTHKT(6+IIGLU1)  =93
39242 C     ISTHKT(6)  =KKKC1
39243       JMOHKT(1,6+IIGLU1)=4+IIGLU1
39244       JMOHKT(2,6+IIGLU1)=5+IIGLU1
39245       JDAHKT(1,6+IIGLU1)=0
39246       JDAHKT(2,6+IIGLU1)=0
39247       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
39248       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
39249       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
39250       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
39251       PHKT(5,6+IIGLU1)
39252      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
39253      *            -PHKT(3,6+IIGLU1)**2)
39254       CHAMAL=CHAM1
39255       IF(IPIP.EQ.1)THEN
39256         IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
39257       ELSEIF(IPIP.EQ.2)THEN
39258         IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
39259       ENDIF
39260       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
39261         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
39262 C                    we drop chain 6 and give the energy to chain 3
39263           IDHKT(6+IIGLU1)=33888
39264           XGIVE=1.D0
39265 C         WRITE(6,*)' drop chain 6 xgive=1'
39266           GO TO 7788
39267         ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
39268 C                    we drop chain 6 and give the energy to chain 3
39269 C                    and change KK11 to IDHKT(4)
39270           IDHKT(6+IIGLU1)=33888
39271           XGIVE=1.D0
39272 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
39273           KK11=IDHKT(4+IIGLU1)
39274           GO TO 7788
39275         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
39276 C                    we drop chain 6 and give the energy to chain 3
39277 C                    and change KK21 to IDHKT(4)
39278 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39279           IDHKT(6+IIGLU1)=33888
39280           XGIVE=1.D0
39281 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
39282           KK21=IDHKT(4+IIGLU1)
39283           GO TO 7788
39284         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
39285 C                    we drop chain 6 and give the energy to chain 3
39286 C                    and change KK22 to IDHKT(4)
39287 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39288           IDHKT(6+IIGLU1)=33888
39289           XGIVE=1.D0
39290 C         WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
39291           KK22=IDHKT(4+IIGLU1)
39292           GO TO 7788
39293         ENDIF
39294 C       IREJ=1
39295         IPCO=0
39296 C       RETURN
39297 C       WRITE(6,*)' MGSQBS1 jump back from chain 6'
39298         GO TO 3466
39299       ENDIF
39300  7788 CONTINUE
39301       IF(IPIP.GE.3)THEN
39302       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
39303      * JMOHKT(1,4+IIGLU1),
39304      * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
39305      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
39306       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
39307      * JMOHKT(1,5+IIGLU1),
39308      * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
39309      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
39310       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
39311      * JMOHKT(1,6+IIGLU1),
39312      * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
39313      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
39314       ENDIF
39315       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
39316       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
39317       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
39318       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
39319       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
39320       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
39321       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
39322       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
39323 C     IDHKT(1)   =IP11
39324       IDHKT(1)   =KK11
39325       ISTHKT(1)  =921
39326       JMOHKT(1,1)=NC1P
39327       JMOHKT(2,1)=0
39328       JDAHKT(1,1)=3+IIGLU1
39329       JDAHKT(2,1)=0
39330       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
39331 C    * +0.5D0*PHKK(1,NC2P)
39332      *+XGIVE*PHKT(1,4+IIGLU1)
39333       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
39334 C    * +0.5D0*PHKK(2,NC2P)
39335      *+XGIVE*PHKT(2,4+IIGLU1)
39336       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
39337 C    * +0.5D0*PHKK(3,NC2P)
39338      *+XGIVE*PHKT(3,4+IIGLU1)
39339       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
39340 C    * +0.5D0*PHKK(4,NC2P)
39341      *+XGIVE*PHKT(4,4+IIGLU1)
39342 C     PHKT(5,1)  =PHKK(5,NC1P)
39343       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39344      *PHKT(1,1)**2)
39345       IF(XMIST.GE.0.D0)THEN
39346       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39347      *PHKT(1,1)**2)
39348       ELSE
39349 C      WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
39350        PHKT(5,1)=0.D0
39351       ENDIF
39352       VHKT(1,1)  =VHKK(1,NC1P)
39353       VHKT(2,1)  =VHKK(2,NC1P)
39354       VHKT(3,1)  =VHKK(3,NC1P)
39355       VHKT(4,1)  =VHKK(4,NC1P)
39356       WHKT(1,1)  =WHKK(1,NC1P)
39357       WHKT(2,1)  =WHKK(2,NC1P)
39358       WHKT(3,1)  =WHKK(3,NC1P)
39359       WHKT(4,1)  =WHKK(4,NC1P)
39360 C     Add here IIGLU1 gluons to this chaina
39361       PG1=0.D0
39362       PG2=0.D0
39363       PG3=0.D0
39364       PG4=0.D0
39365       IF(IIGLU1.GE.1)THEN
39366       JJG=NC1P
39367       DO 61 IIG=2,2+IIGLU1-1
39368         KKG=JJG+IIG-1
39369         IDHKT(IIG)   =IDHKK(KKG)
39370         ISTHKT(IIG)  =921
39371         JMOHKT(1,IIG)=KKG
39372         JMOHKT(2,IIG)=0
39373         JDAHKT(1,IIG)=3+IIGLU1
39374         JDAHKT(2,IIG)=0
39375         PHKT(1,IIG)=PHKK(1,KKG)
39376         PG1=PG1+ PHKT(1,IIG)
39377         PHKT(2,IIG)=PHKK(2,KKG)
39378         PG2=PG2+ PHKT(2,IIG)
39379         PHKT(3,IIG)=PHKK(3,KKG)
39380         PG3=PG3+ PHKT(3,IIG)
39381         PHKT(4,IIG)=PHKK(4,KKG)
39382         PG4=PG4+ PHKT(4,IIG)
39383         PHKT(5,IIG)=PHKK(5,KKG)
39384         VHKT(1,IIG)  =VHKK(1,KKG)
39385         VHKT(2,IIG)  =VHKK(2,KKG)
39386         VHKT(3,IIG)  =VHKK(3,KKG)
39387         VHKT(4,IIG)  =VHKK(4,KKG)
39388         WHKT(1,IIG)  =WHKK(1,KKG)
39389         WHKT(2,IIG)  =WHKK(2,KKG)
39390         WHKT(3,IIG)  =WHKK(3,KKG)
39391         WHKT(4,IIG)  =WHKK(4,KKG)
39392    61 CONTINUE
39393       ENDIF
39394 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39395       IF(IPIP.EQ.1)THEN
39396         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22+3
39397         IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
39398         IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
39399         IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
39400       ELSEIF(IPIP.EQ.2)THEN
39401         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22-3
39402         IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
39403         IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
39404         IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
39405       ENDIF
39406       ISTHKT(2+IIGLU1)  =922
39407       JMOHKT(1,2+IIGLU1)=NC2T
39408       JMOHKT(2,2+IIGLU1)=0
39409       JDAHKT(1,2+IIGLU1)=3+IIGLU1
39410       JDAHKT(2,2+IIGLU1)=0
39411       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
39412      *+XGIVE*PHKT(1,5+IIGLU1)
39413       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
39414      *+XGIVE*PHKT(2,5+IIGLU1)
39415       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
39416      *+XGIVE*PHKT(3,5+IIGLU1)
39417       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
39418      *+XGIVE*PHKT(4,5+IIGLU1)
39419 C     PHKT(5,2)  =PHKK(5,NC2T)
39420       XMIST=(PHKT(4,2+IIGLU1)**2-
39421      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39422      *PHKT(1,2+IIGLU1)**2)
39423       IF(XMIST.GT.0.D0)THEN
39424       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
39425      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39426      *PHKT(1,2+IIGLU1)**2)
39427       ELSE
39428 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39429       PHKT(5,2+IIGLU1)=0.D0
39430       ENDIF
39431       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
39432       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
39433       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
39434       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
39435       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
39436       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
39437       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
39438       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
39439       IDHKT(3+IIGLU1)   =88888
39440 C     IDHKT(3)   =1000*NNNC1+MMMC1+10
39441       ISTHKT(3+IIGLU1)  =93
39442 C     ISTHKT(3)  =KKKC1
39443       JMOHKT(1,3+IIGLU1)=1
39444       JMOHKT(2,3+IIGLU1)=2+IIGLU1
39445       JDAHKT(1,3+IIGLU1)=0
39446       JDAHKT(2,3+IIGLU1)=0
39447       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
39448       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
39449       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
39450       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
39451       PHKT(5,3+IIGLU1)
39452      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
39453      *            -PHKT(3,3+IIGLU1)**2)
39454       IF(IPIP.GE.3)THEN
39455       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
39456      * JDAHKT(1,1),
39457      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
39458       DO 71 IIG=2,2+IIGLU1-1
39459       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39460      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
39461      * JDAHKT(1,IIG),
39462      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39463    71 CONTINUE
39464       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
39465      &             IDHKT(2),JMOHKT(1,2+IIGLU1),
39466      * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
39467      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
39468       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
39469      * JMOHKT(1,3+IIGLU1),
39470      * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
39471      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
39472       ENDIF
39473       CHAMAL=CHAB1
39474 **NEW
39475 C     IF(IPIP.EQ.1)THEN
39476 C       IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
39477 C     ELSEIF(IPIP.EQ.2)THEN
39478 C       IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
39479 C     ENDIF
39480       IF(IPIP.EQ.1)THEN
39481         IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
39482       ELSEIF(IPIP.EQ.2)THEN
39483         IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
39484       ENDIF
39485 **
39486       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
39487 C       IREJ=1
39488         IPCO=0
39489 C       RETURN
39490 C       WRITE(6,*)' MGSQBS1 jump back from chain 3'
39491         GO TO 3466
39492       ENDIF
39493       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
39494       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
39495       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
39496       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
39497       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
39498       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
39499       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
39500       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
39501       IF(IPIP.EQ.1)THEN
39502         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ1+3
39503         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
39504         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
39505         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
39506       ELSEIF(IPIP.EQ.2)THEN
39507         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
39508         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
39509         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
39510         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
39511 C       WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
39512       ENDIF
39513       ISTHKT(7+IIGLU1)  =921
39514       JMOHKT(1,7+IIGLU1)=NC2P
39515       JMOHKT(2,7+IIGLU1)=0
39516       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
39517       JDAHKT(2,7+IIGLU1)=0
39518 C     PHKT(1,7)  =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
39519 C     PHKT(2,7)  =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
39520 C     PHKT(3,7)  =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
39521 C     PHKT(4,7+IIGLU1)  =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
39522 **NEW
39523       IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
39524      &    WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
39525 **
39526       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
39527       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
39528       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
39529       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
39530 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
39531 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
39532       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
39533 C       IREJ=1
39534 C       WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
39535         IPCO=0
39536 C       RETURN
39537         GO TO 3466
39538       ENDIF
39539 C     PHKT(5,7)  =PHKK(5,NC2P)
39540       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
39541      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
39542      *PHKT(1,7+IIGLU1)**2)
39543       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
39544       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
39545       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
39546       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
39547       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
39548       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
39549       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
39550       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
39551 C     Insert here the IIGLU2 gluons
39552       PG1=0.D0
39553       PG2=0.D0
39554       PG3=0.D0
39555       PG4=0.D0
39556       IF(IIGLU2.GE.1)THEN
39557       JJG=NC2P
39558       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39559         KKG=JJG+IIG-7-IIGLU1
39560         IDHKT(IIG)   =IDHKK(KKG)
39561         ISTHKT(IIG)  =921
39562         JMOHKT(1,IIG)=KKG
39563         JMOHKT(2,IIG)=0
39564         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
39565         JDAHKT(2,IIG)=0
39566         PHKT(1,IIG)=PHKK(1,KKG)
39567         PG1=PG1+ PHKT(1,IIG)
39568         PHKT(2,IIG)=PHKK(2,KKG)
39569         PG2=PG2+ PHKT(2,IIG)
39570         PHKT(3,IIG)=PHKK(3,KKG)
39571         PG3=PG3+ PHKT(3,IIG)
39572         PHKT(4,IIG)=PHKK(4,KKG)
39573         PG4=PG4+ PHKT(4,IIG)
39574         PHKT(5,IIG)=PHKK(5,KKG)
39575         VHKT(1,IIG)  =VHKK(1,KKG)
39576         VHKT(2,IIG)  =VHKK(2,KKG)
39577         VHKT(3,IIG)  =VHKK(3,KKG)
39578         VHKT(4,IIG)  =VHKK(4,KKG)
39579         WHKT(1,IIG)  =WHKK(1,KKG)
39580         WHKT(2,IIG)  =WHKK(2,KKG)
39581         WHKT(3,IIG)  =WHKK(3,KKG)
39582         WHKT(4,IIG)  =WHKK(4,KKG)
39583    81 CONTINUE
39584       ENDIF
39585       IDHKT(8+IIGLU1+IIGLU2)   =IP2
39586       ISTHKT(8+IIGLU1+IIGLU2)  =922
39587       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
39588       JMOHKT(2,8+IIGLU1+IIGLU2)=0
39589       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
39590       JDAHKT(2,8+IIGLU1+IIGLU2)=0
39591 **NEW
39592       IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
39593      &    WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
39594 **
39595       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
39596       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
39597       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
39598       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
39599 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
39600       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
39601      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39602      *PHKT(1,8+IIGLU1+IIGLU2)**2)
39603       IF(XMIST.GT.0.D0)THEN
39604       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
39605      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39606      *PHKT(1,8+IIGLU1+IIGLU2)**2)
39607       ELSE
39608 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39609       PHKT(5,8+IIGLU1+IIGLU2)=0.D0
39610       ENDIF
39611       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
39612       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
39613       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
39614       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
39615       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
39616       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
39617       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
39618       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
39619       IDHKT(9+IIGLU1+IIGLU2)   =88888
39620 C     IDHKT(9)   =1000*NNNC2+MMMC2+10
39621       ISTHKT(9+IIGLU1+IIGLU2)  =93
39622 C     ISTHKT(9)  =KKKC2
39623       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
39624       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
39625       JDAHKT(1,9+IIGLU1+IIGLU2)=0
39626       JDAHKT(2,9+IIGLU1+IIGLU2)=0
39627       PHKT(1,9+IIGLU1+IIGLU2)  =PHKT(1,7+IIGLU1)
39628      * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
39629       PHKT(2,9+IIGLU1+IIGLU2)  =PHKT(2,7+IIGLU1)
39630      * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
39631       PHKT(3,9+IIGLU1+IIGLU2)  =PHKT(3,7+IIGLU1)
39632      * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
39633       PHKT(4,9+IIGLU1+IIGLU2)  =PHKT(4,7+IIGLU1)
39634      * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
39635       PHKT(5,9+IIGLU1+IIGLU2)
39636      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
39637      * PHKT(2,9+IIGLU1+IIGLU2)**2
39638      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
39639       IF(IPIP.GE.3)THEN
39640       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
39641      * JMOHKT(1,7+IIGLU1),
39642      * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
39643      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
39644       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39645       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39646      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
39647      * JDAHKT(1,IIG),
39648      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39649    91 CONTINUE
39650       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
39651      * IDHKT(8+IIGLU1+IIGLU2),
39652      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
39653      * JDAHKT(1,8+IIGLU1+IIGLU2),
39654      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
39655       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
39656      * IDHKT(9+IIGLU1+IIGLU2),
39657      * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
39658      * JDAHKT(1,9+IIGLU1+IIGLU2),
39659      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
39660       ENDIF
39661       CHAMAL=CHAB1
39662       IF(IPIP.EQ.1)THEN
39663         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
39664       ELSEIF(IPIP.EQ.2)THEN
39665         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
39666       ENDIF
39667       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
39668 C       IREJ=1
39669         IPCO=0
39670 C       RETURN
39671 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
39672 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
39673         GO TO 3466
39674       ENDIF
39675       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
39676       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
39677       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
39678       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
39679       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
39680       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
39681       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
39682       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
39683 C
39684       IGCOUN=9+IIGLU1+IIGLU2
39685       IPCO=0
39686        RETURN
39687        END
39688
39689 *$ CREATE HKKHKT.FOR
39690 *COPY HKKHKT
39691 C
39692 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
39693 C
39694       SUBROUTINE HKKHKT(I,J)
39695       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39696       SAVE
39697
39698 * event history
39699       PARAMETER (NMXHKK=200000)
39700       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39701      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39702      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39703 * extended event history
39704       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39705      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39706      &                IHIST(2,NMXHKK)
39707
39708       PARAMETER (NTMHKK= 300)
39709       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39710      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39711      +(4,NTMHKK)
39712 C
39713       ISTHKK(I)  =ISTHKT(J)
39714       IDHKK(I)   =IDHKT(J)
39715 C     IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
39716       IF(IDHKK(I).EQ.88888)THEN
39717 C       JMOHKK(1,I)=I-2
39718 C       JMOHKK(2,I)=I-1
39719         JMOHKK(1,I)=I-(J-JMOHKT(1,J))
39720         JMOHKK(2,I)=I-(J-JMOHKT(2,J))
39721       ELSE
39722         JMOHKK(1,I)=JMOHKT(1,J)
39723         JMOHKK(2,I)=JMOHKT(2,J)
39724       ENDIF
39725       JDAHKK(1,I)=JDAHKT(1,J)
39726       JDAHKK(2,I)=JDAHKT(2,J)
39727 C       IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
39728 C       JDAHKK(1,I)=I+2
39729 C     ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
39730 C       JDAHKK(1,I)=I+1
39731 C     ENDIF
39732       IF(JDAHKT(1,J).GT.0)THEN
39733         JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
39734       ENDIF
39735       PHKK(1,I)  =PHKT(1,J)
39736       PHKK(2,I)  =PHKT(2,J)
39737       PHKK(3,I)  =PHKT(3,J)
39738       PHKK(4,I)  =PHKT(4,J)
39739       PHKK(5,I)  =PHKT(5,J)
39740       VHKK(1,I)  =VHKT(1,J)
39741       VHKK(2,I)  =VHKT(2,J)
39742       VHKK(3,I)  =VHKT(3,J)
39743       VHKK(4,I)  =VHKT(4,J)
39744       WHKK(1,I)  =WHKT(1,J)
39745       WHKK(2,I)  =WHKT(2,J)
39746       WHKK(3,I)  =WHKT(3,J)
39747       WHKK(4,I)  =WHKT(4,J)
39748       RETURN
39749       END
39750
39751 *$ CREATE DT_DBREAK.FOR
39752 *COPY DT_DBREAK
39753 *
39754 *===dbreak=============================================================*
39755 *
39756       SUBROUTINE DT_DBREAK(MODE)
39757
39758 ************************************************************************
39759 * This is the steering subroutine for the different diquark breaking   *
39760 * mechanisms.                                                          *
39761 *                                                                      *
39762 * MODE = 1  breaking of projectile diquark in qq-q chain using         *
39763 *           a sea quark (q-qq chain) of the same projectile            *
39764 *      = 2  breaking of target     diquark in q-qq chain using         *
39765 *           a sea quark (qq-q chain) of the same target                *
39766 *      = 3  breaking of projectile diquark in qq-q chain using         *
39767 *           a sea quark (q-aq chain) of the same projectile            *
39768 *      = 4  breaking of target     diquark in q-qq chain using         *
39769 *           a sea quark (aq-q chain) of the same target                *
39770 *      = 5  breaking of projectile anti-diquark in aqaq-aq chain using *
39771 *           a sea anti-quark (aq-aqaq chain) of the same projectile    *
39772 *      = 6  breaking of target     anti-diquark in aq-aqaq chain using *
39773 *           a sea anti-quark (aqaq-aq chain) of the same target        *
39774 *      = 7  breaking of projectile anti-diquark in aqaq-aq chain using *
39775 *           a sea anti-quark (aq-q chain) of the same projectile       *
39776 *      = 8  breaking of target     anti-diquark in aq-aqaq chain using *
39777 *           a sea anti-quark (q-aq chain) of the same target           *
39778 *                                                                      *
39779 * Original version by J. Ranft.                                        *
39780 * This version dated 17.5.00  is written by S. Roesler.                *
39781 ************************************************************************
39782
39783       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39784       SAVE
39785       PARAMETER ( LINP = 10 ,
39786      &            LOUT = 6 ,
39787      &            LDAT = 9 )
39788
39789 * event history
39790       PARAMETER (NMXHKK=200000)
39791       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39792      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39793      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39794 * extended event history
39795       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39796      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39797      &                IHIST(2,NMXHKK)
39798 * flags for input different options
39799       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
39800       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
39801      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
39802 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
39803       PARAMETER (MAXCHN=10000)
39804       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
39805 * diquark-breaking mechanism
39806       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
39807 * flags for particle decays
39808       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
39809      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
39810      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
39811
39812 *
39813 * chain identifiers
39814 * ( 1 = q-aq,   2 = aq-q,   3 = q-qq,   4 = qq-q,
39815 *   5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
39816       DIMENSION IDCHN1(8),IDCHN2(8)
39817       DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
39818       DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
39819 *
39820 * parton identifiers
39821 * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
39822 *   +-51/52 = unitarity-sea, +-61/62 = gluons )
39823       DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
39824       DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
39825      &             31, 31, 31, 31, 31, 31, 31, 31,
39826      &             41, 41, 41, 41, 51, 51, 51, 51/
39827       DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
39828      &             32, 32, 32, 32, 32, 32, 32, 32,
39829      &             42, 42, 42, 42, 52, 52, 52, 52/
39830       DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
39831      &             51, 31, 41, 41, 31, 31, 31, 31,
39832      &              0, 41, 51, 51, 51, 51, 51, 51/
39833       DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
39834      &             32, 52, 42, 42, 32, 32, 32, 32,
39835      &             42,  0, 52, 52, 52, 52, 52, 52/
39836
39837       IF (NCHAIN.LE.0) RETURN
39838       DO 1 I=1,NCHAIN
39839          IDX1 = IDXCHN(1,I)
39840          IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
39841          IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
39842          IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
39843      &       .AND.
39844      &        ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
39845      &                                    (IS1P.EQ.ISP1P(MODE,3)))
39846      &       .AND.
39847      &        ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
39848      &                                    (IS1T.EQ.ISP1T(MODE,3)))
39849      &      ) THEN
39850             DO 2 J=1,NCHAIN
39851                IDX2 = IDXCHN(1,J)
39852                IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
39853                IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
39854                IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
39855      &             .AND.
39856      &              ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
39857      &                                      .OR.(IS2P.EQ.ISP2P(MODE,3)))
39858      &             .AND.
39859      &              ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
39860      &                                      .OR.(IS2T.EQ.ISP2T(MODE,3)))
39861      &            ) THEN
39862 *   find mother nucleons of the diquark to be splitted and of the
39863 *   sea-quark and reject this combination if it is not the same
39864                   IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
39865      &                (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
39866                      IANCES = 1
39867                   ELSE
39868                      IANCES = 2
39869                   ENDIF
39870                   IDXMO1 = JMOHKK(IANCES,IDX1)
39871     4             CONTINUE
39872                   IF ((JMOHKK(1,IDXMO1).NE.0).AND.
39873      &                (JMOHKK(2,IDXMO1).NE.0)) THEN
39874                      IANC = IANCES
39875                   ELSE
39876                      IANC = 1
39877                   ENDIF
39878                   IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
39879                      IDXMO1 = JMOHKK(IANC,IDXMO1)
39880                      GOTO 4
39881                   ENDIF
39882                   IDXMO2 = JMOHKK(IANCES,IDX2)
39883     5             CONTINUE
39884                   IF ((JMOHKK(1,IDXMO2).NE.0).AND.
39885      &                (JMOHKK(2,IDXMO2).NE.0)) THEN
39886                      IANC = IANCES
39887                   ELSE
39888                      IANC = 1
39889                   ENDIF
39890                   IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
39891                      IDXMO2 = JMOHKK(IANC,IDXMO2)
39892                      GOTO 5
39893                   ENDIF
39894                   IF (IDXMO1.NE.IDXMO2) GOTO 2
39895 *   quark content of projectile parton
39896                   IP1   = IDHKK(JMOHKK(1,IDX1))
39897                   IP11  = IP1/1000
39898                   IP12  = (IP1-1000*IP11)/100
39899                   IP2   = IDHKK(JMOHKK(2,IDX1))
39900                   IP21  = IP2/1000
39901                   IP22  = (IP2-1000*IP21)/100
39902 *   quark content of target parton
39903                   IT1  = IDHKK(JMOHKK(1,IDX2))
39904                   IT11 = IT1/1000
39905                   IT12 = (IT1-1000*IT11)/100
39906                   IT2  = IDHKK(JMOHKK(2,IDX2))
39907                   IT21 = IT2/1000
39908                   IT22 = (IT2-1000*IT21)/100
39909 *   split diquark and form new chains
39910                   IF (MODE.EQ.1) THEN
39911                      IF (IT1.EQ.4) GOTO 2
39912                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39913      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39914      &                         IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
39915                   ELSEIF (MODE.EQ.2) THEN
39916                      IF (IT2.EQ.4) GOTO 2
39917                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39918      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39919      &                         IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
39920                   ELSEIF (MODE.EQ.3) THEN
39921                      IF (IT1.EQ.4) GOTO 2
39922                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39923      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39924      &                         IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
39925                   ELSEIF (MODE.EQ.4) THEN
39926                      IF (IT2.EQ.4) GOTO 2
39927                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39928      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39929      &                         IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
39930                   ELSEIF (MODE.EQ.5) THEN
39931                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39932      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39933      &                         IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
39934                   ELSEIF (MODE.EQ.6) THEN
39935                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39936      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39937      &                         IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
39938                   ELSEIF (MODE.EQ.7) THEN
39939                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39940      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39941      &                         IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
39942                   ELSEIF (MODE.EQ.8) THEN
39943                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39944      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39945      &                         IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
39946                   ENDIF
39947                   IF (IREJ.GE.1) THEN
39948                      if ((ipq.lt.0).or.(ipq.ge.4))
39949      &                  write(LOUT,*) 'ipq !!!',ipq,mode
39950                      DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
39951 *   accept or reject new chains corresponding to PDBSEA
39952                   ELSE
39953                      IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
39954                         ACC   = DBRKA(1,MODE)+DBRKA(2,MODE)
39955                         REJ   = DBRKR(1,MODE)+DBRKR(2,MODE)
39956                      ELSEIF (IPQ.EQ.3) THEN
39957                         ACC   = DBRKA(3,MODE)
39958                         REJ   = DBRKR(3,MODE)
39959                      ELSE
39960                         WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
39961                         STOP
39962                      ENDIF
39963                      IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
39964                         DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
39965                         IACC = 1
39966                      ELSE
39967                         DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
39968                         IACC = 0
39969                      ENDIF
39970 *   new chains have been accepted and are now copied into HKKEVT
39971                      IF (IACC.EQ.1) THEN
39972                         IF (LEMCCK) THEN
39973                            CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
39974      &                                    PHKK(3,IDX1),PHKK(4,IDX1),
39975      &                                    1,IDUM1,IDUM2)
39976                            CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
39977      &                                    PHKK(3,IDX2),PHKK(4,IDX2),
39978      &                                    2,IDUM1,IDUM2)
39979                         ENDIF
39980                         IDHKK(IDX1) = 99888
39981                         IDHKK(IDX2) = 99888
39982                         IDXCHN(2,I) = -1
39983                         IDXCHN(2,J) = -1
39984                         DO 3 K=1,IGCOUN
39985                            NHKK = NHKK+1
39986                            CALL HKKHKT(NHKK,K)
39987                            IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
39988                               PX = -PHKK(1,NHKK)
39989                               PY = -PHKK(2,NHKK)
39990                               PZ = -PHKK(3,NHKK)
39991                               PE = -PHKK(4,NHKK)
39992                               CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
39993                            ENDIF
39994     3                   CONTINUE
39995                         IF (LEMCCK) THEN
39996                            CHKLEV = 0.1D0
39997                            CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
39998      &                                                             IREJ)
39999                            IF (IREJ.NE.0) CALL DT_EVTOUT(4)
40000                         ENDIF
40001                         GOTO 1
40002                      ENDIF
40003                   ENDIF
40004                ENDIF
40005     2       CONTINUE
40006          ENDIF
40007     1 CONTINUE
40008       RETURN
40009       END
40010
40011 *$ CREATE DT_CQPAIR.FOR
40012 *COPY DT_CQPAIR
40013 *
40014 *===cqpair=============================================================*
40015 *
40016       SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
40017
40018 ************************************************************************
40019 * This subroutine Creates a Quark-antiquark PAIR from the sea.         *
40020 *                                                                      *
40021 *   XQMAX   maxium energy fraction of quark (input)                    *
40022 *   XAQMAX  maxium energy fraction of antiquark (input)                *
40023 *   XQ      energy fraction of quark (output)                          *
40024 *   XAQ     energy fraction of antiquark (output)                      *
40025 *   IFLV    quark flavour (- antiquark flavor) (output)                *
40026 *                                                                      *
40027 * This version dated 14.5.00  is written by S. Roesler.                *
40028 ************************************************************************
40029
40030       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
40031       SAVE
40032       PARAMETER ( LINP = 10 ,
40033      &            LOUT = 6 ,
40034      &            LDAT = 9 )
40035
40036 * Lorentz-parameters of the current interaction
40037       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
40038      &                UMO,PPCM,EPROJ,PPROJ
40039
40040 *
40041       IREJ = 0
40042       XQ   = 0.0D0
40043       XAQ  = 0.0D0
40044 *
40045 * sample quark flavour
40046 *
40047 *  set seasq here (the one from DTCHAI should be used in the future)
40048       SEASQ = 0.5D0
40049       IFLV  = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
40050 *
40051 * sample energy fractions of sea pair
40052 * we first sample the energy fraction of a gluon and then split the gluon
40053 *
40054 *  maximum energy fraction of the gluon forced via input
40055       XGMAXI = XQMAX+XAQMAX
40056 *  minimum energy fraction of the gluon
40057       XTHR1 = 4.0D0 /UMO**2
40058       XTHR2 = 0.54D0/UMO**1.5D0
40059       XGMIN = MAX(XTHR1,XTHR2)
40060 *  maximum energy fraction of the gluon
40061       XGMAX = 0.3D0
40062       XGMAX = MIN(XGMAXI,XGMAX)
40063       IF (XGMIN.GE.XGMAX) THEN
40064          IREJ = 1
40065          RETURN
40066       ENDIF
40067 *
40068 *  sample energy fraction of the gluon
40069       NLOOP = 0
40070     1 CONTINUE
40071       NLOOP = NLOOP+1
40072       IF (NLOOP.GE.50) THEN
40073          IREJ = 1
40074          RETURN
40075       ENDIF
40076       XGLUON = DT_SAMSQX(XGMIN,XGMAX)
40077       EGLUON = XGLUON*UMO/2.0D0
40078 *
40079 *  split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
40080       ZMIN = MIN(0.1D0,0.5D0/EGLUON)
40081       ZMAX = 1.0D0-ZMIN
40082       RZ   = DT_RNDM(ZMAX)
40083       XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
40084       RQ   = DT_RNDM(ZMAX)
40085       IF (RQ.LT.0.5D0) THEN
40086          XQ  = XGLUON*XHLP
40087          XAQ = XGLUON-XQ
40088       ELSE
40089          XAQ = XGLUON*XHLP
40090          XQ  = XGLUON-XAQ
40091       ENDIF
40092       IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1
40093
40094       RETURN
40095       END