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(8000,2),BRAT(8000),KFDP(8000,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       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
14572       PARAMETER (MAXLND=4000)
14573       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
14574       INTEGER PYK
14575       DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
14576       INTEGER PYCOMP
14577       MODE = KMODE
14578       ISTSTG = 7
14579       IF (MODE.NE.1) ISTSTG = 8
14580       IREJ = 0
14581
14582       IP     = 0
14583       ISH    = 0
14584       INIEMC = 1
14585       NEND   = NHKK
14586       NACCEP = 0
14587       IFRG   = 0
14588       IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
14589       DO 10 I=NPOINT(3),NEND
14590 * sr 14.02.00: seems to be not necessary anymore, commented
14591 C        LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
14592 C    &            ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
14593          LACCEP = .TRUE.
14594 * pick up chains from dtevt1
14595          IDCHK = IDHKK(I)/10000
14596          IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
14597             IF (IDCHK.EQ.7) THEN
14598                IPJE = IDHKK(I)-IDCHK*10000
14599                IF (IPJE.NE.IFRG) THEN
14600                   IFRG = IPJE
14601                   IF (IFRG.GT.NFRG) GOTO 16
14602                ENDIF
14603             ELSE
14604                IPJE = 1
14605                IFRG = IFRG+1
14606                IF (IFRG.GT.NFRG) THEN
14607                   NFRG = -1
14608                   GOTO 16
14609                ENDIF
14610             ENDIF
14611 *   statistics counter
14612 c           IF (IDCH(I).LE.8)
14613 c    &         ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
14614 c           IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
14615 * special treatment for small chains already corrected to hadrons
14616             IF (IDRES(I).NE.0) THEN
14617                IF (IDRES(I).EQ.11) THEN
14618                   ID = IDXRES(I)
14619                ELSE
14620                   ID = IDT_IPDGHA(IDXRES(I))
14621                ENDIF
14622                IF (LEMCCK) THEN
14623                   CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
14624      &                              PHKK(4,I),INIEMC,IDUM,IDUM)
14625                   INIEMC = 2
14626                ENDIF
14627                IP = IP+1
14628                IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
14629                P(IP,1) = PHKK(1,I)
14630                P(IP,2) = PHKK(2,I)
14631                P(IP,3) = PHKK(3,I)
14632                P(IP,4) = PHKK(4,I)
14633                P(IP,5) = PHKK(5,I)
14634                K(IP,1) = 1
14635                K(IP,2) = ID
14636                K(IP,3) = 0
14637                K(IP,4) = 0
14638                K(IP,5) = 0
14639                IHIST(2,I) = 10000*IPJE+IP
14640                IF (IHIST(1,I).LE.-100) THEN
14641                   ISH = ISH+1
14642                   IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14643                   ISJOIN(ISH) = I
14644                ENDIF
14645                N = IP
14646                IHISMO(IP) = I
14647             ELSE
14648                IJ  = 0
14649                DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
14650                   IF (LEMCCK) THEN
14651                      CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
14652      &                                   PHKK(4,KK),INIEMC,IDUM,IDUM)
14653                      CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
14654                      INIEMC = 2
14655                   ENDIF
14656                   ID = IDHKK(KK)
14657                   IF (ID.EQ.0) ID = 21
14658 c                  PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
14659 c                  AM0  = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
14660 c                  AMRQ   = PYMASS(ID)
14661 c                  AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
14662 c                  IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
14663 c     &                (ABS(IDIFF).EQ.0)) THEN
14664 cC                    WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
14665 c                     DELTA      = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
14666 c                     PHKK(4,KK) = PHKK(4,KK)+DELTA
14667 c                     PTOT1      = PTOT-DELTA
14668 c                     PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
14669 c                     PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
14670 c                     PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
14671 c                     PHKK(5,KK) = AMRQ
14672 c                  ENDIF
14673                   IP = IP+1
14674                   IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
14675                   P(IP,1) = PHKK(1,KK)
14676                   P(IP,2) = PHKK(2,KK)
14677                   P(IP,3) = PHKK(3,KK)
14678                   P(IP,4) = PHKK(4,KK)
14679                   P(IP,5) = PHKK(5,KK)
14680                   K(IP,1) = 1
14681                   K(IP,2) = ID
14682                   K(IP,3) = 0
14683                   K(IP,4) = 0
14684                   K(IP,5) = 0
14685                   IHIST(2,KK) = 10000*IPJE+IP
14686                   IF (IHIST(1,KK).LE.-100) THEN
14687                      ISH = ISH+1
14688                      IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14689                      ISJOIN(ISH) = KK
14690                   ENDIF
14691                   IJ = IJ+1
14692                   IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
14693                   IJOIN(IJ)  = IP
14694                   IHISMO(IP) = I
14695    11          CONTINUE
14696                N = IP
14697 * join the two-parton system
14698                CALL PYJOIN(IJ,IJOIN)
14699             ENDIF
14700             IDHKK(I) = 99999
14701          ENDIF
14702    10 CONTINUE
14703    16 CONTINUE
14704       N = IP
14705
14706       IF (IP.GT.0) THEN
14707
14708 * final state parton shower
14709          DO 136 NPJE=1,IPJE
14710             IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
14711                IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
14712                   DO 130 K1=1,ISH
14713                      IF (ISJOIN(K1).EQ.0) GOTO 130
14714                      I = ISJOIN(K1)
14715                      IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
14716      &                                                       GOTO 130
14717                      IH1 = IHIST(2,I)/10000
14718                      IF (IH1.NE.NPJE) GOTO 130
14719                      IH1 = IHIST(2,I)-IH1*10000
14720                      DO 135 K2=K1+1,ISH
14721                         IF (ISJOIN(K2).EQ.0) GOTO 135
14722                         II = ISJOIN(K2)
14723                         IH2 = IHIST(2,II)/10000
14724                         IF (IH2.NE.NPJE) GOTO 135
14725                         IH2 = IHIST(2,II)-IH2*10000
14726                         IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
14727                            PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
14728                            PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
14729                            RQLUN = MIN(PT1,PT2)
14730                            CALL PYSHOW(IH1,IH2,RQLUN)
14731
14732                            ISJOIN(K1) = 0
14733                            ISJOIN(K2) = 0
14734                            GOTO 130
14735                         ENDIF
14736  135                 CONTINUE
14737  130              CONTINUE
14738                ENDIF
14739             ENDIF
14740  136     CONTINUE
14741
14742          CALL DT_INITJS(MODE)
14743 * hadronization
14744
14745          CALL PYEXEC
14746
14747          IF (MSTU(24).NE.0) THEN
14748             WRITE(LOUT,*) ' JETSET-reject at event',
14749      &                    NEVHKK,MSTU(24),KMODE
14750 C           CALL DT_EVTOUT(4)
14751
14752 C           CALL PYLIST(2)
14753
14754             GOTO 9999
14755          ENDIF
14756
14757 *   number of entries in LUJETS
14758
14759          NLINES = PYK(0,1)
14760
14761          NPYMEM = NLINES
14762
14763          DO 12 I=1,NLINES
14764             IFLG(I) = 0
14765    12    CONTINUE
14766
14767          DO 13 II=1,NLINES
14768
14769             IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
14770
14771 *  pick up mother resonance if possible and put it together with
14772 *  their decay-products into the common
14773                IDXMOR = K(II,3)
14774                IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
14775                   KFMOR = K(IDXMOR,2)
14776                   ISMOR = K(IDXMOR,1)
14777                ELSE
14778                   KFMOR = 91
14779                   ISMOR = 1
14780                ENDIF
14781                IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
14782      &             (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
14783                   ID = K(IDXMOR,2)
14784                   MO = IHISMO(PYK(IDXMOR,15))
14785                   PX = PYP(IDXMOR,1)
14786                   PY = PYP(IDXMOR,2)
14787                   PZ = PYP(IDXMOR,3)
14788                   PE = PYP(IDXMOR,4)
14789                   CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14790                   IFLG(IDXMOR) = 1
14791                   MO = NHKK
14792                   DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
14793                      IF (PYK(JDAUG,7).EQ.1) THEN
14794                         ID = PYK(JDAUG,8)
14795                         PX = PYP(JDAUG,1)
14796                         PY = PYP(JDAUG,2)
14797                         PZ = PYP(JDAUG,3)
14798                         PE = PYP(JDAUG,4)
14799                         CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14800                         IF (LEMCCK) THEN
14801                            PX = -PYP(JDAUG,1)
14802                            PY = -PYP(JDAUG,2)
14803                            PZ = -PYP(JDAUG,3)
14804                            PE = -PYP(JDAUG,4)
14805                            CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14806                         ENDIF
14807                         IFLG(JDAUG) = 1
14808                      ENDIF
14809    15             CONTINUE
14810                ELSE
14811 *  there was no mother resonance
14812                   MO = IHISMO(PYK(II,15))
14813                   ID = PYK(II,8)
14814                   PX = PYP(II,1)
14815                   PY = PYP(II,2)
14816                   PZ = PYP(II,3)
14817                   PE = PYP(II,4)
14818                   CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14819                   IF (LEMCCK) THEN
14820                      PX = -PYP(II,1)
14821                      PY = -PYP(II,2)
14822                      PZ = -PYP(II,3)
14823                      PE = -PYP(II,4)
14824                      CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14825                   ENDIF
14826                ENDIF
14827             ENDIF
14828    13    CONTINUE
14829          IF (LEMCCK) THEN
14830             CHKLEV = TINY1
14831             CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
14832 C           IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
14833          ENDIF
14834
14835 * global energy-momentum & flavor conservation check
14836 **sr 16.5. this check is skipped in case of phojet-treatment
14837          IF (MCGENE.EQ.1)
14838      &      CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
14839
14840 * update statistics-counter for diffraction
14841 c        IF (IFLAGD.NE.0) THEN
14842 c           ICDIFF(1) = ICDIFF(1)+1
14843 c           IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
14844 c           IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
14845 c           IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
14846 c           IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
14847 c        ENDIF
14848
14849       ENDIF
14850
14851       RETURN
14852
14853  9999 CONTINUE
14854       IREJ = 1
14855       RETURN
14856       END
14857
14858 *$ CREATE DT_DECAYS.FOR
14859 *COPY DT_DECAYS
14860 *
14861 *===decay==============================================================*
14862 *
14863       SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
14864
14865 ************************************************************************
14866 * Resonance-decay.                                                     *
14867 * This subroutine replaces DDECAY/DECHKK.                              *
14868 *             PIN(4)      4-momentum of resonance          (input)     *
14869 *             IDXIN       BAMJET-index of resonance        (input)     *
14870 *             POUT(20,4)  4-momenta of decay-products      (output)    *
14871 *             IDXOUT(20)  BAMJET-indices of decay-products (output)    *
14872 *             NSEC        number of secondaries            (output)    *
14873 * Adopted from the original version DECHKK.                            *
14874 * This version dated 09.01.95 is written by S. Roesler                 *
14875 ************************************************************************
14876
14877       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14878       SAVE
14879       PARAMETER ( LINP = 10 ,
14880      &            LOUT = 6 ,
14881      &            LDAT = 9 )
14882       PARAMETER (TINY17=1.0D-17)
14883
14884 * HADRIN: decay channel information
14885       PARAMETER (IDMAX9=602)
14886       CHARACTER*8 ZKNAME
14887       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
14888 * particle properties (BAMJET index convention)
14889       CHARACTER*8  ANAME
14890       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14891      &                IICH(210),IIBAR(210),K1(210),K2(210)
14892 * flags for input different options
14893       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14894       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14895      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14896
14897       DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
14898      &          EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
14899      &          CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
14900
14901 * ISTAB = 1 strong and weak decays
14902 *       = 2 strong decays only
14903 *       = 3 strong decays, weak decays for charmed particles and tau
14904 *           leptons only
14905       DATA ISTAB /2/
14906
14907       IREJ = 0
14908       NSEC = 0
14909 * put initial resonance to stack
14910       NSTK = 1
14911       IDXSTK(NSTK) = IDXIN
14912       DO 5 I=1,4
14913          PI(NSTK,I) = PIN(I)
14914     5 CONTINUE
14915
14916 * store initial configuration for energy-momentum cons. check
14917       IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
14918      &                                   PI(NSTK,4),1,IDUM,IDUM)
14919
14920   100 CONTINUE
14921 * get particle from stack
14922       IDXI = IDXSTK(NSTK)
14923 * skip stable particles
14924       IF (ISTAB.EQ.1) THEN
14925          IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
14926          IF ((IDXI.GE.  1).AND.(IDXI.LE.  7)) GOTO 10
14927       ELSEIF (ISTAB.EQ.2) THEN
14928          IF ((IDXI.GE.  1).AND.(IDXI.LE. 30)) GOTO 10
14929          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14930          IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
14931          IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
14932          IF ( IDXI.EQ.109)                    GOTO 10
14933          IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
14934       ELSEIF (ISTAB.EQ.3) THEN
14935          IF ((IDXI.GE.  1).AND.(IDXI.LE. 23)) GOTO 10
14936          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14937          IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
14938          IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
14939       ENDIF
14940
14941 * calculate direction cosines and Lorentz-parameter of decaying part.
14942       PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
14943       PTOT = MAX(PTOT,TINY17)
14944       DO 1 I=1,3
14945          DCOS(I) = PI(NSTK,I)/PTOT
14946     1 CONTINUE
14947       GAM  = PI(NSTK,4)/AAM(IDXI)
14948       BGAM = PTOT/AAM(IDXI)
14949
14950 * get decay-channel
14951       KCHAN = K1(IDXI)-1
14952     2 CONTINUE
14953       KCHAN = KCHAN+1
14954       IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
14955
14956 * identities of secondaries
14957       IDX(1) = NZK(KCHAN,1)
14958       IDX(2) = NZK(KCHAN,2)
14959       IF (IDX(2).LT.1) GOTO 9999
14960       IDX(3) = NZK(KCHAN,3)
14961
14962 * handle decay in rest system of decaying particle
14963       IF (IDX(3).EQ.0) THEN
14964 *   two-particle decay
14965          NDEC = 2
14966          CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
14967      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
14968      &               AAM(IDX(1)),AAM(IDX(2)))
14969       ELSE
14970 *   three-particle decay
14971          NDEC = 3
14972          CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
14973      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
14974      &               CODF(3),COFF(3),SIFF(3),
14975      &               AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
14976       ENDIF
14977       NSTK = NSTK-1
14978
14979 * transform decay products back
14980       DO 3 I=1,NDEC
14981          NSTK = NSTK+1
14982          CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
14983      &               CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
14984      &               PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
14985 * add particle to stack
14986          IDXSTK(NSTK) = IDX(I)
14987          DO 4 J=1,3
14988             PI(NSTK,J) = DCOSF(J)*PFF(I)
14989     4    CONTINUE
14990     3 CONTINUE
14991       GOTO 100
14992
14993    10 CONTINUE
14994 * stable particle, put to output-arrays
14995       NSEC = NSEC+1
14996       DO 6 I=1,4
14997          POUT(NSEC,I) = PI(NSTK,I)
14998     6 CONTINUE
14999       IDXOUT(NSEC) = IDXSTK(NSTK)
15000 * store secondaries for energy-momentum conservation check
15001       IF (LEMCCK)
15002      &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15003      &            -POUT(NSEC,4),2,IDUM,IDUM)
15004       NSTK = NSTK-1
15005       IF (NSTK.GT.0) GOTO 100
15006
15007 * check energy-momentum conservation
15008       IF (LEMCCK) THEN
15009          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15010          IF (IREJ1.NE.0) GOTO 9999
15011       ENDIF
15012
15013       RETURN
15014
15015  9999 CONTINUE
15016       IREJ = 1
15017       RETURN
15018       END
15019
15020 *$ CREATE DT_DECAY1.FOR
15021 *COPY DT_DECAY1
15022 *
15023 *===decay1=============================================================*
15024 *
15025       SUBROUTINE DT_DECAY1
15026
15027 ************************************************************************
15028 * Decay of resonances stored in DTEVT1.                                *
15029 * This version dated 20.01.95 is written by S. Roesler                 *
15030 ************************************************************************
15031
15032       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15033       SAVE
15034       PARAMETER ( LINP = 10 ,
15035      &            LOUT = 6 ,
15036      &            LDAT = 9 )
15037
15038 * event history
15039       PARAMETER (NMXHKK=200000)
15040       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15041      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15042      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15043 * extended event history
15044       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15045      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15046      &                IHIST(2,NMXHKK)
15047
15048       DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15049
15050       NEND = NHKK
15051 C     DO 1 I=NPOINT(5),NEND
15052       DO 1 I=NPOINT(4),NEND
15053          IF (ABS(ISTHKK(I)).EQ.1) THEN
15054             DO 2 K=1,4
15055                PIN(K) = PHKK(K,I)
15056     2       CONTINUE
15057             IDXIN = IDBAM(I)
15058             CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15059             IF (NSEC.GT.1) THEN
15060                DO 3 N=1,NSEC
15061                   IDHAD = IDT_IPDGHA(IDXOUT(N))
15062                   CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15063      &                               POUT(N,3),POUT(N,4),0,0,0)
15064     3          CONTINUE
15065             ENDIF
15066          ENDIF
15067     1 CONTINUE
15068
15069       RETURN
15070       END
15071
15072 *$ CREATE DT_DECPI0.FOR
15073 *COPY DT_DECPI0
15074 *
15075 *===decpi0=============================================================*
15076 *
15077       SUBROUTINE DT_DECPI0
15078
15079 ************************************************************************
15080 * Decay of pi0 handled with JETSET.                                    *
15081 * This version dated 18.02.96 is written by S. Roesler                 *
15082 ************************************************************************
15083
15084       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15085       SAVE
15086       PARAMETER ( LINP = 10 ,
15087      &            LOUT = 6 ,
15088      &            LDAT = 9 )
15089       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15090
15091 * event history
15092       PARAMETER (NMXHKK=200000)
15093       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15094      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15095      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15096 * extended event history
15097       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15098      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15099      &                IHIST(2,NMXHKK)
15100       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15101       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15102       PARAMETER (MAXLND=4000)
15103       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15104 * flags for input different options
15105       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15106       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15107      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15108
15109       INTEGER PYCOMP,PYK
15110
15111       DIMENSION IHISMO(NMXHKK),P1(4)
15112
15113       TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15114
15115       CALL DT_INITJS(2)
15116 * allow pi0 decay
15117       KC = PYCOMP(111)
15118       MDCY(KC,1) = 1
15119
15120       NN  = 0
15121       INI = 0
15122       DO 1 I=1,NHKK
15123          IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15124             IF (INI.EQ.0) THEN
15125                INI = 1
15126             ELSE
15127                INI = 2
15128             ENDIF
15129             IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15130      &                                    PHKK(4,I),INI,IDUM,IDUM)
15131             PT    = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15132             PTOT  = SQRT(PT**2+PHKK(3,I)**2)
15133             COSTH = PHKK(3,I)/(PTOT+TINY10)
15134             IF (COSTH.GT.ONE) THEN
15135                THETA = ZERO
15136             ELSEIF (COSTH.LT.-ONE) THEN
15137                THETA = TWOPI/2.0D0
15138             ELSE
15139                THETA = ACOS(COSTH)
15140             ENDIF
15141             PHI     = ASIN(PHKK(2,I)/(PT  +TINY10))
15142             IF (PHKK(1,I).LT.0.0D0)
15143      &         PHI  = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15144             ENER    = PHKK(4,I)
15145             NN      = NN+1
15146             KTEMP   = MSTU(10)
15147             MSTU(10)= 1
15148             P(NN,5) = PHKK(5,I)
15149             CALL PY1ENT(NN,111,ENER,THETA,PHI)
15150             MSTU(10)  = KTEMP
15151             IHISMO(NN)= I
15152          ENDIF
15153     1 CONTINUE
15154       IF (NN.GT.0) THEN
15155          CALL PYEXEC
15156          NLINES = PYK(0,1)
15157          DO 2 II=1,NLINES
15158             IF (PYK(II,7).EQ.1) THEN
15159                DO 3 KK=1,4
15160                   P1(KK) = PYP(II,KK)
15161     3          CONTINUE
15162                ID = PYK(II,8)
15163                MO = IHISMO(PYK(II,15))
15164                CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15165                IF (LEMCCK)
15166      &            CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15167      &                                            IDUM,IDUM)
15168 *sr: flag with neg. sign (for HELIOS p/A-W jobs)
15169                ISTHKK(MO) = -2
15170             ENDIF
15171     2    CONTINUE
15172          IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15173       ENDIF
15174       MDCY(KC,1) = 0
15175
15176       RETURN
15177       END
15178
15179 *$ CREATE DT_DTWOPD.FOR
15180 *COPY DT_DTWOPD
15181 *
15182 *===dtwopd=============================================================*
15183 *
15184       SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15185      &                                            COF2,SIF2,AM1,AM2)
15186
15187 ************************************************************************
15188 * Two-particle decay.                                                  *
15189 *  UMO                 cm-energy of the decaying system       (input)  *
15190 *  AM1/AM2             masses of the decay products           (input)  *
15191 *  ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15192 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15193 * Revised by S. Roesler, 20.11.95                                      *
15194 ************************************************************************
15195
15196       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15197       SAVE
15198       PARAMETER ( LINP = 10 ,
15199      &            LOUT = 6 ,
15200      &            LDAT = 9 )
15201       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15202
15203       IF (UMO.LT.(AM1+AM2)) THEN
15204          WRITE(LOUT,1000) UMO,AM1,AM2
15205  1000    FORMAT(1X,'DTWOPD:    inconsistent kinematics - UMO,AM1,AM2 ',
15206      &          3E12.3)
15207          STOP
15208       ENDIF
15209
15210       ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15211       ECM2 = UMO-ECM1
15212       PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15213       PCM2 = PCM1
15214       CALL DT_DSFECF(SIF1,COF1)
15215       COD1 = TWO*DT_RNDM(PCM2)-ONE
15216       COD2 = -COD1
15217       COF2 = -COF1
15218       SIF2 = -SIF1
15219
15220       RETURN
15221       END
15222
15223 *$ CREATE DT_DTHREP.FOR
15224 *COPY DT_DTHREP
15225 *
15226 *===dthrep=============================================================*
15227 *
15228       SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15229      &                  SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15230
15231 ************************************************************************
15232 * Three-particle decay.                                                *
15233 *  UMO                 cm-energy of the decaying system       (input)  *
15234 *  AM1/2/3             masses of the decay products           (input)  *
15235 *  ECM1/2/2,PCM1/2/3   cm-energies/momenta of the decay prod. (output) *
15236 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15237 *                                                                      *
15238 * Threpd89: slight revision by A. Ferrari                              *
15239 * Last change on   11-oct-93   by    Alfredo Ferrari, INFN - Milan     *
15240 * Revised by S. Roesler, 20.11.95                                      *
15241 ************************************************************************
15242
15243       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15244       SAVE
15245       PARAMETER ( LINP = 10 ,
15246      &            LOUT = 6 ,
15247      &            LDAT = 9 )
15248
15249       PARAMETER ( ANGLSQ = 2.5D-31 )
15250       PARAMETER ( AZRZRZ = 1.0D-30 )
15251       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
15252       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
15253       PARAMETER ( ONEONE = 1.D+00 )
15254       PARAMETER ( TWOTWO = 2.D+00 )
15255       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15256
15257       COMMON /HNGAMR/ REDU,AMO,AMM(15)
15258 * flags for input different options
15259       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15260       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15261      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15262
15263       DIMENSION F(5),XX(5)
15264       DATA EPS /AZRZRZ/
15265
15266       UMOO=UMO+UMO
15267 C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
15268 C***J. VON NEUMANN - RANDOM - SELECTION OF S2
15269 C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
15270       UUMO=UMO
15271       AAM1=AM1
15272       AAM2=AM2
15273       AAM3=AM3
15274       GU=(AM2+AM3)**2
15275       GO=(UMO-AM1)**2
15276 *     UFAK=1.0000000000001D0
15277 *     IF (GU.GT.GO) UFAK=0.9999999999999D0
15278       IF (GU.GT.GO) THEN
15279          UFAK=ONEMNS
15280       ELSE
15281          UFAK=ONEPLS
15282       END IF
15283       OFAK=2.D0-UFAK
15284       GU=GU*UFAK
15285       GO=GO*OFAK
15286       DS2=(GO-GU)/99.D0
15287       AM11=AM1*AM1
15288       AM22=AM2*AM2
15289       AM33=AM3*AM3
15290       UMO2=UMO*UMO
15291       RHO2=0.D0
15292       S22=GU
15293       DO 124 I=1,100
15294          S21=S22
15295          S22=GU+(I-1.D0)*DS2
15296          RHO1=RHO2
15297          RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
15298      *                                             (S22+EPS)
15299          IF(RHO2.LT.RHO1) GO TO 125
15300   124 CONTINUE
15301   125 S2SUP=(S22-S21)*.5D0+S21
15302       SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
15303      *                                           (S2SUP+EPS)
15304       SUPRHO=SUPRHO*1.05D0
15305       XO=S21-DS2
15306       IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
15307       IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
15308       XX(1)=XO
15309       XX(3)=S22
15310       X1=(XO+S22)*0.5D0
15311       XX(2)=X1
15312       F(3)=RHO2
15313       F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
15314       F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
15315       DO 126 I=1,16
15316          X4=(XX(1)+XX(2))*0.5D0
15317          X5=(XX(2)+XX(3))*0.5D0
15318          F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
15319      *                                               (X4+EPS)
15320          F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
15321      *                                               (X5+EPS)
15322          XX(4)=X4
15323          XX(5)=X5
15324          DO 128 II=1,5
15325             IA=II
15326             DO 128 III=IA,5
15327                IF (F (II).GE.F (III)) GO TO 128
15328                FH=F(II)
15329                F(II)=F(III)
15330                F(III)=FH
15331                FH=XX(II)
15332                XX(II)=XX(III)
15333                XX(III)=FH
15334 128      CONTINUE
15335          SUPRHO=F(1)
15336          S2SUP=XX(1)
15337          DO 129 II=1,3
15338             IA=II
15339             DO 129 III=IA,3
15340                IF (XX(II).GE.XX(III)) GO TO 129
15341                FH=F(II)
15342                F(II)=F(III)
15343                F(III)=FH
15344                FH=XX(II)
15345                XX(II)=XX(III)
15346                XX(III)=FH
15347 129      CONTINUE
15348 126   CONTINUE
15349       AM23=(AM2+AM3)**2
15350       ITH=0
15351       REDU=2.D0
15352     1 CONTINUE
15353       ITH=ITH+1
15354       IF (ITH.GT.200) REDU=-9.D0
15355       IF (ITH.GT.200) GO TO 400
15356       C=DT_RNDM(REDU)
15357 *     S2=AM23+C*((UMO-AM1)**2-AM23)
15358       S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
15359       Y=DT_RNDM(S2)
15360       Y=Y*SUPRHO
15361       RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
15362       IF(Y.GT.RHO) GO TO 1
15363 C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
15364       S1=DT_RNDM(S2)
15365       S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
15366      &RHO*.5D0
15367       S3=UMO2+AM11+AM22+AM33-S1-S2
15368       ECM1=(UMO2+AM11-S2)/UMOO
15369       ECM2=(UMO2+AM22-S3)/UMOO
15370       ECM3=(UMO2+AM33-S1)/UMOO
15371       PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
15372       PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
15373       PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
15374       CALL DT_DSFECF(SFE,CFE)
15375 C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
15376 C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
15377       PCM12 = PCM1 * PCM2
15378       IF ( PCM12 .LT. ANGLSQ ) GO TO 200
15379       COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
15380       GO TO 300
15381  200  CONTINUE
15382          UW=DT_RNDM(S1)
15383          COSTH=(UW-0.5D+00)*2.D+00
15384  300  CONTINUE
15385 *     IF(ABS(COSTH).GT.0.9999999999999999D0)
15386 *    &COSTH=SIGN(0.9999999999999999D0,COSTH)
15387       IF(ABS(COSTH).GT.ONEONE)
15388      &COSTH=SIGN(ONEONE,COSTH)
15389       IF (REDU.LT.1.D+00) RETURN
15390       COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
15391 *     IF(ABS(COSTH2).GT.0.9999999999999999D0)
15392 *    &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
15393       IF(ABS(COSTH2).GT.ONEONE)
15394      &COSTH2=SIGN(ONEONE,COSTH2)
15395       SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
15396       SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
15397       SINTH1=COSTH2*SINTH-COSTH*SINTH2
15398       COSTH1=COSTH*COSTH2+SINTH2*SINTH
15399 C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
15400 C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
15401 C***THE DIRECTION OF PARTICLE 3
15402 C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
15403       CX11=-COSTH1
15404       CY11=SINTH1*CFE
15405       CZ11=SINTH1*SFE
15406       CX22=-COSTH2
15407       CY22=-SINTH2*CFE
15408       CZ22=-SINTH2*SFE
15409       CALL DT_DSFECF(SIF3,COF3)
15410       COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
15411       SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
15412     2 FORMAT(5F20.15)
15413       COD1=CX11*COD3+CZ11*SID3
15414       CHLP=(ONEONE-COD1)*(ONEONE+COD1)
15415       IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
15416      &CX11,CZ11
15417       SID1=SQRT(CHLP)
15418       COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
15419       SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
15420       COD2=CX22*COD3+CZ22*SID3
15421       SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
15422       COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
15423       SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
15424  400  CONTINUE
15425 * === Energy conservation check: === *
15426       EOCHCK = UMO - ECM1 - ECM2 - ECM3
15427 *     SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
15428 *     SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
15429 *     SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
15430       PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
15431       PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
15432      &       + PCM3 * COF3 * SID3
15433       PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
15434      &       + PCM3 * SIF3 * SID3
15435       EOCMPR = 1.D-12 * UMO
15436       IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
15437      &     .GT. EOCMPR ) THEN
15438 **sr 5.5.95 output-unit changed
15439          IF (IOULEV(1).GT.0) THEN
15440             WRITE(LOUT,*)
15441      &      ' *** Threpd: energy/momentum conservation failure! ***',
15442      &      EOCHCK,PXCHCK,PYCHCK,PZCHCK
15443             WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
15444          ENDIF
15445 **
15446       END IF
15447       RETURN
15448       END
15449
15450 *$ CREATE DT_DBKLAS.FOR
15451 *COPY DT_DBKLAS
15452 *
15453 *===dbklas=============================================================*
15454 *
15455       SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
15456
15457       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15458       SAVE
15459       PARAMETER ( LINP = 10 ,
15460      &            LOUT = 6 ,
15461      &            LDAT = 9 )
15462
15463 * quark-content to particle index conversion (DTUNUC 1.x)
15464       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15465      &                IA08(6,21),IA10(6,21)
15466
15467       IF (I) 20,20,10
15468 * baryons
15469    10 CONTINUE
15470       CALL DT_INDEXD(J,K,IND)
15471       I8  = IB08(I,IND)
15472       I10 = IB10(I,IND)
15473       IF (I8.LE.0) I8 = I10
15474       RETURN
15475 * antibaryons
15476    20 CONTINUE
15477       II = IABS(I)
15478       JJ = IABS(J)
15479       KK = IABS(K)
15480       CALL DT_INDEXD(JJ,KK,IND)
15481       I8  = IA08(II,IND)
15482       I10 = IA10(II,IND)
15483       IF (I8.LE.0) I8 = I10
15484
15485       RETURN
15486       END
15487
15488 *$ CREATE DT_INDEXD.FOR
15489 *COPY DT_INDEXD
15490 *
15491 *===indexd=============================================================*
15492 *
15493       SUBROUTINE DT_INDEXD(KA,KB,IND)
15494
15495       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15496       SAVE
15497       PARAMETER ( LINP = 10 ,
15498      &            LOUT = 6 ,
15499      &            LDAT = 9 )
15500
15501       KP = KA*KB
15502       KS = KA+KB
15503       IF (KP.EQ.1) IND=1
15504       IF (KP.EQ.2) IND=2
15505       IF (KP.EQ.3) IND=3
15506       IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
15507       IF (KP.EQ.5) IND=5
15508       IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
15509       IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
15510       IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
15511       IF (KP.EQ.8)  IND=9
15512       IF (KP.EQ.10) IND=10
15513       IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
15514       IF (KP.EQ.9)  IND=12
15515       IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
15516       IF (KP.EQ.15) IND=14
15517       IF (KP.EQ.18) IND=15
15518       IF (KP.EQ.16) IND=16
15519       IF (KP.EQ.20) IND=17
15520       IF (KP.EQ.24) IND=18
15521       IF (KP.EQ.25) IND=19
15522       IF (KP.EQ.30) IND=20
15523       IF (KP.EQ.36) IND=21
15524
15525       RETURN
15526       END
15527
15528 *$ CREATE DT_DCHANT.FOR
15529 *COPY DT_DCHANT
15530 *
15531 *===dchant=============================================================*
15532 *
15533       SUBROUTINE DT_DCHANT
15534
15535       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15536       SAVE
15537       PARAMETER ( LINP = 10 ,
15538      &            LOUT = 6 ,
15539      &            LDAT = 9 )
15540       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15541
15542 * HADRIN: decay channel information
15543       PARAMETER (IDMAX9=602)
15544       CHARACTER*8 ZKNAME
15545       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15546 * particle properties (BAMJET index convention)
15547       CHARACTER*8  ANAME
15548       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15549      &                IICH(210),IIBAR(210),K1(210),K2(210)
15550
15551       DIMENSION HWT(IDMAX9)
15552
15553 * change of weights wt from absolut values into the sum of wt of a dec.
15554       DO 10 J=1,IDMAX9
15555          HWT(J) = ZERO
15556    10 CONTINUE
15557 C     DO 999 KKK=1,210
15558 C        WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
15559 C    &      ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
15560 C    &      K1(KKK),K2(KKK)
15561 C 999 CONTINUE
15562 C     STOP
15563       DO 30 I=1,210
15564          IK1 = K1(I)
15565          IK2 = K2(I)
15566          HV  = ZERO
15567          DO 20 J=IK1,IK2
15568             HV     = HV+WT(J)
15569             HWT(J) = HV
15570 **sr 13.1.95
15571             IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
15572  1000       FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
15573    20    CONTINUE
15574    30 CONTINUE
15575       DO 40 J=1,IDMAX9
15576          WT(J) = HWT(J)
15577    40 CONTINUE
15578
15579       RETURN
15580       END
15581
15582 *$ CREATE DT_DDATAR.FOR
15583 *COPY DT_DDATAR
15584 *
15585 *===ddatar=============================================================*
15586 *
15587       SUBROUTINE DT_DDATAR
15588
15589       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15590       SAVE
15591       PARAMETER ( LINP = 10 ,
15592      &            LOUT = 6 ,
15593      &            LDAT = 9 )
15594       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15595
15596 * quark-content to particle index conversion (DTUNUC 1.x)
15597       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15598      &                IA08(6,21),IA10(6,21)
15599
15600       DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
15601
15602       DATA IV/ 33, 34, 38,123,  0,  0, 32, 33, 39,124,
15603      &          0,  0, 36, 37, 96,127,  0,  0,126,125,
15604      &        128,129,14*0/
15605       DATA IP/ 23, 14, 16,116,  0,  0, 13, 23, 25,117,
15606      &          0,  0, 15, 24, 31,120,  0,  0,119,118,
15607      &        121,122,14*0/
15608       DATA IB/  0,  1, 21,140,  0,  0,  8, 22,137,  0,
15609      &          0, 97,138,  0,  0,146,  0,  0,  0,  0,
15610      &          0,  1,  8, 22,137,  0,  0,  0, 20,142,
15611      &          0,  0, 98,139,  0,  0,147,  0,  0,  0,
15612      &          0,  0, 21, 22, 97,138,  0,  0, 20, 98,
15613      &        139,  0,  0,  0,145,  0,  0,148,  0,  0,
15614      &          0,  0,  0,140,137,138,146,  0,  0,142,
15615      &        139,147,  0,  0,145,148,           50*0/
15616       DATA IBB/53, 54,104,161,  0,  0, 55,105,162,  0,
15617      &          0,107,164,  0,  0,167,  0,  0,  0,  0,
15618      &          0, 54, 55,105,162,  0,  0, 56,106,163,
15619      &          0,  0,108,165,  0,  0,168,  0,  0,  0,
15620      &          0,  0,104,105,107,164,  0,  0,106,108,
15621      &        165,  0,  0,109,166,  0,  0,169,  0,  0,
15622      &          0,  0,  0,161,162,164,167,  0,  0,163,
15623      &        165,168,  0,  0,166,169,  0,  0,170,47*0/
15624       DATA IA/  0,  2, 99,152,  0,  0,  9,100,149,  0,
15625      &          0,102,150,  0,  0,158,  0,  0,  0,  0,
15626      &          0,  2,  9,100,149,  0,  0,  0,101,154,
15627      &          0,  0,103,151,  0,  0,159,  0,  0,  0,
15628      &          0,  0, 99,100,102,150,  0,  0,101,103,
15629      &        151,  0,  0,  0,157,  0,  0,160,  0,  0,
15630      &          0,  0,  0,152,149,150,158,  0,  0,154,
15631      &        151,159,  0,  0,157,160,           50*0/
15632       DATA IAA/67, 68,110,171,  0,  0, 69,111,172,  0,
15633      &          0,113,174,  0,  0,177,  0,  0,  0,  0,
15634      &          0, 68, 69,111,172,  0,  0, 70,112,173,
15635      &          0,  0,114,175,  0,  0,178,  0,  0,  0,
15636      &          0,  0,110,111,113,174,  0,  0,112,114,
15637      &        175,  0,  0,115,176,  0,  0,179,  0,  0,
15638      &          0,  0,  0,171,172,174,177,  0,  0,173,
15639      &        175,178,  0,  0,176,179,  0,  0,180,47*0/
15640
15641       L=0
15642       DO 2 I=1,6
15643          DO 1 J=1,6
15644             L = L+1
15645             IMPS(I,J) = IP(L)
15646             IMVE(I,J) = IV(L)
15647     1    CONTINUE
15648     2 CONTINUE
15649       L=0
15650       DO 4 I=1,6
15651          DO 3 J=1,21
15652             L = L+1
15653             IB08(I,J) = IB(L)
15654             IB10(I,J) = IBB(L)
15655             IA08(I,J) = IA(L)
15656             IA10(I,J) = IAA(L)
15657     3    CONTINUE
15658     4 CONTINUE
15659 C     A1  = 0.88D0
15660 C     B1  = 3.0D0
15661 C     B2  = 3.0D0
15662 C     B3  = 8.0D0
15663 C     LT  = 0
15664 C     LB  = 0
15665 C     BET = 12.0D0
15666 C     AS  = 0.25D0
15667 C     B8  = 0.33D0
15668 C     AME = 0.95D0
15669 C     DIQ = 0.375D0
15670 C     ISU = 4
15671
15672       RETURN
15673       END
15674
15675 *$ CREATE DT_INITJS.FOR
15676 *COPY DT_INITJS
15677 *
15678 *===initjs=============================================================*
15679 *
15680       SUBROUTINE DT_INITJS(MODE)
15681
15682 ************************************************************************
15683 * Initialize JETSET paramters.                                         *
15684 *           MODE = 0 default settings                                  *
15685 *                = 1 PHOJET settings                                   *
15686 *                = 2 DTUNUC settings                                   *
15687 * This version dated 16.02.96 is written by S. Roesler                 *
15688 *                                                                      *
15689 * Last change 27.12.2006 by S. Roesler.                                *
15690 ************************************************************************
15691
15692       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15693       SAVE
15694       PARAMETER ( LINP = 10 ,
15695      &            LOUT = 6 ,
15696      &            LDAT = 9 )
15697       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15698
15699       LOGICAL LFIRST,LFIRDT,LFIRPH
15700
15701       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15702       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15703       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15704 * flags for particle decays
15705       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
15706      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
15707      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
15708 * flags for input different options
15709       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15710       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15711      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15712
15713       INTEGER PYCOMP
15714
15715       DIMENSION IDXSTA(40)
15716       DATA IDXSTA
15717 *          K0s   pi0  lam   alam  sig+  asig+ sig-  asig- tet0  atet0
15718      &  /  310,  111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
15719 *          tet- atet-  om-  aom-   D+    D-    D0    aD0   Ds+   aDs+
15720      &    3312,-3312, 3334,-3334,  411, -411,  421, -421,  431, -431,
15721 *          etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
15722      &     441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
15723 *         Ksic0 aKsic+aKsic0 sig0 asig0
15724      &    4132,-4232,-4132, 3212,-3212, 5*0/
15725
15726       DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
15727
15728       IF (LFIRST) THEN
15729 * save default settings
15730          PDEF1  = PARJ(1)
15731          PDEF2  = PARJ(2)
15732          PDEF3  = PARJ(3)
15733          PDEF5  = PARJ(5)
15734          PDEF6  = PARJ(6)
15735          PDEF7  = PARJ(7)
15736          PDEF18 = PARJ(18)
15737          PDEF19 = PARJ(19)
15738          PDEF21 = PARJ(21)
15739          PDEF42 = PARJ(42)
15740          MDEF12 = MSTJ(12)
15741 * LUJETS / PYJETS array-dimensions
15742          MSTU(4) = 4000
15743 * increase maximum number of JETSET-error prints
15744          MSTU(22) = 50000
15745 * prevent particles decaying
15746          DO 1 I=1,35
15747             IF (I.LT.34) THEN
15748                KC = PYCOMP(IDXSTA(I))
15749                IF (KC.GT.0) THEN
15750                   IF (I.EQ.2) THEN
15751 *  pi0 decay
15752 C                    MDCY(KC,1) = 1
15753                      MDCY(KC,1) = 0
15754 **cr mode
15755 C                 ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
15756 C   &                    (I.EQ.8).OR.(I.EQ.10)) THEN
15757 C                 ELSEIF (I.EQ.4) THEN
15758 C                    MDCY(KC,1) = 1
15759 **
15760                   ELSE
15761 C AM                     MDCY(KC,1) = 0
15762                   ENDIF
15763                ENDIF
15764             ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
15765                KC = PYCOMP(IDXSTA(I))
15766                IF (KC.GT.0) THEN
15767 C AM                 MDCY(KC,1) = 0
15768                ENDIF
15769             ENDIF
15770     1    CONTINUE
15771 *
15772 *
15773 * popcorn:
15774          IF (PDB.LE.ZERO) THEN
15775 *   no popcorn-mechanism
15776             MSTJ(12) = 1
15777          ELSE
15778             MSTJ(12) = 3
15779             PARJ(5)  = PDB
15780          ENDIF
15781 * set JETSET-parameter requested by input cards
15782          IF (NMSTU.GT.0) THEN
15783             DO 2 I=1,NMSTU
15784                MSTU(IMSTU(I)) = MSTUX(I)
15785     2       CONTINUE
15786          ENDIF
15787          IF (NMSTJ.GT.0) THEN
15788             DO 3 I=1,NMSTJ
15789                MSTJ(IMSTJ(I)) = MSTJX(I)
15790     3       CONTINUE
15791          ENDIF
15792          IF (NPARU.GT.0) THEN
15793             DO 4 I=1,NPARU
15794                PARU(IPARU(I)) = PARUX(I)
15795     4       CONTINUE
15796          ENDIF
15797          LFIRST = .FALSE.
15798       ENDIF
15799 *
15800 * PARJ(1)  suppression of qq-aqaq pair prod. compared to
15801 *          q-aq pair prod.                      (default: 0.1)
15802 * PARJ(2)  strangeness suppression               (default: 0.3)
15803 * PARJ(3)  extra suppression of strange diquarks (default: 0.4)
15804 * PARJ(6)  extra suppression of sas-pair shared by B and
15805 *          aB in BMaB                           (default: 0.5)
15806 * PARJ(7)  extra suppression of strange meson M in BMaB
15807 *          configuration                        (default: 0.5)
15808 * PARJ(18) spin 3/2 baryon suppression           (default: 1.0)
15809 * PARJ(21) width sigma in Gaussian p_x, p_y transverse
15810 *          momentum distrib. for prim. hadrons  (default: 0.35)
15811 * PARJ(42) b-parameter for symmetric Lund-fragmentation
15812 *          function                             (default: 0.9 GeV^-2)
15813 *
15814 * PHOJET settings
15815       IF (MODE.EQ.1) THEN
15816 *   JETSET default
15817 C        PARJ(1)  = PDEF1
15818 C        PARJ(2)  = PDEF2
15819 C        PARJ(3)  = PDEF3
15820 C        PARJ(6)  = PDEF6
15821 C        PARJ(7)  = PDEF7
15822 C        PARJ(18) = PDEF18
15823 C        PARJ(21) = PDEF21
15824 C        PARJ(42) = PDEF42
15825 **sr 18.11.98 parameter tuning
15826 C        PARJ(1)  = 0.092D0
15827 C        PARJ(2)  = 0.25D0
15828 C        PARJ(3)  = 0.45D0
15829 C        PARJ(19) = 0.3D0
15830 C        PARJ(21) = 0.45D0
15831 C        PARJ(42) = 1.0D0
15832 **sr 28.04.99 parameter tuning (May 99 minor modifications)
15833          PARJ(1)  = 0.085D0
15834          PARJ(2)  = 0.26D0
15835          PARJ(3)  = 0.8D0
15836          PARJ(11) = 0.38D0
15837          PARJ(18) = 0.3D0
15838          PARJ(19) = 0.4D0
15839          PARJ(21) = 0.36D0
15840          PARJ(41) = 0.3D0
15841          PARJ(42) = 0.86D0
15842          IF (NPARJ.GT.0) THEN
15843             DO 10 I=1,NPARJ
15844                IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
15845    10       CONTINUE
15846          ENDIF
15847          IF (LFIRPH) THEN
15848             WRITE(LOUT,'(1X,A)')
15849      &         'DT_INITJS: JETSET-parameter for PHOJET'
15850             CALL DT_JSPARA(0)
15851             LFIRPH = .FALSE.
15852          ENDIF
15853 * DTUNUC settings
15854       ELSEIF (MODE.EQ.2) THEN
15855          IF (IFRAG(2).EQ.1) THEN
15856 **sr parameters before 9.3.96
15857 C           PARJ(2)  = 0.27D0
15858 C           PARJ(3)  = 0.6D0
15859 C           PARJ(6)  = 0.75D0
15860 C           PARJ(7)  = 0.75D0
15861 C           PARJ(21) = 0.55D0
15862 C           PARJ(42) = 1.3D0
15863 **sr 18.11.98 parameter tuning
15864 C           PARJ(1)  = 0.05D0
15865 C           PARJ(2)  = 0.27D0
15866 C           PARJ(3)  = 0.4D0
15867 C           PARJ(19) = 0.2D0
15868 C           PARJ(21) = 0.45D0
15869 C           PARJ(42) = 1.0D0
15870 **sr 28.04.99 parameter tuning
15871             PARJ(1)  = 0.11D0
15872             PARJ(2)  = 0.36D0
15873             PARJ(3)  = 0.8D0
15874             PARJ(19) = 0.2D0
15875             PARJ(21) = 0.3D0
15876             PARJ(41) = 0.3D0
15877             PARJ(42) = 0.58D0
15878             IF (NPARJ.GT.0) THEN
15879                DO 20 I=1,NPARJ
15880                   IF (IPARJ(I).LT.0) THEN
15881                      IDX = ABS(IPARJ(I))
15882                      PARJ(IDX) = PARJX(I)
15883                   ENDIF
15884    20          CONTINUE
15885             ENDIF
15886             IF (LFIRDT) THEN
15887                WRITE(LOUT,'(1X,A)')
15888      &           'DT_INITJS: JETSET-parameter for DTUNUC'
15889                CALL DT_JSPARA(0)
15890                LFIRDT = .FALSE.
15891             ENDIF
15892          ELSEIF (IFRAG(2).EQ.2) THEN
15893             PARJ(1)  = 0.11D0
15894             PARJ(2)  = 0.27D0
15895             PARJ(3)  = 0.3D0
15896             PARJ(6)  = 0.35D0
15897             PARJ(7)  = 0.45D0
15898             PARJ(18) = 0.66D0
15899 C           PARJ(21) = 0.55D0
15900 C           PARJ(42) = 1.0D0
15901             PARJ(21) = 0.60D0
15902             PARJ(42) = 1.3D0
15903          ELSE
15904             PARJ(1)  = PDEF1
15905             PARJ(2)  = PDEF2
15906             PARJ(3)  = PDEF3
15907             PARJ(6)  = PDEF6
15908             PARJ(7)  = PDEF7
15909             PARJ(18) = PDEF18
15910             PARJ(21) = PDEF21
15911             PARJ(42) = PDEF42
15912          ENDIF
15913       ELSE
15914          PARJ(1)  = PDEF1
15915          PARJ(2)  = PDEF2
15916          PARJ(3)  = PDEF3
15917          PARJ(5)  = PDEF5
15918          PARJ(6)  = PDEF6
15919          PARJ(7)  = PDEF7
15920          PARJ(18) = PDEF18
15921          PARJ(19) = PDEF19
15922          PARJ(21) = PDEF21
15923          PARJ(42) = PDEF42
15924          MSTJ(12) = MDEF12
15925       ENDIF
15926
15927       RETURN
15928       END
15929
15930 *$ CREATE DT_JSPARA.FOR
15931 *COPY DT_JSPARA
15932 *
15933 *===jspara=============================================================*
15934 *
15935       SUBROUTINE DT_JSPARA(MODE)
15936
15937       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15938       SAVE
15939       PARAMETER ( LINP = 10 ,
15940      &            LOUT = 6 ,
15941      &            LDAT = 9 )
15942       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
15943      &           ONE=1.0D0,ZERO=0.0D0)
15944
15945       LOGICAL LFIRST
15946
15947       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15948
15949       DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
15950
15951       DATA LFIRST /.TRUE./
15952
15953 * save the default JETSET-parameter on the first call
15954       IF (LFIRST) THEN
15955          DO 1 I=1,200
15956             ISTU(I) = MSTU(I)
15957             QARU(I) = PARU(I)
15958             ISTJ(I) = MSTJ(I)
15959             QARJ(I) = PARJ(I)
15960     1    CONTINUE
15961          LFIRST = .FALSE.
15962       ENDIF
15963
15964       WRITE(LOUT,1000)
15965  1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
15966
15967 * compare the default JETSET-parameter with the present values
15968       DO 2 I=1,200
15969          IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
15970             WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
15971 C           ISTU(I) = MSTU(I)
15972          ENDIF
15973          DIFF = ABS(PARU(I)-QARU(I))
15974          IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
15975             WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
15976 C           QARU(I) = PARU(I)
15977          ENDIF
15978          IF (MSTJ(I).NE.ISTJ(I)) THEN
15979             WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
15980 C           ISTJ(I) = MSTJ(I)
15981          ENDIF
15982          DIFF = ABS(PARJ(I)-QARJ(I))
15983          IF (DIFF.GE.1.0D-5) THEN
15984             WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
15985 C           QARJ(I) = PARJ(I)
15986          ENDIF
15987     2 CONTINUE
15988  1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
15989  1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
15990
15991       RETURN
15992       END
15993
15994 *$ CREATE DT_FOZOCA.FOR
15995 *COPY DT_FOZOCA
15996 *
15997 *===fozoca=============================================================*
15998 *
15999       SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16000
16001 ************************************************************************
16002 * This subroutine treats the complete FOrmation ZOne supressed intra-  *
16003 * nuclear CAscade.                                                     *
16004 *               LFZC = .true.  cascade has been treated                *
16005 *                    = .false. cascade skipped                         *
16006 * This is a completely revised version of the original FOZOKL.         *
16007 * This version dated 18.11.95 is written by S. Roesler                 *
16008 ************************************************************************
16009
16010       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16011       SAVE
16012       PARAMETER ( LINP = 10 ,
16013      &            LOUT = 6 ,
16014      &            LDAT = 9 )
16015       PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16016       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16017
16018       LOGICAL LSTART,LCAS,LFZC
16019
16020 * event history
16021       PARAMETER (NMXHKK=200000)
16022       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16023      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16024      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16025 * extended event history
16026       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16027      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16028      &                IHIST(2,NMXHKK)
16029 * rejection counter
16030       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16031      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16032      &                IREXCI(3),IRDIFF(2),IRINC
16033 * properties of interacting particles
16034       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16035 * Glauber formalism: collision properties
16036       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16037      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16038 * flags for input different options
16039       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16040       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16041      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16042 * final state after intranuclear cascade step
16043       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16044 * parameter for intranuclear cascade
16045       LOGICAL LPAULI
16046       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16047
16048       DIMENSION NCWOUN(2)
16049
16050       DATA LSTART /.TRUE./
16051
16052       LFZC = .TRUE.
16053       IREJ = 0
16054
16055 * skip cascade if hadron-hadron interaction or if supressed by user
16056       IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16057 * skip cascade if not all possible chains systems are hadronized
16058       DO 1 I=1,8
16059          IF (.NOT.LHADRO(I)) GOTO 9999
16060     1 CONTINUE
16061
16062       IF (LSTART) THEN
16063          WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16064  1000    FORMAT(/,1X,'FOZOCA:  intranuclear cascade treated for a ',
16065      &          'maximum of',I4,' generations',/,10X,'formation time ',
16066      &          'parameter:',F5.1,'  fm/c',9X,'modus:',I2)
16067          IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16068          IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16069  1001    FORMAT(10X,'p_t dependent formation zone',/)
16070  1002    FORMAT(10X,'constant formation zone',/)
16071          LSTART = .FALSE.
16072       ENDIF
16073
16074 * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16075 * which may interact with final state particles are stored in a seperate
16076 * array - here all proj./target nucleon-indices (just for simplicity)
16077       NOINC = 0
16078       DO 9 I=1,NPOINT(1)-1
16079          NOINC = NOINC+1
16080          IDXINC(NOINC) = I
16081     9 CONTINUE
16082
16083 * initialize Pauli-principle treatment (find wounded nucleons)
16084       NWOUND(1) = 0
16085       NWOUND(2) = 0
16086       NCWOUN(1) = 0
16087       NCWOUN(2) = 0
16088       DO 2 J=1,NPOINT(1)
16089          DO 3 I=1,2
16090             IF (ISTHKK(J).EQ.10+I) THEN
16091                NWOUND(I) = NWOUND(I)+1
16092                EWOUND(I,NWOUND(I)) = PHKK(4,J)
16093                IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16094             ENDIF
16095     3    CONTINUE
16096     2 CONTINUE
16097
16098 * modify nuclear potential for wounded nucleons
16099       IPRCL  = IP -NWOUND(1)
16100       IPZRCL = IPZ-NCWOUN(1)
16101       ITRCL  = IT -NWOUND(2)
16102       ITZRCL = ITZ-NCWOUN(2)
16103       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16104
16105       NSTART = NPOINT(4)
16106       NEND   = NHKK
16107
16108     7 CONTINUE
16109       DO 8 I=NSTART,NEND
16110
16111          IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16112 * select nucleus the cascade starts first (proj. - 1, target - -1)
16113             NCAS   = 1
16114 *   projectile/target with probab. 1/2
16115             IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16116                IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16117 *   in the nucleus with highest mass
16118             ELSEIF (INCMOD.EQ.2) THEN
16119                IF (IP.GT.IT) THEN
16120                   NCAS = -NCAS
16121                ELSEIF (IP.EQ.IT) THEN
16122                   IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16123                ENDIF
16124 * the nucleus the cascade starts first is requested to be the one
16125 * moving in the direction of the secondary
16126             ELSEIF (INCMOD.EQ.3) THEN
16127                NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
16128             ENDIF
16129 * check that the selected "nucleus" is not a hadron
16130             IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
16131      &          ((NCAS.EQ.-1).AND.(IT.LE.1)))    NCAS = -NCAS
16132
16133 * treat intranuclear cascade in the nucleus selected first
16134             LCAS = .FALSE.
16135             CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16136             IF (IREJ1.NE.0) GOTO 9998
16137 * treat intranuclear cascade in the other nucleus if this isn't a had.
16138             NCAS = -NCAS
16139             IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
16140      &          ((NCAS.EQ.-1).AND.(IT.GT.1)))    THEN
16141                IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16142                IF (IREJ1.NE.0) GOTO 9998
16143             ENDIF
16144
16145          ENDIF
16146
16147     8 CONTINUE
16148       NSTART = NEND+1
16149       NEND   = NHKK
16150       IF (NSTART.LE.NEND) GOTO 7
16151
16152       RETURN
16153
16154  9998 CONTINUE
16155 * reject this event
16156       IRINC = IRINC+1
16157       IREJ = 1
16158
16159  9999 CONTINUE
16160 * intranucl. cascade not treated because of interaction properties or
16161 * it is supressed by user or it was rejected or...
16162       LFZC = .FALSE.
16163 * reset flag characterizing direction of motion in n-n-cms
16164 **sr14-11-95
16165 C     DO 9990 I=NPOINT(5),NHKK
16166 C        IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
16167 C9990 CONTINUE
16168
16169       RETURN
16170       END
16171
16172 *$ CREATE DT_INUCAS.FOR
16173 *COPY DT_INUCAS
16174 *
16175 *===inucas=============================================================*
16176 *
16177       SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
16178
16179 ************************************************************************
16180 * Formation zone supressed IntraNUclear CAScade for one final state    *
16181 * particle.                                                            *
16182 *           IT, IP    mass numbers of target, projectile nuclei        *
16183 *           IDXCAS    index of final state particle in DTEVT1          *
16184 *           NCAS =  1 intranuclear cascade in projectile               *
16185 *                = -1 intranuclear cascade in target                   *
16186 * This version dated 18.11.95 is written by S. Roesler                 *
16187 ************************************************************************
16188
16189       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16190       SAVE
16191       PARAMETER ( LINP = 10 ,
16192      &            LOUT = 6 ,
16193      &            LDAT = 9 )
16194
16195       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
16196      &           OHALF=0.5D0,ONE=1.0D0)
16197       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16198       PARAMETER (TWOPI=6.283185307179586454D+00)
16199       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
16200
16201       LOGICAL LABSOR,LCAS
16202
16203 * event history
16204       PARAMETER (NMXHKK=200000)
16205       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16206      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16207      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16208 * extended event history
16209       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16210      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16211      &                IHIST(2,NMXHKK)
16212 * final state after inc step
16213       PARAMETER (MAXFSP=10)
16214       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
16215 * flags for input different options
16216       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16217       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16218      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16219 * particle properties (BAMJET index convention)
16220       CHARACTER*8  ANAME
16221       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16222      &                IICH(210),IIBAR(210),K1(210),K2(210)
16223 * Glauber formalism: collision properties
16224       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16225      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16226 * nuclear potential
16227       LOGICAL LFERMI
16228       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
16229      &                EBINDP(2),EBINDN(2),EPOT(2,210),
16230      &                ETACOU(2),ICOUL,LFERMI
16231 * parameter for intranuclear cascade
16232       LOGICAL LPAULI
16233       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16234 * final state after intranuclear cascade step
16235       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16236 * nucleon-nucleon event-generator
16237       CHARACTER*8 CMODEL
16238       LOGICAL LPHOIN
16239       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
16240 * statistics: residual nuclei
16241       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
16242      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
16243      &                NINCST(2,4),NINCEV(2),
16244      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
16245      &                NRESPB(2),NRESCH(2),NRESEV(4),
16246      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
16247      &                NEVAFI(2,2)
16248
16249       DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
16250      &          PCAS1(5),PNUC(5),BGTA(4),
16251      &          BGCAS(2),GACAS(2),BECAS(2),
16252      &          RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
16253
16254       DATA PDIF /0.545D0/
16255
16256       IREJ = 0
16257
16258 * update counter
16259       IF (NINCEV(1).NE.NEVHKK) THEN
16260          NINCEV(1) = NEVHKK
16261          NINCEV(2) = NINCEV(2)+1
16262       ENDIF
16263
16264 * "BAMJET-index" of this hadron
16265       IDCAS = IDBAM(IDXCAS)
16266       IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
16267
16268 * skip gammas, electrons, etc..
16269       IF (AAM(IDCAS).LT.TINY2) RETURN
16270
16271 * Lorentz-trsf. into projectile rest system
16272       IF (IP.GT.1) THEN
16273          CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16274      &               PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
16275      &               PCAS(1,4),IDCAS,-2)
16276          PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
16277          PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
16278          IF (PCAS(1,5).GT.ZERO) THEN
16279             PCAS(1,5) = SQRT(PCAS(1,5))
16280          ELSE
16281             PCAS(1,5) = AAM(IDCAS)
16282          ENDIF
16283          DO 20 K=1,3
16284             COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
16285    20    CONTINUE
16286 * Lorentz-parameters
16287 *   particle rest system --> projectile rest system
16288          BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
16289          GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
16290          BECAS(1) = BGCAS(1)/GACAS(1)
16291       ELSE
16292          DO 21 K=1,5
16293             PCAS(1,K) = ZERO
16294             IF (K.LE.3) COSCAS(1,K) = ZERO
16295    21    CONTINUE
16296          PTOCAS(1) = ZERO
16297          BGCAS(1)  = ZERO
16298          GACAS(1)  = ZERO
16299          BECAS(1)  = ZERO
16300       ENDIF
16301 * Lorentz-trsf. into target rest system
16302       IF (IT.GT.1) THEN
16303 * LEPTO: final state particles are already in target rest frame
16304 C        IF (MCGENE.EQ.3) THEN
16305 C           PCAS(2,1) = PHKK(1,IDXCAS)
16306 C           PCAS(2,2) = PHKK(2,IDXCAS)
16307 C           PCAS(2,3) = PHKK(3,IDXCAS)
16308 C           PCAS(2,4) = PHKK(4,IDXCAS)
16309 C        ELSE
16310             CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16311      &                  PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
16312      &                  PCAS(2,4),IDCAS,-3)
16313 C        ENDIF
16314          PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
16315          PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
16316          IF (PCAS(2,5).GT.ZERO) THEN
16317             PCAS(2,5) = SQRT(PCAS(2,5))
16318          ELSE
16319             PCAS(2,5) = AAM(IDCAS)
16320          ENDIF
16321          DO 22 K=1,3
16322             COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
16323    22    CONTINUE
16324 * Lorentz-parameters
16325 *   particle rest system --> target rest system
16326          BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
16327          GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
16328          BECAS(2) = BGCAS(2)/GACAS(2)
16329       ELSE
16330          DO 23 K=1,5
16331             PCAS(2,K) = ZERO
16332             IF (K.LE.3) COSCAS(2,K) = ZERO
16333    23    CONTINUE
16334          PTOCAS(2) = ZERO
16335          BGCAS(2)  = ZERO
16336          GACAS(2)  = ZERO
16337          BECAS(2)  = ZERO
16338       ENDIF
16339
16340 * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
16341 * potential (see CONUCL)
16342       RNUC(1)  = (RPROJ+4.605D0*PDIF)*FM2MM
16343       RNUC(2)  = (RTARG+4.605D0*PDIF)*FM2MM
16344 * impact parameter (the projectile moving along z)
16345       BIMPC(1) = ZERO
16346       BIMPC(2) = BIMPAC*FM2MM
16347
16348 * get position of initial hadron in projectile/target rest-syst.
16349       DO 3 K=1,4
16350          VTXCAS(1,K) = WHKK(K,IDXCAS)
16351          VTXCAS(2,K) = VHKK(K,IDXCAS)
16352     3 CONTINUE
16353
16354       ICAS = 1
16355       I2   = 2
16356       IF (NCAS.EQ.-1) THEN
16357          ICAS = 2
16358          I2   = 1
16359       ENDIF
16360
16361       IF (PTOCAS(ICAS).LT.TINY10) THEN
16362          WRITE(LOUT,1000) PTOCAS
16363  1000    FORMAT(1X,'INUCAS:   warning! zero momentum of initial',
16364      &          '  hadron ',/,20X,2E12.4)
16365          GOTO 9999
16366       ENDIF
16367
16368 * reset spectator flags
16369       NSPE = 0
16370       IDXSPE(1) = 0
16371       IDXSPE(2) = 0
16372       IDSPE(1)  = 0
16373       IDSPE(2)  = 0
16374
16375 * formation length (in fm)
16376 C     IF (LCAS) THEN
16377 C        DEL0 = ZERO
16378 C     ELSE
16379          DEL0 = TAUFOR*BGCAS(ICAS)
16380          IF (ITAUVE.EQ.1) THEN
16381             AMT  = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
16382             DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
16383          ENDIF
16384 C     ENDIF
16385 *   sample from exp(-del/del0)
16386       DEL1   = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
16387 * save formation time
16388       TAUSA1 = DEL1/BGCAS(ICAS)
16389       REL1   = TAUSA1*BGCAS(I2)
16390
16391       DEL    = DEL1
16392       TAUSAM = DEL/BGCAS(ICAS)
16393       REL    = TAUSAM*BGCAS(I2)
16394
16395 * special treatment for negative particles unable to escape
16396 * nuclear potential (implemented for ap, pi-, K- only)
16397       LABSOR = .FALSE.
16398       IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
16399 *   threshold energy = nuclear potential + Coulomb potential
16400 *   (nuclear potential for hadron-nucleus interactions only)
16401          ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
16402          IF (PCAS(ICAS,4).LT.ETHR) THEN
16403             DO 4 K=1,5
16404                PCAS1(K) = PCAS(ICAS,K)
16405     4       CONTINUE
16406 *   "absorb" negative particle in nucleus
16407             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
16408             IF (IREJ1.NE.0) GOTO 9999
16409             IF (NSPE.GE.1) LABSOR = .TRUE.
16410          ENDIF
16411       ENDIF
16412
16413 * if the initial particle has not been absorbed proceed with
16414 * "normal" cascade
16415       IF (.NOT.LABSOR) THEN
16416
16417 *   calculate coordinates of hadron at the end of the formation zone
16418 *   transport-time and -step in the rest system where this step is
16419 *   treated
16420          DSTEP  = DEL*FM2MM
16421          DTIME  = DSTEP/BECAS(ICAS)
16422          RSTEP  = REL*FM2MM
16423          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16424             RTIME = RSTEP/BECAS(I2)
16425          ELSE
16426             RTIME = ZERO
16427          ENDIF
16428 *   save step whithout considering the overlapping region
16429          DSTEP1 = DEL1*FM2MM
16430          DTIME1 = DSTEP1/BECAS(ICAS)
16431          RSTEP1 = REL1*FM2MM
16432          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16433             RTIME1 = RSTEP1/BECAS(I2)
16434          ELSE
16435             RTIME1 = ZERO
16436          ENDIF
16437 *   transport to the end of the formation zone in this system
16438          DO 5 K=1,3
16439             VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
16440             VTXCA1(I2,K)   = VTXCAS(I2,K)  +RSTEP1*COSCAS(I2,K)
16441             VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
16442             VTXCAS(I2,K)   = VTXCAS(I2,K)  +RSTEP*COSCAS(I2,K)
16443     5    CONTINUE
16444          VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
16445          VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME1
16446          VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16447          VTXCAS(I2,4)   = VTXCAS(I2,4)  +RTIME
16448
16449          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16450             XCAS   = VTXCAS(ICAS,1)
16451             YCAS   = VTXCAS(ICAS,2)
16452             XNCLTA = BIMPAC*FM2MM
16453             RNCLPR = (RPROJ+RNUCLE)*FM2MM
16454             RNCLTA = (RTARG+RNUCLE)*FM2MM
16455 C           RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
16456 C           RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
16457 C           RNCLPR = (RPROJ)*FM2MM
16458 C           RNCLTA = (RTARG)*FM2MM
16459             RCASPR = SQRT( XCAS**2        +YCAS**2)
16460             RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
16461             IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
16462                IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
16463             ENDIF
16464          ENDIF
16465
16466 *   check if particle is already outside of the corresp. nucleus
16467          RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
16468      &                VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
16469          IF (RDIST.GE.RNUC(ICAS)) THEN
16470 *   here: IDCH is the generation of the final state part. starting
16471 *   with zero for hadronization products
16472 *   flag particles of generation 0 being outside the nuclei after
16473 *   formation time (to be used for excitation energy calculation)
16474             IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
16475      &         NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
16476             GOTO 9997
16477          ENDIF
16478          DIST   = DLARGE
16479          DISTP  = DLARGE
16480          DISTN  = DLARGE
16481          IDXP   = 0
16482          IDXN   = 0
16483
16484 *   already here: skip particles being outside HADRIN "energy-window"
16485 *   to avoid wasting of time
16486          NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
16487          IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
16488             NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
16489 C           WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
16490 C1002       FORMAT(1X,'INUCAS:   warning! momentum of particle with ',
16491 C    &             'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
16492 C    &             E12.4,', above or below HADRIN-thresholds',I6)
16493             NSPE = 0
16494             GOTO 9997
16495          ENDIF
16496
16497          DO 7 IDXHKK=1,NOINC
16498             I = IDXINC(IDXHKK)
16499 *   scan DTEVT1 for unwounded or excited nucleons
16500             IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
16501                DO 8 K=1,3
16502                   IF (ICAS.EQ.1) THEN
16503                      VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
16504                   ELSEIF (ICAS.EQ.2) THEN
16505                      VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
16506                   ENDIF
16507     8          CONTINUE
16508                POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
16509      &                  VTXDST(2)*COSCAS(ICAS,2)+
16510      &                  VTXDST(3)*COSCAS(ICAS,3)
16511 *   check if nucleon is situated in forward direction
16512                IF (POSNUC.GT.ZERO) THEN
16513 *   distance between hadron and this nucleon
16514                   DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16515      &                          VTXDST(3)**2)
16516 *   impact parameter
16517                   BIMNU2 = DISTNU**2-POSNUC**2
16518                   IF (BIMNU2.LT.ZERO) THEN
16519                      WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
16520  1001                FORMAT(1X,'INUCAS:   warning! inconsistent impact',
16521      &                      '  parameter ',/,20X,3E12.4)
16522                      GOTO 7
16523                   ENDIF
16524                   BIMNU  = SQRT(BIMNU2)
16525 *   maximum impact parameter to have interaction
16526                   IDNUC  = IDT_ICIHAD(IDHKK(I))
16527                   IDNUC1 = IDT_MCHAD(IDNUC)
16528                   IDCAS1 = IDT_MCHAD(IDCAS)
16529                   DO 19 K=1,5
16530                      PCAS1(K) = PCAS(ICAS,K)
16531                      PNUC(K)  = PHKK(K,I)
16532    19             CONTINUE
16533 * Lorentz-parameter for trafo into rest-system of target
16534                   DO 18 K=1,4
16535                      BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
16536    18             CONTINUE
16537 * transformation of projectile into rest-system of target
16538                   CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
16539      &                        PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
16540      &                        PPTOT,PX,PY,PZ,PE)
16541 **
16542 C                 CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
16543 C                 CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
16544                   DUMZER = ZERO
16545                   CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
16546                   CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
16547                   IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
16548      &                (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
16549                   SIGIN = SIGTOT-SIGEL-SIGAB
16550 C                 SIGTOT = SIGIN+SIGEL+SIGAB
16551 **
16552                   BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
16553 *   check if interaction is possible
16554                   IF (BIMNU.LE.BIMMAX) THEN
16555 *   get nucleon with smallest distance and kind of interaction
16556 *   (elastic/inelastic)
16557                      IF (DISTNU.LT.DIST) THEN
16558                         DIST      = DISTNU
16559                         BINT      = BIMNU
16560                         IF (IDNUC.NE.IDSPE(1)) THEN
16561                            IDSPE(2)  = IDSPE(1)
16562                            IDXSPE(2) = IDXSPE(1)
16563                            IDSPE(1)  = IDNUC
16564                         ENDIF
16565                         IDXSPE(1) = I
16566                         NSPE      = 1
16567 **sr
16568                         SELA = SIGEL
16569                         SABS = SIGAB
16570                         STOT = SIGTOT
16571 C                       IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
16572 C                          SELA = SIGEL
16573 C                          STOT = SIGIN+SIGEL
16574 C                       ELSE
16575 C                          SELA = SIGEL+0.75D0*SIGIN
16576 C                          STOT = 0.25D0*SIGIN+SELA
16577 C                       ENDIF
16578 **
16579                      ENDIF
16580                   ENDIf
16581                ENDIF
16582                DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16583      &                       VTXDST(3)**2)
16584                IDNUC  = IDT_ICIHAD(IDHKK(I))
16585                IF (IDNUC.EQ.1) THEN
16586                   IF (DISTNU.LT.DISTP) THEN
16587                      DISTP = DISTNU
16588                      IDXP  = I
16589                      POSP  = POSNUC
16590                   ENDIF
16591                ELSEIF (IDNUC.EQ.8) THEN
16592                   IF (DISTNU.LT.DISTN) THEN
16593                      DISTN = DISTNU
16594                      IDXN  = I
16595                      POSN  = POSNUC
16596                   ENDIF
16597                ENDIF
16598             ENDIF
16599     7    CONTINUE
16600
16601 * there is no nucleon for a secondary interaction
16602          IF (NSPE.EQ.0) GOTO 9997
16603
16604 C        IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
16605 C    &      WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
16606          IF (IDXSPE(2).EQ.0) THEN
16607             IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
16608 C              DO 80 K=1,3
16609 C                 IF (ICAS.EQ.1) THEN
16610 C                    VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
16611 C                 ELSEIF (ICAS.EQ.2) THEN
16612 C                    VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
16613 C                 ENDIF
16614 C  80          CONTINUE
16615 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16616 C    &                       VTXDST(3)**2)
16617 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
16618                   IDXSPE(2) = IDXN
16619                   IDSPE(2)  = 8
16620 C              ELSE
16621 C                 STOT = STOT-SABS
16622 C                 SABS = ZERO
16623 C              ENDIF
16624             ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
16625 C              DO 81 K=1,3
16626 C                 IF (ICAS.EQ.1) THEN
16627 C                    VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
16628 C                 ELSEIF (ICAS.EQ.2) THEN
16629 C                    VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
16630 C                 ENDIF
16631 C  81          CONTINUE
16632 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16633 C    &                       VTXDST(3)**2)
16634 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
16635                   IDXSPE(2) = IDXP
16636                   IDSPE(2)  = 1
16637 C              ELSE
16638 C                 STOT = STOT-SABS
16639 C                 SABS = ZERO
16640 C              ENDIF
16641             ELSE
16642                STOT = STOT-SABS
16643                SABS = ZERO
16644             ENDIF
16645          ENDIF
16646          RR = DT_RNDM(DIST)
16647          IF (RR.LT.SELA/STOT) THEN
16648             IPROC = 2
16649          ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
16650             IPROC = 3
16651          ELSE
16652             IPROC = 1
16653          ENDIF
16654
16655          DO 9 K=1,5
16656             PCAS1(K) = PCAS(ICAS,K)
16657             PNUC(K)  = PHKK(K,IDXSPE(1))
16658     9    CONTINUE
16659          IF (IPROC.EQ.3) THEN
16660 * 2-nucleon absorption of pion
16661             NSPE = 2
16662             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
16663             IF (IREJ1.NE.0) GOTO 9999
16664             IF (NSPE.GE.1) LABSOR = .TRUE.
16665          ELSE
16666 * sample secondary interaction
16667             IDNUC = IDBAM(IDXSPE(1))
16668             CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
16669             IF (IREJ1.EQ.1) GOTO 9999
16670             IF (IREJ1.GT.1) GOTO 9998
16671          ENDIF
16672       ENDIF
16673
16674 * update arrays to include Pauli-principle
16675       DO 10 I=1,NSPE
16676          IF (NWOUND(ICAS).LE.299) THEN
16677             NWOUND(ICAS) = NWOUND(ICAS)+1
16678             EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
16679          ENDIF
16680    10 CONTINUE
16681
16682 * dump initial hadron for energy-momentum conservation check
16683       IF (LEMCCK)
16684      &   CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
16685      &               PCAS(ICAS,4),1,IDUM,IDUM)
16686
16687 * dump final state particles into DTEVT1
16688
16689 *   check if Pauli-principle is fulfilled
16690       NPAULI = 0
16691       NWTMP(1) = NWOUND(1)
16692       NWTMP(2) = NWOUND(2)
16693       DO 111 I=1,NFSP
16694          NPAULI = 0
16695          J1 = 2
16696          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16697      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
16698          DO 117 J=1,J1
16699             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
16700             IF (J.EQ.1) THEN
16701                IDX = ICAS
16702                PE  = PFSP(4,I)
16703             ELSE
16704                IDX  = I2
16705                MODE = 1
16706                IF (IDX.EQ.1) MODE = -1
16707                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
16708             ENDIF
16709 * first check if cascade step is forbidden due to Pauli-principle
16710 * (in case of absorpion this step is forced)
16711             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16712      &          (IDFSP(I).EQ.8))) THEN
16713 *   get nuclear potential barrier
16714                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16715                IF (IDFSP(I).EQ.1) THEN
16716                   POTLOW = POT-EBINDP(IDX)
16717                ELSE
16718                   POTLOW = POT-EBINDN(IDX)
16719                ENDIF
16720 *   final state particle not able to escape nucleus
16721                IF (PE.LE.POTLOW) THEN
16722 *     check if there are wounded nucleons
16723                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16724      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
16725                      NPAULI      = NPAULI+1
16726                      NWOUND(IDX) = NWOUND(IDX)-1
16727                   ELSE
16728 *     interaction prohibited by Pauli-principle
16729                      NWOUND(1) = NWTMP(1)
16730                      NWOUND(2) = NWTMP(2)
16731                      GOTO 9997
16732                   ENDIF
16733                ENDIF
16734             ENDIF
16735   117    CONTINUE
16736   111 CONTINUE
16737
16738       NPAULI = 0
16739       NWOUND(1) = NWTMP(1)
16740       NWOUND(2) = NWTMP(2)
16741
16742       DO 11 I=1,NFSP
16743
16744          IST = ISTHKK(IDXCAS)
16745
16746          NPAULI = 0
16747          J1 = 2
16748          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16749      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
16750          DO 17 J=1,J1
16751             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
16752             IDX = ICAS
16753             PE  = PFSP(4,I)
16754             IF (J.EQ.2) THEN
16755                IDX = I2
16756                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
16757             ENDIF
16758 * first check if cascade step is forbidden due to Pauli-principle
16759 * (in case of absorpion this step is forced)
16760             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16761      &          (IDFSP(I).EQ.8))) THEN
16762 *   get nuclear potential barrier
16763                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16764                IF (IDFSP(I).EQ.1) THEN
16765                   POTLOW = POT-EBINDP(IDX)
16766                ELSE
16767                   POTLOW = POT-EBINDN(IDX)
16768                ENDIF
16769 *   final state particle not able to escape nucleus
16770                IF (PE.LE.POTLOW) THEN
16771 *     check if there are wounded nucleons
16772                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16773      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
16774                      NWOUND(IDX) = NWOUND(IDX)-1
16775                      NPAULI = NPAULI+1
16776                      IST    = 14+IDX
16777                   ELSE
16778 *     interaction prohibited by Pauli-principle
16779                      NWOUND(1) = NWTMP(1)
16780                      NWOUND(2) = NWTMP(2)
16781                      GOTO 9997
16782                   ENDIF
16783 **sr
16784 c               ELSEIF (PE.LE.POT) THEN
16785 cC              ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
16786 cC                 NWOUND(IDX) = NWOUND(IDX)-1
16787 c**
16788 c                  NPAULI = NPAULI+1
16789 c                  IST    = 14+IDX
16790                ENDIF
16791             ENDIF
16792    17    CONTINUE
16793
16794 * dump final state particles for energy-momentum conservation check
16795          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
16796      &                           -PFSP(4,I),2,IDUM,IDUM)
16797
16798          PX = PFSP(1,I)
16799          PY = PFSP(2,I)
16800          PZ = PFSP(3,I)
16801          PE = PFSP(4,I)
16802          IF (ABS(IST).EQ.1) THEN
16803 * transform particles back into n-n cms
16804 * LEPTO: leave final state particles in target rest frame
16805 C           IF (MCGENE.EQ.3) THEN
16806 C              PFSP(1,I) = PX
16807 C              PFSP(2,I) = PY
16808 C              PFSP(3,I) = PZ
16809 C              PFSP(4,I) = PE
16810 C           ELSE
16811                IMODE = ICAS+1
16812                CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16813      &                     PFSP(4,I),IDFSP(I),IMODE)
16814 C           ENDIF
16815          ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
16816 * target cascade but fsp got stuck in proj. --> transform it into
16817 * proj. rest system
16818             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16819      &                  PFSP(4,I),IDFSP(I),-1)
16820          ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
16821 * proj. cascade but fsp got stuck in target --> transform it into
16822 * target rest system
16823             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16824      &                  PFSP(4,I),IDFSP(I),1)
16825          ENDIF
16826
16827 * dump final state particles into DTEVT1
16828          IGEN = IDCH(IDXCAS)+1
16829          ID   = IDT_IPDGHA(IDFSP(I))
16830          IXR  = 0
16831          IF (LABSOR) IXR = 99
16832          CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
16833      &               PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
16834
16835 * update the counter for particles which got stuck inside the nucleus
16836          IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
16837             NOINC = NOINC+1
16838             IDXINC(NOINC) = NHKK
16839          ENDIF
16840          IF (LABSOR) THEN
16841 *   in case of absorption the spatial treatment is an approximate
16842 *   solution anyway (the positions of the nucleons which "absorb" the
16843 *   cascade particle are not taken into consideration) therefore the
16844 *   particles are produced at the position of the cascade particle
16845             DO 12 K=1,4
16846                WHKK(K,NHKK) = WHKK(K,IDXCAS)
16847                VHKK(K,NHKK) = VHKK(K,IDXCAS)
16848    12       CONTINUE
16849          ELSE
16850 *   DDISTL - distance the cascade particle moves to the intera. point
16851 *   (the position where impact-parameter = distance to the interacting
16852 *   nucleon), DIST - distance to the interacting nucleon at the time of
16853 *   formation of the cascade particle, BINT - impact-parameter of this
16854 *   cascade-interaction
16855             DDISTL = SQRT(DIST**2-BINT**2)
16856             DTIME  = DDISTL/BECAS(ICAS)
16857             DTIMEL = DDISTL/BGCAS(ICAS)
16858             RDISTL = DTIMEL*BGCAS(I2)
16859             IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16860                RTIME = RDISTL/BECAS(I2)
16861             ELSE
16862                RTIME = ZERO
16863             ENDIF
16864 *   RDISTL, RTIME are this step and time in the rest system of the other
16865 *   nucleus
16866             DO 13 K=1,3
16867                VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
16868                VTXCA1(I2,K)   = VTXCAS(I2,K)  +COSCAS(I2,K)  *RDISTL
16869    13       CONTINUE
16870             VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16871             VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME
16872 *   position of particle production is half the impact-parameter to
16873 *   the interacting nucleon
16874             DO 14 K=1,3
16875                WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
16876                VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
16877    14       CONTINUE
16878 *   time of production of secondary = time of interaction
16879             WHKK(4,NHKK) = VTXCA1(1,4)
16880             VHKK(4,NHKK) = VTXCA1(2,4)
16881          ENDIF
16882
16883    11 CONTINUE
16884
16885 * modify status and position of cascade particle (the latter for
16886 * statistics reasons only)
16887       ISTHKK(IDXCAS) = 2
16888       IF (LABSOR) ISTHKK(IDXCAS) = 19
16889       IF (.NOT.LABSOR) THEN
16890          DO 15 K=1,4
16891             WHKK(K,IDXCAS) = VTXCA1(1,K)
16892             VHKK(K,IDXCAS) = VTXCA1(2,K)
16893    15    CONTINUE
16894       ENDIF
16895
16896       DO 16 I=1,NSPE
16897          IS = IDXSPE(I)
16898 * dump interacting nucleons for energy-momentum conservation check
16899          IF (LEMCCK)
16900      &      CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
16901      &                                                  2,IDUM,IDUM)
16902 * modify entry for interacting nucleons
16903          IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
16904          IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
16905          IF (I.GE.2) THEN
16906             JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
16907             JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
16908          ENDIF
16909    16 CONTINUE
16910
16911 * check energy-momentum conservation
16912       IF (LEMCCK) THEN
16913          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
16914          IF (IREJ1.NE.0) GOTO 9999
16915       ENDIF
16916
16917 * update counter
16918       IF (LABSOR) THEN
16919          NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
16920       ELSE
16921          IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
16922          IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
16923       ENDIF
16924
16925       RETURN
16926
16927  9997 CONTINUE
16928  9998 CONTINUE
16929 * transport-step but no cascade step due to configuration (i.e. there
16930 * is no nucleon for interaction etc.)
16931       IF (LCAS) THEN
16932          DO 100 K=1,4
16933 C           WHKK(K,IDXCAS) = VTXCAS(1,K)
16934 C           VHKK(K,IDXCAS) = VTXCAS(2,K)
16935             WHKK(K,IDXCAS) = VTXCA1(1,K)
16936             VHKK(K,IDXCAS) = VTXCA1(2,K)
16937   100    CONTINUE
16938       ENDIF
16939
16940 C9998 CONTINUE
16941 * no cascade-step because of configuration
16942 * (i.e. hadron outside nucleus etc.)
16943       LCAS = .TRUE.
16944       RETURN
16945
16946  9999 CONTINUE
16947 * rejection
16948       IREJ = 1
16949       RETURN
16950       END
16951
16952 *$ CREATE DT_ABSORP.FOR
16953 *COPY DT_ABSORP
16954 *
16955 *===absorp=============================================================*
16956 *
16957       SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
16958
16959 ************************************************************************
16960 * Two-nucleon absorption of antiprotons, pi-, and K-.                  *
16961 * Antiproton absorption is handled by HADRIN.                          *
16962 * The following channels for meson-absorption are considered:          *
16963 *          pi- + p + p ---> n + p                                      *
16964 *          pi- + p + n ---> n + n                                      *
16965 *          K-  + p + p ---> sigma+ + n / Lam + p / sigma0 + p          *
16966 *          K-  + p + n ---> sigma- + n / Lam + n / sigma0 + n          *
16967 *          K-  + p + p ---> sigma- + n                                 *
16968 *      IDCAS, PCAS   identity, momentum of particle to be absorbed     *
16969 *      NCAS =  1     intranuclear cascade in projectile                *
16970 *           = -1     intranuclear cascade in target                    *
16971 *      NSPE          number of spectator nucleons involved             *
16972 *      IDXSPE(2)     DTEVT1-indices of spectator nucleons involved     *
16973 * Revised version of the original STOPIK written by HJM and J. Ranft.  *
16974 * This version dated 24.02.95 is written by S. Roesler                 *
16975 ************************************************************************
16976
16977       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16978       SAVE
16979       PARAMETER ( LINP = 10 ,
16980      &            LOUT = 6 ,
16981      &            LDAT = 9 )
16982       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
16983      &           ONETHI=0.3333D0,TWOTHI=0.6666D0)
16984
16985 * event history
16986       PARAMETER (NMXHKK=200000)
16987       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16988      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16989      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16990 * extended event history
16991       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16992      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16993      &                IHIST(2,NMXHKK)
16994 * flags for input different options
16995       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16996       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16997      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16998 * final state after inc step
16999       PARAMETER (MAXFSP=10)
17000       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17001 * particle properties (BAMJET index convention)
17002       CHARACTER*8  ANAME
17003       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17004      &                IICH(210),IIBAR(210),K1(210),K2(210)
17005
17006       DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17007      &          PTOT3P(4),BG3P(4),
17008      &          ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17009
17010       IREJ = 0
17011       NFSP = 0
17012
17013 * skip particles others than ap, pi-, K- for mode=0
17014       IF ((MODE.EQ.0).AND.
17015      &    (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17016 * skip particles others than pions for mode=1
17017 * (2-nucleon absorption in intranuclear cascade)
17018       IF ((MODE.EQ.1).AND.
17019      &    (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17020
17021       NUCAS = NCAS
17022       IF (NUCAS.EQ.-1) NUCAS = 2
17023
17024       IF (MODE.EQ.0) THEN
17025 * scan spectator nucleons for nucleons being able to "absorb"
17026          NSPE      = 0
17027          IDXSPE(1) = 0
17028          IDXSPE(2) = 0
17029          DO 1 I=1,NHKK
17030             IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17031                NSPE         = NSPE+1
17032                IDXSPE(NSPE) = I
17033                IDSPE(NSPE)  = IDBAM(I)
17034                IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17035                IF (NSPE.EQ.2) THEN
17036                   IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17037      &                                  (IDSPE(2).EQ.8)) THEN
17038 *    there is no pi-+n+n channel
17039                      NSPE = 1
17040                      GOTO 1
17041                   ELSE
17042                      GOTO 2
17043                   ENDIF
17044                ENDIF
17045             ENDIF
17046     1    CONTINUE
17047
17048     2    CONTINUE
17049       ENDIF
17050 * transform excited projectile nucleons (status=15) into proj. rest s.
17051       DO 3 I=1,NSPE
17052          DO 4 K=1,5
17053             PSPE(I,K) = PHKK(K,IDXSPE(I))
17054     4    CONTINUE
17055     3 CONTINUE
17056
17057 * antiproton absorption
17058       IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17059          DO 5 K=1,5
17060             PSPE1(K) = PSPE(1,K)
17061     5    CONTINUE
17062          CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17063          IF (IREJ1.NE.0) GOTO 9999
17064
17065 * meson absorption
17066       ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17067      &                      .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17068          IF (IDCAS.EQ.14) THEN
17069 *   pi- absorption
17070             IDFSP(1) = 8
17071             IDFSP(2) = 8
17072             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17073          ELSEIF (IDCAS.EQ.13) THEN
17074 *   pi+ absorption
17075             IDFSP(1) = 1
17076             IDFSP(2) = 1
17077             IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17078          ELSEIF (IDCAS.EQ.23) THEN
17079 *   pi0 absorption
17080             IDFSP(1) = IDSPE(1)
17081             IDFSP(2) = IDSPE(2)
17082          ELSEIF (IDCAS.EQ.16) THEN
17083 *   K- absorption
17084             R = DT_RNDM(PCAS)
17085             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17086                IF (R.LT.ONETHI) THEN
17087                   IDFSP(1) = 21
17088                   IDFSP(2) = 8
17089                ELSEIF (R.LT.TWOTHI) THEN
17090                   IDFSP(1) = 17
17091                   IDFSP(2) = 1
17092                ELSE
17093                   IDFSP(1) = 22
17094                   IDFSP(2) = 1
17095                ENDIF
17096             ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17097                IDFSP(1) = 20
17098                IDFSP(2) = 8
17099             ELSE
17100                IF (R.LT.ONETHI) THEN
17101                   IDFSP(1) = 20
17102                   IDFSP(2) = 1
17103                ELSEIF (R.LT.TWOTHI) THEN
17104                   IDFSP(1) = 17
17105                   IDFSP(2) = 8
17106                ELSE
17107                   IDFSP(1) = 22
17108                   IDFSP(2) = 8
17109                ENDIF
17110             ENDIF
17111          ENDIF
17112 *   dump initial particles for energy-momentum cons. check
17113          IF (LEMCCK) THEN
17114             CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
17115             CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
17116      &                                                    IDUM,IDUM)
17117             CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
17118      &                                                    IDUM,IDUM)
17119          ENDIF
17120 *   get Lorentz-parameter of 3 particle initial state
17121          DO 6 K=1,4
17122             PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
17123     6    CONTINUE
17124          P3P  = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
17125          AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
17126          DO 7 K=1,4
17127             BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
17128     7    CONTINUE
17129 *   2-particle decay of the 3-particle compound system
17130          CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
17131      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
17132      &               AAM(IDFSP(1)),AAM(IDFSP(2)))
17133          DO 8 I=1,2
17134             SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
17135             PX  = PCMF(I)*COFF(I)*SDF
17136             PY  = PCMF(I)*SIFF(I)*SDF
17137             PZ  = PCMF(I)*CODF(I)
17138             CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
17139      &                  ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17140      &                  PFSP(4,I))
17141             PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
17142 *   check consistency of kinematics
17143             IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
17144                WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
17145  1001          FORMAT(1X,'ABSORP:   warning! inconsistent',
17146      &                ' tree-particle kinematics',/,20X,'id: ',I3,
17147      &                ' AAM = ',E10.4,' MFSP = ',E10.4)
17148             ENDIF
17149 *   dump final state particles for energy-momentum cons. check
17150             IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17151      &                              -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17152     8    CONTINUE
17153          NFSP = 2
17154          IF (LEMCCK) THEN
17155             CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
17156             IF (IREJ1.NE.0) THEN
17157                WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
17158      &                      AM3P
17159                GOTO 9999
17160             ENDIF
17161          ENDIF
17162       ELSE
17163          IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
17164  1000    FORMAT(1X,'ABSORP:   warning! absorption for particle ',I3,
17165      &          ' impossible',/,20X,'too few spectators (',I2,')')
17166          NSPE = 0
17167       ENDIF
17168
17169       RETURN
17170
17171  9999 CONTINUE
17172       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
17173       IREJ = 1
17174       RETURN
17175       END
17176
17177 *$ CREATE DT_HADRIN.FOR
17178 *COPY DT_HADRIN
17179 *
17180 *===hadrin=============================================================*
17181 *
17182       SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
17183
17184 ************************************************************************
17185 * Interface to the HADRIN-routines for inelastic and elastic           *
17186 * scattering.                                                          *
17187 *      IDPR,PPR(5)   identity, momentum of projectile                  *
17188 *      IDTA,PTA(5)   identity, momentum of target                      *
17189 *      MODE  = 1     inelastic interaction                             *
17190 *            = 2     elastic   interaction                             *
17191 * Revised version of the original FHAD.                                *
17192 * This version dated 27.10.95 is written by S. Roesler                 *
17193 ************************************************************************
17194
17195       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17196       SAVE
17197       PARAMETER ( LINP = 10 ,
17198      &            LOUT = 6 ,
17199      &            LDAT = 9 )
17200       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
17201      &           TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
17202
17203       LOGICAL LCORR,LMSSG
17204
17205 * flags for input different options
17206       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17207       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17208      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17209 * final state after inc step
17210       PARAMETER (MAXFSP=10)
17211       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17212 * particle properties (BAMJET index convention)
17213       CHARACTER*8  ANAME
17214       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17215      &                IICH(210),IIBAR(210),K1(210),K2(210)
17216 * output-common for DHADRI/ELHAIN
17217 * final state from HADRIN interaction
17218       PARAMETER (MAXFIN=10)
17219       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
17220      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
17221
17222       DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
17223      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
17224
17225       DATA LMSSG /.TRUE./
17226
17227       IREJ  = 0
17228       NFSP  = 0
17229       KCORR = 0
17230       IMCORR(1) = 0
17231       IMCORR(2) = 0
17232       LCORR = .FALSE.
17233
17234 *   dump initial particles for energy-momentum cons. check
17235       IF (LEMCCK) THEN
17236          CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
17237          CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
17238       ENDIF
17239
17240       AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
17241       AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
17242       IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
17243      &    (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
17244      &    (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
17245          IF (LMSSG.AND.(IOULEV(3).GT.0))
17246      &   WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
17247  1000    FORMAT(1X,'HADRIN:   warning! inconsistent projectile/target',
17248      &          ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
17249      &          E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
17250          LMSSG = .FALSE.
17251          LCORR = .TRUE.
17252       ENDIF
17253
17254 * convert initial state particles into particles which can be
17255 * handled by HADRIN
17256       IDHPR = IDPR
17257       IDHTA = IDTA
17258       IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
17259          IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
17260          DO 1 K=1,4
17261             P1IN(K) = PPR(K)
17262             P2IN(K) = PTA(K)
17263     1    CONTINUE
17264          XM1 = AAM(IDHPR)
17265          XM2 = AAM(IDHTA)
17266          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17267          IF (IREJ1.GT.0) THEN
17268             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
17269             GOTO 9999
17270          ENDIF
17271          DO 2 K=1,4
17272             PPR(K) = P1OUT(K)
17273             PTA(K) = P2OUT(K)
17274     2    CONTINUE
17275          PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
17276          PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
17277       ENDIF
17278
17279 * Lorentz-parameter for trafo into rest-system of target
17280       DO 3 K=1,4
17281          BGTA(K) = PTA(K)/PTA(5)
17282     3 CONTINUE
17283 * transformation of projectile into rest-system of target
17284       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
17285      &            PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
17286      &            PPR1(4))
17287
17288 * direction cosines of projectile in target rest system
17289       CX = PPR1(1)/PPRTO1
17290       CY = PPR1(2)/PPRTO1
17291       CZ = PPR1(3)/PPRTO1
17292
17293 * sample inelastic interaction
17294       IF (MODE.EQ.1) THEN
17295          CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
17296          IF (IRH.EQ.1) GOTO 9998
17297 * sample elastic interaction
17298       ELSEIF (MODE.EQ.2) THEN
17299          CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
17300          IF (IREJ1.NE.0) THEN
17301             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
17302             GOTO 9999
17303          ENDIF
17304          IF (IRH.EQ.1) GOTO 9998
17305       ELSE
17306          WRITE(LOUT,1001) MODE,INTHAD
17307  1001    FORMAT(1X,'HADRIN:   warning! inconsistent interaction mode',
17308      &          I4,' (INTHAD =',I4,')')
17309          GOTO 9999
17310       ENDIF
17311
17312 * transform final state particles back into Lab.
17313       DO 4 I=1,IRH
17314          NFSP = NFSP+1
17315          PX   = CXRH(I)*PLRH(I)
17316          PY   = CYRH(I)*PLRH(I)
17317          PZ   = CZRH(I)*PLRH(I)
17318          CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
17319      &               PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
17320      &               PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
17321          IDFSP(NFSP) = ITRH(I)
17322          AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
17323      &                                            PFSP(3,NFSP)**2
17324          IF (AMFSP2.LT.-TINY3) THEN
17325             WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
17326      &                       PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
17327  1002       FORMAT(1X,'HADRIN:   warning! final state particle (id = ',
17328      &             I2,') with negative mass^2',/,1X,5E12.4)
17329             GOTO 9999
17330          ELSE
17331             PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
17332             IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
17333                WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
17334      &                          PFSP(5,NFSP)
17335  1003          FORMAT(1X,'HADRIN:   warning! final state particle',
17336      &                ' (id = ',I2,') with inconsistent mass',/,1X,
17337      &                2E12.4)
17338                KCORR         = KCORR+1
17339                IF (KCORR.GT.2) GOTO 9999
17340                IMCORR(KCORR) = NFSP
17341             ENDIF
17342          ENDIF
17343 *   dump final state particles for energy-momentum cons. check
17344          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17345      &                           -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17346     4 CONTINUE
17347
17348 * transform momenta on mass shell in case of inconsistencies in
17349 * HADRIN
17350       IF (KCORR.GT.0) THEN
17351          IF (KCORR.EQ.2) THEN
17352             I1 = IMCORR(1)
17353             I2 = IMCORR(2)
17354          ELSE
17355             IF (IMCORR(1).EQ.1) THEN
17356                I1 = 1
17357                I2 = 2
17358             ELSE
17359                I1 = 1
17360                I2 = IMCORR(1)
17361             ENDIF
17362          ENDIF
17363          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
17364      &                           PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
17365          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
17366      &                           PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
17367          DO 5 K=1,4
17368             P1IN(K) = PFSP(K,I1)
17369             P2IN(K) = PFSP(K,I2)
17370     5    CONTINUE
17371          XM1 = AAM(IDFSP(I1))
17372          XM2 = AAM(IDFSP(I2))
17373          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17374          IF (IREJ1.GT.0) THEN
17375             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
17376 C           GOTO 9999
17377          ENDIF
17378          DO 6 K=1,4
17379             PFSP(K,I1) = P1OUT(K)
17380             PFSP(K,I2) = P2OUT(K)
17381     6    CONTINUE
17382          PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
17383      &                    -PFSP(2,I1)**2-PFSP(3,I1)**2)
17384          PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
17385      &                    -PFSP(2,I2)**2-PFSP(3,I2)**2)
17386 *   dump final state particles for energy-momentum cons. check
17387          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
17388      &                           -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
17389          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
17390      &                           -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
17391       ENDIF
17392
17393 * check energy-momentum conservation
17394       IF (LEMCCK) THEN
17395          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
17396          IF (IREJ1.NE.0) GOTO 9999
17397       ENDIF
17398
17399       RETURN
17400
17401  9998 CONTINUE
17402       IREJ = 2
17403       RETURN
17404
17405  9999 CONTINUE
17406       IREJ = 1
17407       RETURN
17408       END
17409
17410 *$ CREATE DT_HADCOL.FOR
17411 *COPY DT_HADCOL
17412 *
17413 *===hadcol=============================================================*
17414 *
17415       SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
17416
17417 ************************************************************************
17418 * Interface to the HADRIN-routines for inelastic and elastic           *
17419 * scattering. This subroutine samples hadron-nucleus interactions      *
17420 * below DPM-threshold.                                                 *
17421 *      IDPROJ        BAMJET-index of projectile hadron                 *
17422 *      PPN           projectile momentum in target rest frame          *
17423 *      IDXTAR        DTEVT1-index of target nucleon undergoing         *
17424 *                    interaction with projectile hadron                *
17425 * This subroutine replaces HADHAD.                                     *
17426 * This version dated 5.5.95 is written by S. Roesler                   *
17427 ************************************************************************
17428
17429       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17430       SAVE
17431       PARAMETER ( LINP = 10 ,
17432      &            LOUT = 6 ,
17433      &            LDAT = 9 )
17434       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
17435
17436       LOGICAL LSTART
17437
17438 * event history
17439       PARAMETER (NMXHKK=200000)
17440       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17441      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17442      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17443 * extended event history
17444       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17445      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17446      &                IHIST(2,NMXHKK)
17447 * nuclear potential
17448       LOGICAL LFERMI
17449       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17450      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17451      &                ETACOU(2),ICOUL,LFERMI
17452 * interface HADRIN-DPM
17453       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
17454 * parameter for intranuclear cascade
17455       LOGICAL LPAULI
17456       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17457 * final state after inc step
17458       PARAMETER (MAXFSP=10)
17459       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17460 * particle properties (BAMJET index convention)
17461       CHARACTER*8  ANAME
17462       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17463      &                IICH(210),IIBAR(210),K1(210),K2(210)
17464
17465       DIMENSION PPROJ(5),PNUC(5)
17466
17467       DATA LSTART /.TRUE./
17468
17469       IREJ   = 0
17470
17471       NPOINT(1) = NHKK+1
17472
17473       TAUSAV = TAUFOR
17474 **sr 6/9/01 commented
17475 C     TAUFOR = TAUFOR/2.0D0
17476 **
17477       IF (LSTART) THEN
17478          WRITE(LOUT,1000)
17479  1000    FORMAT(/,1X,'HADCOL:  Scattering handled by HADRIN')
17480          WRITE(LOUT,1001) TAUFOR
17481  1001    FORMAT(/,1X,'HADCOL:  Formation zone parameter set to ',
17482      &          F5.1,' fm/c')
17483          LSTART = .FALSE.
17484       ENDIF
17485
17486       IDNUC  = IDBAM(IDXTAR)
17487       IDNUC1 = IDT_MCHAD(IDNUC)
17488       IDPRO1 = IDT_MCHAD(IDPROJ)
17489
17490       IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
17491          IPROC = INTHAD
17492       ELSE
17493 **
17494 C        CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
17495 C        CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
17496          DUMZER = ZERO
17497          CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
17498          SIGIN = SIGTOT-SIGEL
17499 C        SIGTOT = SIGIN+SIGEL
17500 **
17501          IPROC  = 1
17502          IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
17503       ENDIF
17504
17505       PPROJ(1) = ZERO
17506       PPROJ(2) = ZERO
17507       PPROJ(3) = PPN
17508       PPROJ(5) = AAM(IDPROJ)
17509       PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
17510       DO 1 K=1,5
17511          PNUC(K)  = PHKK(K,IDXTAR)
17512     1 CONTINUE
17513
17514       ILOOP = 0
17515     2 CONTINUE
17516       ILOOP = ILOOP+1
17517       IF (ILOOP.GT.100) GOTO 9999
17518
17519       CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
17520       IF (IREJ1.EQ.1) GOTO 9999
17521
17522       IF (IREJ1.GT.1) THEN
17523 * no interaction possible
17524 *   require Pauli blocking
17525          IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
17526          IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
17527          IF ((IIBAR(IDPROJ).NE.1).AND.
17528      &       (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5)))              GOTO 2
17529 *   store incoming particle as final state particle
17530          CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
17531          CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
17532          NPOINT(4) = NHKK
17533       ELSE
17534 * require Pauli blocking for final state nucleons
17535          DO 4 I=1,NFSP
17536             IF ((IDFSP(I).EQ.1).AND.
17537      &          (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I))))       GOTO 2
17538             IF ((IDFSP(I).EQ.8).AND.
17539      &          (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I))))       GOTO 2
17540             IF ((IIBAR(IDFSP(I)).NE.1).AND.
17541      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
17542     4    CONTINUE
17543 * store final state particles
17544          DO 5 I=1,NFSP
17545             IST = 1
17546             IF ((IIBAR(IDFSP(I)).EQ.1).AND.
17547      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
17548             IDHAD = IDT_IPDGHA(IDFSP(I))
17549             CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
17550             CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
17551      &                                        PCMS,ECMS,0,0,0)
17552             IF (I.EQ.1) NPOINT(4) = NHKK
17553             VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
17554             VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
17555             VHKK(3,NHKK) = VHKK(3,IDXTAR)
17556             VHKK(4,NHKK) = VHKK(4,IDXTAR)
17557             WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
17558             WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
17559             WHKK(3,NHKK) = WHKK(3,1)
17560             WHKK(4,NHKK) = WHKK(4,1)
17561     5    CONTINUE
17562       ENDIF
17563       TAUFOR = TAUSAV
17564       RETURN
17565
17566  9999 CONTINUE
17567       IREJ = 1
17568       TAUFOR = TAUSAV
17569       RETURN
17570       END
17571
17572 *$ CREATE DT_GETEMU.FOR
17573 *COPY DT_GETEMU
17574 *
17575 *===getemu=============================================================*
17576 *
17577       SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
17578
17579 ************************************************************************
17580 * Sampling of emulsion component to be considered as target-nucleus.   *
17581 * This version dated 6.5.95   is written by S. Roesler.                *
17582 ************************************************************************
17583
17584       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17585       SAVE
17586       PARAMETER ( LINP = 10 ,
17587      &            LOUT = 6 ,
17588      &            LDAT = 9 )
17589       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
17590
17591       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
17592 * emulsion treatment
17593       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
17594      &                NCOMPO,IEMUL
17595 * Glauber formalism: flags and parameters for statistics
17596       LOGICAL LPROD
17597       CHARACTER*8 CGLB
17598       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
17599
17600       IF (MODE.EQ.0) THEN
17601          SUMFRA = ZERO
17602          RR = DT_RNDM(SUMFRA)
17603          IT  = 0
17604          ITZ = 0
17605          DO 1 ICOMP=1,NCOMPO
17606             SUMFRA = SUMFRA+EMUFRA(ICOMP)
17607             IF (SUMFRA.GT.RR) THEN
17608                IT    = IEMUMA(ICOMP)
17609                ITZ   = IEMUCH(ICOMP)
17610                KKMAT = ICOMP
17611                GOTO 2
17612             ENDIF
17613     1    CONTINUE
17614     2    CONTINUE
17615          IF (IT.LE.0) THEN
17616             WRITE(LOUT,'(1X,A,E12.3)')
17617      &       'Warning!  norm. failure within emulsion fractions',
17618      &       SUMFRA
17619             STOP
17620          ENDIF
17621       ELSEIF (MODE.EQ.1) THEN
17622          NDIFF = 10000
17623          DO 3 I=1,NCOMPO
17624             IDIFF = ABS(IT-IEMUMA(I))
17625             IF (IDIFF.LT.NDIFF) THEN
17626                KKMAT = I
17627                NDIFF = IDIFF
17628             ENDIF
17629     3    CONTINUE
17630       ELSE
17631          STOP 'DT_GETEMU'
17632       ENDIF
17633
17634 * bypass for variable projectile/target/energy runs: the correct
17635 * Glauber data will be always loaded on kkmat=1
17636       IF (IOGLB.EQ.100) THEN
17637          KKMAT = 1
17638       ENDIF
17639
17640       RETURN
17641       END
17642
17643 *$ CREATE DT_NCLPOT.FOR
17644 *COPY DT_NCLPOT
17645 *
17646 *===nclpot=============================================================*
17647 *
17648       SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
17649
17650 ************************************************************************
17651 * Calculation of Coulomb and nuclear potential for a given configurat. *
17652 *               IPZ, IP       charge/mass number of proj.              *
17653 *               ITZ, IT       charge/mass number of targ.              *
17654 *               AFERP,AFERT   factors modifying proj./target pot.      *
17655 *                             if =0, FERMOD is used                    *
17656 *               MODE = 0      calculation of binding energy            *
17657 *                    = 1      pre-calculated binding energy is used    *
17658 * This version dated 16.11.95  is written by S. Roesler.               *
17659 *                                                                      *
17660 * Last change 28.12.2006 by S. Roesler.                                *
17661 ************************************************************************
17662
17663       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17664       SAVE
17665       PARAMETER ( LINP = 10 ,
17666      &            LOUT = 6 ,
17667      &            LDAT = 9 )
17668       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
17669      &           TINY10=1.0D-10)
17670
17671       LOGICAL LSTART
17672
17673 * particle properties (BAMJET index convention)
17674       CHARACTER*8  ANAME
17675       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17676      &                IICH(210),IIBAR(210),K1(210),K2(210)
17677 * nuclear potential
17678       LOGICAL LFERMI
17679       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17680      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17681      &                ETACOU(2),ICOUL,LFERMI
17682
17683       DIMENSION IDXPOT(14)
17684 *                   ap   an  lam  alam sig- sig+ sig0 tet0 tet- asig-
17685       DATA IDXPOT /   2,   9,  17,  18,  20,  21,  22,  97,  98,  99,
17686 *                 asig0 asig+ atet0 atet+
17687      &              100, 101, 102, 103/
17688
17689       DATA AN     /0.4D0/
17690       DATA LSTART /.TRUE./
17691
17692       IF (MODE.EQ.0) THEN
17693          EBINDP(1) = ZERO
17694          EBINDN(1) = ZERO
17695          EBINDP(2) = ZERO
17696          EBINDN(2) = ZERO
17697       ENDIF
17698       AIP  = DBLE(IP)
17699       AIPZ = DBLE(IPZ)
17700       AIT  = DBLE(IT)
17701       AITZ = DBLE(ITZ)
17702
17703       FERMIP = AFERP
17704       IF (AFERP.LE.ZERO) FERMIP = FERMOD
17705       FERMIT = AFERT
17706       IF (AFERT.LE.ZERO) FERMIT = FERMOD
17707
17708 * Fermi momenta and binding energy for projectile
17709       IF ((IP.GT.1).AND.LFERMI) THEN
17710          IF (MODE.EQ.0) THEN
17711 C           EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
17712 C           EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
17713             BIP  = AIP -ONE
17714             BIPZ = AIPZ-ONE
17715             EBINDP(1) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIP,BIPZ)
17716      &                                            -DT_ENERGY(AIP,AIPZ))
17717             IF (AIP.LE.AIPZ) THEN
17718                EBINDN(1) = EBINDP(1)
17719                WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
17720             ELSE
17721                EBINDN(1) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17722      &                     +DT_ENERGY(BIP,AIPZ)-DT_ENERGY(AIP,AIPZ))
17723             ENDIF
17724          ENDIF
17725          PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
17726          PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
17727       ELSE
17728          PFERMP(1) = ZERO
17729          PFERMN(1) = ZERO
17730       ENDIF
17731 * effective nuclear potential for projectile
17732 C     EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
17733 C     EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
17734       EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
17735       EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
17736
17737 * Fermi momenta and binding energy for target
17738       IF ((IT.GT.1).AND.LFERMI) THEN
17739          IF (MODE.EQ.0) THEN
17740 C           EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
17741 C           EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
17742             BIT  = AIT -ONE
17743             BITZ = AITZ-ONE
17744
17745             EBINDP(2) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIT,BITZ)
17746      &                                            -DT_ENERGY(AIT,AITZ))
17747
17748             IF (AIT.LE.AITZ) THEN
17749                EBINDN(2) = EBINDP(2)
17750                WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
17751             ELSE
17752
17753                EBINDN(2) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17754      &                     +DT_ENERGY(BIT,AITZ)-DT_ENERGY(AIT,AITZ))
17755
17756             ENDIF
17757          ENDIF
17758          PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
17759          PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
17760       ELSE
17761          PFERMP(2) = ZERO
17762          PFERMN(2) = ZERO
17763       ENDIF
17764 * effective nuclear potential for target
17765 C     EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
17766 C     EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
17767       EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
17768       EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
17769
17770       DO 2 I=1,14
17771          EPOT(1,IDXPOT(I)) = EPOT(1,8)
17772          EPOT(2,IDXPOT(I)) = EPOT(2,8)
17773     2 CONTINUE
17774
17775 * Coulomb energy
17776       ETACOU(1) = ZERO
17777       ETACOU(2) = ZERO
17778       IF (ICOUL.EQ.1) THEN
17779          IF (IP.GT.1)
17780      &   ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
17781          IF (IT.GT.1)
17782      &   ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
17783       ENDIF
17784
17785       IF (LSTART) THEN
17786          WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
17787      &                    EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
17788      &                    EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
17789      &                    FERMOD,ETACOU
17790  1000    FORMAT(/,/,1X,'NCLPOT:    quantities for inclusion of nuclear'
17791      &           ,' effects',/,12X,'---------------------------',
17792      &           '----------------',/,/,38X,'projectile',
17793      &           '      target',/,/,1X,'Mass number / charge',
17794      &           17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy  -',
17795      &           ' proton   (GeV) ',2E14.4,/,17X,'- neutron  (GeV)'
17796      &          ,1X,2E14.4,/,1X,'Fermi-potential - proton   (GeV)',
17797      &           1X,2E14.4,/,17X,'- neutron  (GeV) ',2E14.4,/,/,
17798      &           1X,'Scale factor for Fermi-momentum    ',F4.2,/,
17799      &           /,1X,'Coulomb-energy ',2(E14.4,' GeV  '),/,/)
17800          LSTART = .FALSE.
17801       ENDIF
17802
17803       RETURN
17804       END
17805
17806 *$ CREATE DT_RESNCL.FOR
17807 *COPY DT_RESNCL
17808 *
17809 *===resncl=============================================================*
17810 *
17811       SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
17812
17813 ************************************************************************
17814 * Treatment of residual nuclei and nuclear effects.                    *
17815 *         MODE = 1     initializations                                 *
17816 *              = 2     treatment of final state                        *
17817 * This version dated 16.11.95 is written by S. Roesler.                *
17818 *                                                                      *
17819 * Last change 05.01.2007 by S. Roesler.                                *
17820 ************************************************************************
17821
17822       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17823       SAVE
17824       PARAMETER ( LINP = 10 ,
17825      &            LOUT = 6 ,
17826      &            LDAT = 9 )
17827       PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
17828      &           TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
17829      &           ONETHI=ONE/THREE)
17830       PARAMETER (AMUAMU = 0.93149432D0,
17831      &           FM2MM  = 1.0D-12,
17832      &           RNUCLE = 1.12D0)
17833       PARAMETER ( EMVGEV = 1.0                D-03 )
17834       PARAMETER ( AMUGEV = 0.93149432         D+00 )
17835       PARAMETER ( AMPRTN = 0.93827231         D+00 )
17836       PARAMETER ( AMNTRN = 0.93956563         D+00 )
17837       PARAMETER ( AMELCT = 0.51099906         D-03 )
17838       PARAMETER ( HLFHLF = 0.5D+00 )
17839       PARAMETER ( FERTHO = 14.33       D-09 )
17840       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
17841       PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
17842       PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
17843
17844 * event history
17845       PARAMETER (NMXHKK=200000)
17846       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17847      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17848      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17849 * extended event history
17850       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17851      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17852      &                IHIST(2,NMXHKK)
17853 * particle properties (BAMJET index convention)
17854       CHARACTER*8  ANAME
17855       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17856      &                IICH(210),IIBAR(210),K1(210),K2(210)
17857 * flags for input different options
17858       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17859       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17860      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17861 * nuclear potential
17862       LOGICAL LFERMI
17863       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17864      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17865      &                ETACOU(2),ICOUL,LFERMI
17866 * properties of interacting particles
17867       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
17868 * properties of photon/lepton projectiles
17869       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
17870 * Lorentz-parameters of the current interaction
17871       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
17872      &                UMO,PPCM,EPROJ,PPROJ
17873 * treatment of residual nuclei: wounded nucleons
17874       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
17875 * treatment of residual nuclei: 4-momenta
17876       LOGICAL LRCLPR,LRCLTA
17877       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
17878      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
17879
17880       DIMENSION PFSP(4),PSEC(4),PSEC0(4)
17881       DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
17882      &          IDXCOR(15000),IDXOTH(NMXHKK)
17883
17884       GOTO (1,2) MODE
17885
17886 *------- initializations
17887     1 CONTINUE
17888
17889 * initialize arrays for residual nuclei
17890       DO 10 K=1,5
17891          IF (K.LE.4) THEN
17892             PFSP(K)     = ZERO
17893          ENDIF
17894          PINIPR(K) = ZERO
17895          PINITA(K) = ZERO
17896          PRCLPR(K) = ZERO
17897          PRCLTA(K) = ZERO
17898          TRCLPR(K) = ZERO
17899          TRCLTA(K) = ZERO
17900    10 CONTINUE
17901       SCPOT = ONE
17902       NLOOP = 0
17903
17904 * correction of projectile 4-momentum for effective target pot.
17905 * and Coulomb-energy (in case of hadron-nucleus interaction only)
17906       IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
17907          EPNI = EPN
17908 *   Coulomb-energy:
17909 *     positively charged hadron - check energy for Coloumb pot.
17910          IF (IICH(IJPROJ).EQ.1) THEN
17911             THRESH = ETACOU(2)+AAM(IJPROJ)
17912             IF (EPNI.LE.THRESH) THEN
17913                WRITE(LOUT,1000)
17914  1000          FORMAT(/,1X,'KKINC:  WARNING!  projectile energy',
17915      &                ' below Coulomb threshold - event rejected',/)
17916                ISTHKK(1) = 1
17917                RETURN
17918             ENDIF
17919 *     negatively charged hadron - increase energy by Coulomb energy
17920          ELSEIF (IICH(IJPROJ).EQ.-1) THEN
17921             EPNI = EPNI+ETACOU(2)
17922          ENDIF
17923          IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
17924 *   Effective target potential
17925 *sr 6.6. binding energy only (to avoid negative exc. energies)
17926 C           EPNI = EPNI+EPOT(2,IJPROJ)
17927             EBIPOT = EBINDP(2)
17928             IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
17929      &         EBIPOT = EBINDN(2)
17930             EPNI = EPNI+ABS(EBIPOT)
17931 * re-initialization of DTLTRA
17932             DUM1 = ZERO
17933             DUM2 = ZERO
17934             CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
17935          ENDIF
17936       ENDIF
17937
17938 * projectile in n-n cms
17939       IF ((IP.LE.1).AND.(IT.GT.1)) THEN
17940          PMASS1 = AAM(IJPROJ)
17941 C* VDM assumption
17942 C         IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
17943          IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
17944          PMASS2 = AAM(1)
17945          PM1 = SIGN(PMASS1**2,PMASS1)
17946          PM2 = SIGN(PMASS2**2,PMASS2)
17947          PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
17948          PINIPR(5) = PMASS1
17949          IF (PMASS1.GT.ZERO) THEN
17950             PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
17951      &                      *(PINIPR(4)+PINIPR(5)))
17952          ELSE
17953             PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
17954          ENDIF
17955          AIT  = DBLE(IT)
17956          AITZ = DBLE(ITZ)
17957          PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
17958          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
17959       ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
17960          PMASS1 = AAM(1)
17961          PMASS2 = AAM(IJTARG)
17962          PM1 = SIGN(PMASS1**2,PMASS1)
17963          PM2 = SIGN(PMASS2**2,PMASS2)
17964          PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
17965          PINITA(5) = PMASS2
17966          PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
17967      &                    *(PINITA(4)+PINITA(5)))
17968          AIP  = DBLE(IP)
17969          AIPZ = DBLE(IPZ)
17970          PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
17971          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
17972       ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
17973          AIP  = DBLE(IP)
17974          AIPZ = DBLE(IPZ)
17975          PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
17976          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
17977          AIT  = DBLE(IT)
17978          AITZ = DBLE(ITZ)
17979          PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
17980          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
17981       ENDIF
17982
17983       RETURN
17984
17985 *------- treatment of final state
17986     2 CONTINUE
17987
17988       NLOOP = NLOOP+1
17989       IF (NLOOP.GT.1) SCPOT = 0.10D0
17990 C     WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
17991
17992       JPW  = NPW
17993       JPCW = NPCW
17994       JTW  = NTW
17995       JTCW = NTCW
17996       DO 40 K=1,4
17997          PFSP(K)   = ZERO
17998    40 CONTINUE
17999
18000       NOB = 0
18001       NOM = 0
18002       DO 900 I=NPOINT(4),NHKK
18003          IDXOTH(I) = -1
18004          IF (ISTHKK(I).EQ.1) THEN
18005             IF (IDBAM(I).EQ.7) GOTO 900
18006             IPOT = 0
18007             IOTHER = 0
18008 * particle moving into forward direction
18009             IF (PHKK(3,I).GE.ZERO) THEN
18010 *   most likely to be effected by projectile potential
18011                IPOT = 1
18012 *     there is no projectile nucleus, try target
18013                IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18014                   IPOT   = 2
18015                   IF (IP.GT.1) IOTHER = 1
18016 *       there is no target nucleus --> skip
18017                   IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18018                ENDIF
18019 * particle moving into backward direction
18020             ELSE
18021 *   most likely to be effected by target potential
18022                IPOT = 2
18023 *     there is no target nucleus, try projectile
18024                IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18025                   IPOT   = 1
18026                   IF (IT.GT.1) IOTHER = 1
18027 *       there is no projectile nucleus --> skip
18028                   IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18029                ENDIF
18030             ENDIF
18031             IFLG = -IPOT
18032 * nobam=3: particle is in overlap-region or neither inside proj. nor target
18033 *      =1: particle is not in overlap-region AND is inside target (2)
18034 *      =2: particle is not in overlap-region AND is inside projectile (1)
18035 * flag particles which are inside the nucleus ipot but not in its
18036 * overlap region
18037             IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
18038             IF (IDBAM(I).NE.0) THEN
18039 * baryons: keep all nucleons and all others where flag is set
18040                IF (IIBAR(IDBAM(I)).NE.0) THEN
18041                   IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
18042      &                                                              THEN
18043                      NOB = NOB+1
18044                      PMOMB(NOB) = PHKK(3,I)
18045                      IDXB(NOB)  = SIGN(10000000*IABS(IFLG)
18046      &                           +1000000*IOTHER+I,IFLG)
18047                   ENDIF
18048 * mesons: keep only those mesons where flag is set
18049                ELSE
18050                   IF (IFLG.GT.0) THEN
18051                      NOM = NOM+1
18052                      PMOMM(NOM) = PHKK(3,I)
18053                      IDXM(NOM)  = 10000000*IFLG+1000000*IOTHER+I
18054                   ENDIF
18055                ENDIF
18056             ENDIF
18057          ENDIF
18058   900 CONTINUE
18059 *
18060 * sort particles in the arrays according to increasing long. momentum
18061       CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
18062       CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
18063 *
18064 * shuffle indices into one and the same array according to the later
18065 * sequence of correction
18066       NCOR = 0
18067       IF (IT.GT.1) THEN
18068          DO 910 I=1,NOB
18069             IF (PMOMB(I).GT.ZERO) GOTO 911
18070             NCOR = NCOR+1
18071             IDXCOR(NCOR) = IDXB(I)
18072   910    CONTINUE
18073   911    CONTINUE
18074          IF (IP.GT.1) THEN
18075             DO 912 J=1,NOB
18076                I = NOB+1-J
18077                IF (PMOMB(I).LT.ZERO) GOTO 913
18078                NCOR = NCOR+1
18079                IDXCOR(NCOR) = IDXB(I)
18080   912       CONTINUE
18081   913       CONTINUE
18082          ELSE
18083             DO 914 I=1,NOB
18084                IF (PMOMB(I).GT.ZERO) THEN
18085                   NCOR = NCOR+1
18086                   IDXCOR(NCOR) = IDXB(I)
18087                ENDIF
18088   914       CONTINUE
18089          ENDIF
18090       ELSE
18091          DO 915 J=1,NOB
18092             I = NOB+1-J
18093             NCOR = NCOR+1
18094             IDXCOR(NCOR) = IDXB(I)
18095   915    CONTINUE
18096       ENDIF
18097       DO 925 I=1,NOM
18098          IF (PMOMM(I).GT.ZERO) GOTO 926
18099          NCOR = NCOR+1
18100          IDXCOR(NCOR) = IDXM(I)
18101   925 CONTINUE
18102   926 CONTINUE
18103       DO 927 J=1,NOM
18104          I = NOM+1-J
18105          IF (PMOMM(I).LT.ZERO) GOTO 928
18106          NCOR = NCOR+1
18107          IDXCOR(NCOR) = IDXM(I)
18108   927 CONTINUE
18109   928 CONTINUE
18110 *
18111 C      IF (NEVHKK.EQ.484) THEN
18112 C         WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
18113 C 9000    FORMAT(1X,'wounded nucleons (proj.-p,n  targ.-p,n)',/,4I10)
18114 C         WRITE(LOUT,9001) NOB,NOM,NCOR
18115 C 9001    FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
18116 C         WRITE(LOUT,'(/,A)') ' baryons '
18117 C         DO 950 I=1,NOB
18118 CC           J     = IABS(IDXB(I))
18119 CC           INDEX = J-IABS(J/10000000)*10000000
18120 C            IPOT   = IABS(IDXB(I))/10000000
18121 C            IOTHER = IABS(IDXB(I))/1000000-IPOT*10
18122 C            INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
18123 C            WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
18124 C  950    CONTINUE
18125 C         WRITE(LOUT,'(/,A)') ' mesons '
18126 C         DO 951 I=1,NOM
18127 CC           INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
18128 C            IPOT   = IABS(IDXM(I))/10000000
18129 C            IOTHER = IABS(IDXM(I))/1000000-IPOT*10
18130 C            INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
18131 C            WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
18132 C  951    CONTINUE
18133 C 9002    FORMAT(1X,4I14,E14.5)
18134 C         WRITE(LOUT,'(/,A)') ' all '
18135 C         DO 952 I=1,NCOR
18136 CC           J     = IABS(IDXCOR(I))
18137 CC           INDEX = J-IABS(J/10000000)*10000000
18138 CC            IPOT   = IABS(IDXCOR(I))/10000000
18139 C            IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
18140 C            INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
18141 C            WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
18142 C  952    CONTINUE
18143 C 9003    FORMAT(1X,4I14)
18144 C      ENDIF
18145 *
18146       DO 20 ICOR=1,NCOR
18147          IPOT   = IABS(IDXCOR(ICOR))/10000000
18148          IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
18149          I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
18150          IDXOTH(I) = 1
18151
18152          IDSEC  = IDBAM(I)
18153
18154 * reduction of particle momentum by corresponding nuclear potential
18155 * (this applies only if Fermi-momenta are requested)
18156
18157          IF (LFERMI) THEN
18158
18159 *   Lorentz-transformation into the rest system of the selected nucleus
18160             IMODE = -IPOT-1
18161             CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18162      &                  PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
18163             PSECO  = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
18164             AMSEC  = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
18165             JPMOD  = 0
18166
18167             CHKLEV = TINY3
18168             IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
18169             IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
18170             IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
18171                IF (IOULEV(3).GT.0)
18172      &            WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
18173  2000          FORMAT(1X,'RESNCL: inconsistent mass of particle',
18174      &                ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
18175      &                I4,'   AMSEC: ',E12.3,'  AAM(IDSEC): ',E12.3,/)
18176                GOTO 23
18177             ENDIF
18178
18179             DO 21 K=1,4
18180                PSEC0(K) = PSEC(K)
18181    21       CONTINUE
18182
18183 *   the correction for nuclear potential effects is applied to as many
18184 *   p/n as many nucleons were wounded; the momenta of other final state
18185 *   particles are corrected only if they materialize inside the corresp.
18186 *   nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
18187 *   = 3 part. outside proj. and targ., >=10 in overlapping region)
18188             IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
18189                IF (IPOT.EQ.1) THEN
18190                   IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
18191 *      this is most likely a wounded nucleon
18192 **test
18193 C                    RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
18194 C    &                           +(VHKK(2,IPW(JPW))/FM2MM)**2
18195 C    &                           +(VHKK(3,IPW(JPW))/FM2MM)**2)
18196 C                    RAD   = RNUCLE*DBLE(IP)**ONETHI
18197 C                    FDEN  = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
18198 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18199 **
18200                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18201                      JPW = JPW-1
18202                      JPMOD = 1
18203                   ELSE
18204 *      correct only if part. was materialized inside nucleus
18205 *      and if it is ouside the overlapping region
18206                      IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
18207                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18208                         JPMOD = 1
18209                      ENDIF
18210                   ENDIF
18211                ELSEIF (IPOT.EQ.2) THEN
18212                   IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
18213 *      this is most likely a wounded nucleon
18214 **test
18215 C                    RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
18216 C    &                           +(VHKK(2,ITW(JTW))/FM2MM)**2
18217 C    &                           +(VHKK(3,ITW(JTW))/FM2MM)**2)
18218 C                    RAD   = RNUCLE*DBLE(IT)**ONETHI
18219 C                    FDEN  = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
18220 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18221 **
18222                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18223                      JTW = JTW-1
18224                      JPMOD = 1
18225                   ELSE
18226 *      correct only if part. was materialized inside nucleus
18227                      IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
18228                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18229                         JPMOD = 1
18230                      ENDIF
18231                   ENDIF
18232                ENDIF
18233             ELSE
18234                IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
18235                   PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18236                   JPMOD = 1
18237                ENDIF
18238             ENDIF
18239
18240             IF (NLOOP.EQ.1) THEN
18241 * Coulomb energy correction:
18242 * the treatment of Coulomb potential correction is similar to the
18243 * one for nuclear potential
18244                IF (IDSEC.EQ.1) THEN
18245                   IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
18246                      JPCW = JPCW-1
18247                   ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
18248                      JTCW = JTCW-1
18249                   ELSE
18250                      IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18251                   ENDIF
18252                ELSE
18253                   IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18254                ENDIF
18255                IF (IICH(IDSEC).EQ.1) THEN
18256 *    pos. particles: check if they are able to escape Coulomb potential
18257                   IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
18258                      ISTHKK(I) = 14+IPOT
18259                      IF (ISTHKK(I).EQ.15) THEN
18260                         DO 26 K=1,4
18261                            PHKK(K,I) = PSEC0(K)
18262                            TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18263    26                CONTINUE
18264                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18265                         IF (IDSEC.EQ.1) NPCW = NPCW-1
18266                      ELSEIF (ISTHKK(I).EQ.16) THEN
18267                         DO 27 K=1,4
18268                            PHKK(K,I) = PSEC0(K)
18269                            TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18270    27                   CONTINUE
18271                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18272                         IF (IDSEC.EQ.1) NTCW = NTCW-1
18273                      ENDIF
18274                      GOTO 20
18275                   ENDIF
18276                ELSEIF (IICH(IDSEC).EQ.-1) THEN
18277 *    neg. particles: decrease energy by Coulomb-potential
18278                   PSEC(4) = PSEC(4)-ETACOU(IPOT)
18279                   JPMOD = 1
18280                ENDIF
18281             ENDIF
18282
18283    25       CONTINUE
18284
18285             IF (PSEC(4).LT.AMSEC) THEN
18286                IF (IOULEV(6).GT.0)
18287      &            WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
18288  2001          FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
18289      &                ' is not allowed to escape nucleus',/,
18290      &                8X,'id : ',I3,'   reduced energy: ',E15.4,
18291      &                '   mass: ',E12.3)
18292                ISTHKK(I) = 14+IPOT
18293                IF (ISTHKK(I).EQ.15) THEN
18294                   DO 28 K=1,4
18295                      PHKK(K,I) = PSEC0(K)
18296                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18297    28             CONTINUE
18298                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18299                   IF (IDSEC.EQ.1) NPCW = NPCW-1
18300                ELSEIF (ISTHKK(I).EQ.16) THEN
18301                   DO 29 K=1,4
18302                      PHKK(K,I) = PSEC0(K)
18303                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18304    29             CONTINUE
18305                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18306                   IF (IDSEC.EQ.1) NTCW = NTCW-1
18307                ENDIF
18308                GOTO 20
18309             ENDIF
18310
18311             IF (JPMOD.EQ.1) THEN
18312                PSECN  = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
18313 * 4-momentum after correction for nuclear potential
18314                DO 22 K=1,3
18315                   PSEC(K) = PSEC(K)*PSECN/PSECO
18316    22          CONTINUE
18317
18318 * store recoil momentum from particles escaping the nuclear potentials
18319                DO 30 K=1,4
18320                   IF (IPOT.EQ.1) THEN
18321                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
18322                   ELSEIF (IPOT.EQ.2) THEN
18323                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
18324                   ENDIF
18325    30          CONTINUE
18326
18327 * transform momentum back into n-n cms
18328                IMODE = IPOT+1
18329                CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
18330      &                     PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18331      &                     IDSEC,IMODE)
18332             ENDIF
18333
18334          ENDIF
18335
18336    23    CONTINUE
18337          DO 31 K=1,4
18338             PFSP(K) = PFSP(K)+PHKK(K,I)
18339    31    CONTINUE
18340
18341    20 CONTINUE
18342
18343       DO 33 I=NPOINT(4),NHKK
18344          IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
18345             PFSP(1) = PFSP(1)+PHKK(1,I)
18346             PFSP(2) = PFSP(2)+PHKK(2,I)
18347             PFSP(3) = PFSP(3)+PHKK(3,I)
18348             PFSP(4) = PFSP(4)+PHKK(4,I)
18349          ENDIF
18350    33 CONTINUE
18351
18352       DO 34 K=1,5
18353          PRCLPR(K) = TRCLPR(K)
18354          PRCLTA(K) = TRCLTA(K)
18355    34 CONTINUE
18356
18357       IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18358 * hadron-nucleus interactions: get residual momentum from energy-
18359 * momentum conservation
18360          DO 32 K=1,4
18361             PRCLPR(K) = ZERO
18362             PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
18363    32    CONTINUE
18364       ELSE
18365 * nucleus-hadron, nucleus-nucleus: get residual momentum from
18366 * accumulated recoil momenta of particles leaving the spectators
18367 *   transform accumulated recoil momenta of residual nuclei into
18368 *   n-n cms
18369          PZI = PRCLPR(3)
18370          PEI = PRCLPR(4)
18371          CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
18372          PZI = PRCLTA(3)
18373          PEI = PRCLTA(4)
18374          CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
18375 C        IF (IP.GT.1) THEN
18376             PRCLPR(3) = PRCLPR(3)+PINIPR(3)
18377             PRCLPR(4) = PRCLPR(4)+PINIPR(4)
18378 C        ENDIF
18379          IF (IT.GT.1) THEN
18380             PRCLTA(3) = PRCLTA(3)+PINITA(3)
18381             PRCLTA(4) = PRCLTA(4)+PINITA(4)
18382          ENDIF
18383       ENDIF
18384
18385 * check momenta of residual nuclei
18386       IF (LEMCCK) THEN
18387          CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
18388      &               1,IDUM,IDUM)
18389          CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
18390      &               2,IDUM,IDUM)
18391          CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
18392      &               2,IDUM,IDUM)
18393          CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
18394      &               2,IDUM,IDUM)
18395          CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
18396 **sr 19.12. changed to avoid output when used with phojet
18397 C        CHKLEV = TINY3
18398          CHKLEV = TINY1
18399          CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
18400 C        IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
18401 C    &      CALL DT_EVTOUT(4)
18402          IF (IREJ1.GT.0) RETURN
18403       ENDIF
18404
18405       RETURN
18406       END
18407
18408 *$ CREATE DT_SCN4BA.FOR
18409 *COPY DT_SCN4BA
18410 *
18411 *===scn4ba=============================================================*
18412 *
18413       SUBROUTINE DT_SCN4BA
18414
18415 ************************************************************************
18416 * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot.    *
18417 * This version dated 12.12.95 is written by S. Roesler.                *
18418 ************************************************************************
18419
18420       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18421       SAVE
18422       PARAMETER ( LINP = 10 ,
18423      &            LOUT = 6 ,
18424      &            LDAT = 9 )
18425       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18426      &           TINY10=1.0D-10)
18427
18428 * event history
18429       PARAMETER (NMXHKK=200000)
18430       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18431      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18432      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18433 * extended event history
18434       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18435      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18436      &                IHIST(2,NMXHKK)
18437 * particle properties (BAMJET index convention)
18438       CHARACTER*8  ANAME
18439       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18440      &                IICH(210),IIBAR(210),K1(210),K2(210)
18441 * properties of interacting particles
18442       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18443 * nuclear potential
18444       LOGICAL LFERMI
18445       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18446      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18447      &                ETACOU(2),ICOUL,LFERMI
18448 * treatment of residual nuclei: wounded nucleons
18449       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18450 * treatment of residual nuclei: 4-momenta
18451       LOGICAL LRCLPR,LRCLTA
18452       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18453      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18454
18455       DIMENSION PLAB(2,5),PCMS(4)
18456
18457       IREJ = 0
18458
18459 * get number of wounded nucleons
18460       NPW    = 0
18461       NPW0   = 0
18462       NPCW   = 0
18463       NPSTCK = 0
18464       NTW    = 0
18465       NTW0   = 0
18466       NTCW   = 0
18467       NTSTCK = 0
18468
18469       ISGLPR = 0
18470       ISGLTA = 0
18471       LRCLPR = .FALSE.
18472       LRCLTA = .FALSE.
18473
18474 C     DO 2 I=1,NHKK
18475       DO 2 I=1,NPOINT(1)
18476 * projectile nucleons wounded in primary interaction and in fzc
18477          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
18478             NPW      = NPW+1
18479             IPW(NPW) = I
18480             NPSTCK   = NPSTCK+1
18481             IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
18482             IF (ISTHKK(I).EQ.11)  NPW0 = NPW0+1
18483 C           IF (IP.GT.1) THEN
18484                DO 5 K=1,4
18485                   TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
18486     5          CONTINUE
18487 C           ENDIF
18488 * target nucleons wounded in primary interaction and in fzc
18489          ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
18490             NTW      = NTW+1
18491             ITW(NTW) = I
18492             NTSTCK   = NTSTCK+1
18493             IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
18494             IF (ISTHKK(I).EQ.12)  NTW0 = NTW0+1
18495             IF (IT.GT.1) THEN
18496                DO 6 K=1,4
18497                   TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
18498     6          CONTINUE
18499             ENDIF
18500          ELSEIF (ISTHKK(I).EQ.13) THEN
18501             ISGLPR = I
18502          ELSEIF (ISTHKK(I).EQ.14) THEN
18503             ISGLTA = I
18504          ENDIF
18505     2 CONTINUE
18506
18507       DO 11 I=NPOINT(4),NHKK
18508 * baryons which are unable to escape the nuclear potential of proj.
18509          IF (ISTHKK(I).EQ.15) THEN
18510             ISGLPR = I
18511             NPSTCK = NPSTCK-1
18512             IF (IIBAR(IDBAM(I)).NE.0) THEN
18513                NPW    = NPW-1
18514                IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
18515             ENDIF
18516             DO 7 K=1,4
18517                TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18518     7       CONTINUE
18519 * baryons which are unable to escape the nuclear potential of targ.
18520          ELSEIF (ISTHKK(I).EQ.16) THEN
18521             ISGLTA = I
18522             NTSTCK = NTSTCK-1
18523             IF (IIBAR(IDBAM(I)).NE.0) THEN
18524                NTW    = NTW-1
18525                IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
18526             ENDIF
18527             DO 8 K=1,4
18528                TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18529     8       CONTINUE
18530          ENDIF
18531    11 CONTINUE
18532
18533 * residual nuclei so far
18534       IRESP = IP-NPSTCK
18535       IREST = IT-NTSTCK
18536
18537 * ckeck for "residual nuclei" consisting of one nucleon only
18538 * treat it as final state particle
18539       IF (IRESP.EQ.1) THEN
18540          ID  = IDBAM(ISGLPR)
18541          IST = ISTHKK(ISGLPR)
18542          CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
18543      &               PHKK(3,ISGLPR),PHKK(4,ISGLPR),
18544      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
18545          IF (IST.EQ.13) THEN
18546             ISTHKK(ISGLPR) = 11
18547          ELSE
18548             ISTHKK(ISGLPR) = 2
18549          ENDIF
18550          CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
18551      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18552      &               IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
18553          NOBAM(NHKK)      = NOBAM(ISGLPR)
18554          JDAHKK(1,ISGLPR) = NHKK
18555          DO 21 K=1,4
18556             TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
18557    21    CONTINUE
18558       ENDIF
18559       IF (IREST.EQ.1) THEN
18560          ID  = IDBAM(ISGLTA)
18561          IST = ISTHKK(ISGLTA)
18562          CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
18563      &               PHKK(3,ISGLTA),PHKK(4,ISGLTA),
18564      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
18565          IF (IST.EQ.14) THEN
18566             ISTHKK(ISGLTA) = 12
18567          ELSE
18568             ISTHKK(ISGLTA) = 2
18569          ENDIF
18570          CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
18571      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18572      &               IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
18573          NOBAM(NHKK)      = NOBAM(ISGLTA)
18574          JDAHKK(1,ISGLTA) = NHKK
18575          DO 22 K=1,4
18576             TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
18577    22    CONTINUE
18578       ENDIF
18579
18580 * get nuclear potential corresp. to the residual nucleus
18581       IPRCL  = IP -NPW
18582       IPZRCL = IPZ-NPCW
18583       ITRCL  = IT -NTW
18584       ITZRCL = ITZ-NTCW
18585       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
18586
18587 * baryons unable to escape the nuclear potential are treated as
18588 * excited nucleons (ISTHKK=15,16)
18589       DO 3 I=NPOINT(4),NHKK
18590          IF (ISTHKK(I).EQ.1) THEN
18591             ID  = IDBAM(I)
18592             IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
18593 *   final state n and p not being outside of both nuclei are considered
18594                NPOTP = 1
18595                NPOTT = 1
18596                IF ( (IP.GT.1)      .AND.(IRESP.GT.1).AND.
18597      &              (NOBAM(I).NE.1).AND.(NPW.GT.0)        ) THEN
18598 *     Lorentz-trsf. into proj. rest sys. for those being inside proj.
18599                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18600      &                        PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
18601      &                        PLAB(1,4),ID,-2)
18602                   PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
18603                   PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
18604      &                                  (PLAB(1,4)+PLABT) ))
18605                   EKIN = PLAB(1,4)-PLAB(1,5)
18606                   IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
18607                   IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
18608                ENDIF
18609                IF ( (IT.GT.1)      .AND.(IREST.GT.1).AND.
18610      &              (NOBAM(I).NE.2).AND.(NTW.GT.0)        ) THEN
18611 *     Lorentz-trsf. into targ. rest sys. for those being inside targ.
18612                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18613      &                        PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
18614      &                        PLAB(2,4),ID,-3)
18615                   PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
18616                   PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
18617      &                                  (PLAB(2,4)+PLABT) ))
18618                   EKIN = PLAB(2,4)-PLAB(2,5)
18619                   IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
18620                   IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
18621                ENDIF
18622                IF (PHKK(3,I).GE.ZERO) THEN
18623                   ISTHKK(I) = NPOTT
18624                   IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
18625                ELSE
18626                   ISTHKK(I) = NPOTP
18627                   IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
18628                ENDIF
18629                IF (ISTHKK(I).NE.1) THEN
18630                   J = ISTHKK(I)-14
18631                   DO 4 K=1,5
18632                      PHKK(K,I) = PLAB(J,K)
18633     4             CONTINUE
18634                   IF (ISTHKK(I).EQ.15) THEN
18635                      NPW = NPW-1
18636                      IF (ID.EQ.1) NPCW = NPCW-1
18637                      DO 9 K=1,4
18638                         TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18639     9                CONTINUE
18640                   ELSEIF (ISTHKK(I).EQ.16) THEN
18641                      NTW = NTW-1
18642                      IF (ID.EQ.1) NTCW = NTCW-1
18643                      DO 10 K=1,4
18644                         TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18645    10                CONTINUE
18646                   ENDIF
18647                ENDIF
18648             ENDIF
18649          ENDIF
18650     3 CONTINUE
18651
18652 * again: get nuclear potential corresp. to the residual nucleus
18653       IPRCL  = IP -NPW
18654       IPZRCL = IPZ-NPCW
18655       ITRCL  = IT -NTW
18656       ITZRCL = ITZ-NTCW
18657 c      AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
18658 cC     AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
18659 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
18660 C     AFERP = 0.0D0
18661 c      AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
18662 cC     AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
18663 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
18664 C     AFERT = 0.0D0
18665 C     IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
18666 C     IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
18667 C     IF (AFERP.GT.0.85D0) AFERP = 0.85D0
18668 C     IF (AFERT.GT.0.85D0) AFERT = 0.85D0
18669       AFERP = FERMOD+0.1D0
18670       AFERT = FERMOD+0.1D0
18671
18672       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
18673
18674       RETURN
18675       END
18676
18677 *$ CREATE DT_FICONF.FOR
18678 *COPY DT_FICONF
18679 *
18680 *===ficonf=============================================================*
18681 *
18682       SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
18683
18684 ************************************************************************
18685 * Treatment of FInal CONFiguration including evaporation, fission and  *
18686 * Fermi-break-up (for light nuclei only).                              *
18687 * Adopted from the original routine FINALE and extended to residual    *
18688 * projectile nuclei.                                                   *
18689 * This version dated 12.12.95 is written by S. Roesler.                *
18690 *                                                                      *
18691 * Last change 27.12.2006 by S. Roesler.                                *
18692 ************************************************************************
18693
18694       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18695       SAVE
18696       PARAMETER ( LINP = 10 ,
18697      &            LOUT = 6 ,
18698      &            LDAT = 9 )
18699       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18700       PARAMETER (ANGLGB=5.0D-16)
18701       PARAMETER (AMUAMU=0.93149432D0,AMELEC=0.51099906D-3)
18702
18703 * event history
18704       PARAMETER (NMXHKK=200000)
18705       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18706      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18707      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18708 * extended event history
18709       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18710      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18711      &                IHIST(2,NMXHKK)
18712 * rejection counter
18713       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
18714      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
18715      &                IREXCI(3),IRDIFF(2),IRINC
18716 * central particle production, impact parameter biasing
18717       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
18718 * particle properties (BAMJET index convention)
18719       CHARACTER*8  ANAME
18720       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18721      &                IICH(210),IIBAR(210),K1(210),K2(210)
18722 * treatment of residual nuclei: 4-momenta
18723       LOGICAL LRCLPR,LRCLTA
18724       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18725      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18726 * treatment of residual nuclei: properties of residual nuclei
18727       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
18728      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
18729      &                NTOTFI(2),NPROFI(2)
18730 * statistics: residual nuclei
18731       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
18732      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
18733      &                NINCST(2,4),NINCEV(2),
18734      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
18735      &                NRESPB(2),NRESCH(2),NRESEV(4),
18736      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
18737      &                NEVAFI(2,2)
18738 * flags for input different options
18739       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18740       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18741      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18742 * (original name: FINUC)
18743       PARAMETER (MXP=999)
18744       COMMON /FKFINU/ CXR    (MXP), CYR    (MXP), CZR    (MXP),
18745      &                CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
18746      &                TKI    (MXP), PLR    (MXP), WEI    (MXP),
18747      &                TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
18748      &                KPART  (MXP)
18749 * (original name: RESNUC)
18750       LOGICAL LRNFSS, LFRAGM
18751       COMMON /FKRESN/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
18752      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
18753      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
18754      &                  PYRES,  PZRES, PTRES2,  KTARP,  KTARN, IGREYP,
18755      &                 IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
18756      &                  ICRES,  IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
18757      &                 IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
18758      &                  IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
18759      &                 LFRAGM
18760       COMMON /FKNDAT/ AV0WEL,     APFRMX,     AEFRMX,     AEFRMA,
18761      &                RDSNUC,     V0WELL (2), PFRMMX (2), EFRMMX (2),
18762      &                EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
18763      &                VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
18764      &                PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
18765      &                EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
18766      &                ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV    ,
18767      &                AMRCSQ    , ATO1O3    , ZTO1O3    , ELBNDE (0:100)
18768 * (original name: PAREVT)
18769       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
18770      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
18771       PARAMETER ( NALLWP = 39   )
18772       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
18773      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
18774      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
18775      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
18776 * event flag
18777       COMMON /DTEVNO/ NEVENT,ICASCA
18778
18779       DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
18780      &          PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
18781      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
18782
18783       DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
18784       LOGICAL LLCPOT
18785       DATA EXC,NEXC /520*ZERO,520*0/
18786       DATA EXPNUC /4.0D-3,4.0D-3/
18787
18788       IREJ   = 0
18789       LRCLPR = .FALSE.
18790       LRCLTA = .FALSE.
18791
18792 * skip residual nucleus treatment if not requested or in case
18793 * of central collisions
18794       IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
18795
18796       DO 1 K=1,2
18797          IDPAR(K) = 0
18798          IDXPAR(K)= 0
18799          NTOT(K)  = 0
18800          NTOTFI(K)= 0
18801          NPRO(K)  = 0
18802          NPROFI(K)= 0
18803          NN(K)    = 0
18804          NH(K)    = 0
18805          NHPOS(K) = 0
18806          NQ(K)    = 0
18807          EEXC(K)  = ZERO
18808          MO1(K)   = 0
18809          MO2(K)   = 0
18810          DO 2 I=1,4
18811             VRCL(K,I) = ZERO
18812             WRCL(K,I) = ZERO
18813     2    CONTINUE
18814     1 CONTINUE
18815       NFSP = 0
18816       INUC(1) = IP
18817       INUC(2) = IT
18818
18819       DO 3 I=1,NHKK
18820
18821 * number of final state particles
18822          IF (ABS(ISTHKK(I)).EQ.1) THEN
18823             NFSP  = NFSP+1
18824             IDFSP = IDBAM(I)
18825          ENDIF
18826
18827 * properties of remaining nucleon configurations
18828          KF = 0
18829          IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
18830          IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
18831          IF (KF.GT.0) THEN
18832             IF (MO1(KF).EQ.0) MO1(KF) = I
18833             MO2(KF)  = I
18834 *   position of residual nucleus = average position of nucleons
18835             DO 4 K=1,4
18836                VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
18837                WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
18838     4       CONTINUE
18839 *   total number of particles contributing to each residual nucleus
18840             NTOT(KF)  = NTOT(KF)+1
18841             IDTMP     = IDBAM(I)
18842             IDXTMP    = I
18843 *   total charge of residual nuclei
18844             NQ(KF) = NQ(KF)+IICH(IDTMP)
18845 *   number of protons
18846             IF (IDHKK(I).EQ.2212) THEN
18847                NPRO(KF) = NPRO(KF)+1
18848 *   number of neutrons
18849             ELSEIF (IDHKK(I).EQ.2112) THEN
18850                NN(KF) = NN(KF)+1
18851             ELSE
18852 *   number of baryons other than n, p
18853                IF (IIBAR(IDTMP).EQ.1) THEN
18854                   NH(KF) = NH(KF)+1
18855                   IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
18856                ELSE
18857 *   any other mesons (status set to 1)
18858 C                 WRITE(LOUT,1002) KF,IDTMP
18859 C1002             FORMAT(1X,'FICONF:   residual nucleus ',I2,
18860 C    &                   ' containing meson ',I4,', status set to 1')
18861                   ISTHKK(I) = 1
18862                   IDTMP     = IDPAR(KF)
18863                   IDXTMP    = IDXPAR(KF)
18864                   NTOT(KF)  = NTOT(KF)-1
18865                ENDIF
18866             ENDIF
18867             IDPAR(KF)  = IDTMP
18868             IDXPAR(KF) = IDXTMP
18869          ENDIF
18870     3 CONTINUE
18871
18872 * reject elastic events (def: one final state particle = projectile)
18873       IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
18874          IREXCI(3) = IREXCI(3)+1
18875          GOTO 9999
18876 C        RETURN
18877       ENDIF
18878
18879 * check if one nucleus disappeared..
18880 C     IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
18881 C        DO 5 K=1,4
18882 C           PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
18883 C           PRCLPR(K) = ZERO
18884 C   5    CONTINUE
18885 C     ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
18886 C        DO 6 K=1,4
18887 C           PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
18888 C           PRCLTA(K) = ZERO
18889 C   6    CONTINUE
18890 C     ENDIF
18891
18892       ICOR   = 0
18893       INORCL = 0
18894       DO 7 I=1,2
18895          DO 8 K=1,4
18896 * get the average of the nucleon positions
18897             VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
18898             WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
18899             IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
18900             IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
18901     8    CONTINUE
18902 * mass number and charge of residual nuclei
18903          AIF(I)  = DBLE(NTOT(I))
18904          AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
18905          IF (NTOT(I).GT.1) THEN
18906 * masses of residual nuclei in ground state
18907             AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*DT_ENERGY(AIF(I),AIZF(I))
18908 * masses of residual nuclei
18909             PTORCL   = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
18910             AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
18911             IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
18912 *
18913 *   M_res^2 < 0 : configuration not allowed
18914 *
18915 *      a) re-calculate E_exc with scaled nuclear potential
18916 *         (conditional jump to label 9998)
18917 *      b) or reject event if N_loop(max) is exceeded
18918 *         (conditional jump to label 9999)
18919 *
18920             IF (AMRCL(I).LE.ZERO) THEN
18921                IF (IOULEV(3).GT.0)
18922      &            WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
18923      &                             PRCL(I,4),NTOT
18924  1000          FORMAT(1X,'warning! negative excitation energy',/,
18925      &                I4,4E15.4,2I4)
18926                AMRCL(I) = ZERO
18927                EEXC(I)  = ZERO
18928                IF (NLOOP.LE.500) THEN
18929                   GOTO 9998
18930                ELSE
18931                   IREXCI(2) = IREXCI(2)+1
18932                   GOTO 9999
18933                ENDIF
18934 *
18935 *   0 < M_res < M_res0 : mass below ground-state mass
18936 *
18937 *      a) we had residual nuclei with mass N_tot and reasonable E_exc
18938 *         before- assign average E_exc of those configurations to this
18939 *         one ( Nexc(i,N_tot) > 0 )
18940 *      b) or (and this applies always if run in transport codes) go up
18941 *         one mass number and
18942 *           i) if mass now larger than proj/targ mass or if run in
18943 *              transport codes assign average E_exc per wounded nucleon
18944 *              x number of wounded nucleons (Inuc-Ntot)
18945 *          ii) or assign average E_exc of those configurations to this
18946 *              one ( Nexc(i,m) > 0 )
18947 *
18948             ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
18949      &                                                         THEN
18950                M = MIN(NTOT(I),260)
18951                IF (NEXC(I,M).GT.0) THEN
18952                   AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
18953                ELSE
18954    70             CONTINUE
18955                   M = M+1
18956 **sr corrected 27.12.06
18957 *                 IF (M.GE.INUC(I)) THEN
18958 *                    AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
18959                   IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
18960                      IF ( INUC (I) .GT. NTOT (I) ) THEN
18961                         AMRCL(I) = AMRCL0(I)
18962      &                         + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
18963                      ELSE
18964                         AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
18965                      END IF
18966 **
18967                   ELSE
18968                      IF (NEXC(I,M).GT.0) THEN
18969                         AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
18970                      ELSE
18971                         GOTO 70
18972                      ENDIF
18973                   ENDIF
18974                ENDIF
18975                EEXC(I)  = AMRCL(I)-AMRCL0(I)
18976                ICOR     = ICOR+I
18977 *
18978 *   M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
18979 *
18980 *      a) re-calculate E_exc with scaled nuclear potential
18981 *         (conditional jump to label 9998)
18982 *      b) or reject event if N_loop(max) is exceeded
18983 *         (conditional jump to label 9999)
18984 *
18985 *
18986             ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
18987                IF (IOULEV(3).GT.0)
18988      &            WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
18989  1004          FORMAT(1X,'warning! too high excitation energy',/,
18990      &                I4,1P,2E15.4,3I5)
18991                AMRCL(I) = ZERO
18992                EEXC(I)  = ZERO
18993                IF (NLOOP.LE.500) THEN
18994                   GOTO 9998
18995                ELSE
18996                   IREXCI(2) = IREXCI(2)+1
18997                   GOTO 9999
18998                ENDIF
18999 *
19000 *   Otherwise (reasonable E_exc) :
19001 *      E_exc = M_res - M_res0
19002 *      in addition: calculate and save E_exc per wounded nucleon as
19003 *                   well as E_exc in <E_exc> counter
19004 *
19005             ELSE
19006 * excitation energies of residual nuclei
19007                EEXC(I)   = AMRCL(I)-AMRCL0(I)
19008 **sr 27.12.06 new excitation energy correction by A.F.
19009 *
19010 * all parts with Ilcopt<3 commented since not used
19011 *
19012 * still to be done/decided:
19013 *   Increase Icor and put back both residual nuclei on mass shell
19014 *   with the exciting correction further below.
19015 *   For the moment the modification in the excitation energy is simply
19016 *   corrected by scaling the energy of the residual nucleus.
19017 *
19018                LLCPOT = .TRUE.
19019                ILCOPT = 3
19020                IF ( LLCPOT ) THEN
19021                   NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
19022                   IF ( ILCOPT .LE. 2 ) THEN
19023 C* Patch for Fermi momentum reduction correlated with impact parameter:
19024 C                     FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
19025 C                     DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
19026 C                     AKPRHO = ONE - DLKPRH
19027 C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
19028 C                     FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO  - ONE,
19029 C     &                              0.05D+00 )
19030 C*                    REDORI = 0.75D+00
19031 C*                    REDORI = ONE
19032 C                     REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19033                   ELSE
19034                      DLKPRH = ZERO
19035                      RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
19036 *  Take out roughly one/half of the skin:
19037                      RDCORE = RDCORE - 0.5D+00
19038                      FRCFLL = RDCORE**3
19039                      PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
19040                      PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
19041                      FRCFLL = ONE - PRSKIN
19042                      FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
19043                      REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19044                   END IF
19045                   IF ( NNCHIT .GT. 0 ) THEN
19046 C                     IF ( ILCOPT .EQ. 1 ) THEN
19047 C                        SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
19048 C                        DO 1220 NCH = 1, 10
19049 C                           ETAETA = ( ONE - SKINRH**INUC(I)
19050 C     &                            - DBLE(INUC(I))* ( ONE - FRCFLL )
19051 C     &                            * ( ONE - SKINRH ) )
19052 C     &                            / ( SKINRH**INUC(I) - DBLE (INUC(I))
19053 C     &                            * ( ONE - FRCFLL) * SKINRH )
19054 C                           SKINRH = SKINRH * ( ONE + ETAETA )
19055 C 1220                   CONTINUE
19056 C                        PRSKIN = SKINRH**(NNCHIT-1)
19057 C                     ELSE IF ( ILCOPT .EQ. 2 ) THEN
19058 C                        PRSKIN = ONE - FRCFLL
19059 C                     END IF
19060                      REDCTN = ZERO
19061                      DO 1230 NCH = 1, NNCHIT
19062                         IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
19063                            PRFRMI = (( ONE - 2.D+00 * DLKPRH )
19064      &                            * DT_RNDM(PRFRMI))**0.333333333333D+00
19065                         ELSE
19066                            PRFRMI = ( ONE - 2.D+00 * DLKPRH
19067      &                            * DT_RNDM(PRFRMI))**0.333333333333D+00
19068                         END IF
19069                         REDCTN = REDCTN + PRFRMI**2
19070  1230                CONTINUE
19071                      REDCTN = REDCTN / DBLE (NNCHIT)
19072                   ELSE
19073                      REDCTN = 0.5D+00
19074                   END IF
19075                   EEXC  (I) = EEXC   (I) * REDCTN / REDORI
19076                   AMRCL (I) = AMRCL0 (I) + EEXC (I)
19077                   PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
19078                END IF
19079 **
19080                IF (ICASCA.EQ.0) THEN
19081                   EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
19082                   M = MIN(NTOT(I),260)
19083                   EXC(I,M)  = EXC(I,M)+EEXC(I)
19084                   NEXC(I,M) = NEXC(I,M)+1
19085                ENDIF
19086             ENDIF
19087          ELSEIF (NTOT(I).EQ.1) THEN
19088             WRITE(LOUT,1003) I
19089  1003       FORMAT(1X,'FICONF:   warning! NTOT(I)=1? (I=',I3,')')
19090             GOTO 9999
19091          ELSE
19092             AMRCL0(I) = ZERO
19093             AMRCL(I)  = ZERO
19094             EEXC(I)   = ZERO
19095             INORCL    = INORCL+I
19096          ENDIF
19097     7 CONTINUE
19098
19099       PRCLPR(5) = AMRCL(1)
19100       PRCLTA(5) = AMRCL(2)
19101
19102       IF (ICOR.GT.0) THEN
19103          IF (INORCL.EQ.0) THEN
19104 * one or both residual nuclei consist of one nucleon only, transform
19105 * this nucleon on mass shell
19106             DO 9 K=1,4
19107                P1IN(K) = PRCL(1,K)
19108                P2IN(K) = PRCL(2,K)
19109     9       CONTINUE
19110             XM1 = AMRCL(1)
19111             XM2 = AMRCL(2)
19112             CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
19113             IF (IREJ1.GT.0) THEN
19114                WRITE(LOUT,*) 'ficonf-mashel rejection'
19115                GOTO 9999
19116             ENDIF
19117             DO 10 K=1,4
19118                PRCL(1,K) = P1OUT(K)
19119                PRCL(2,K) = P2OUT(K)
19120                PRCLPR(K) = P1OUT(K)
19121                PRCLTA(K) = P2OUT(K)
19122    10       CONTINUE
19123             PRCLPR(5) = AMRCL(1)
19124             PRCLTA(5) = AMRCL(2)
19125          ELSE
19126             IF (IOULEV(3).GT.0)
19127      &      WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
19128      &                       INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
19129      &                       AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
19130      &                       AMRCL(2),AMRCL(2)-AMRCL0(2)
19131  1001       FORMAT(1X,'FICONF:   warning! no residual nucleus for',
19132      &             ' correction',/,11X,'at event',I8,
19133      &             ',  nucleon config. 1:',2I4,' 2:',2I4,
19134      &             2(/,11X,3E12.3))
19135             IF (NLOOP.LE.500) THEN
19136                GOTO 9998
19137             ELSE
19138                IREXCI(1) = IREXCI(1)+1
19139             ENDIF
19140          ENDIF
19141       ENDIF
19142
19143 * update counter
19144 C     IF (NRESEV(1).NE.NEVHKK) THEN
19145 C        NRESEV(1) = NEVHKK
19146 C        NRESEV(2) = NRESEV(2)+1
19147 C     ENDIF
19148       NRESEV(2) = NRESEV(2)+1
19149       DO 15 I=1,2
19150          EXCDPM(I)   = EXCDPM(I)+EEXC(I)
19151          EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
19152          NRESTO(I) = NRESTO(I)+NTOT(I)
19153          NRESPR(I) = NRESPR(I)+NPRO(I)
19154          NRESNU(I) = NRESNU(I)+NN(I)
19155          NRESBA(I) = NRESBA(I)+NH(I)
19156          NRESPB(I) = NRESPB(I)+NHPOS(I)
19157          NRESCH(I) = NRESCH(I)+NQ(I)
19158    15 CONTINUE
19159
19160 * evaporation
19161       IF (LEVPRT) THEN
19162          DO 13 I=1,2
19163 * initialize evaporation counter
19164             EEXCFI(I) = ZERO
19165             IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
19166      &          (EEXC(I).GT.ZERO)) THEN
19167 * put residual nuclei into DTEVT1
19168                IDRCL = 80000
19169                JMASS = INT( AIF(I))
19170                JCHAR = INT(AIZF(I))
19171 *  the following patch is required to transmit the correct excitation
19172 *   energy to Eventd
19173                IF (ITRSPT.EQ.1) THEN
19174                   IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
19175      &                (IOULEV(3).GT.0))
19176      &               WRITE(LOUT,*)
19177      &                  ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
19178      &                              AMRCL(I),AMRCL0(I),EEXC(I)
19179                   PRCL0 = PRCL(I,4)
19180                   PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
19181      &                                                    +PRCL(I,3)**2)
19182                   IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
19183                      WRITE(LOUT,*)
19184      &                  ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
19185                   ENDIF
19186                ENDIF
19187                CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
19188      &              PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
19189 **sr 22.6.97
19190                NOBAM(NHKK) = I
19191 **
19192                DO 14 J=1,4
19193                   VHKK(J,NHKK) = VRCL(I,J)
19194                   WHKK(J,NHKK) = WRCL(I,J)
19195    14          CONTINUE
19196 *  interface to evaporation module - fill final residual nucleus into
19197 *  common FKRESN
19198 *   fill resnuc only if code is not used as event generator in Fluka
19199                IF (ITRSPT.NE.1) THEN
19200                   PXRES  = PRCL(I,1)
19201                   PYRES  = PRCL(I,2)
19202                   PZRES  = PRCL(I,3)
19203                   IBRES  = NPRO(I)+NN(I)+NH(I)
19204                   ICRES  = NPRO(I)+NHPOS(I)
19205                   ANOW   = DBLE(IBRES)
19206                   ZNOW   = DBLE(ICRES)
19207                   PTRES  = SQRT(PXRES**2+PYRES**2+PZRES**2)
19208 *   ground state mass of the residual nucleus (should be equal to AM0T)
19209                   AMMRES = AMRCL0(I)
19210                   AMNRES = AMMRES-ZNOW*AMELEC+ELBNDE(ICRES)
19211 *  common FKFINU
19212                   TV = ZERO
19213 *   kinetic energy of residual nucleus
19214                   TVRECL = PRCL(I,4)-AMRCL(I)
19215 *   excitation energy of residual nucleus
19216                   TVCMS  = EEXC(I)
19217                   PTOLD  = PTRES
19218                   PTRES  = SQRT(ABS(TVRECL*(TVRECL+
19219      &                          2.0D0*(AMMRES+TVCMS))))
19220                   IF (PTOLD.LT.ANGLGB) THEN
19221                      CALL DT_RACO(PXRES,PYRES,PZRES)
19222                      PTOLD = ONE
19223                   ENDIF
19224                   PXRES = PXRES*PTRES/PTOLD
19225                   PYRES = PYRES*PTRES/PTOLD
19226                   PZRES = PZRES*PTRES/PTOLD
19227 * zero counter of secondaries from evaporation
19228                   NP = 0
19229 * evaporation
19230                   WE = ONE
19231                   CALL DT_EVEVAP(WE)
19232 * put evaporated particles and residual nuclei to DTEVT1
19233                   MO = NHKK
19234                   CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
19235                ENDIF
19236                EEXCFI(I) = EXCITF
19237                EXCEVA(I) = EXCEVA(I)+EXCITF
19238             ENDIF
19239    13    CONTINUE
19240       ENDIF
19241
19242       RETURN
19243
19244 C9998 IREXCI(1) = IREXCI(1)+1
19245  9998 IREJ   = IREJ+1
19246  9999 CONTINUE
19247       LRCLPR = .TRUE.
19248       LRCLTA = .TRUE.
19249       IREJ   = IREJ+1
19250       RETURN
19251       END
19252
19253 *$ CREATE DT_EVA2HE.FOR
19254 *COPY DT_EVA2HE
19255 *                                                                      *
19256 *====eva2he============================================================*
19257 *                                                                      *
19258       SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
19259
19260 ************************************************************************
19261 * Interface between common's of evaporation module (FKFINU,FKFHVY)     *
19262 * and DTEVT1.                                                          *
19263 *    MO    DTEVT1-index of "mother" (residual) nucleus before evap.    *
19264 *    EEXCF exitation energy of residual nucleus after evaporation      *
19265 *    IRCL  = 1 projectile residual nucleus                             *
19266 *          = 2 target     residual nucleus                             *
19267 * This version dated 19.04.95 is written by S. Roesler.                *
19268 *                                                                      *
19269 * Last change 27.12.2006 by S. Roesler.                                *
19270 ************************************************************************
19271
19272       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19273       SAVE
19274       PARAMETER ( LINP = 10 ,
19275      &            LOUT = 6 ,
19276      &            LDAT = 9 )
19277       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
19278
19279 * event history
19280       PARAMETER (NMXHKK=200000)
19281       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19282      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19283      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19284 * Note: DTEVT2 - special use for heavy fragments !
19285 *       (IDRES(I) = mass number, IDXRES(I) = charge)
19286 * extended event history
19287       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19288      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19289      &                IHIST(2,NMXHKK)
19290 * particle properties (BAMJET index convention)
19291       CHARACTER*8  ANAME
19292       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19293      &                IICH(210),IIBAR(210),K1(210),K2(210)
19294 * flags for input different options
19295       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19296       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19297      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19298 * statistics: residual nuclei
19299       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19300      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19301      &                NINCST(2,4),NINCEV(2),
19302      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19303      &                NRESPB(2),NRESCH(2),NRESEV(4),
19304      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19305      &                NEVAFI(2,2)
19306 * treatment of residual nuclei: properties of residual nuclei
19307       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19308      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19309      &                NTOTFI(2),NPROFI(2)
19310 * (original name: FINUC)
19311       PARAMETER (MXP=999)
19312       COMMON /FKFINU/ CXR    (MXP), CYR    (MXP), CZR    (MXP),
19313      &                CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
19314      &                TKI    (MXP), PLR    (MXP), WEI    (MXP),
19315      &                TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
19316      &                KPART  (MXP)
19317 * (original name: FHEAVY,FHEAVC)
19318       PARAMETER ( MXHEAV = 100 )
19319       CHARACTER*8 ANHEAV
19320       COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19321      &                CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19322      &                PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19323      &                AMHEAV  ( 12 ) , AMNHEA  ( 12 ) ,
19324      &                KHEAVY (MXHEAV), ICHEAV  ( 12 ) ,
19325      &                IBHEAV  ( 12 ) , NPHEAV
19326       COMMON /FKFHVC/ ANHEAV  ( 12 )
19327 * (original name: RESNUC)
19328       LOGICAL LRNFSS, LFRAGM
19329       COMMON /FKRESN/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19330      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19331      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
19332      &                  PYRES,  PZRES, PTRES2,  KTARP,  KTARN, IGREYP,
19333      &                 IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
19334      &                  ICRES,  IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
19335      &                 IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
19336      &                  IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
19337      &                 LFRAGM
19338
19339       DIMENSION IPTOKP(39)
19340       DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
19341      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
19342      & 100, 101, 97, 102, 98, 103, 109, 115 /
19343
19344       IREJ = 0
19345
19346 * skip if evaporation package is not included
19347       IF (.NOT.LEVAPO) RETURN
19348
19349 * update counter
19350       IF (NRESEV(3).NE.NEVHKK) THEN
19351          NRESEV(3) = NEVHKK
19352          NRESEV(4) = NRESEV(4)+1
19353       ENDIF
19354
19355       IF (LEMCCK)
19356      &   CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
19357      &                                                   IDUM,IDUM)
19358 * mass number/charge of residual nucleus before evaporation
19359       IBTOT = IDRES(MO)
19360       IZTOT = IDXRES(MO)
19361
19362 * protons/neutrons/gammas
19363       DO 1 I=1,NP
19364          PX    = CXR(I)*PLR(I)
19365          PY    = CYR(I)*PLR(I)
19366          PZ    = CZR(I)*PLR(I)
19367          ID    = IPTOKP(KPART(I))
19368          IDPDG = IDT_IPDGHA(ID)
19369          AM    = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
19370      &           (2.0D0*MAX(TKI(I),TINY10))
19371          IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
19372             WRITE(LOUT,1000) ID,AM,AAM(ID)
19373  1000       FORMAT(1X,'EVA2HE:  inconsistent mass of evap. ',
19374      &             'particle',I3,2E10.3)
19375          ENDIF
19376          PE = TKI(I)+AM
19377          CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
19378          NOBAM(NHKK) = IRCL
19379          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19380          IBTOT = IBTOT-IIBAR(ID)
19381          IZTOT = IZTOT-IICH(ID)
19382     1 CONTINUE
19383
19384 * heavy fragments
19385       DO 2 I=1,NPHEAV
19386          PX     = CXHEAV(I)*PHEAVY(I)
19387          PY     = CYHEAV(I)*PHEAVY(I)
19388          PZ     = CZHEAV(I)*PHEAVY(I)
19389          IDHEAV = 80000
19390          AM     = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
19391      &            (2.0D0*MAX(TKHEAV(I),TINY10))
19392          PE     = TKHEAV(I)+AM
19393          CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
19394      &                  IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
19395          NOBAM(NHKK) = IRCL
19396          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19397          IBTOT = IBTOT-IBHEAV(KHEAVY(I))
19398          IZTOT = IZTOT-ICHEAV(KHEAVY(I))
19399     2 CONTINUE
19400
19401       IF (IBRES.GT.0) THEN
19402 * residual nucleus after evaporation
19403          IDNUC = 80000
19404          CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
19405      &                                        IBRES,ICRES,0)
19406          NOBAM(NHKK) = IRCL
19407       ENDIF
19408       EEXCF = TVCMS
19409       NTOTFI(IRCL) = IBRES
19410       NPROFI(IRCL) = ICRES
19411       IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
19412       IBTOT = IBTOT-IBRES
19413       IZTOT = IZTOT-ICRES
19414
19415 * count events with fission
19416       NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
19417       IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
19418
19419 * energy-momentum conservation check
19420       IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
19421 C     IF (IREJ.GT.0) THEN
19422 C        CALL DT_EVTOUT(4)
19423 C        WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
19424 C     ENDIF
19425 * baryon-number/charge conservation check
19426       IF (IBTOT+IZTOT.NE.0) THEN
19427          WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
19428  1001    FORMAT(1X,'EVA2HE:   baryon-number/charge conservation ',
19429      &          'failure at event ',I8,' :  IBTOT,IZTOT = ',2I3)
19430       ENDIF
19431
19432       RETURN
19433       END
19434
19435 *$ CREATE DT_EBIND.FOR
19436 *COPY DT_EBIND
19437 *
19438 *===ebind==============================================================*
19439 *
19440       DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
19441
19442 ************************************************************************
19443 * Binding energy for nuclei.                                           *
19444 * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972)                  *
19445 *                 IA        mass number                                *
19446 *                 IZ        atomic number                              *
19447 * This version dated 5.5.95   is updated by S. Roesler.                *
19448 ************************************************************************
19449
19450       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19451       SAVE
19452       PARAMETER ( LINP = 10 ,
19453      &            LOUT = 6 ,
19454      &            LDAT = 9 )
19455       PARAMETER (ZERO=0.0D0)
19456
19457       DATA       A1,       A2,        A3,        A4,      A5
19458      &     / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
19459
19460       IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
19461          WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0.  ',IA,IZ
19462          DT_EBIND = ZERO
19463          RETURN
19464       ENDIF
19465       AA = IA
19466       DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
19467      &        -A4*(IA-2*IZ)**2/AA
19468       IF (MOD(IA,2).EQ.1) THEN
19469          IA5 = 0
19470       ELSEIF (MOD(IZ,2).EQ.1) THEN
19471          IA5 = 1
19472       ELSE
19473          IA5 = -1
19474       ENDIF
19475       DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
19476
19477       RETURN
19478       END
19479
19480 **sr 30.6. routine replaced completely
19481 *$ CREATE DT_ENERGY.FOR
19482 *COPY DT_ENERGY
19483 *                                                                      *
19484 *=== energy ===========================================================*
19485 *                                                                      *
19486       DOUBLE PRECISION FUNCTION DT_ENERGY( A, Z )
19487
19488 C     INCLUDE '(DBLPRC)'
19489 * DBLPRC.ADD
19490       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19491       SAVE
19492 * (original name: GLOBAL)
19493       PARAMETER ( KALGNM = 2 )
19494       PARAMETER ( ANGLGB = 5.0D-16 )
19495       PARAMETER ( ANGLSQ = 2.5D-31 )
19496       PARAMETER ( AXCSSV = 0.2D+16 )
19497       PARAMETER ( ANDRFL = 1.0D-38 )
19498       PARAMETER ( AVRFLW = 1.0D+38 )
19499       PARAMETER ( AINFNT = 1.0D+30 )
19500       PARAMETER ( AZRZRZ = 1.0D-30 )
19501       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
19502       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
19503       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
19504       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
19505       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
19506       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
19507       PARAMETER ( CSNNRM = 2.0D-15 )
19508       PARAMETER ( DMXTRN = 1.0D+08 )
19509       PARAMETER ( ZERZER = 0.D+00 )
19510       PARAMETER ( ONEONE = 1.D+00 )
19511       PARAMETER ( TWOTWO = 2.D+00 )
19512       PARAMETER ( THRTHR = 3.D+00 )
19513       PARAMETER ( FOUFOU = 4.D+00 )
19514       PARAMETER ( FIVFIV = 5.D+00 )
19515       PARAMETER ( SIXSIX = 6.D+00 )
19516       PARAMETER ( SEVSEV = 7.D+00 )
19517       PARAMETER ( EIGEIG = 8.D+00 )
19518       PARAMETER ( ANINEN = 9.D+00 )
19519       PARAMETER ( TENTEN = 10.D+00 )
19520       PARAMETER ( HLFHLF = 0.5D+00 )
19521       PARAMETER ( ONETHI = ONEONE / THRTHR )
19522       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
19523       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
19524       PARAMETER ( THRTWO = THRTHR / TWOTWO )
19525       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
19526       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
19527       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
19528       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
19529       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
19530       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
19531       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
19532       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
19533       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
19534       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
19535       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
19536       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
19537       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
19538       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
19539       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
19540       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
19541       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
19542       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
19543       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
19544       PARAMETER ( CLIGHT = 2.99792458         D+10 )
19545       PARAMETER ( AVOGAD = 6.0221367          D+23 )
19546       PARAMETER ( BOLTZM = 1.380658           D-23 )
19547       PARAMETER ( AMELGR = 9.1093897          D-28 )
19548       PARAMETER ( PLCKBR = 1.05457266         D-27 )
19549       PARAMETER ( ELCCGS = 4.8032068          D-10 )
19550       PARAMETER ( ELCMKS = 1.60217733         D-19 )
19551       PARAMETER ( AMUGRM = 1.6605402          D-24 )
19552       PARAMETER ( AMMUMU = 0.113428913        D+00 )
19553       PARAMETER ( AMPRMU = 1.007276470        D+00 )
19554       PARAMETER ( AMNEMU = 1.008664904        D+00 )
19555       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
19556       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
19557       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
19558       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
19559       PARAMETER ( PLABRC = 0.197327053        D+00 )
19560       PARAMETER ( AMELCT = 0.51099906         D-03 )
19561       PARAMETER ( AMUGEV = 0.93149432         D+00 )
19562       PARAMETER ( AMMUON = 0.105658389        D+00 )
19563       PARAMETER ( AMPRTN = 0.93827231         D+00 )
19564       PARAMETER ( AMNTRN = 0.93956563         D+00 )
19565       PARAMETER ( AMDEUT = 1.87561339         D+00 )
19566       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19567      &                   * 1.D-09 )
19568       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
19569       PARAMETER ( BLTZMN = 8.617385           D-14 )
19570       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
19571       PARAMETER ( GFOHB3 = 1.16639            D-05 )
19572       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
19573       PARAMETER ( SIN2TW = 0.2319             D+00 )
19574       PARAMETER ( GEVMEV = 1.0                D+03 )
19575       PARAMETER ( EMVGEV = 1.0                D-03 )
19576       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
19577       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
19578       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
19579       LOGICAL LGBIAS, LGBANA
19580       COMMON /FKGLOB/ LGBIAS, LGBANA
19581 C     INCLUDE '(DIMPAR)'
19582 * DIMPAR.ADD
19583       PARAMETER ( MXXRGN = 5000 )
19584       PARAMETER ( MXXMDF = 82   )
19585       PARAMETER ( MXXMDE = 54   )
19586       PARAMETER ( MFSTCK = 1000 )
19587       PARAMETER ( MESTCK = 100  )
19588       PARAMETER ( NALLWP = 39   )
19589       PARAMETER ( NELEMX = 80   )
19590       PARAMETER ( MPDPDX = 8    )
19591       PARAMETER ( ICOMAX = 180  )
19592       PARAMETER ( NSTBIS = 304  )
19593       PARAMETER ( IDMAXP = 220  )
19594       PARAMETER ( IDMXDC = 640  )
19595       PARAMETER ( MKBMX1 = 1    )
19596       PARAMETER ( MKBMX2 = 1    )
19597 C     INCLUDE '(IOUNIT)'
19598 * IOUNIT.ADD
19599       PARAMETER ( LUNIN  =  5 )
19600       PARAMETER ( LUNOUT =  6 )
19601 **sr 19.5. set error output-unit from 15 to 6
19602       PARAMETER ( LUNERR = 6  )
19603       PARAMETER ( LUNBER = 14 )
19604       PARAMETER ( LUNECH =  8 )
19605       PARAMETER ( LUNFLU = 13 )
19606       PARAMETER ( LUNGEO = 16 )
19607       PARAMETER ( LUNPMF = 12 )
19608       PARAMETER ( LUNRAN =  2 )
19609       PARAMETER ( LUNXSC =  9 )
19610       PARAMETER ( LUNDET = 17 )
19611       PARAMETER ( LUNRAY = 10 )
19612       PARAMETER ( LUNRDB =  1 )
19613       PARAMETER ( LUNPGO =  7 )
19614       PARAMETER ( LUNPGS =  4 )
19615       PARAMETER ( LUNSCR =  3 )
19616 *
19617 *----------------------------------------------------------------------*
19618 *                                                                      *
19619 *     Revised version of the original routine from EVAP:               *
19620 *                                                                      *
19621 *     Created on   15 may 1990     by    Alfredo Ferrari & Paola Sala  *
19622 *                                                   Infn - Milan       *
19623 *                                                                      *
19624 *     Last change on 19-sep-95     by    Alfredo Ferrari               *
19625 *                                                                      *
19626 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
19627 *     !!!  It is supposed to be used with the updated atomic   !!!     *
19628 *     !!!                    mass data file                    !!!     *
19629 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
19630 *                                                                      *
19631 *----------------------------------------------------------------------*
19632 *
19633 *  Mass number below which "unknown" isotopes out of the Z-interval
19634 *  reported in the mass tabulations are completely unstable and made
19635 *  up by Z proton masses + N neutron masses:
19636       PARAMETER ( KAFREE =  4 )
19637 *  Mass number below which "unknown" isotopes out of the Z-interval
19638 *  reported in the mass tabulations are supposed to be particle unstable
19639       PARAMETER ( KAPUNS = 12 )
19640 *  Minimum energy required for particle unstable isotopes
19641       PARAMETER ( DEPUNS = 0.5D+00 )
19642 *
19643 * (original name: EVA0)
19644       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
19645      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
19646      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
19647      *                T (4,7), RMASS (297), ALPH (297), BET (297),
19648      *                APRIME (250), IA (6), IZ (6)
19649 * (original name: ISOTOP)
19650       PARAMETER ( NAMSMX = 270 )
19651       PARAMETER ( NZGVAX =  15 )
19652       PARAMETER ( NISMMX = 574 )
19653       COMMON /FKISOT/ WAPS   (NAMSMX,NZGVAX),  T12NUC (NAMSMX,NZGVAX),
19654      &                WAPISM (NISMMX), T12ISM (NISMMX),
19655      &                ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
19656      &                AMSSST (100)  , ISOMNM (NSTBIS), ISONDX (2,100),
19657      &                JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
19658      &                INWAPS (NAMSMX), JSPISM (NISMMX),
19659      &                JPTISM (NISMMX), IZWISM (NISMMX),
19660      &                INWISM (0:NAMSMX)
19661 *
19662 CPH      SAVE KA0, KZ0, IZ0
19663       DATA KA0, KZ0, IZ0 / -1, -1, -1 /
19664 *
19665       IFLAG = 1
19666       GO TO 10
19667 *======================================================================*
19668 *                                                                      *
19669 *     Entry ENergy - KNOWn                                             *
19670 *                                                                      *
19671 *======================================================================*
19672       ENTRY DT_ENKNOW ( A, Z, IZZ0 )
19673       IZZ0  =-1
19674       IFLAG = 2
19675    10 CONTINUE
19676 *
19677       KA0 = NINT ( A )
19678       KZ0 = NINT ( Z )
19679       N   = KA0 - KZ0
19680 *  +-------------------------------------------------------------------*
19681 *  |  Null residual nucleus:
19682       IF ( KA0 .EQ. 0 .AND. KZ0 .LE. 0 ) THEN
19683          IF ( IFLAG .EQ. 1 ) THEN
19684             DT_ENERGY = ZERZER
19685          ELSE
19686             DT_ENKNOW = ZERZER
19687             IZZ0   = -1
19688          END IF
19689          RETURN
19690 *  |
19691 *  +-------------------------------------------------------------------*
19692 *  |  Only protons:
19693       ELSE IF ( N .LE. 0 ) THEN
19694          IF ( N .LT. 0 ) THEN
19695             WRITE ( LUNOUT, * )
19696      &     ' DPMJET stopped in energy: mass number =< atomic number !!',
19697      &       KA0, KZ0
19698             WRITE ( LUNOUT, * )
19699      &     ' DPMJET stopped in energy: mass number =< atomic number !!',
19700      &       KA0, KZ0
19701                WRITE ( 77, * )
19702      &  ' ^^^DPMJET stopped in energy: mass number =< atomic number !!',
19703      &       KA0, KZ0
19704             STOP 'DT_ENERGY:KA0-KZ0'
19705          END IF
19706          IZ0    = -1
19707          IF ( IFLAG .EQ. 1 ) THEN
19708             DT_ENERGY = Z * WAPS ( 1, 2 )
19709          ELSE
19710             DT_ENKNOW = Z * WAPS ( 1, 2 )
19711             IZZ0   = -1
19712          END IF
19713          RETURN
19714 *  |
19715 *  +-------------------------------------------------------------------*
19716 *  |  Only neutrons:
19717       ELSE IF ( KZ0 .LE. 0 ) THEN
19718          IF ( KZ0 .LT. 0 ) THEN
19719             WRITE ( LUNOUT, * )
19720      &   ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19721             WRITE ( LUNOUT, * )
19722      &   ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19723             WRITE ( 77, * )
19724      &' ^^^DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19725             STOP 'DT_ENERGY:KZ0<0'
19726          END IF
19727          IZ0    = -1
19728          IF ( IFLAG .EQ. 1 ) THEN
19729             DT_ENERGY = A * WAPS ( 1, 1 )
19730          ELSE
19731             DT_ENKNOW = A * WAPS ( 1, 1 )
19732             IZZ0   = -1
19733          END IF
19734          RETURN
19735       END IF
19736 *  |
19737 *  +-------------------------------------------------------------------*
19738 *  +-------------------------------------------------------------------*
19739 *  |  No actual nucleus
19740 *  |
19741 *  +-------------------------------------------------------------------*
19742 *  +-------------------------------------------------------------------*
19743 *  |  A larger than maximum allowed:
19744       IF ( KA0 .GT. NAMSMX ) THEN
19745          IZ0    = -1
19746          IF ( IFLAG .EQ. 1 ) THEN
19747             DT_ENERGY = DT_ENRG( A, Z )
19748          ELSE
19749             DT_ENKNOW = DT_ENRG( A, Z )
19750             IZZ0   = -1
19751          END IF
19752          RETURN
19753       END IF
19754 *  |
19755 *  +-------------------------------------------------------------------*
19756       IZZ = INWAPS ( KA0 )
19757 *  +-------------------------------------------------------------------*
19758 *  |  Too much neutron rich with respect to the stability line:
19759       IF ( KZ0 .LT. IZZ ) THEN
19760 *  |  +----------------------------------------------------------------*
19761 *  |  |  Up to A=Kafree all "bound" masses are known, set it unbound:
19762          IF ( KA0 .LE. KAFREE ) THEN
19763             DT_ENERGY = AINFNT
19764 *  |  |
19765 *  |  +----------------------------------------------------------------*
19766 *  |  |  Up to Kapuns: be sure it is particle unstable
19767          ELSE IF ( KA0 .LE. KAPUNS ) THEN
19768 *  |  |  Exp. excess mass for A,IZZ
19769             ENEEXP = WAPS ( KA0, 1 )
19770 *  |  |  Cameron excess mass for A, IZZ
19771             ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19772 *  |  |  Cameron excess mass for A, Z
19773             DT_ENERGY = DT_ENRG( A, Z )
19774 *  |  |  Use just the difference according to Cameron!!!
19775             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19776             JZZ    = INWAPS ( KA0 - 1 )
19777             LZZ    = INWAPS ( KA0 - 2 )
19778 *  |  |  +-------------------------------------------------------------*
19779 *  |  |  |  Residual mass for n-decay known:
19780             IF ( KZ0 .GE. JZZ .AND. KZ0 .LE. JZZ + NZGVAX - 1 ) THEN
19781                IZ0    = KZ0 - JZZ + 1
19782                DT_ENERGY = MAX(DT_ENERGY,WAPS (KA0-1,IZ0) + WAPS (1,1)
19783      &                      + DEPUNS )
19784 *  |  |  |
19785 *  |  |  +-------------------------------------------------------------*
19786 *  |  |  |  Residual mass for 2n-decay known:
19787             ELSE IF ( KZ0 .GE. LZZ .AND. KZ0 .LE. LZZ + NZGVAX - 1 )THEN
19788                IZ0    = KZ0 - LZZ + 1
19789                DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19790      &                      ( WAPS (1,1) + DEPUNS ) )
19791 *  |  |  |
19792 *  |  |  +-------------------------------------------------------------*
19793 *  |  |  |  Set it unbound:
19794             ELSE
19795                DT_ENERGY = AINFNT
19796             END IF
19797 *  |  |  |
19798 *  |  |  +-------------------------------------------------------------*
19799 *  |  |
19800 *  |  +----------------------------------------------------------------*
19801 *  |  |  Proceed as usual:
19802          ELSE
19803 *  |  |  Exp. excess mass for A,IZZ
19804             ENEEXP = WAPS ( KA0, 1 )
19805 *  |  |  Cameron excess mass for A, IZZ
19806             ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19807 *  |  |  Cameron excess mass for A, Z
19808             DT_ENERGY = DT_ENRG( A, Z )
19809 *  |  |  Use just the difference according to Cameron!!!
19810             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19811          END IF
19812 *  |  |
19813 *  |  +----------------------------------------------------------------*
19814 *  |  Be sure not to have a positive energy state:
19815          DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19816          IZ0    = -1
19817          IF ( IFLAG .EQ. 2 ) THEN
19818             DT_ENKNOW = DT_ENERGY
19819             IZZ0   = -1
19820          END IF
19821          RETURN
19822 *  |
19823 *  +-------------------------------------------------------------------*
19824 *  |  Too much proton rich with respect to the stability line:
19825       ELSE IF ( KZ0 .GT. IZZ + NZGVAX - 1 ) THEN
19826 *  |  +----------------------------------------------------------------*
19827 *  |  |  Up to A=Kafree all "bound" masses are known, set it unbound:
19828          IF ( KA0 .LE. KAFREE ) THEN
19829             DT_ENERGY = AINFNT
19830 *  |  |
19831 *  |  +----------------------------------------------------------------*
19832 *  |  |  Up to Kapuns: be sure it is particle unstable
19833          ELSE IF ( KA0 .LE. KAPUNS ) THEN
19834 *  |  |  Exp. excess mass for A,IZZ+NZGVAX-1
19835             ENEEXP = WAPS ( KA0, NZGVAX )
19836 *  |  |  Cameron excess mass for A, IZZ+NZGVAX-1
19837             ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19838 *  |  |  Cameron excess mass for A, Z
19839             DT_ENERGY = DT_ENRG( A, Z )
19840 *  |  |  Use just the difference according to Cameron!!!
19841             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19842             JZZ    = INWAPS ( KA0 - 1 )
19843             LZZ    = INWAPS ( KA0 - 2 )
19844 *  |  |  +-------------------------------------------------------------*
19845 *  |  |  |  Residual mass for p-decay known:
19846             IF ( KZ0-1 .GE. JZZ .AND. KZ0-1 .LE. JZZ + NZGVAX - 1 ) THEN
19847                IZ0    = KZ0 - 1 - JZZ + 1
19848                DT_ENERGY = MAX (DT_ENERGY, WAPS (KA0-1,IZ0) + WAPS (1,2)
19849      &                      + DEPUNS )
19850 *  |  |  |
19851 *  |  |  +-------------------------------------------------------------*
19852 *  |  |  |  Residual mass for 2p-decay known:
19853             ELSE IF ( KZ0-2 .GE. LZZ .AND. KZ0-2 .LE. LZZ + NZGVAX - 1 )
19854      &         THEN
19855                IZ0    = KZ0 - 2 - LZZ + 1
19856                DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19857      &                      ( WAPS (1,2) + DEPUNS ) )
19858 *  |  |  |
19859 *  |  |  +-------------------------------------------------------------*
19860 *  |  |  |  Set it unbound:
19861             ELSE
19862                DT_ENERGY = AINFNT
19863             END IF
19864 *  |  |  |
19865 *  |  |  +-------------------------------------------------------------*
19866 *  |  |
19867 *  |  +----------------------------------------------------------------*
19868 *  |  |  Proceed as usual:
19869          ELSE
19870 *  |  |  Exp. excess mass for A,IZZ+NZGVAX-1
19871             ENEEXP = WAPS ( KA0, NZGVAX )
19872 *  |  |  Cameron excess mass for A, IZZ+NZGVAX-1
19873             ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19874 *  |  |  Cameron excess mass for A, Z
19875             DT_ENERGY = DT_ENRG( A, Z )
19876 *  |  |  Use just the difference according to Cameron!!!
19877             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19878          END IF
19879 *  |  |
19880 *  |  +----------------------------------------------------------------*
19881 *  |  Be sure not to have a positive energy state:
19882          DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19883          IZ0    = -1
19884          IF ( IFLAG .EQ. 2 ) THEN
19885             DT_ENKNOW = DT_ENERGY
19886             IZZ0   = -1
19887          END IF
19888          RETURN
19889 *  |
19890 *  +-------------------------------------------------------------------*
19891 *  |  Known isotope or anyway isotope "inside" the stability zone
19892       ELSE
19893          IZ0    = KZ0 - IZZ + 1
19894          DT_ENERGY = WAPS ( KA0, IZ0 )
19895          IF ( IFLAG .EQ. 2 ) IZZ0 = IZ0
19896 *  |  +----------------------------------------------------------------*
19897 *  |  |  Mass not known
19898          IF ( ABS (DT_ENERGY) .LT. ANGLGB .AND. (KA0 .NE. 12 .OR. KZ0
19899      &        .NE. 6) ) THEN
19900             IF ( IFLAG .EQ. 2 ) IZZ0 = -1
19901 *  |  |  +-------------------------------------------------------------*
19902 *  |  |  |  Set it unbound:
19903             IF ( KA0 .LE. KAFREE ) THEN
19904                DT_ENERGY = AINFNT
19905 *  |  |  |
19906 *  |  |  +-------------------------------------------------------------*
19907 *  |  |  |  Try to get a reasonable excess mass:
19908             ELSE
19909                JZ0 = -100
19910 *  |  |  |  +----------------------------------------------------------*
19911 *  |  |  |  |  Check the closest one known:
19912                DO 500 JZZ = 1, NZGVAX
19913                   IF ( ABS ( WAPS (KA0,JZZ) ) .GT. ANGLGB .AND.
19914      &                 ABS (JZZ-IZ0) .LT. ABS (JZ0-IZ0) ) JZ0 = JZZ
19915                   IF ( ABS (JZ0-IZ0) .EQ. 1 ) GO TO 550
19916   500          CONTINUE
19917 *  |  |  |  |
19918 *  |  |  |  +----------------------------------------------------------*
19919   550          CONTINUE
19920 *  |  |  |  Exp. excess mass for A,IZZ+JZ0-1
19921                ENEEXP = WAPS ( KA0, JZ0 )
19922 *  |  |  |  Cameron excess mass for A, IZZ+JZ0-1
19923                ENECA1 = DT_ENRG( A, DBLE (IZZ+JZ0-1) )
19924 *  |  |  |  Cameron excess mass for A, Z
19925                DT_ENERGY = DT_ENRG( A, Z )
19926 *  |  |  |  Use just the difference according to Cameron!!!
19927                DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19928                IZ0    = -1
19929             END IF
19930 *  |  |  |
19931 *  |  |  +-------------------------------------------------------------*
19932 *  |  |  Be sure not to have a positive energy state:
19933             DT_ENERGY = MIN(DT_ENERGY,(A-Z)*WAPS(1,1)+Z*WAPS (1,2) )
19934          END IF
19935 *  |  |
19936 *  |  +----------------------------------------------------------------*
19937          IF ( IFLAG .EQ. 2 ) DT_ENKNOW = DT_ENERGY
19938          RETURN
19939       END IF
19940 *  |
19941 *  +-------------------------------------------------------------------*
19942 *=== End of Function Energy ===========================================*
19943 *     RETURN
19944       END
19945 **
19946
19947 *$ CREATE DT_ENRG.FOR
19948 *COPY DT_ENRG
19949 *                                                                      *
19950 *=== enrg =============================================================*
19951 *                                                                      *
19952       DOUBLE PRECISION FUNCTION DT_ENRG(A,Z)
19953
19954       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19955       SAVE
19956
19957       PARAMETER ( ZERZER = 0.D+00 )
19958       PARAMETER ( ONEONE = 1.D+00 )
19959       PARAMETER ( LUNIN  = 5  )
19960       PARAMETER ( LUNOUT = 6  )
19961 *
19962 *----------------------------------------------------------------------*
19963 *                                                                      *
19964 *     Revised version of the original routine from EVAP:               *
19965 *                                                                      *
19966 *     Created on   15 may 1990     by    Alfredo Ferrari & Paola Sala  *
19967 *                                                   Infn - Milan       *
19968 *                                                                      *
19969 *     Last change on 01-oct-94     by    Alfredo Ferrari               *
19970 *                                                                      *
19971 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
19972 *     !!!  It is supposed to be used with the updated atomic   !!!     *
19973 *     !!!                    mass data file                    !!!     *
19974 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
19975 *                                                                      *
19976 *----------------------------------------------------------------------*
19977 *
19978       PARAMETER ( O16OLD = 931.145  D+00 )
19979       PARAMETER ( O16NEW = 931.19826D+00 )
19980       PARAMETER ( O16RAT = O16NEW / O16OLD )
19981       PARAMETER ( C12NEW = 931.49432D+00 )
19982       PARAMETER ( ADJUST = -8.322737768178909D-02 )
19983       PARAMETER ( AINFNT = 1.0D+30 )
19984 * (original name: EVA0)
19985       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
19986      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
19987      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
19988      *                T (4,7), RMASS (297), ALPH (297), BET (297),
19989      *                APRIME (250), IA (6), IZ (6)
19990       LOGICAL LFIRST
19991 CPH      SAVE LFIRST, EXHYDR, EXNEUT
19992       DATA LFIRST / .TRUE. /
19993 *
19994       IF ( LFIRST ) THEN
19995          LFIRST = .FALSE.
19996 **sr 30.6.
19997 C        EXHYDR = DT_ENERGY( ONEONE, ONEONE )
19998 C        EXNEUT = DT_ENERGY( ONEONE, ZERZER )
19999          EXHYDR = A
20000          EXNEUT = Z
20001          DT_ENRG   = -AINFNT
20002          RETURN
20003 **
20004       END IF
20005       IZ0 = NINT (Z)
20006       IF ( IZ0 .LE. 0 ) THEN
20007          DT_ENRG = A * EXNEUT
20008          RETURN
20009       END IF
20010       N   = NINT (A-Z)
20011       IF ( N .LE. 0 ) THEN
20012          DT_ENRG = Z * EXHYDR
20013          RETURN
20014       END IF
20015       AM2ZOA= (A-Z-Z)/A
20016       AM2ZOA=AM2ZOA*AM2ZOA
20017       A13 = RMASS(NINT(A))
20018 *     A13 = A**.3333333333333333D+00
20019       AM13 = 1.D+00/A13
20020       EV=-17.0354D+00*(1.D+00 -1.84619 D+00*AM2ZOA)*A
20021       ES= 25.8357D+00*(1.D+00 -1.712185D+00*AM2ZOA)*
20022      &    (1.D+00 -0.62025D+00*AM13*AM13)*
20023      &    (A13*A13 -.62025D+00)
20024       EC= 0.799D+00*Z*(Z-1.D+00)*AM13*(((1.5772D+00*AM13 +1.2273D+00)*
20025      &    AM13-1.5849D+00)*
20026      &    AM13*AM13 +1.D+00)
20027       EEX= -0.4323D+00*AM13*Z**1.3333333D+00*
20028      &   (((0.49597D+00*AM13 -0.14518D+00)*AM13 -0.57811D+00) * AM13
20029      &   + 1.D+00)
20030       DT_ENRG=8.367D+00*A-0.783D+00*Z +EV +ES +EC +EEX+CAM2(IZ0)+CAM3(N)
20031       DT_ENRG=(DT_ENRG + A * O16OLD ) * O16RAT - A * ( C12NEW - ADJUST )
20032       DT_ENRG  = MIN ( DT_ENRG, Z * EXHYDR + ( A - Z ) * EXNEUT )
20033       RETURN
20034 *=== End of function Enrg =============================================*
20035       END
20036
20037 *$ CREATE DT_INCINI.FOR
20038 *COPY DT_INCINI
20039 *                                                                      *
20040 *=== incini ===========================================================*
20041 *                                                                      *
20042       SUBROUTINE DT_INCINI
20043
20044       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20045       SAVE
20046
20047       PARAMETER ( ZERZER = 0.D+00 )
20048       PARAMETER ( ONEONE = 1.D+00 )
20049       PARAMETER ( TWOTWO = 2.D+00 )
20050       PARAMETER ( THRTHR = 3.D+00 )
20051       PARAMETER ( FOUFOU = 4.D+00 )
20052       PARAMETER ( EIGEIG = 8.D+00 )
20053       PARAMETER ( ANINEN = 9.D+00 )
20054       PARAMETER ( HLFHLF = 0.5D+00 )
20055       PARAMETER ( ONETHI = ONEONE / THRTHR )
20056       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20057       PARAMETER ( PLABRC = 0.197327053        D+00 )
20058       PARAMETER ( AMELCT = 0.51099906         D-03 )
20059       PARAMETER ( AMUGEV = 0.93149432         D+00 )
20060       PARAMETER ( AMPRTN = 0.93827231         D+00 )
20061       PARAMETER ( AMNTRN = 0.93956563         D+00 )
20062       PARAMETER ( AMDEUT = 1.87561339         D+00 )
20063       PARAMETER ( EMVGEV = 1.0                D-03 )
20064
20065       PARAMETER ( LUNOUT = 6  )
20066 *
20067 *----------------------------------------------------------------------*
20068 *                                                                      *
20069 *     Created on  10  june  1990   by    Alfredo Ferrari & Paola Sala  *
20070 *                                                   Infn - Milan       *
20071 *                                                                      *
20072 *     Last change on 02-may-95     by    Alfredo Ferrari               *
20073 *                                                                      *
20074 *                                                                      *
20075 *----------------------------------------------------------------------*
20076 *
20077 * (original name: FHEAVY,FHEAVC)
20078       PARAMETER ( MXHEAV = 100 )
20079       CHARACTER*8 ANHEAV
20080       COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20081      &                CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20082      &                PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20083      &                AMHEAV  ( 12 ) , AMNHEA  ( 12 ) ,
20084      &                KHEAVY (MXHEAV), ICHEAV  ( 12 ) ,
20085      &                IBHEAV  ( 12 ) , NPHEAV
20086       COMMON /FKFHVC/ ANHEAV  ( 12 )
20087 * (original name: INPFLG)
20088       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20089 * (original name: FRBKCM)
20090       PARAMETER ( MXFFBK =     6 )
20091       PARAMETER ( MXZFBK =     9 )
20092       PARAMETER ( MXNFBK =    10 )
20093       PARAMETER ( MXAFBK =    16 )
20094       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20095       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20096       PARAMETER ( NXAFBK = MXAFBK + 1 )
20097       PARAMETER ( MXPSST =   300 )
20098       PARAMETER ( MXPSFB = 41000 )
20099       LOGICAL LFRMBK, LNCMSS
20100       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20101      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20102      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20103      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
20104      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20105      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20106      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20107      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20108      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
20109 * (original name: NUCDAT)
20110       PARAMETER ( AMUAMU = AMUGEV )
20111       PARAMETER ( AMPROT = AMPRTN )
20112       PARAMETER ( AMNEUT = AMNTRN )
20113       PARAMETER ( AMELEC = AMELCT )
20114       PARAMETER ( R0NUCL = 1.12        D+00 )
20115       PARAMETER ( RCCOUL = 1.7         D+00 )
20116       PARAMETER ( FERTHO = 14.33       D-09 )
20117       PARAMETER ( EXPEBN = 2.39        D+00 )
20118       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
20119       PARAMETER ( AMUC12 = AMUGEV - HLFHLF * AMELCT + BEXC12 / 12.D+00 )
20120       PARAMETER ( AMHYDR = AMPRTN + AMELCT  )
20121       PARAMETER ( AMHTON = AMHYDR - AMNTRN  )
20122       PARAMETER ( AMNTOU = AMNTRN - AMUC12  )
20123       PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
20124       PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
20125       PARAMETER ( GAMMIN = 1.0D-06 )
20126       PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
20127       PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
20128       COMMON /FKNDAT/ AV0WEL,     APFRMX,     AEFRMX,     AEFRMA,
20129      &                RDSNUC,     V0WELL (2), PFRMMX (2), EFRMMX (2),
20130      &                EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
20131      &                VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
20132      &                PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
20133      &                EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
20134      &                ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV    ,
20135      &                AMRCSQ    , ATO1O3    , ZTO1O3    , ELBNDE (0:100)
20136 * (original name: PAREVT)
20137       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20138      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20139       PARAMETER ( NALLWP = 39   )
20140       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20141      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20142      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20143      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20144 * (original name: NUCOLD)
20145       COMMON /FKNOLD/ HELP (2), HHLP (2), FTVTH (2), FINCX (2),
20146      &                EKPOLD (2), BBOLD, ZZOLD, SQROLD, ASEASQ,
20147      &                FSPRED, FEX0RD
20148 *
20149       BBOLD  = - 1.D+10
20150       ZZOLD  = - 1.D+10
20151       SQROLD = - 1.D+10
20152       APFRMX = PLABRC * ( ANINEN * PIPIPI / EIGEIG )**ONETHI / R0NUCL
20153       AMNUCL (1) = AMPROT
20154       AMNUCL (2) = AMNEUT
20155       AMNUSQ (1) = AMPROT * AMPROT
20156       AMNUSQ (2) = AMNEUT * AMNEUT
20157       AMNHLP = HLFHLF * ( AMNUCL (1) + AMNUCL (2) )
20158       ASQHLP = AMNHLP**2
20159 *     ASQHLP = HLFHLF * ( AMNUSQ (1) + AMNUSQ (2) )
20160       AEFRMX = SQRT ( ASQHLP + APFRMX**2 ) - AMNHLP
20161       AEFRMA = 0.3D+00 * APFRMX**2 / AMNHLP * ( ONEONE - APFRMX**2 /
20162      &         ( 5.6D+00 * ASQHLP ) )
20163       AV0WEL = AEFRMX + EBNDAV
20164       EBNDNG (1) = EBNDAV
20165       EBNDNG (2) = EBNDAV
20166       AEXC12 = EMVGEV * DT_ENERGY( 12.D+00, 6.D+00 )
20167       CEXC12 = EMVGEV * DT_ENRG( 12.D+00, 6.D+00 )
20168       AMMC12 = 12.D+00 * AMUGEV + AEXC12
20169       AMNC12 = AMMC12 - 6.D+00 * AMELCT + FERTHO * 6.D+00**EXPEBN
20170       AEXO16 = EMVGEV * DT_ENERGY( 16.D+00, 8.D+00 )
20171       CEXO16 = EMVGEV * DT_ENRG( 16.D+00, 8.D+00 )
20172       AMMO16 = 16.D+00 * AMUGEV + AEXO16
20173       AMNO16 = AMMO16 - 8.D+00 * AMELCT + FERTHO * 8.D+00**EXPEBN
20174       AEXS28 = EMVGEV * DT_ENERGY( 28.D+00, 14.D+00 )
20175       CEXS28 = EMVGEV * DT_ENRG( 28.D+00, 14.D+00 )
20176       AMMS28 = 28.D+00 * AMUGEV + AEXS28
20177       AMNS28 = AMMS28 - 14.D+00 * AMELCT + FERTHO * 14.D+00**EXPEBN
20178       AEXC40 = EMVGEV * DT_ENERGY( 40.D+00, 20.D+00 )
20179       CEXC40 = EMVGEV * DT_ENRG( 40.D+00, 20.D+00 )
20180       AMMC40 = 40.D+00 * AMUGEV + AEXC40
20181       AMNC40 = AMMC40 - 20.D+00 * AMELCT + FERTHO * 20.D+00**EXPEBN
20182       AEXF56 = EMVGEV * DT_ENERGY( 56.D+00, 26.D+00 )
20183       CEXF56 = EMVGEV * DT_ENRG( 56.D+00, 26.D+00 )
20184       AMMF56 = 56.D+00 * AMUGEV + AEXF56
20185       AMNF56 = AMMF56 - 26.D+00 * AMELCT + FERTHO * 26.D+00**EXPEBN
20186       AEX107 = EMVGEV * DT_ENERGY( 107.D+00, 47.D+00 )
20187       CEX107 = EMVGEV * DT_ENRG( 107.D+00, 47.D+00 )
20188       AMM107 = 107.D+00 * AMUGEV + AEX107
20189       AMN107 = AMM107 - 47.D+00 * AMELCT + FERTHO * 47.D+00**EXPEBN
20190       AEX132 = EMVGEV * DT_ENERGY( 132.D+00, 54.D+00 )
20191       CEX132 = EMVGEV * DT_ENRG( 132.D+00, 54.D+00 )
20192       AMM132 = 132.D+00 * AMUGEV + AEX132
20193       AMN132 = AMM132 - 54.D+00 * AMELCT + FERTHO * 54.D+00**EXPEBN
20194       AEX181 = EMVGEV * DT_ENERGY( 181.D+00, 73.D+00 )
20195       CEX181 = EMVGEV * DT_ENRG( 181.D+00, 73.D+00 )
20196       AMM181 = 181.D+00 * AMUGEV + AEX181
20197       AMN181 = AMM181 - 73.D+00 * AMELCT + FERTHO * 73.D+00**EXPEBN
20198       AEX208 = EMVGEV * DT_ENERGY( 208.D+00, 82.D+00 )
20199       CEX208 = EMVGEV * DT_ENRG( 208.D+00, 82.D+00 )
20200       AMM208 = 208.D+00 * AMUGEV + AEX208
20201       AMN208 = AMM208 - 82.D+00 * AMELCT + FERTHO * 82.D+00**EXPEBN
20202       AEX238 = EMVGEV * DT_ENERGY( 238.D+00, 92.D+00 )
20203       CEX238 = EMVGEV * DT_ENRG( 238.D+00, 92.D+00 )
20204       AMM238 = 238.D+00 * AMUGEV + AEX238
20205       AMN238 = AMM238 - 92.D+00 * AMELCT + FERTHO * 92.D+00**EXPEBN
20206
20207       AMHEAV (1) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ZERZER )
20208       AMHEAV (2) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ONEONE )
20209       AMHEAV (3) = TWOTWO * AMUGEV
20210      &             + EMVGEV * DT_ENERGY( TWOTWO, ONEONE )
20211       AMHEAV (4) = THRTHR * AMUGEV
20212      &             + EMVGEV * DT_ENERGY( THRTHR, ONEONE )
20213       AMHEAV (5) = THRTHR * AMUGEV
20214      &             + EMVGEV * DT_ENERGY( THRTHR, TWOTWO )
20215       AMHEAV (6) = FOUFOU * AMUGEV
20216      &             + EMVGEV * DT_ENERGY( FOUFOU, TWOTWO )
20217       ELBNDE (0) = ZERZER
20218       ELBNDE (1) = 13.6D-09
20219       DO 2000 IZ = 2, 100
20220          ELBNDE ( IZ ) = FERTHO * DBLE ( IZ )**EXPEBN
20221 2000  CONTINUE
20222       AMNHEA (1) = AMHEAV (1) + ELBNDE (0)
20223       AMNHEA (2) = AMHEAV (2) - AMELCT + ELBNDE (1)
20224       AMNHEA (3) = AMHEAV (3) - AMELCT + ELBNDE (1)
20225       AMNHEA (4) = AMHEAV (4) - AMELCT + ELBNDE (1)
20226       AMNHEA (5) = AMHEAV (5) - TWOTWO * AMELCT + ELBNDE (2)
20227       AMNHEA (6) = AMHEAV (6) - TWOTWO * AMELCT + ELBNDE (2)
20228       IF ( LEVPRT ) THEN
20229          WRITE ( LUNOUT, * )' **** Evaporation from residual nucleus',
20230      &                      ' activated **** '
20231          IF ( LDEEXG ) WRITE ( LUNOUT, * )' **** Deexcitation gamma',
20232      &                      ' production activated **** '
20233 **sr 18.5.95
20234 * commented, since obsolete
20235 C        IF ( LHEAVY ) WRITE ( LUNOUT, * )' **** Evaporated "heavies"',
20236 C    &                      ' transport activated **** '
20237          IF ( IFISS .GT. 0 )
20238      &                 WRITE ( LUNOUT, * )' **** High Energy fission ',
20239      &                      ' requested & activated **** '
20240          IF ( LFRMBK )
20241      &                 WRITE ( LUNOUT, * )' **** Fermi Break Up ',
20242      &                      ' requested & activated **** '
20243          IF ( LFRMBK ) CALL DT_FRBKIN(.FALSE.,.FALSE.)
20244       ELSE
20245          LDEEXG = .FALSE.
20246          LHEAVY = .FALSE.
20247          LFRMBK = .FALSE.
20248          IFISS  = 0
20249       END IF
20250       RETURN
20251 *=== End of subroutine incini =========================================*
20252       END
20253
20254 *$ CREATE DT_STALIN.FOR
20255 *COPY DT_STALIN
20256 *                                                                      *
20257 *=== stalin ===========================================================*
20258 *                                                                      *
20259       SUBROUTINE DT_STALIN
20260
20261       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20262       SAVE
20263       PARAMETER ( ANGLGB = 5.0D-16 )
20264       PARAMETER ( ZERZER = 0.D+00 )
20265       PARAMETER ( ONEONE = 1.D+00 )
20266       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20267       PARAMETER ( AMUGEV = 0.93149432         D+00 )
20268       PARAMETER ( EMVGEV = 1.0                D-03 )
20269       PARAMETER ( NSTBIS = 304  )
20270       PARAMETER ( LUNIN  = 5  )
20271       PARAMETER ( LUNOUT = 6  )
20272 *
20273 *----------------------------------------------------------------------*
20274 *                                                                      *
20275 *     STAbility LINe calculation:                                      *
20276 *                                                                      *
20277 *     Created on 04 december 1992  by    Alfredo Ferrari & Paola Sala  *
20278 *                                                   Infn - Milan       *
20279 *                                                                      *
20280 *     Last change on 04-dec-92     by    Alfredo Ferrari               *
20281 *                                                                      *
20282 *                                                                      *
20283 *----------------------------------------------------------------------*
20284 *
20285 * (original name: ISOTOP)
20286       PARAMETER ( NAMSMX = 270 )
20287       PARAMETER ( NZGVAX =  15 )
20288       PARAMETER ( NISMMX = 574 )
20289       COMMON /FKISOT/ WAPS   (NAMSMX,NZGVAX),  T12NUC (NAMSMX,NZGVAX),
20290      &                WAPISM (NISMMX), T12ISM (NISMMX),
20291      &                ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20292      &                AMSSST (100)  , ISOMNM (NSTBIS), ISONDX (2,100),
20293      &                JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20294      &                INWAPS (NAMSMX), JSPISM (NISMMX),
20295      &                JPTISM (NISMMX), IZWISM (NISMMX),
20296      &                INWISM (0:NAMSMX)
20297 *
20298       DIMENSION ZNORM (260)
20299 *  +-------------------------------------------------------------------*
20300 *  |
20301       DO 1000 IZ=1,100
20302          DO 500 J=1,2
20303             ASTLIN (J,IZ) = ZERZER
20304   500    CONTINUE
20305  1000 CONTINUE
20306 *  |
20307 *  +-------------------------------------------------------------------*
20308 *  +-------------------------------------------------------------------*
20309 *  |
20310       DO 2000 IA=1,260
20311          ZNORM (IA) = ZERZER
20312          DO 1500 J=1,2
20313             ZSTLIN (J,IA) = ZERZER
20314  1500    CONTINUE
20315  2000 CONTINUE
20316 *  |
20317 *  +-------------------------------------------------------------------*
20318 *  +-------------------------------------------------------------------*
20319 *  |  Loop on the Atomic Number
20320       DO 3000 IZ=1,100
20321          AMSSST (IZ) = ZERZER
20322          ANORM       = ONEONE
20323          ZTAR        = IZ
20324 *  |  +----------------------------------------------------------------*
20325 *  |  |    Loop on the stable isotopes
20326          DO 2500 IS = ISONDX (1,IZ), ISONDX (2,IZ)
20327             IA = ISOMNM (IS)
20328             ASTLIN (1,IZ) = ASTLIN (1,IZ) + ABUISO (IS) * IA
20329             ASTLIN (2,IZ) = ASTLIN (2,IZ) + ABUISO (IS) * IA**2
20330             ZNORM    (IA) = ZNORM (IA) + ABUISO (IS)
20331             ZSTLIN (1,IA) = ZSTLIN (1,IA) + ABUISO (IS) * IZ
20332             ZSTLIN (2,IA) = ZSTLIN (2,IA) + ABUISO (IS) * IZ**2
20333             AHELP  = IA
20334             IF ( AHELP .LE. 1.00001D+00 ) THEN
20335                ANORM = ONEONE / ( ONEONE - ABUISO (IS) )
20336                GO TO 2500
20337             END IF
20338             AMSSST (IZ) = ABUISO (IS) * ( AHELP * AMUGEV
20339      &                  + EMVGEV * DT_ENERGY(AHELP,ZTAR) ) + AMSSST (IZ)
20340  2500    CONTINUE
20341 *  |  |
20342 *  |  +----------------------------------------------------------------*
20343          AMSSST (IZ) = ANORM * AMSSST (IZ) / AMUGEV
20344 *  |  Normalize and print A_stab versus Z data:
20345          ASTLIN (2,IZ) = MAX ( SQRT (ASTLIN(2,IZ)-ASTLIN(1,IZ)**2),
20346      &                         0.5D+00 )
20347 *        WRITE (LUNOUT,*)'  Z:',IZ,' A_stab:',SNGL(ASTLIN(1,IZ)),
20348 *    &                   '  Sigma_st',SNGL(ASTLIN(2,IZ))
20349  3000 CONTINUE
20350 *  |
20351 *  +-------------------------------------------------------------------*
20352 *  +-------------------------------------------------------------------*
20353 *  |  Normalize and print Z_stab versus A data:
20354       DO 4000 IA=1,260
20355          ZSTLIN (1,IA) = ZSTLIN (1,IA) / MAX ( ZNORM (IA), 1.D-10 )
20356          ZSTLIN (2,IA) = ZSTLIN (2,IA) / MAX ( ZNORM (IA), 1.D-10 )
20357          ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ZSTLIN (1,IA)**2 )
20358          IF ( ZNORM (IA) .GT. ANGLGB )
20359 **sr 2.11. avoid underflows at Pentium
20360      &      ZSTLIN (2,IA) =
20361      &               MAX ( SQRT ( ABS(ZSTLIN(2,IA)-ZSTLIN(1,IA)**2) ),
20362 C    &      ZSTLIN (2,IA) = MAX ( SQRT (ZSTLIN(2,IA)-ZSTLIN(1,IA)**2),
20363      &                            0.3D+00 )
20364  4000 CONTINUE
20365 *  |
20366 *  +-------------------------------------------------------------------*
20367 *  +-------------------------------------------------------------------*
20368 *  |  Normalize and print Z_stab versus A data:
20369       DO 5000 IA=1,260
20370          IF ( ZNORM (IA) .LE. ANGLGB ) THEN
20371             DO 4200 JA = IA-1,1,-1
20372                IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20373                   IA1 = JA
20374                   GO TO 4300
20375                END IF
20376  4200       CONTINUE
20377  4300       CONTINUE
20378             DO 4400 JA = IA+1,260
20379                IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20380                   IA2 = JA
20381                   GO TO 4500
20382                END IF
20383  4400       CONTINUE
20384             IA2 = IA1
20385             IA1 = IA1 - 1
20386  4500       CONTINUE
20387             ZSTLIN (1,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20388      &                    * ( ZSTLIN (1,IA2) - ZSTLIN (1,IA1) )
20389      &                    + ZSTLIN (1,IA1)
20390             ZSTLIN (2,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20391      &                    * ( ZSTLIN (2,IA2) - ZSTLIN (2,IA1) )
20392      &                    + ZSTLIN (2,IA1)
20393          END IF
20394          IZ = MIN ( 100, NINT (ZSTLIN(1,IA)) )
20395          ATOZ = IZ / ASTLIN (1,IZ)
20396          ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ATOZ * ASTLIN (2,IZ) )
20397 *        WRITE (LUNOUT,*)'  A:',IA,' Z_stab:',SNGL(ZSTLIN(1,IA)),
20398 *    &                   '  Sigma_st',SNGL(ZSTLIN(2,IA))
20399  5000 CONTINUE
20400 *  |
20401 *  +-------------------------------------------------------------------*
20402       RETURN
20403       END
20404
20405 *$ CREATE DT_BERTTP.FOR
20406 *COPY DT_BERTTP
20407 *
20408 *=== berttp ===========================================================*
20409 *                                                                      *
20410       SUBROUTINE DT_BERTTP
20411
20412       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20413       SAVE
20414
20415       PARAMETER ( CSNNRM = 2.0D-15 )
20416       PARAMETER ( ZERZER = 0.D+00 )
20417       PARAMETER ( ONEONE = 1.D+00 )
20418       PARAMETER ( THRTHR = 3.D+00 )
20419       PARAMETER ( SIXSIX = 6.D+00 )
20420       PARAMETER ( ONETHI = ONEONE / THRTHR )
20421       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20422       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
20423       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
20424       PARAMETER ( EMVGEV = 1.0                D-03 )
20425
20426       PARAMETER ( NSTBIS = 304  )
20427
20428       PARAMETER ( LUNIN  = 5  )
20429       PARAMETER ( LUNOUT = 6  )
20430 **sr 19.5. set error output-unit from 15 to 6
20431       PARAMETER ( LUNERR = 6  )
20432 C---------------------------------------------------------------------
20433 C SUBNAME = DT_BERTTP --- READ BERTINI DATA
20434 C---------------------------------------------------------------------
20435 C     ---------------------------------- I-N-C DATA
20436 C     COMMON R8(2127),R4(64),CRSC(600,4),R8B(336),CS(29849)
20437 C     REAL*8 R8,R8B,CRSC,CS
20438 C     REAL*4 R4
20439 C     --------------------------------- EVAPORATION DATA
20440 * (original name: COOKCM)
20441       PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
20442       LOGICAL LDEFOZ, LDEFON
20443       PARAMETER ( INCOOK = 150, IZCOOK = 98 )
20444       COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
20445      &                SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
20446      &                PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
20447 * (original name: EVA0)
20448       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
20449      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
20450      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
20451      *                T (4,7), RMASS (297), ALPH (297), BET (297),
20452      *                APRIME (250), IA (6), IZ (6)
20453 * (original name: FRBKCM)
20454       PARAMETER ( MXFFBK =     6 )
20455       PARAMETER ( MXZFBK =     9 )
20456       PARAMETER ( MXNFBK =    10 )
20457       PARAMETER ( MXAFBK =    16 )
20458       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20459       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20460       PARAMETER ( NXAFBK = MXAFBK + 1 )
20461       PARAMETER ( MXPSST =   300 )
20462       PARAMETER ( MXPSFB = 41000 )
20463       LOGICAL LFRMBK, LNCMSS
20464       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20465      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20466      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20467      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
20468      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20469      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20470      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20471      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20472      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
20473 * (original name: HETTP)
20474       COMMON /FKHETP/  NHSTP,NBERTP,IOSUB,INSRS
20475 * (original name: INPFLG)
20476       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20477 * (original name: ISOTOP)
20478       PARAMETER ( NAMSMX = 270 )
20479       PARAMETER ( NZGVAX =  15 )
20480       PARAMETER ( NISMMX = 574 )
20481       COMMON /FKISOT/ WAPS   (NAMSMX,NZGVAX),  T12NUC (NAMSMX,NZGVAX),
20482      &                WAPISM (NISMMX), T12ISM (NISMMX),
20483      &                ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20484      &                AMSSST (100)  , ISOMNM (NSTBIS), ISONDX (2,100),
20485      &                JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20486      &                INWAPS (NAMSMX), JSPISM (NISMMX),
20487      &                JPTISM (NISMMX), IZWISM (NISMMX),
20488      &                INWISM (0:NAMSMX)
20489 * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
20490       PARAMETER ( PI     = PIPIPI )
20491       PARAMETER ( PISQ   = PIPISQ )
20492       PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
20493       PARAMETER ( RZNUCL = 1.12        D+00 )
20494       PARAMETER ( RMSPRO = 0.8         D+00 )
20495       PARAMETER ( R0PROT = RMSPRO / SQRT12  )
20496       PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
20497      &          / R0PROT )
20498       PARAMETER ( RLLE04 = RZNUCL )
20499       PARAMETER ( RLLE16 = RZNUCL )
20500       PARAMETER ( RLGT16 = RZNUCL )
20501       PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
20502       PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
20503       PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
20504       PARAMETER ( SKLE04 = 1.4D+00 )
20505       PARAMETER ( SKLE16 = 1.9D+00 )
20506       PARAMETER ( SKGT16 = 2.4D+00 )
20507       PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
20508       PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
20509       PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
20510       PARAMETER ( ALPHA0 = 0.1D+00 )
20511       PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
20512       PARAMETER ( GAMSK0 = 0.9D+00 )
20513       PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
20514       PARAMETER ( POTME0 = 0.6666666666666667D+00 )
20515       PARAMETER ( POTBA0 = 1.D+00 )
20516       PARAMETER ( PNFRAT = 1.533D+00 )
20517       PARAMETER ( RADPIM = 0.035D+00 )
20518       PARAMETER ( RDPMHL = 14.D+00   )
20519       PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
20520       PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
20521       PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
20522       PARAMETER ( AP0PFS = 0.5D+00 )
20523       PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
20524       PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
20525       PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
20526       PARAMETER ( MXSCIN = 50     )
20527       LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
20528      &        LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
20529       COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
20530      &                RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
20531      &                SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
20532      &                CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
20533      &                PFRTAB (2:260)
20534       COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
20535      &                ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
20536      &                RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
20537      &                YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
20538      &                RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
20539      &                PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
20540      &                PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
20541      &                BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
20542      &                YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
20543      &                XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
20544      &                SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
20545      &                R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
20546      &                PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
20547      &                EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
20548      &                PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
20549      &                EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
20550      &                PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
20551      &                BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
20552       COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
20553      &                RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
20554      &                EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
20555      &                BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
20556      &                WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
20557      &                POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
20558      &                BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
20559      &                SIGPAB (3), SIGNAB (3), HHLP   (2), FORTOT (2),
20560      &                FPNBLC, DPNBLC, FFTFLG, IFTFLG,
20561      &                IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
20562      &                KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
20563      &                NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
20564      &                IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
20565      &                LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
20566       COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
20567       COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
20568      &                YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
20569      &                AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
20570      &                NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
20571      &                NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
20572      &                ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
20573      &                LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
20574      &                LNCDCY, LNUSCT
20575       DIMENSION AWSTAB (2:260), SIGMAB (3)
20576       EQUIVALENCE ( DEFPRO, DEFNUC (1) )
20577       EQUIVALENCE ( DEFNEU, DEFNUC (2) )
20578       EQUIVALENCE ( RHOIPP, RHONCP (1) )
20579       EQUIVALENCE ( RHOINP, RHONCP (2) )
20580       EQUIVALENCE ( RHOIP2, RHONC2 (1) )
20581       EQUIVALENCE ( RHOIN2, RHONC2 (2) )
20582       EQUIVALENCE ( RHOIP3, RHONC3 (1) )
20583       EQUIVALENCE ( RHOIN3, RHONC3 (2) )
20584       EQUIVALENCE ( RHOIPT, RHONCT (1) )
20585       EQUIVALENCE ( RHOINT, RHONCT (2) )
20586       EQUIVALENCE ( OMALHL, SK3PAR )
20587       EQUIVALENCE ( ALPHAL, HABPAR )
20588       EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
20589       EQUIVALENCE ( SIGMPE, SIGMPR (1) )
20590       EQUIVALENCE ( SIGMPC, SIGMPR (2) )
20591       EQUIVALENCE ( SIGMPI, SIGMPR (3) )
20592       EQUIVALENCE ( SIGMPA, SIGMPR (4) )
20593       EQUIVALENCE ( SIGMNE, SIGMNU (1) )
20594       EQUIVALENCE ( SIGMNC, SIGMNU (2) )
20595       EQUIVALENCE ( SIGMNI, SIGMNU (3) )
20596       EQUIVALENCE ( SIGMNA, SIGMNU (4) )
20597       EQUIVALENCE ( SIGMA2, SIGPAB (1) )
20598       EQUIVALENCE ( SIGMA3, SIGPAB (2) )
20599       EQUIVALENCE ( SIGMAS, SIGPAB (3) )
20600       EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
20601 * (original name: NUCLEV)
20602       LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
20603       COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
20604      &                DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
20605      &                CUMRAD (0:160,2), RUSNUC (2),
20606      &                ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
20607      &                NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
20608      &                NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
20609      &                JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
20610      &                MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
20611      &                NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
20612      &                LFLVSL, LRLVSL, LEQSBL
20613       DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
20614      &          MGSSPR (19) , MGSSNE (25)
20615       EQUIVALENCE ( RUSNUC (1), RUSPRO )
20616       EQUIVALENCE ( RUSNUC (2), RUSNEU )
20617       EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
20618       EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
20619       EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
20620       EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
20621       EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
20622       EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
20623       EQUIVALENCE ( NTANUC (1), NTAPRO )
20624       EQUIVALENCE ( NTANUC (2), NTANEU )
20625       EQUIVALENCE ( NAVNUC (1), NAVPRO )
20626       EQUIVALENCE ( NAVNUC (2), NAVNEU )
20627       EQUIVALENCE ( NLSNUC (1), NLSPRO )
20628       EQUIVALENCE ( NLSNUC (2), NLSNEU )
20629       EQUIVALENCE ( NCONUC (1), NCOPRO )
20630       EQUIVALENCE ( NCONUC (2), NCONEU )
20631       EQUIVALENCE ( NSKNUC (1), NSKPRO )
20632       EQUIVALENCE ( NSKNUC (2), NSKNEU )
20633       EQUIVALENCE ( NHANUC (1), NHAPRO )
20634       EQUIVALENCE ( NHANUC (2), NHANEU )
20635       EQUIVALENCE ( NUSNUC (1), NUSPRO )
20636       EQUIVALENCE ( NUSNUC (2), NUSNEU )
20637       EQUIVALENCE ( NACNUC (1), NACPRO )
20638       EQUIVALENCE ( NACNUC (2), NACNEU )
20639       EQUIVALENCE ( JMXNUC (1), JMXPRO )
20640       EQUIVALENCE ( JMXNUC (2), JMXNEU )
20641       EQUIVALENCE ( MAGNUC (1), MAGPRO )
20642       EQUIVALENCE ( MAGNUC (2), MAGNEU )
20643 * (original name: PAREVT)
20644       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20645      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20646       PARAMETER ( NALLWP = 39   )
20647       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20648      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20649      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20650      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20651 * (original name: XSEPAR)
20652       COMMON /FKXSEP/ AANXSE (100), BBNXSE (100), CCNXSE (100),
20653      &                DDNXSE (100), EENXSE (100), ZZNXSE (100),
20654      &                EMNXSE (100), XMNXSE (100),
20655      &                AAPXSE (100), BBPXSE (100), CCPXSE (100),
20656      &                DDPXSE (100), EEPXSE (100), FFPXSE (100),
20657      &                ZZPXSE (100), EMPXSE (100), XMPXSE (100)
20658
20659 C---------------------------------------------------------------------
20660 **sr 17.5.95
20661 * modified for use in DPMJET
20662 C     WRITE( LUNOUT,'(A,I2)')
20663 C    & ' *** Reading evaporation and nuclear data from unit: ', NBERTP
20664 C     REWIND NBERTP
20665       IF (LEVPRT) WRITE(LUNOUT,1000)
20666  1000 FORMAT(/,1X,'BERTTP:',4X,'Initialization of evaporation module',
20667      &       /,12X,'------------------------------------',/)
20668       NBERNW = 23
20669 CPH      OPEN (UNIT=NBERNW,FILE='dpmjet.dat',STATUS='UNKNOWN')
20670
20671 **sr 17.5.
20672 *!!!! changed to be able to read the ASCII !!!!
20673 **
20674 C A. Ferrari: first of all read isotopic data
20675       READ (NBERNW,*) ISONDX
20676       READ (NBERNW,*) ISOMNM
20677       READ (NBERNW,*) ABUISO
20678 C     READ (NBERTP) ISONDX
20679 C     READ (NBERTP) ISOMNM
20680 C     READ (NBERTP) ABUISO
20681       DO 1 I=1,4
20682 C        READ  (NBERTP) (CRSC(J,I),J=1,600)
20683 C A. Ferrari: commented also the dummy read to save disk space
20684 C        READ  (NBERTP)
20685     1 CONTINUE
20686 C     READ  (NBERTP) CS
20687 C A. Ferrari: commented also the dummy read to save disk space
20688 C     READ  (NBERTP)
20689 C---------------------------------------------------------------------
20690       READ (NBERNW,*) (P0(I),P1(I),P2(I),I=1,1001)
20691       READ (NBERNW,*) IA,IZ
20692       DO 2 I=1,6
20693          FLA(I)=IA(I)
20694          FLZ(I)=IZ(I)
20695     2 CONTINUE
20696       READ (NBERNW,*) RHO,OMEGA
20697       READ (NBERNW,*) EXMASS
20698       READ (NBERNW,*) CAM2
20699       READ (NBERNW,*) CAM3
20700       READ (NBERNW,*) CAM4
20701       READ (NBERNW,*) CAM5
20702       READ (NBERNW,*) ((T(I,J),J=1,7),I=1,3)
20703       DO 3 I=1,7
20704          T(4,I) = ZERZER
20705     3 CONTINUE
20706       READ (NBERNW,*) RMASS
20707       READ (NBERNW,*) ALPH
20708       READ (NBERNW,*) BET
20709       READ (NBERNW,*) INWAPS
20710       READ (NBERNW,*) WAPS
20711       READ (NBERNW,*) T12NUC
20712       READ (NBERNW,*) JSPNUC
20713       READ (NBERNW,*) JPTNUC
20714       READ (NBERNW,*) INWISM
20715       READ (NBERNW,*) IZWISM
20716       READ (NBERNW,*) WAPISM
20717       READ (NBERNW,*) T12ISM
20718       READ (NBERNW,*) JSPISM
20719       READ (NBERNW,*) JPTISM
20720       READ (NBERNW,*) APRIME
20721       IF (LEVPRT)
20722      &WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20723       READ (NBERNW,*) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20724       IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20725      &     ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20726          WRITE (LUNOUT,*)
20727      &         ' *** Inconsistent Nuclear Geometry data on file ***'
20728          STOP
20729       END IF
20730       READ (NBERNW,*) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20731      &              EKATAB, PFATAB, PFRTAB
20732       READ (NBERNW,*) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20733      &              EMNXSE, XMNXSE
20734       READ (NBERNW,*) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20735      &              ZZPXSE, EMPXSE, XMPXSE
20736 *  Data about Fermi-breakup:
20737       READ (NBERNW,*) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20738       IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20739      &     MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20740          WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20741      &                   ' in the Nuclear Data file ***'
20742          STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20743       END IF
20744       READ (NBERNW,*) IFRBKN
20745       READ (NBERNW,*) IFRBKZ
20746       READ (NBERNW,*) IFBKSP
20747       READ (NBERNW,*) IFBKST
20748       READ (NBERNW,*) EEXFBK
20749
20750       CLOSE (UNIT=NBERNW)
20751
20752 C     READ (NBERTP) (P0(I),P1(I),P2(I),I=1,1001)
20753 C     READ (NBERTP) IA,IZ
20754 C     DO 2 I=1,6
20755 C        FLA(I)=IA(I)
20756 C        FLZ(I)=IZ(I)
20757 C   2 CONTINUE
20758 C     READ (NBERTP) RHO,OMEGA
20759 C     READ (NBERTP) EXMASS
20760 C     READ (NBERTP) CAM2
20761 C     READ (NBERTP) CAM3
20762 C     READ (NBERTP) CAM4
20763 C     READ (NBERTP) CAM5
20764 C     READ (NBERTP) ((T(I,J),J=1,7),I=1,3)
20765 C     DO 3 I=1,7
20766 C        T(4,I) = ZERZER
20767 C   3 CONTINUE
20768 C     READ (NBERTP) RMASS
20769 C     READ (NBERTP) ALPH
20770 C     READ (NBERTP) BET
20771 C     READ (NBERTP) INWAPS
20772 C     READ (NBERTP) WAPS
20773 C     READ (NBERTP) T12NUC
20774 C     READ (NBERTP) JSPNUC
20775 C     READ (NBERTP) JPTNUC
20776 C     READ (NBERTP) INWISM
20777 C     READ (NBERTP) IZWISM
20778 C     READ (NBERTP) WAPISM
20779 C     READ (NBERTP) T12ISM
20780 C     READ (NBERTP) JSPISM
20781 C     READ (NBERTP) JPTISM
20782 C     READ (NBERTP) APRIME
20783 C     WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20784 C     READ (NBERTP) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20785 C     IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20786 C    &     ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20787 C        WRITE (LUNOUT,*)
20788 C    &         ' *** Inconsistent Nuclear Geometry data on file ***'
20789 C        STOP
20790 C     END IF
20791 C     READ (NBERTP) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20792 C    &              EKATAB, PFATAB, PFRTAB
20793 C     READ (NBERTP) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20794 C    &              EMNXSE, XMNXSE
20795 C     READ (NBERTP) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20796 C    &              ZZPXSE, EMPXSE, XMPXSE
20797 *  Data about Fermi-breakup:
20798 C     READ (NBERTP) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20799 C     IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20800 C    &     MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20801 C        WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20802 C    &                   ' in the Nuclear Data file ***'
20803 C        STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20804 C     END IF
20805 C     READ (NBERTP) IFRBKN
20806 C     READ (NBERTP) IFRBKZ
20807 C     READ (NBERTP) IFBKSP
20808 C     READ (NBERTP) IFBKST
20809 C     READ (NBERTP) EEXFBK
20810 C     CLOSE (UNIT=NBERTP)
20811       DO 100 JZ = 1, 130
20812          SHENUC ( JZ, 1 ) = EMVGEV * ( CAM2 (JZ) + CAM4 (JZ) )
20813   100 CONTINUE
20814       DO 200 JA = 1, 200
20815          SHENUC ( JA, 2 ) = EMVGEV * ( CAM3 (JA) + CAM5 (JA) )
20816   200 CONTINUE
20817       CALL DT_STALIN
20818       IF ( ILVMOD .LE. 0 ) THEN
20819          ILVMOD = IB0
20820       ELSE
20821          IB0 = ILVMOD
20822       END IF
20823       IF ( LLVMOD ) THEN
20824          DO 300 JZ = 1, IZCOOK
20825             CAM4 (JZ) = PZCOOK (JZ)
20826   300    CONTINUE
20827          DO 400 JN = 1, INCOOK
20828             CAM5 (JN) = PNCOOK (JZ)
20829   400    CONTINUE
20830       END IF
20831 **sr
20832       IF (LEVPRT) THEN
20833          WRITE (LUNOUT,*)
20834          IF ( ILVMOD .EQ. 1 ) THEN
20835             WRITE (LUNOUT,*)
20836      &   ' **** Standard EVAP T=0 level density used ****'
20837          ELSE IF ( ILVMOD .EQ. 2 ) THEN
20838             WRITE (LUNOUT,*)
20839      &   ' **** Gilbert & Cameron T=0 N,Z-dep. level density used ****'
20840          ELSE IF ( ILVMOD .EQ. 3 ) THEN
20841             WRITE (LUNOUT,*)
20842      &      ' **** Julich A-dependent level density used ****'
20843          ELSE IF ( ILVMOD .EQ. 4 ) THEN
20844             WRITE (LUNOUT,*)
20845      &   ' **** Brancazio & Cameron T=0 N,Z-dep. level density used',
20846      &                                                          ' ****'
20847          ELSE
20848             WRITE (LUNOUT,*)
20849      &   ' **** Unknown T=0 level density option requested ****'
20850             STOP 'BERTTP-ILVMOD'
20851          END IF
20852          IF ( JLVMOD .LE. 0 ) THEN
20853             GAMIGN = ZERZER
20854             WRITE (LUNOUT,*)
20855      &   ' **** No Excitation en. dependence for level densities ****'
20856          ELSE IF ( JLVMOD .EQ. 1 ) THEN
20857             WRITE (LUNOUT,*)
20858      &   ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20859             WRITE (LUNOUT,*)
20860      &   ' **** with Ignyatuk (1975, 1st) set of parameters for T=oo',
20861      &                                                        ' ****'
20862             GAMIGN = 0.054D+00
20863             BETIGN = -6.3 D-05
20864             ALPIGN = 0.154D+00
20865             POWIGN = ZERZER
20866          ELSE IF ( JLVMOD .EQ. 2 ) THEN
20867             WRITE (LUNOUT,*)
20868      &   ' ****   Ignyatuk (1975, 1st) level density en. dep. used ****'
20869             WRITE (LUNOUT,*)
20870      &   ' **** with UNKNOWN set of parameters for T=oo ****'
20871             STOP 'BERTTP-JLVMOD'
20872          ELSE IF ( JLVMOD .EQ. 3 ) THEN
20873             WRITE (LUNOUT,*)
20874      &   ' ****   Ignyatuk (1975, 1st) level density en. dep. used ****'
20875             WRITE (LUNOUT,*)
20876      &   ' **** with UNKNOWN set of parameters for T=oo ****'
20877             STOP 'BERTTP-JLVMOD'
20878          ELSE IF ( JLVMOD .EQ. 4 ) THEN
20879             WRITE (LUNOUT,*)
20880      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20881             WRITE (LUNOUT,*)
20882      &   ' **** with Ignyatuk (1975, 2nd) set of parameters for T=oo',
20883      &                                                        ' ****'
20884             GAMIGN = 0.054D+00
20885             BETIGN = 0.162D+00
20886             ALPIGN = 0.114D+00
20887             POWIGN = -ONETHI
20888          ELSE IF ( JLVMOD .EQ. 5 ) THEN
20889             WRITE (LUNOUT,*)
20890      &   ' ****  Ignyatuk (1975, 2nd) level density en. dep. used  ****'
20891             WRITE (LUNOUT,*)
20892      &   ' **** with Iljinov & Mebel 1st set of parameters for T=oo****'
20893             GAMIGN = 0.051D+00
20894             BETIGN = 0.098D+00
20895             ALPIGN = 0.114D+00
20896             POWIGN = -ONETHI
20897          ELSE IF ( JLVMOD .EQ. 6 ) THEN
20898             WRITE (LUNOUT,*)
20899      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20900             WRITE (LUNOUT,*)
20901      &   ' **** with Iljinov & Mebel 2nd set of parameters for T=oo****'
20902             GAMIGN = -0.46D+00
20903             BETIGN = 0.107D+00
20904             ALPIGN = 0.111D+00
20905             POWIGN = -ONETHI
20906          ELSE IF ( JLVMOD .EQ. 7 ) THEN
20907             WRITE (LUNOUT,*)
20908      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20909             WRITE (LUNOUT,*)
20910      &   ' **** with Iljinov & Mebel 3rd set of parameters for T=oo****'
20911             GAMIGN = 0.059D+00
20912             BETIGN = 0.257D+00
20913             ALPIGN = 0.072D+00
20914             POWIGN = -ONETHI
20915          ELSE IF ( JLVMOD .EQ. 8 ) THEN
20916             WRITE (LUNOUT,*)
20917      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20918             WRITE (LUNOUT,*)
20919      &   ' **** with Iljinov & Mebel 4th set of parameters for T=oo****'
20920             GAMIGN = -0.37D+00
20921             BETIGN = 0.229D+00
20922             ALPIGN = 0.077D+00
20923             POWIGN = -ONETHI
20924          ELSE
20925             WRITE (LUNOUT,*)
20926      &   ' **** Unknown T=oo level density option requested ****'
20927             STOP 'BERTTP-JLVMOD'
20928          END IF
20929          IF ( LLVMOD ) THEN
20930             WRITE (LUNOUT,*)
20931      &      ' **** Cook''s modified pairing energy used ****'
20932          ELSE
20933             WRITE (LUNOUT,*)
20934      &      ' **** Original Gilbert/Cameron pairing energy used ****'
20935          END IF
20936       ENDIF
20937 **
20938
20939       ILVMOD = IB0
20940       DO 500 JZ = 1, 130
20941          PAENUC ( JZ, 1 ) = EMVGEV * CAM4 (JZ)
20942   500 CONTINUE
20943       DO 600 JA = 1, 200
20944          PAENUC ( JA, 2 ) = EMVGEV * CAM5 (JA)
20945   600 CONTINUE
20946       RETURN
20947       END
20948
20949 *$ CREATE DT_EVEVAP.FOR
20950 *COPY DT_EVEVAP
20951 *
20952 *====evevap============================================================*
20953 *
20954       SUBROUTINE DT_EVEVAP(WE)
20955
20956       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20957       SAVE
20958       PARAMETER ( LINP = 10 ,
20959      &            LOUT = 6 ,
20960      &            LDAT = 9 )
20961
20962 * flags for input different options
20963       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
20964       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
20965      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
20966
20967       LEVAPO = .FALSE.
20968
20969       RETURN
20970       END
20971
20972 *$ CREATE DT_FRBKIN.FOR
20973 *COPY DT_FRBKIN
20974 *
20975 *====frbkin============================================================*
20976 *
20977       SUBROUTINE DT_FRBKIN(LDUM1,LDUM2)
20978
20979       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20980       SAVE
20981       PARAMETER ( LINP = 10 ,
20982      &            LOUT = 6 ,
20983      &            LDAT = 9 )
20984
20985       LOGICAL LDUM1,LDUM2
20986
20987       RETURN
20988       END
20989
20990 *$ CREATE DT_EXPLOD.FOR
20991 *COPY DT_EXPLOD
20992 *
20993 *=== explod ===========================================================*
20994 *
20995       SUBROUTINE DT_EXPLOD( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
20996      &                    PYEXPL, PZEXPL )
20997
20998       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20999       SAVE
21000
21001       DIMENSION PXEXPL (NPEXPL), PYEXPL (NPEXPL), PZEXPL (NPEXPL),
21002      &          ETEXPL (NPEXPL), AMEXPL (NPEXPL)
21003
21004       RETURN
21005       END
21006
21007 ************************************************************************
21008 *                                                                      *
21009 *  DPMJET 3.0:   cross section routines                                *
21010 *                                                                      *
21011 ************************************************************************
21012 *
21013 *
21014 *     SUBROUTINE DT_SHNDIF
21015 *         diffractive cross sections (all energies)
21016 *     SUBROUTINE DT_PHOXS
21017 *         total and inel. cross sections from PHOJET interpol. tables
21018 *     SUBROUTINE DT_XSHN
21019 *         total and el. cross sections for all energies
21020 *     SUBROUTINE DT_SIHNAB
21021 *         pion 2-nucleon absorption cross sections
21022 *     SUBROUTINE DT_SIGEMU
21023 *         cross section for target "compounds"
21024 *     SUBROUTINE DT_SIGGA
21025 *         photon nucleus cross sections
21026 *     SUBROUTINE DT_SIGGAT
21027 *         photon nucleus cross sections from tables
21028 *     SUBROUTINE DT_SANO
21029 *         anomalous hard photon-nucleon cross sections from tables
21030 *     SUBROUTINE DT_SIGGP
21031 *         photon nucleon cross sections
21032 *     SUBROUTINE DT_SIGVEL
21033 *         quasi-elastic vector meson prod. cross sections
21034 *     DOUBLE PRECISION FUNCTION DT_SIGVP
21035 *         sigma_VN(tilde)
21036 *     DOUBLE PRECISION FUNCTION DT_RRM2
21037 *     DOUBLE PRECISION FUNCTION DT_RM2
21038 *     DOUBLE PRECISION FUNCTION DT_SAM2
21039 *     SUBROUTINE DT_CKMT
21040 *     SUBROUTINE DT_CKMTX
21041 *     SUBROUTINE DT_PDF0
21042 *     SUBROUTINE DT_CKMTQ0
21043 *     SUBROUTINE DT_CKMTDE
21044 *     SUBROUTINE DT_CKMTPR
21045 *     FUNCTION DT_CKMTFF
21046 *
21047 *     SUBROUTINE DT_FLUINI
21048 *         total nucleon cross section fluctuation treatment
21049 *
21050 *     SUBROUTINE DT_SIGTBL
21051 *         pre-tabulation of low-energy elastic x-sec. using SIHNEL
21052 *     SUBROUTINE DT_XSTABL
21053 *         service routines
21054 *
21055 *
21056 *$ CREATE DT_SHNDIF.FOR
21057 *COPY DT_SHNDIF
21058 *
21059 *===shndif===============================================================*
21060 *
21061       SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
21062
21063 **********************************************************************
21064 *   Single diffractive hadron-nucleon cross sections                 *
21065 *                                              S.Roesler 14/1/93     *
21066 *                                                                    *
21067 *   The cross sections are calculated from extrapolated single       *
21068 *   diffractive antiproton-proton cross sections (DTUJET92) using    *
21069 *   scaling relations between total and single diffractive cross     *
21070 *   sections.                                                        *
21071 **********************************************************************
21072
21073       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21074       SAVE
21075       PARAMETER (ZERO=0.0D0)
21076
21077 * particle properties (BAMJET index convention)
21078       CHARACTER*8  ANAME
21079       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21080      &                IICH(210),IIBAR(210),K1(210),K2(210)
21081 *
21082       CSD1   =   4.201483727D0
21083       CSD4   = -0.4763103556D-02
21084       CSD5   =  0.4324148297D0
21085 *
21086       CHMSD1 =  0.8519297242D0
21087       CHMSD4 = -0.1443076599D-01
21088       CHMSD5 =  0.4014954567D0
21089 *
21090       EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
21091       PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
21092 *
21093       SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21094       SHMSD  = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
21095       FRAC   = SHMSD/SDIAPP
21096 *
21097       GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
21098      &     999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
21099      &      10, 10, 20, 20, 20) KPROJ
21100 *
21101    10 CONTINUE
21102 *---------------------------- p - p , n - p , sigma0+- - p ,
21103 *                             Lambda - p
21104       CSD1   =  6.004476070D0
21105       CSD4   = -0.1257784606D-03
21106       CSD5   =  0.2447335720D0
21107       SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21108       SIGDIH = FRAC*SIGDIF
21109       RETURN
21110 *
21111    20 CONTINUE
21112 *
21113       KPSCAL = 2
21114       KTSCAL = 1
21115 C     F      = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
21116       DUMZER = ZERO
21117       CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
21118       F      = SDIAPP/SIGTO
21119       KT     = 1
21120 C     SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
21121       CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
21122       SIGDIF = SIGTO*F
21123       SIGDIH = FRAC*SIGDIF
21124       RETURN
21125 *
21126   999 CONTINUE
21127 *-------------------------- leptons..
21128       SIGDIF = 1.D-10
21129       SIGDIH = 1.D-10
21130       RETURN
21131       END
21132
21133 *$ CREATE DT_PHOXS.FOR
21134 *COPY DT_PHOXS
21135 *
21136 *===phoxs================================================================*
21137 *
21138       SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
21139
21140 ************************************************************************
21141 * Total/inelastic proton-nucleon cross sections taken from PHOJET-     *
21142 * interpolation tables.                                                *
21143 * This version dated 05.11.97 is written by S. Roesler                 *
21144 ************************************************************************
21145
21146       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21147       SAVE
21148
21149       PARAMETER ( LINP = 10 ,
21150      &            LOUT = 6 ,
21151      &            LDAT = 9 )
21152       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21153       PARAMETER (TWOPI  = 6.283185307179586454D+00,
21154      &           PI     = TWOPI/TWO,
21155      &           GEV2MB = 0.38938D0)
21156
21157       LOGICAL LFIRST
21158       DATA LFIRST /.TRUE./
21159
21160 * nucleon-nucleon event-generator
21161       CHARACTER*8 CMODEL
21162       LOGICAL LPHOIN
21163       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21164 * particle properties (BAMJET index convention)
21165       CHARACTER*8  ANAME
21166       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21167      &                IICH(210),IIBAR(210),K1(210),K2(210)
21168
21169 **PHOJET105a
21170 C     PARAMETER (IEETAB=10)
21171 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21172 **PHOJET110
21173 C  energy-interpolation table
21174       INTEGER IEETA2
21175       PARAMETER ( IEETA2 = 20 )
21176       INTEGER ISIMAX
21177       DOUBLE PRECISION SIGTAB,SIGECM
21178       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21179 **
21180
21181       IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
21182          WRITE(LOUT,*) MCGENE
21183  1000    FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
21184          STOP
21185       ENDIF
21186
21187       IF (ECM.LE.ZERO) THEN
21188          EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
21189          ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
21190       ENDIF
21191
21192       IF (MODE.EQ.1) THEN
21193 * DL
21194          DELDL = 0.0808D0
21195          EPSDL = -0.4525D0
21196          S     = ECM*ECM
21197          STOT  = 21.7D0*S**DELDL+56.08D0*S**EPSDL
21198          ALPHAP= 0.25D0
21199          BEL   = 8.5D0+2.D0*ALPHAP*LOG(S)
21200          SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
21201          SINE  = STOT-SIGEL
21202          SDIF1 = ZERO
21203       ELSE
21204 * Phojet
21205          IP = 1
21206          IF(ECM.LE.SIGECM(IP,1)) THEN
21207            I1 = 1
21208            I2 = 1
21209          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21210            DO 1 I=2,ISIMAX
21211               IF (ECM.LE.SIGECM(IP,I)) GOTO 2
21212     1      CONTINUE
21213     2      CONTINUE
21214            I1 = I-1
21215            I2 = I
21216          ELSE
21217            IF (LFIRST) THEN
21218               WRITE(LOUT,'(/1X,A,2E12.3)')
21219      &          'PHOXS: warning! energy above initialization limit (',
21220      &          ECM,SIGECM(IP,ISIMAX)
21221              LFIRST = .FALSE.
21222            ENDIF
21223            I1 = ISIMAX
21224            I2 = ISIMAX
21225          ENDIF
21226          FAC2 = ZERO
21227          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21228      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21229          FAC1  = ONE-FAC2
21230          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21231          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21232          SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
21233      &           FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
21234          BEL   = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
21235       ENDIF
21236
21237       RETURN
21238       END
21239
21240 *$ CREATE DT_XSHN.FOR
21241 *COPY DT_XSHN
21242 *
21243 *===xshn===============================================================*
21244 *
21245       SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
21246
21247 ************************************************************************
21248 * Total and elastic hadron-nucleon cross section.                      *
21249 * Below 500GeV cross sections are based on the '98 data compilation    *
21250 * of the PDG. At higher energies PHOJET results are used (patched to   *
21251 * the low energy data at 500GeV).                                      *
21252 *     IP      projectile index (BAMJET numbering scheme)               *
21253 *             (should be in the range 1..25)                           *
21254 *     IT      target index (BAMJET numbering scheme)                   *
21255 *             (1 = proton, 8 = neutron)                                *
21256 *     PL      laboratory momentum                                      *
21257 *     ECM     cm. energy (ignored if PL>0)                             *
21258 *     STOT    total cross section                                      *
21259 *     SELA    elastic cross section                                    *
21260 * Last change: 24.4.99 by S. Roesler                                   *
21261 ************************************************************************
21262
21263       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21264       SAVE
21265
21266       PARAMETER ( LINP = 10 ,
21267      &            LOUT = 6 ,
21268      &            LDAT = 9 )
21269       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
21270
21271       PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
21272      &           PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
21273       PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
21274
21275       LOGICAL LFIRST
21276 * particle properties (BAMJET index convention)
21277       CHARACTER*8  ANAME
21278       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21279      &                IICH(210),IIBAR(210),K1(210),K2(210)
21280 * nucleon-nucleon event-generator
21281       CHARACTER*8 CMODEL
21282       LOGICAL LPHOIN
21283       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21284 **PHOJET105a
21285 C     PARAMETER (IEETAB=10)
21286 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21287 **PHOJET110
21288 C  energy-interpolation table
21289       INTEGER IEETA2
21290       PARAMETER ( IEETA2 = 20 )
21291       INTEGER ISIMAX
21292       DOUBLE PRECISION SIGTAB,SIGECM
21293       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21294
21295       DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
21296       DIMENSION IDXDAT(25,2)
21297 *
21298       DATA APL /
21299      &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
21300      &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
21301      &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
21302      &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
21303      & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
21304      & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
21305      & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
21306 *
21307 * total cross sections:
21308 * p p
21309       DATA (ASIGTO(1,K),K=1,NPOINT) /
21310      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21311      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21312      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
21313      & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
21314      & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
21315      & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
21316      & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
21317 * pbar p
21318       DATA (ASIGTO(2,K),K=1,NPOINT) /
21319      & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
21320      & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
21321      & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
21322      & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
21323      & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
21324      & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
21325      & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
21326 * n p
21327       DATA (ASIGTO(3,K),K=1,NPOINT) /
21328      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21329      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21330      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21331      & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
21332      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21333      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21334      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21335 * pi+ p
21336       DATA (ASIGTO(4,K),K=1,NPOINT) /
21337      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21338      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21339      & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
21340      & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
21341      & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
21342      & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
21343      & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
21344 * pi- p
21345       DATA (ASIGTO(5,K),K=1,NPOINT) /
21346      & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
21347      & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
21348      & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
21349      & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
21350      & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
21351      & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
21352      & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
21353 * K+ p
21354       DATA (ASIGTO(6,K),K=1,NPOINT) /
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.097, 1.097,
21357      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
21358      & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
21359      & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
21360      & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
21361      & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
21362 * K- p
21363       DATA (ASIGTO(7,K),K=1,NPOINT) /
21364      & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
21365      & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
21366      & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
21367      & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
21368      & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
21369      & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
21370      & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21371 * K+ n
21372       DATA (ASIGTO(8,K),K=1,NPOINT) /
21373      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21374      & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21375      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21376      & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21377      & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21378      & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21379      & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21380 * K- n
21381       DATA (ASIGTO(9,K),K=1,NPOINT) /
21382      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21383      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21384      & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21385      & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21386      & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21387      & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21388      & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21389 * Lambda p
21390       DATA (ASIGTO(10,K),K=1,NPOINT) /
21391      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21392      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21393      & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21394      & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21395      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21396      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21397      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21398 *
21399 * elastic cross sections:
21400 * p p
21401       DATA (ASIGEL(1,K),K=1,NPOINT) /
21402      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21403      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21404      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21405      & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21406      & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21407      & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21408      & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21409 * pbar p
21410       DATA (ASIGEL(2,K),K=1,NPOINT) /
21411      & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21412      & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21413      & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21414      & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21415      & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21416      & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21417      & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21418 * n p
21419       DATA (ASIGEL(3,K),K=1,NPOINT) /
21420      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21421      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21422      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21423      & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21424      & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21425      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21426      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21427 * pi+ p
21428       DATA (ASIGEL(4,K),K=1,NPOINT) /
21429      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21430      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21431      & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21432      & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21433      & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21434      & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21435      & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21436 * pi- p
21437       DATA (ASIGEL(5,K),K=1,NPOINT) /
21438      & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21439      & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21440      & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21441      & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21442      & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21443      & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21444      & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21445 * K+ p
21446       DATA (ASIGEL(6,K),K=1,NPOINT) /
21447      & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21448      & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21449      & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21450      & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21451      & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21452      & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21453      & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21454 * K- p
21455       DATA (ASIGEL(7,K),K=1,NPOINT) /
21456      & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21457      & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21458      & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21459      & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21460      & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21461      & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21462      & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21463 * K+ n
21464       DATA (ASIGEL(8,K),K=1,NPOINT) /
21465      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21466      & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21467      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21468      & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21469      & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21470      & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21471      & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21472 * K- n
21473       DATA (ASIGEL(9,K),K=1,NPOINT) /
21474      & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21475      & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21476      & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21477      & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21478      & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21479      & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21480      & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21481 * Lambda p
21482       DATA (ASIGEL(10,K),K=1,NPOINT) /
21483      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21484      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21485      & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21486      & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21487      & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21488      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21489      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21490
21491       DATA (IDXDAT(K,1),K=1,25) /
21492      &  1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21493      &  1, 3,45, 8, 9/
21494       DATA (IDXDAT(K,2),K=1,25) /
21495      &  3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21496      &  3, 1,45, 6, 7/
21497
21498       DATA LFIRST /.TRUE./
21499
21500       IF (LFIRST) THEN
21501          APLABL = LOG10(PLABLO)
21502          APLABH = LOG10(PLABHI)
21503          APTHRE = LOG10(PTHRE)
21504          ADP1   = (APTHRE-APLABL)/DBLE(NPOIN1)
21505          ADP2   = (APLABH-APTHRE)/DBLE(NPOIN2)
21506          DUM0   = ZERO
21507          PHOPLA = PLABHI
21508          PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21509          ECMS   = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21510          IF (MCGENE.EQ.2) THEN
21511             IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21512                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21513             ELSE
21514                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21515             ENDIF
21516          ELSE
21517             CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21518          ENDIF
21519          PHOSEL = PHOSTO-PHOSIN
21520          APHOST = LOG10(PHOSTO)
21521          APHOSE = LOG10(PHOSEL)
21522          LFIRST = .FALSE.
21523       ENDIF
21524       STOT = ZERO
21525       SELA = ZERO
21526       PLAB = PL
21527       ECMS = ECM
21528       IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21529          WRITE(LOUT,1000) IP,IT
21530  1000    FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21531      &          'proj/target',2I4)
21532          STOP
21533       ENDIF
21534
21535       IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21536          ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21537          PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21538       ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21539          WRITE(LOUT,1001) PLAB,ECMS
21540  1001    FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21541          STOP
21542       ENDIF
21543
21544 * index of spectrum
21545       IDXP = IP
21546       IF (IP.GT.25) THEN
21547          IF (AAM(IP).GT.ZERO) THEN
21548             IF (ABS(IIBAR(IP)).GT.0) THEN
21549                IDXP = 1
21550             ELSE
21551                IDXP = 13
21552             ENDIF
21553          ELSE
21554             IDXP = 7
21555          ENDIF
21556       ENDIF
21557       IDXT = 1
21558       IF (IT.EQ.8) IDXT = 2
21559       IDXS = IDXDAT(IDXP,IDXT)
21560       IF (IDXS.EQ.0) RETURN
21561
21562 * compute momentum bin indices
21563       IF (PLAB.LT.PLABLO) THEN
21564          IDX0 = 1
21565          IDX1 = 1
21566       ELSEIF (PLAB.GE.PLABHI) THEN
21567          IDX0 = NPOINT
21568          IDX1 = NPOINT
21569       ELSE
21570          APLAB = LOG10(PLAB)
21571          IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21572             IDX0 = INT((APLAB-APLABL)/ADP1)+1
21573          ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21574             IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21575          ENDIF
21576          IDX1 = IDX0+1
21577       ENDIF
21578
21579 * interpolate cross section
21580       IF (IDXS.GT.10) THEN
21581          IDXS1 = IDXS/10
21582          IDXS2 = IDXS-10*IDXS1
21583          IF (IDX0.EQ.IDX1) THEN
21584             IF (IDX0.EQ.1) THEN
21585                ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21586                ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21587             ELSE
21588                DUM0   = ZERO
21589                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21590                PHOSEL = PHOSTO-PHOSIN
21591                ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21592                ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21593                ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21594                ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21595                ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
21596                ASELA  = 0.5D0*(ASELA1+ASELA2)
21597             ENDIF
21598          ELSE
21599             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21600             ASTOT1 = ASIGTO(IDXS1,IDX0)+
21601      &               FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21602             ASTOT2 = ASIGTO(IDXS2,IDX0)+
21603      &               FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21604             ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
21605             ASELA1 = ASIGEL(IDXS1,IDX0)+
21606      &               FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21607             ASELA2 = ASIGEL(IDXS2,IDX0)+
21608      &               FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21609             ASELA  = 0.5D0*(ASELA1+ASELA2)
21610          ENDIF
21611       ELSE
21612          IF (IDX0.EQ.IDX1) THEN
21613             IF (IDX0.EQ.1) THEN
21614                ASTOT = ASIGTO(IDXS,IDX0)
21615                ASELA = ASIGEL(IDXS,IDX0)
21616             ELSE
21617                DUM0   = ZERO
21618                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21619                PHOSEL = PHOSTO-PHOSIN
21620                ASTOT  = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21621                ASELA  = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21622             ENDIF
21623          ELSE
21624             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21625             ASTOT = ASIGTO(IDXS,IDX0)+
21626      &              FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21627             ASELA = ASIGEL(IDXS,IDX0)+
21628      &              FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21629          ENDIF
21630       ENDIF
21631       STOT = 10.0D0**ASTOT
21632       SELA = 10.0D0**ASELA
21633
21634       RETURN
21635       END
21636
21637 *$ CREATE DT_SIHNAB.FOR
21638 *COPY DT_SIHNAB
21639 *
21640 *===sihnab===============================================================*
21641 *
21642       SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21643
21644 **********************************************************************
21645 * Pion 2-nucleon absorption cross sections.                          *
21646 * (sigma_tot for pi+ d --> p p, pi- d --> n n                        *
21647 *  taken from Ritchie PRC 28 (1983) 926 )                            *
21648 * This version dated 18.05.96 is written by S. Roesler               *
21649 **********************************************************************
21650
21651       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21652       SAVE
21653       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21654       PARAMETER (AMPR = 938.0D0,
21655      &           AMPI = 140.0D0,
21656      &           AMDE = TWO*AMPR,
21657      &           A    = -1.2D0,
21658      &           B    = 3.5D0,
21659      &           C    = 7.4D0,
21660      &           D    = 5600.0D0,
21661      &           ER   = 2136.0D0)
21662
21663       SIGABS = ZERO
21664       IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21665      &                   .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21666       PTOT = PLAB*1.0D3
21667       EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21668       IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21669       ECM  = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21670       SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21671 * approximate 3N-abs., I=1-abs. etc.
21672       SIGABS = SIGABS/0.40D0
21673 * pi0-absorption (rough approximation!!)
21674       IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21675
21676       RETURN
21677       END
21678
21679 *$ CREATE DT_SIGEMU.FOR
21680 *COPY DT_SIGEMU
21681 *
21682 *===sigemu=============================================================*
21683 *
21684       SUBROUTINE DT_SIGEMU
21685
21686 ************************************************************************
21687 * Combined cross section for target compounds.                         *
21688 * This version dated 6.4.98   is written by S. Roesler                 *
21689 ************************************************************************
21690
21691       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21692       SAVE
21693       PARAMETER ( LINP = 10 ,
21694      &            LOUT = 6 ,
21695      &            LDAT = 9 )
21696       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21697      &           OHALF=0.5D0,ONE=1.0D0)
21698
21699       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21700 * Glauber formalism: cross sections
21701       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21702      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21703      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21704      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21705      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21706      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21707      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21708      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21709      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21710      &                BSLOPE,NEBINI,NQBINI
21711 * emulsion treatment
21712       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21713      &                NCOMPO,IEMUL
21714 * nucleon-nucleon event-generator
21715       CHARACTER*8 CMODEL
21716       LOGICAL LPHOIN
21717       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21718
21719       IF (MCGENE.NE.4) THEN
21720          WRITE(LOUT,'(A)') ' DT_SIGEMU:    Combined cross sections'
21721          WRITE(LOUT,'(15X,A)') '-----------------------'
21722       ENDIF
21723       DO 1 IE=1,NEBINI
21724          DO 2 IQ=1,NQBINI
21725             SIGTOT = ZERO
21726             SIGELA = ZERO
21727             SIGQEP = ZERO
21728             SIGQET = ZERO
21729             SIGQE2 = ZERO
21730             SIGPRO = ZERO
21731             SIGDEL = ZERO
21732             SIGDQE = ZERO
21733             ERRTOT = ZERO
21734             ERRELA = ZERO
21735             ERRQEP = ZERO
21736             ERRQET = ZERO
21737             ERRQE2 = ZERO
21738             ERRPRO = ZERO
21739             ERRDEL = ZERO
21740             ERRDQE = ZERO
21741             IF (NCOMPO.GT.0) THEN
21742                DO 3 IC=1,NCOMPO
21743                   SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21744                   SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21745                   SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21746                   SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21747                   SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21748                   SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21749                   SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21750                   SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21751                   ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21752                   ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21753                   ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21754                   ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21755                   ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21756                   ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21757                   ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21758                   ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21759     3          CONTINUE
21760                ERRTOT = SQRT(ERRTOT)
21761                ERRELA = SQRT(ERRELA)
21762                ERRQEP = SQRT(ERRQEP)
21763                ERRQET = SQRT(ERRQET)
21764                ERRQE2 = SQRT(ERRQE2)
21765                ERRPRO = SQRT(ERRPRO)
21766                ERRDEL = SQRT(ERRDEL)
21767                ERRDQE = SQRT(ERRDQE)
21768             ELSE
21769                SIGTOT = XSTOT(IE,IQ,1)
21770                SIGELA = XSELA(IE,IQ,1)
21771                SIGQEP = XSQEP(IE,IQ,1)
21772                SIGQET = XSQET(IE,IQ,1)
21773                SIGQE2 = XSQE2(IE,IQ,1)
21774                SIGPRO = XSPRO(IE,IQ,1)
21775                SIGDEL = XSDEL(IE,IQ,1)
21776                SIGDQE = XSDQE(IE,IQ,1)
21777                ERRTOT = XETOT(IE,IQ,1)
21778                ERRELA = XEELA(IE,IQ,1)
21779                ERRQEP = XEQEP(IE,IQ,1)
21780                ERRQET = XEQET(IE,IQ,1)
21781                ERRQE2 = XEQE2(IE,IQ,1)
21782                ERRPRO = XEPRO(IE,IQ,1)
21783                ERRDEL = XEDEL(IE,IQ,1)
21784                ERRDQE = XEDQE(IE,IQ,1)
21785             ENDIF
21786             IF (MCGENE.NE.4) THEN
21787                WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21788  1000         FORMAT(/,1X,'E_cm =',F9.1,' GeV  Q^2 =',F6.1,' GeV^2 :',/)
21789                WRITE(LOUT,1001) SIGTOT,ERRTOT
21790  1001          FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21791                WRITE(LOUT,1002) SIGELA,ERRELA
21792  1002          FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21793                WRITE(LOUT,1003) SIGQEP,ERRQEP
21794  1003          FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21795      &                F11.5,' mb')
21796                WRITE(LOUT,1004) SIGQET,ERRQET
21797  1004          FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21798      &                F11.5,' mb')
21799                WRITE(LOUT,1005) SIGQE2,ERRQE2
21800  1005          FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21801      &                ' +-',F11.5,' mb')
21802                WRITE(LOUT,1006) SIGPRO,ERRPRO
21803  1006          FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21804                WRITE(LOUT,1007) SIGDEL,ERRDEL
21805  1007          FORMAT(1X,'diff-el   ',27X,F10.4,' +-',F11.5,' mb')
21806                WRITE(LOUT,1008) SIGDQE,ERRDQE
21807  1008          FORMAT(1X,'diff-qel  ',27X,F10.4,' +-',F11.5,' mb')
21808             ENDIF
21809
21810     2    CONTINUE
21811     1 CONTINUE
21812
21813       RETURN
21814       END
21815
21816 *$ CREATE DT_SIGGA.FOR
21817 *COPY DT_SIGGA
21818 *
21819 *===sigga==============================================================*
21820 *
21821       SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21822
21823 ************************************************************************
21824 * Total/inelastic photon-nucleus cross sections.                       *
21825 *     !!!! Overwrites SHMAKI-initialization. Do not use it during      *
21826 *          production runs !!!!                                        *
21827 * This version dated 27.03.96 is written by S. Roesler                 *
21828 ************************************************************************
21829
21830       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21831       SAVE
21832       PARAMETER ( LINP = 10 ,
21833      &            LOUT = 6 ,
21834      &            LDAT = 9 )
21835       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21836      &           OHALF=0.5D0,ONE=1.0D0)
21837       PARAMETER (AMPROT = 0.938D0)
21838
21839       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21840 * Glauber formalism: cross sections
21841       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21842      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21843      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21844      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21845      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21846      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21847      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21848      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21849      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21850      &                BSLOPE,NEBINI,NQBINI
21851
21852       NT  = NTI
21853       X   = XI
21854       Q2  = Q2I
21855       ECM = ECMI
21856       XNU = XNUI
21857       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21858      &   ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21859       CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21860       STOT  = XSTOT(1,1,1)
21861       ETOT  = XETOT(1,1,1)
21862       SIN   = XSPRO(1,1,1)
21863       EIN   = XEPRO(1,1,1)
21864
21865       RETURN
21866       END
21867
21868 *$ CREATE DT_SIGGAT.FOR
21869 *COPY DT_SIGGAT
21870 *
21871 *===siggat=============================================================*
21872 *
21873       SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21874
21875 ************************************************************************
21876 * Total/inelastic photon-nucleus cross sections.                       *
21877 * Uses pre-tabulated cross section.                                    *
21878 * This version dated 29.07.96 is written by S. Roesler                 *
21879 ************************************************************************
21880
21881       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21882       SAVE
21883       PARAMETER ( LINP = 10 ,
21884      &            LOUT = 6 ,
21885      &            LDAT = 9 )
21886       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21887      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21888
21889       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21890 * Glauber formalism: cross sections
21891       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21892      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21893      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21894      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21895      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21896      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21897      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21898      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21899      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21900      &                BSLOPE,NEBINI,NQBINI
21901
21902       NTARG = ABS(NT)
21903       I1   = 1
21904       I2   = 1
21905       RATE = ONE
21906       IF (NEBINI.GT.1) THEN
21907          IF (ECMI.GE.ECMNN(NEBINI)) THEN
21908             I1   = NEBINI
21909             I2   = NEBINI
21910             RATE = ONE
21911          ELSEIF (ECMI.GT.ECMNN(1)) THEN
21912             DO 1 I=2,NEBINI
21913                IF (ECMI.LT.ECMNN(I)) THEN
21914                   I1   = I-1
21915                   I2   = I
21916                   RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21917                   GOTO 2
21918                ENDIF
21919     1       CONTINUE
21920     2       CONTINUE
21921          ENDIF
21922       ENDIF
21923       J1   = 1
21924       J2   = 1
21925       RATQ = ONE
21926       IF (NQBINI.GT.1) THEN
21927          IF (Q2I.GE.Q2G(NQBINI)) THEN
21928             J1   = NQBINI
21929             J2   = NQBINI
21930             RATQ = ONE
21931          ELSEIF (Q2I.GT.Q2G(1)) THEN
21932             DO 3 I=2,NQBINI
21933                IF (Q2I.LT.Q2G(I)) THEN
21934                   J1   = I-1
21935                   J2   = I
21936                   RATQ = LOG10(    Q2I/MAX(Q2G(J1),TINY14))/
21937      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21938 C                 RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21939                   GOTO 4
21940                ENDIF
21941     3       CONTINUE
21942     4       CONTINUE
21943          ENDIF
21944       ENDIF
21945
21946       STOT = XSTOT(I1,J1,NTARG)+
21947      &   RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21948      &   RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21949      &   RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21950      &              XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21951
21952       RETURN
21953       END
21954
21955 *$ CREATE DT_SANO.FOR
21956 *COPY DT_SANO
21957 *
21958 *===sigano=============================================================*
21959 *
21960       DOUBLE PRECISION FUNCTION DT_SANO(ECM)
21961
21962 ************************************************************************
21963 * This version dated 31.07.96 is written by S. Roesler                 *
21964 ************************************************************************
21965
21966       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21967       SAVE
21968       PARAMETER ( LINP = 10 ,
21969      &            LOUT = 6 ,
21970      &            LDAT = 9 )
21971       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21972      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21973       PARAMETER (NE = 8)
21974
21975 * VDM parameter for photon-nucleus interactions
21976       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21977 * properties of interacting particles
21978       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
21979
21980       DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
21981       DATA ECMANO /
21982      &             0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
21983      &             0.100D+04,0.200D+04,0.500D+04
21984      &            /
21985 * fixed cut (3 GeV/c)
21986       DATA FRAANO /
21987      &             0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
21988      &             0.062D+00,0.054D+00,0.042D+00
21989      &            /
21990       DATA SIGHRD /
21991      &           4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
21992      &           3.3086D-01,7.6255D-01,2.1319D+00
21993      &            /
21994 * running cut (based on obsolete Phojet-caluclations, bugs..)
21995 C     DATA FRAANO /
21996 C    &             0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
21997 C    &             0.167E+00,0.150E+00,0.131E+00
21998 C    &            /
21999 C     DATA SIGHRD /
22000 C    &           6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
22001 C    &           2.5736E-01,4.5593E-01,8.2550E-01
22002 C    &            /
22003
22004       DT_SANO = ZERO
22005       IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
22006       J1   = 0
22007       J2   = 0
22008       RATE = ONE
22009       IF (ECM.GE.ECMANO(NE)) THEN
22010          J1 = NE
22011          J2 = NE
22012       ELSEIF (ECM.GT.ECMANO(1)) THEN
22013          DO 1 IE=2,NE
22014             IF (ECM.LT.ECMANO(IE)) THEN
22015                J1   = IE-1
22016                J2   = IE
22017                RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
22018                GOTO 2
22019             ENDIF
22020     1    CONTINUE
22021     2    CONTINUE
22022       ENDIF
22023       IF ((J1.GT.0).AND.(J2.GT.0)) THEN
22024          AFRA1  = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
22025          AFRA2  = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
22026          DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
22027       ENDIF
22028
22029       RETURN
22030       END
22031
22032 *$ CREATE DT_SIGGP.FOR
22033 *COPY DT_SIGGP
22034 *
22035 *===siggp==============================================================*
22036 *
22037       SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
22038
22039 ************************************************************************
22040 * Total/inelastic photon-nucleon cross sections.                       *
22041 * This version dated 30.04.96 is written by S. Roesler                 *
22042 ************************************************************************
22043
22044       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22045       SAVE
22046       PARAMETER ( LINP = 10 ,
22047      &            LOUT = 6 ,
22048      &            LDAT = 9 )
22049       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22050       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
22051      &           PI     = TWOPI/TWO,
22052      &           GEV2MB = 0.38938D0,
22053      &           ALPHEM = ONE/137.0D0)
22054
22055 * particle properties (BAMJET index convention)
22056       CHARACTER*8  ANAME
22057       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22058      &                IICH(210),IIBAR(210),K1(210),K2(210)
22059 * VDM parameter for photon-nucleus interactions
22060       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22061
22062 **PHOJET105a
22063 C     CHARACTER*8 MDLNA
22064 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
22065 C     PARAMETER (IEETAB=10)
22066 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
22067 **PHOJET110
22068 C  model switches and parameters
22069       CHARACTER*8 MDLNA
22070       INTEGER ISWMDL,IPAMDL
22071       DOUBLE PRECISION PARMDL
22072       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
22073 C  energy-interpolation table
22074       INTEGER IEETA2
22075       PARAMETER ( IEETA2 = 20 )
22076       INTEGER ISIMAX
22077       DOUBLE PRECISION SIGTAB,SIGECM
22078       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
22079 **
22080
22081 C     PARAMETER (NPOINT=80)
22082       PARAMETER (NPOINT=16)
22083       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22084
22085       STOT = ZERO
22086       SINE = ZERO
22087       SDIR = ZERO
22088
22089       W2 = ECMI**2
22090       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22091      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22092       Q2 = Q2I
22093       X  = XI
22094 * photoprod.
22095       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22096          Q2 = 0.0001D0
22097          X  = Q2/(W2+Q2-AAM(1)**2)
22098 * DIS
22099       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22100          X  = Q2/(W2+Q2-AAM(1)**2)
22101       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22102          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22103       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22104          W2 = Q2*(ONE-X)/X+AAM(1)**2
22105       ELSE
22106          WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
22107          STOP
22108       ENDIF
22109       ECM = SQRT(W2)
22110
22111       IF (MODEGA.EQ.1) THEN
22112          SCALE = SQRT(Q2)
22113          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22114      &                                                       IDPDF)
22115 C        W = SQRT(W2)
22116 C        ALLMF2 = PHO_ALLM97(Q2,W)
22117 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22118          STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22119          SINE = ZERO
22120          SDIR = ZERO
22121       ELSEIF (MODEGA.EQ.2) THEN
22122          IF (INTRGE(1).EQ.1) THEN
22123             AMLO2 = (3.0D0*AAM(13))**2
22124          ELSEIF (INTRGE(1).EQ.2) THEN
22125             AMLO2 = AAM(33)**2
22126          ELSE
22127             AMLO2 = AAM(96)**2
22128          ENDIF
22129          IF (INTRGE(2).EQ.1) THEN
22130             AMHI2 = W2/TWO
22131          ELSEIF (INTRGE(2).EQ.2) THEN
22132             AMHI2 = W2/4.0D0
22133          ELSE
22134             AMHI2 = W2
22135          ENDIF
22136          AMHI20 = (ECM-AAM(1))**2
22137          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22138          XAMLO  = LOG( AMLO2+Q2 )
22139          XAMHI  = LOG( AMHI2+Q2 )
22140 **PHOJET105a
22141 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22142 **PHOJET112
22143          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22144 **
22145          SUM  = ZERO
22146          DO 1 J=1,NPOINT
22147             AM2 = EXP(ABSZX(J))-Q2
22148             IF (AM2.LT.16.0D0) THEN
22149                R = TWO
22150             ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
22151                R = 10.0D0/3.0D0
22152             ELSE
22153                R = 11.0D0/3.0D0
22154             ENDIF
22155 C           FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22156             FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22157      &            * (ONE+EPSPOL*Q2/AM2)
22158             SUM = SUM+WEIGHT(J)*FAC
22159     1    CONTINUE
22160          SINE = SUM
22161          SDIR = DT_SIGVP(X,Q2)
22162          STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
22163          SDIR = SDIR/(0.588D0+RL2+Q2)
22164 C        STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
22165       ELSEIF (MODEGA.EQ.3) THEN
22166          CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
22167       ELSEIF (MODEGA.EQ.4) THEN
22168 *  load cross sections from PHOJET interpolation table
22169          IP = 1
22170          IF(ECM.LE.SIGECM(IP,1)) THEN
22171            I1 = 1
22172            I2 = 1
22173          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
22174            DO 2 I=2,ISIMAX
22175               IF (ECM.LE.SIGECM(IP,I)) GOTO 3
22176     2      CONTINUE
22177     3      CONTINUE
22178            I1 = I-1
22179            I2 = I
22180          ELSE
22181            WRITE(LOUT,'(/1X,A,2E12.3)')
22182      &       'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
22183            I1 = ISIMAX
22184            I2 = ISIMAX
22185          ENDIF
22186          FAC2 = ZERO
22187          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
22188      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
22189          FAC1 = ONE-FAC2
22190 *  cross section dependence on photon virtuality
22191          FSUP1 = ZERO
22192          DO 4 I=1,3
22193             FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
22194      &                                /(1.D0+Q2/PARMDL(30+I))**2
22195     4    CONTINUE
22196          FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
22197          FAC1  = FAC1*FSUP1
22198          FAC2  = FAC2*FSUP1
22199          FSUP2 = 1.0D0
22200          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
22201          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
22202          SDIR  = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
22203 **re:
22204          STOT  = STOT-SDIR
22205 **
22206          SDIR  = SDIR/(FSUP1*FSUP2)
22207 **re:
22208          STOT  = STOT+SDIR
22209 **
22210       ENDIF
22211
22212       RETURN
22213       END
22214
22215 *$ CREATE DT_SIGVEL.FOR
22216 *COPY DT_SIGVEL
22217 *
22218 *===sigvel=============================================================*
22219 *
22220       SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
22221
22222 ************************************************************************
22223 * Cross section for elastic vector meson production                    *
22224 * This version dated 10.05.96 is written by S. Roesler                 *
22225 ************************************************************************
22226
22227       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22228       SAVE
22229       PARAMETER ( LINP = 10 ,
22230      &            LOUT = 6 ,
22231      &            LDAT = 9 )
22232       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22233       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
22234      &           PI     = TWOPI/TWO,
22235      &           GEV2MB = 0.38938D0,
22236      &           ALPHEM = ONE/137.0D0)
22237
22238 * particle properties (BAMJET index convention)
22239       CHARACTER*8  ANAME
22240       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22241      &                IICH(210),IIBAR(210),K1(210),K2(210)
22242 * VDM parameter for photon-nucleus interactions
22243       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22244
22245       W2 = ECMI**2
22246       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22247      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22248       Q2 = Q2I
22249       X  = XI
22250 * photoprod.
22251       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22252          Q2 = 0.0001D0
22253          X  = Q2/(W2+Q2-AAM(1)**2)
22254 * DIS
22255       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22256          X  = Q2/(W2+Q2-AAM(1)**2)
22257       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22258          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22259       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22260          W2 = Q2*(ONE-X)/X+AAM(1)**2
22261       ELSE
22262          WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
22263          STOP
22264       ENDIF
22265       ECM = SQRT(W2)
22266
22267       AMV  = AAM(IDXV)
22268       AMV2 = AMV**2
22269
22270       BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
22271      &        +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
22272       ROSH   = 0.1D0
22273       STOVP  = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
22274       SELVP  = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
22275
22276       IF (IDXV.EQ.33) THEN
22277          COUPL = 0.00365D0
22278       ELSE
22279          STOP
22280       ENDIF
22281       SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
22282       SIG2 = SELVP
22283       SVEL  = COUPL * (AMV2/(AMV2+Q2))**2
22284      &              * (ONE+EPSPOL*Q2/AMV2) * SELVP
22285
22286       RETURN
22287       END
22288
22289 *$ CREATE DT_SIGVP.FOR
22290 *COPY DT_SIGVP
22291 *
22292 *===sigvp==============================================================*
22293 *
22294       DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
22295
22296 ************************************************************************
22297 * sigma_Vp                                                             *
22298 ************************************************************************
22299
22300       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22301       SAVE
22302
22303       PARAMETER ( LINP = 10 ,
22304      &            LOUT = 6 ,
22305      &            LDAT = 9 )
22306       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22307       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22308      &           PI    = TWOPI/TWO,
22309      &           GEV2MB = 0.38938D0,
22310      &           AMPROT = 0.938D0,
22311      &           ALPHEM = ONE/137.0D0)
22312 * VDM parameter for photon-nucleus interactions
22313       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22314
22315       X  = XI
22316       Q2 = Q2I
22317       IF (XI.LE.ZERO)  X  = 0.0001D0
22318       IF (Q2I.LE.ZERO) Q2 = 0.0001D0
22319
22320       ECM    = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
22321
22322       SCALE = SQRT(Q2)
22323       IF (MODEGA.EQ.1) THEN
22324          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22325      &                                                       IDPDF)
22326 C        W = ECM
22327 C        ALLMF2 = PHO_ALLM97(Q2,W)
22328 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22329 C        STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22330 C        DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
22331          DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
22332       ELSEIF (MODEGA.EQ.4) THEN
22333          CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
22334 C        F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
22335          DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
22336       ELSE
22337          STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
22338       ENDIF
22339
22340       RETURN
22341
22342       END
22343
22344 *$ CREATE DT_RRM2.FOR
22345 *COPY DT_RRM2
22346 *
22347 *===RRM2===============================================================*
22348 *
22349       DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22350
22351       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22352       SAVE
22353       PARAMETER ( LINP = 10 ,
22354      &            LOUT = 6 ,
22355      &            LDAT = 9 )
22356       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22357       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22358      &           PI    = TWOPI/TWO,
22359      &           GEV2MB = 0.38938D0)
22360
22361 * particle properties (BAMJET index convention)
22362       CHARACTER*8  ANAME
22363       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22364      &                IICH(210),IIBAR(210),K1(210),K2(210)
22365 * VDM parameter for photon-nucleus interactions
22366       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22367
22368       S   = Q2*(ONE-X)/X+AAM(1)**2
22369       ECM = SQRT(S)
22370
22371       IF (INTRGE(1).EQ.1) THEN
22372          AMLO2 = (3.0D0*AAM(13))**2
22373       ELSEIF (INTRGE(1).EQ.2) THEN
22374          AMLO2 = AAM(33)**2
22375       ELSE
22376          AMLO2 = AAM(96)**2
22377       ENDIF
22378       IF (INTRGE(2).EQ.1) THEN
22379          AMHI2 = S/TWO
22380       ELSEIF (INTRGE(2).EQ.2) THEN
22381          AMHI2 = S/4.0D0
22382       ELSE
22383          AMHI2 = S
22384       ENDIF
22385       AMHI20 = (ECM-AAM(1))**2
22386       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22387
22388       AM1C2 = 16.0D0
22389       AM2C2 = 121.0D0
22390       IF (AMHI2.LE.AM1C2) THEN
22391          DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22392       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22393          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22394      &          10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22395       ELSE
22396          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22397      &          10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22398      &          11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22399       ENDIF
22400
22401       RETURN
22402       END
22403
22404 *$ CREATE DT_RM2.FOR
22405 *COPY DT_RM2
22406 *
22407 *===RM2================================================================*
22408 *
22409       DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22410
22411       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22412       SAVE
22413       PARAMETER ( LINP = 10 ,
22414      &            LOUT = 6 ,
22415      &            LDAT = 9 )
22416       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22417       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22418      &           PI    = TWOPI/TWO,
22419      &           GEV2MB = 0.38938D0)
22420 * VDM parameter for photon-nucleus interactions
22421       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22422
22423       IF (RL2.LE.ZERO) THEN
22424          DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22425      &        (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22426      &         +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22427       ELSE
22428          TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22429          TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22430          DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22431      &       -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22432      &       +EPSPOL*(
22433      &         -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22434      &       -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22435       ENDIF
22436
22437       RETURN
22438       END
22439
22440 *$ CREATE DT_SAM2.FOR
22441 *COPY DT_SAM2
22442 *
22443 *===SAM2===============================================================*
22444 *
22445       DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22446
22447       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22448       SAVE
22449       PARAMETER ( LINP = 10 ,
22450      &            LOUT = 6 ,
22451      &            LDAT = 9 )
22452       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22453      &           TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22454       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22455      &           PI    = TWOPI/TWO,
22456      &           GEV2MB = 0.38938D0)
22457
22458 * particle properties (BAMJET index convention)
22459       CHARACTER*8  ANAME
22460       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22461      &                IICH(210),IIBAR(210),K1(210),K2(210)
22462 * VDM parameter for photon-nucleus interactions
22463       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22464
22465       S = ECM**2
22466       IF (INTRGE(1).EQ.1) THEN
22467          AMLO2 = (3.0D0*AAM(13))**2
22468       ELSEIF (INTRGE(1).EQ.2) THEN
22469          AMLO2 = AAM(33)**2
22470       ELSE
22471          AMLO2 = AAM(96)**2
22472       ENDIF
22473       IF (INTRGE(2).EQ.1) THEN
22474          AMHI2 = S/TWO
22475       ELSEIF (INTRGE(2).EQ.2) THEN
22476          AMHI2 = S/4.0D0
22477       ELSE
22478          AMHI2 = S
22479       ENDIF
22480       AMHI20 = (ECM-AAM(1))**2
22481       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22482
22483       AM1C2 = 16.0D0
22484       AM2C2 = 121.0D0
22485       YLO   = LOG(AMLO2+Q2)
22486       YC1   = LOG(AM1C2+Q2)
22487       YC2   = LOG(AM2C2+Q2)
22488       YHI   = LOG(AMHI2+Q2)
22489       IF (AMHI2.LE.AM1C2) THEN
22490          FACHI = TWO
22491       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22492          FACHI = TENTRD
22493       ELSE
22494          FACHI = ELVTRD
22495       ENDIF
22496
22497     1 CONTINUE
22498       YSAM2  = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22499       IF (YSAM2.LE.YC1) THEN
22500          FAC = TWO
22501       ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22502          FAC = TENTRD
22503       ELSE
22504          FAC = ELVTRD
22505       ENDIF
22506       WEIGMX = FACHI*(ONE-Q2*EXP(  -YHI))
22507       XSAM2  = FAC  *(ONE-Q2*EXP(-YSAM2))
22508       IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22509
22510       DT_SAM2   = EXP(YSAM2)-Q2
22511
22512       RETURN
22513       END
22514
22515 *$ CREATE DT_CKMT.FOR
22516 *COPY DT_CKMT
22517 *
22518 *===ckmt===============================================================*
22519 *
22520       SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22521      &                F2,IPAR)
22522
22523 ************************************************************************
22524 * This version dated 31.01.96 is written by S. Roesler                 *
22525 ************************************************************************
22526
22527       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22528       SAVE
22529       PARAMETER ( LINP = 10 ,
22530      &            LOUT = 6 ,
22531      &            LDAT = 9 )
22532       PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22533
22534       PARAMETER (Q02 = 2.0D0,
22535      &           DQ2 = 10.05D0,
22536      &           Q12 = Q02+DQ2)
22537
22538       DIMENSION PD(-6:6),SEA(3),VAL(2)
22539
22540       CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22541       CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22542       ADQ2 = LOG10(Q12)-LOG10(Q02)
22543       F2P  = (F2Q1-F2Q0)/ADQ2
22544       CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22545       CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22546       F2PP = (F2PQ1-F2PQ0)/ADQ2
22547       FX   = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22548
22549       Q2     = MAX(SCALE**2.0D0,TINY10)
22550       SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22551       IF (Q2.LT.Q02) THEN
22552          CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22553          UPV  = VAL(1)
22554          DNV  = VAL(2)
22555          USEA = SEA(1)
22556          DSEA = SEA(2)
22557          STR  = SEA(3)
22558          CHM  = 0.0D0
22559          BOT  = 0.0D0
22560          TOP  = 0.0D0
22561          GL   = GLU
22562       ELSE
22563          CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22564          F2 = F2*SMOOTH
22565          UPV  = PD(2)-PD(3)
22566          DNV  = PD(1)-PD(3)
22567          USEA = PD(3)
22568          DSEA = PD(3)
22569          STR  = PD(3)
22570          CHM  = PD(4)
22571          BOT  = PD(5)
22572          TOP  = PD(6)
22573          GL   = PD(0)
22574 C        UPV  = UPV*SMOOTH
22575 C        DNV  = DNV*SMOOTH
22576 C        USEA = USEA*SMOOTH
22577 C        DSEA = DSEA*SMOOTH
22578 C        STR  = STR*SMOOTH
22579 C        CHM  = CHM*SMOOTH
22580 C        GL   = GL*SMOOTH
22581       ENDIF
22582
22583       RETURN
22584       END
22585 C
22586
22587 *$ CREATE DT_CKMTX.FOR
22588 *COPY DT_CKMTX
22589       SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22590 C**********************************************************************
22591 C
22592 C     PDF based on Regge theory, evolved with .... by ....
22593 C
22594 C     input: IPAR     2212   proton (not installed)
22595 C                       45   Pomeron
22596 C                      100   Deuteron
22597 C
22598 C     output: PD(-6:6) x*f(x)  parton distribution functions
22599 C            (PDFLIB convention: d = PD(1), u = PD(2) )
22600 C
22601 C**********************************************************************
22602
22603       SAVE
22604       DOUBLE PRECISION  X,SCALE2,PD(-6:6),CDN,CUP,F2
22605       PARAMETER ( LINP = 10 ,
22606      &            LOUT = 6 ,
22607      &            LDAT = 9 )
22608       DIMENSION QQ(7)
22609 C
22610       Q2=SNGL(SCALE2)
22611       Q1S=Q2
22612       XX=SNGL(X)
22613 C  QCD lambda for evolution
22614       OWLAM = 0.23D0
22615       OWLAM2=OWLAM**2
22616 C  Q0**2 for evolution
22617       Q02 = 2.D0
22618 C
22619 C
22620 C  the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22621 C                        q(6)=x*charm, q(7)=x*gluon
22622 C
22623       SB=0.
22624       IF(Q2-Q02) 1,1,2
22625     2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22626     1 CONTINUE
22627       IF(IPAR.EQ.2212) THEN
22628         CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22629         CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22630         CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22631         CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22632         CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22633         CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22634         CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22635 C     ELSEIF (IPAR.EQ.45) THEN
22636 C       CALL CKMTPO(1,0,XX,SB,QQ(1))
22637 C       CALL CKMTPO(2,0,XX,SB,QQ(2))
22638 C       CALL CKMTPO(3,0,XX,SB,QQ(3))
22639 C       CALL CKMTPO(4,0,XX,SB,QQ(4))
22640 C       CALL CKMTPO(5,0,XX,SB,QQ(5))
22641 C       CALL CKMTPO(8,0,XX,SB,QQ(6))
22642 C       CALL CKMTPO(7,0,XX,SB,QQ(7))
22643       ELSEIF (IPAR.EQ.100) THEN
22644         CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22645         CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22646         CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22647         CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22648         CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22649         CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22650         CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22651       ELSE
22652         WRITE(LOUT,'(1X,A,I4,A)')
22653      &     'CKMTX:   IPAR =',IPAR,' not implemented!'
22654         STOP
22655       ENDIF
22656 C
22657       PD(-6) = 0.D0
22658       PD(-5) = 0.D0
22659       PD(-4) = DBLE(QQ(6))
22660       PD(-3) = DBLE(QQ(3))
22661       PD(-2) = DBLE(QQ(4))
22662       PD(-1) = DBLE(QQ(5))
22663       PD(0)  = DBLE(QQ(7))
22664       PD(1)  = DBLE(QQ(2))
22665       PD(2)  = DBLE(QQ(1))
22666       PD(3)  = DBLE(QQ(3))
22667       PD(4)  = DBLE(QQ(6))
22668       PD(5)  = 0.D0
22669       PD(6)  = 0.D0
22670       IF(IPAR.EQ.45) THEN
22671         CDN = (PD(1)-PD(-1))/2.D0
22672         CUP = (PD(2)-PD(-2))/2.D0
22673         PD(-1) = PD(-1) + CDN
22674         PD(-2) = PD(-2) + CUP
22675         PD(1) = PD(-1)
22676         PD(2) = PD(-2)
22677       ENDIF
22678       F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22679      &     1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22680      &     1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22681       END
22682 C
22683
22684 *$ CREATE DT_PDF0.FOR
22685 *COPY DT_PDF0
22686 *
22687 *===pdf0===============================================================*
22688 *
22689       SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22690
22691 ************************************************************************
22692 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
22693 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
22694 *                   IPAR  = 2212   proton                              *
22695 *                         =  100   deuteron                            *
22696 * This version dated 31.01.96 is written by S. Roesler                 *
22697 ************************************************************************
22698
22699       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22700       SAVE
22701       PARAMETER ( LINP = 10 ,
22702      &            LOUT = 6 ,
22703      &            LDAT = 9 )
22704       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22705
22706       PARAMETER (
22707      &              AA     = 0.1502D0,
22708      &              BBDEU  = 1.2D0,
22709      &              BUD    = 0.754D0,
22710      &              BDD    = 0.4495D0,
22711      &              BUP    = 1.2064D0,
22712      &              BDP    = 0.1798D0,
22713      &              DELTA0 = 0.07684D0,
22714      &              D      = 1.117D0,
22715      &              C      = 3.5489D0,
22716      &              A      = 0.2631D0,
22717      &              B      = 0.6452D0,
22718      &              ALPHAR = 0.415D0,
22719      &              E      = 0.1D0
22720      &          )
22721
22722       PARAMETER (NPOINT=16)
22723 C     DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22724       DIMENSION SEA(3),VAL(2)
22725
22726       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22727       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
22728 * proton, deuteron
22729       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22730          CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22731          SEA(1) = 0.75D0*SEA0
22732          SEA(2) = SEA(1)
22733          SEA(3) = SEA(1)
22734          VAL(1) = 9.0D0/4.0D0*VALU0
22735          VAL(2) = 9.0D0*VALD0
22736          GLU0   = SEA(1)/(1.0D0-X)
22737          F2     = SEA0+VALU0+VALD0
22738          F2PDF  = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22739      &            1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22740      &            1.0D0/9.0D0*(2.0D0*SEA(3))
22741          IF (ABS(F2-F2PDF).GT.TINY9) THEN
22742             WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22743             STOP
22744          ENDIF
22745 **PHOJET105a
22746 C        CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22747 **PHOJET112
22748 C        CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22749 **
22750 C        SUMQ = ZERO
22751 C        SUMG = ZERO
22752 C        DO 1 J=1,NPOINT
22753 C           CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22754 C           VALU0 = 9.0D0/4.0D0*VALU0
22755 C           VALD0 = 9.0D0*VALD0
22756 C           SEA0  = 0.75D0*SEA0
22757 C           SUMQ  = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22758 C           SUMG  = SUMG+ (SEA0/(1.0D0-ABSZX(J)))  *WEIGHT(J)
22759 C   1    CONTINUE
22760 C        GLU = GLU0*(1.0D0-SUMQ)/SUMG
22761       ELSE
22762          WRITE(LOUT,'(1X,A,I4,A)')
22763      &      'PDF0:   IPAR =',IPAR,' not implemented!'
22764          STOP
22765       ENDIF
22766
22767       RETURN
22768       END
22769
22770 *$ CREATE DT_CKMTQ0.FOR
22771 *COPY DT_CKMTQ0
22772 *
22773 *===ckmtq0=============================================================*
22774 *
22775       SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22776
22777 ************************************************************************
22778 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
22779 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
22780 *                   IPAR  = 2212   proton                              *
22781 *                         =  100   deuteron                            *
22782 * This version dated 31.01.96 is written by S. Roesler                 *
22783 ************************************************************************
22784
22785       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22786       SAVE
22787       PARAMETER ( LINP = 10 ,
22788      &            LOUT = 6 ,
22789      &            LDAT = 9 )
22790       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22791
22792       PARAMETER (
22793      &              AA     = 0.1502D0,
22794      &              BBDEU  = 1.2D0,
22795      &              BUD    = 0.754D0,
22796      &              BDD    = 0.4495D0,
22797      &              BUP    = 1.2064D0,
22798      &              BDP    = 0.1798D0,
22799      &              DELTA0 = 0.07684D0,
22800      &              D      = 1.117D0,
22801      &              C      = 3.5489D0,
22802      &              A      = 0.2631D0,
22803      &              B      = 0.6452D0,
22804      &              ALPHAR = 0.415D0,
22805      &              E      = 0.1D0
22806      &          )
22807
22808       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22809       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
22810 * proton, deuteron
22811       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22812          IF (IPAR.EQ.2212) THEN
22813             BU = BUP
22814             BD = BDP
22815          ELSE
22816             BU = BUD
22817             BD = BDD
22818          ENDIF
22819          SEA0  = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22820      &          (Q2/(Q2+A))**(1.0D0+DELTA)
22821          VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22822      &           (Q2/(Q2+B))**(ALPHAR)
22823          VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22824      &           (Q2/(Q2+B))**(ALPHAR)
22825       ELSE
22826          WRITE(LOUT,'(1X,A,I4,A)')
22827      &      'CKMTQ0: IPAR =',IPAR,' not implemented!'
22828          STOP
22829       ENDIF
22830       RETURN
22831       END
22832 C
22833 C
22834
22835 *$ CREATE DT_CKMTDE.FOR
22836 *COPY DT_CKMTDE
22837       SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22838 C
22839 C**********************************************************************
22840 C    Deuteron - PDFs
22841 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22842 C    ANS = PDF(I)
22843 C    This version by S. Roesler, 30.01.96
22844 C**********************************************************************
22845
22846       SAVE
22847       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22848       EQUIVALENCE (GF(1,1,1),DL(1))
22849       DATA DELTA/.13/
22850 C
22851       DATA (DL(K),K=    1,   85) /
22852      &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22853      &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22854      &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22855      &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22856      &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22857      &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22858      &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22859      &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22860      &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22861      &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22862      &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22863      &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22864      &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22865      &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22866      &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22867      &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22868      &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22869       DATA (DL(K),K=   86,  170) /
22870      &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22871      &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22872      &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22873      &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22874      &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22875      &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22876      &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22885      &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22886      &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22887       DATA (DL(K),K=  171,  255) /
22888      &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22889      &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22890      &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22891      &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22892      &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22893      &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22894      &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22895      &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22896      &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22897      &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22898      &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22899      &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22900      &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22901      &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22902      &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22903      &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22904      &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22905       DATA (DL(K),K=  256,  340) /
22906      &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22907      &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22908      &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22909      &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22910      &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22919      &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22920      &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22921      &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22922      &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22923       DATA (DL(K),K=  341,  425) /
22924      &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22925      &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22926      &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22927      &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22928      &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22929      &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22930      &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22931      &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22932      &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22933      &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22934      &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22935      &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22936      &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22937      &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22938      &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22939      &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22940      &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22941       DATA (DL(K),K=  426,  510) /
22942      &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22943      &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22944      &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22953      &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22954      &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22955      &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22956      &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22957      &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22958      &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22959       DATA (DL(K),K=  511,  595) /
22960      &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
22961      &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
22962      &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
22963      &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
22964      &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
22965      &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
22966      &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
22967      &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
22968      &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
22969      &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
22970      &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
22971      &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
22972      &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
22973      &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
22974      &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
22975      &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
22976      &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
22977       DATA (DL(K),K=  596,  680) /
22978      &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22987      &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
22988      &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
22989      &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
22990      &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
22991      &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
22992      &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
22993      &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
22994      &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
22995       DATA (DL(K),K=  681,  765) /
22996      &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
22997      &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
22998      &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
22999      &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
23000      &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
23001      &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
23002      &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
23003      &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
23004      &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
23005      &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
23006      &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
23007      &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
23008      &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
23009      &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
23010      &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
23011      &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
23012      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23013       DATA (DL(K),K=  766,  850) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23021      &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23022      &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
23023      &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
23024      &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
23025      &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
23026      &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
23027      &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
23028      &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
23029      &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
23030      &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
23031       DATA (DL(K),K=  851,  935) /
23032      &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
23033      &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
23034      &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
23035      &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
23036      &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
23037      &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
23038      &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
23039      &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
23040      &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
23041      &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
23042      &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
23043      &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
23044      &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
23045      &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
23046      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23047      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23048      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23049       DATA (DL(K),K=  936, 1020) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23055      &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23056      &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
23057      &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
23058      &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
23059      &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
23060      &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
23061      &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
23062      &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
23063      &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
23064      &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
23065      &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
23066      &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
23067       DATA (DL(K),K= 1021, 1105) /
23068      &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
23069      &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
23070      &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
23071      &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
23072      &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
23073      &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
23074      &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
23075      &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
23076      &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
23077      &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
23078      &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
23079      &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
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      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23085       DATA (DL(K),K= 1106, 1190) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23089      &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23090      &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
23091      &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
23092      &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
23093      &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
23094      &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
23095      &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
23096      &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
23097      &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
23098      &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
23099      &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
23100      &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
23101      &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
23102      &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
23103       DATA (DL(K),K= 1191, 1275) /
23104      &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
23105      &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
23106      &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
23107      &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
23108      &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
23109      &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
23110      &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
23111      &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
23112      &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
23113      &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
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      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23121       DATA (DL(K),K= 1276, 1360) /
23122      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23123      &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23124      &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
23125      &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
23126      &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
23127      &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
23128      &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
23129      &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
23130      &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
23131      &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
23132      &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
23133      &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
23134      &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
23135      &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
23136      &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
23137      &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
23138      &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
23139       DATA (DL(K),K= 1361, 1445) /
23140      &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
23141      &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
23142      &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
23143      &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
23144      &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
23145      &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
23146      &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
23147      &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23156      &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23157       DATA (DL(K),K= 1446, 1530) /
23158      &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
23159      &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
23160      &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
23161      &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
23162      &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
23163      &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
23164      &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
23165      &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
23166      &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
23167      &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
23168      &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
23169      &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
23170      &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
23171      &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
23172      &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
23173      &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
23174      &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
23175       DATA (DL(K),K= 1531, 1615) /
23176      &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
23177      &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
23178      &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
23179      &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
23180      &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
23181      &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23190      &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23191      &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
23192      &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
23193       DATA (DL(K),K= 1616, 1700) /
23194      &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
23195      &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
23196      &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
23197      &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
23198      &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
23199      &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
23200      &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
23201      &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
23202      &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
23203      &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
23204      &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
23205      &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
23206      &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
23207      &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
23208      &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
23209      &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
23210      &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
23211       DATA (DL(K),K= 1701, 1785) /
23212      &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
23213      &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
23214      &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
23215      &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23224      &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23225      &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
23226      &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
23227      &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
23228      &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
23229       DATA (DL(K),K= 1786, 1870) /
23230      &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
23231      &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
23232      &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
23233      &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
23234      &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
23235      &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
23236      &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
23237      &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
23238      &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
23239      &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
23240      &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
23241      &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
23242      &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
23243      &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
23244      &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
23245      &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
23246      &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
23247       DATA (DL(K),K= 1871, 1955) /
23248      &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
23249      &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23258      &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23259      &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
23260      &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
23261      &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
23262      &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
23263      &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
23264      &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
23265       DATA (DL(K),K= 1956, 2040) /
23266      &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
23267      &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
23268      &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
23269      &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
23270      &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
23271      &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
23272      &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
23273      &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
23274      &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
23275      &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
23276      &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
23277      &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
23278      &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
23279      &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
23280      &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
23281      &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
23282      &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
23283       DATA (DL(K),K= 2041, 2125) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23292      &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23293      &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
23294      &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
23295      &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
23296      &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
23297      &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
23298      &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
23299      &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
23300      &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
23301       DATA (DL(K),K= 2126, 2210) /
23302      &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
23303      &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
23304      &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
23305      &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
23306      &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
23307      &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
23308      &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
23309      &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
23310      &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
23311      &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
23312      &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
23313      &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
23314      &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
23315      &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
23316      &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
23317      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23318      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23319       DATA (DL(K),K= 2211, 2295) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23326      &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23327      &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23328      &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23329      &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23330      &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23331      &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23332      &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23333      &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23334      &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23335      &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23336      &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23337       DATA (DL(K),K= 2296, 2380) /
23338      &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23339      &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23340      &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23341      &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23342      &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23343      &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23344      &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23345      &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23346      &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23347      &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23348      &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23349      &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23350      &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
23351      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23352      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23353      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23354      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23355       DATA (DL(K),K= 2381, 2465) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23360      &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23361      &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23362      &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23363      &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23364      &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23365      &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23366      &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23367      &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23368      &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23369      &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23370      &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23371      &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23372      &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23373       DATA (DL(K),K= 2466, 2550) /
23374      &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23375      &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23376      &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23377      &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23378      &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23379      &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23380      &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23381      &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23382      &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23383      &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23384      &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
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      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23391       DATA (DL(K),K= 2551, 2635) /
23392      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23393      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23394      &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23395      &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23396      &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23397      &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23398      &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23399      &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23400      &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23401      &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23402      &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23403      &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23404      &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23405      &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23406      &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23407      &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23408      &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23409       DATA (DL(K),K= 2636, 2720) /
23410      &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23411      &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23412      &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23413      &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23414      &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23415      &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23416      &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23417      &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23418      &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
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      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23427       DATA (DL(K),K= 2721, 2805) /
23428      &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23429      &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23430      &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23431      &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23432      &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23433      &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23434      &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23435      &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23436      &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23437      &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23438      &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23439      &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23440      &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23441      &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23442      &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23443      &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23444      &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23445       DATA (DL(K),K= 2806, 2890) /
23446      &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23447      &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23448      &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23449      &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23450      &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23451      &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23452      &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23461      &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23462      &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23463       DATA (DL(K),K= 2891, 2975) /
23464      &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23465      &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23466      &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23467      &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23468      &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23469      &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23470      &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23471      &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23472      &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23473      &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23474      &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23475      &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23476      &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23477      &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23478      &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23479      &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23480      &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23481       DATA (DL(K),K= 2976, 3060) /
23482      &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23483      &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23484      &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23485      &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23486      &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23495      &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23496      &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23497      &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23498      &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23499       DATA (DL(K),K= 3061, 3145) /
23500      &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23501      &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23502      &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23503      &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23504      &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23505      &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23506      &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23507      &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23508      &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23509      &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23510      &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23511      &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23512      &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23513      &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23514      &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23515      &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23516      &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23517       DATA (DL(K),K= 3146, 3230) /
23518      &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23519      &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23520      &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23529      &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23530      &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23531      &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23532      &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23533      &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23534      &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23535       DATA (DL(K),K= 3231, 3315) /
23536      &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23537      &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23538      &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23539      &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23540      &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23541      &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23542      &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23543      &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23544      &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23545      &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23546      &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23547      &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23548      &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23549      &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23550      &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23551      &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23552      &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23553       DATA (DL(K),K= 3316, 3400) /
23554      &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23563      &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23564      &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23565      &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23566      &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23567      &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23568      &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23569      &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23570      &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23571       DATA (DL(K),K= 3401, 3485) /
23572      &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23573      &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23574      &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23575      &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23576      &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23577      &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23578      &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23579      &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23580      &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23581      &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23582      &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23583      &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23584      &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23585      &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23586      &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23587      &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23588      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23589       DATA (DL(K),K= 3486, 3570) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23597      &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23598      &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23599      &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23600      &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23601      &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23602      &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23603      &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23604      &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23605      &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23606      &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23607       DATA (DL(K),K= 3571, 3655) /
23608      &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23609      &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23610      &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23611      &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23612      &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23613      &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23614      &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23615      &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23616      &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23617      &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23618      &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23619      &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23620      &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23621      &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
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      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23625       DATA (DL(K),K= 3656, 3740) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23631      &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23632      &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23633      &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23634      &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23635      &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23636      &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23637      &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23638      &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23639      &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23640      &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23641      &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23642      &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23643       DATA (DL(K),K= 3741, 3825) /
23644      &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23645      &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23646      &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23647      &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23648      &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23649      &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23650      &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23651      &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23652      &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23653      &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23654      &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23655      &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
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      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23661       DATA (DL(K),K= 3826, 3910) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23665      &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23666      &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23667      &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23668      &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23669      &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23670      &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23671      &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23672      &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23673      &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23674      &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23675      &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23676      &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23677      &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23678      &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23679       DATA (DL(K),K= 3911, 3995) /
23680      &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23681      &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23682      &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23683      &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23684      &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23685      &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23686      &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23687      &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23688      &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23689      &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
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      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23697       DATA (DL(K),K= 3996, 4000) /
23698      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23699 C
23700       ANS = 0.
23701       IF (X.GT.0.9985) RETURN
23702       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23703 C
23704       IS  = S/DELTA+1
23705       IS1 = IS+1
23706       DO 1 L=1,25
23707          KL    = L+NDRV*25
23708          F1(L) = GF(I,IS,KL)
23709          F2(L) = GF(I,IS1,KL)
23710     1 CONTINUE
23711       A1 = DT_CKMTFF(X,F1)
23712       A2 = DT_CKMTFF(X,F2)
23713 C      A1=ALOG(A1)
23714 C      A2=ALOG(A2)
23715       S1  = (IS-1)*DELTA
23716       S2  = S1+DELTA
23717       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23718 C      ANS=EXP(ANS)
23719       RETURN
23720       END
23721 C
23722 C
23723
23724 *$ CREATE DT_CKMTPR.FOR
23725 *COPY DT_CKMTPR
23726       SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23727 C
23728 C**********************************************************************
23729 C    Proton   - PDFs
23730 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23731 C    ANS = PDF(I)
23732 C    This version by S. Roesler, 31.01.96
23733 C**********************************************************************
23734
23735       SAVE
23736       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23737       EQUIVALENCE (GF(1,1,1),DL(1))
23738       DATA DELTA/.10/
23739 C
23740       DATA (DL(K),K=    1,   85) /
23741      &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23742      &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23743      &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23744      &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23745      &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23746      &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23747      &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23748      &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23749      &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23750      &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23751      &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23752      &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23753      &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23754      &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23755      &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23756      &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23757      &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23758       DATA (DL(K),K=   86,  170) /
23759      &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23760      &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23761      &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23762      &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23763      &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23764      &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23765      &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23766      &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23767      &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23768      &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23769      &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23770      &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23771      &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23772      &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23773      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23774      &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23775      &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23776       DATA (DL(K),K=  171,  255) /
23777      &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23778      &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23779      &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23780      &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23781      &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23782      &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23783      &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23784      &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23785      &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23786      &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23787      &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23788      &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23789      &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23790      &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23791      &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23792      &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23793      &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23794       DATA (DL(K),K=  256,  340) /
23795      &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23796      &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23797      &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23798      &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23799      &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23800      &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23801      &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23802      &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23803      &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23804      &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23805      &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23806      &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23807      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23808      &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23809      &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23810      &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23811      &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23812       DATA (DL(K),K=  341,  425) /
23813      &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23814      &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23815      &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23816      &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23817      &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23818      &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23819      &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23820      &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23821      &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23822      &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23823      &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23824      &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23825      &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23826      &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23827      &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23828      &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23829      &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23830       DATA (DL(K),K=  426,  510) /
23831      &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23832      &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23833      &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23834      &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23835      &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23836      &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23837      &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23838      &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23839      &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23840      &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23841      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23842      &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23843      &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23844      &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23845      &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23846      &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23847      &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23848       DATA (DL(K),K=  511,  595) /
23849      &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23850      &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23851      &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23852      &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23853      &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23854      &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23855      &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23856      &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23857      &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23858      &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23859      &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23860      &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23861      &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23862      &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23863      &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23864      &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23865      &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23866       DATA (DL(K),K=  596,  680) /
23867      &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23868      &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23869      &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23870      &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23871      &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23872      &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23873      &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23874      &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23875      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23876      &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23877      &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23878      &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23879      &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23880      &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23881      &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23882      &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23883      &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23884       DATA (DL(K),K=  681,  765) /
23885      &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23886      &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23887      &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23888      &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23889      &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23890      &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23891      &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23892      &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23893      &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23894      &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23895      &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23896      &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23897      &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23898      &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23899      &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23900      &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23901      &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23902       DATA (DL(K),K=  766,  850) /
23903      &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23904      &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23905      &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23906      &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23907      &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23908      &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23909      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23910      &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23911      &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23912      &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23913      &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23914      &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23915      &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23916      &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23917      &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23918      &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23919      &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23920       DATA (DL(K),K=  851,  935) /
23921      &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23922      &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23923      &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23924      &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23925      &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23926      &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23927      &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23928      &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23929      &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23930      &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23931      &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23932      &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23933      &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23934      &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23935      &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23936      &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23937      &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23938       DATA (DL(K),K=  936, 1020) /
23939      &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23940      &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23941      &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23942      &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23943      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23944      &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23945      &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23946      &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23947      &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23948      &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23949      &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23950      &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23951      &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23952      &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23953      &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23954      &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23955      &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23956       DATA (DL(K),K= 1021, 1105) /
23957      &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23958      &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23959      &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23960      &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
23961      &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
23962      &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
23963      &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
23964      &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
23965      &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
23966      &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
23967      &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
23968      &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
23969      &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
23970      &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
23971      &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
23972      &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
23973      &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
23974       DATA (DL(K),K= 1106, 1190) /
23975      &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
23976      &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23977      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23978      &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23979      &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
23980      &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
23981      &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
23982      &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
23983      &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
23984      &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
23985      &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
23986      &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
23987      &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
23988      &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
23989      &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
23990      &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
23991      &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
23992       DATA (DL(K),K= 1191, 1275) /
23993      &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
23994      &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
23995      &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
23996      &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
23997      &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
23998      &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
23999      &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
24000      &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
24001      &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
24002      &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
24003      &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
24004      &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
24005      &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
24006      &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
24007      &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
24008      &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
24009      &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
24010       DATA (DL(K),K= 1276, 1360) /
24011      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24012      &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
24013      &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
24014      &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
24015      &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
24016      &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
24017      &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
24018      &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
24019      &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
24020      &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
24021      &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
24022      &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
24023      &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
24024      &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
24025      &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
24026      &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
24027      &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
24028       DATA (DL(K),K= 1361, 1445) /
24029      &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
24030      &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
24031      &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
24032      &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
24033      &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
24034      &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
24035      &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
24036      &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
24037      &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
24038      &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
24039      &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
24040      &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
24041      &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
24042      &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
24043      &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
24044      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24045      &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
24046       DATA (DL(K),K= 1446, 1530) /
24047      &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
24048      &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
24049      &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
24050      &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
24051      &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
24052      &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
24053      &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
24054      &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
24055      &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
24056      &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
24057      &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
24058      &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
24059      &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
24060      &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
24061      &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
24062      &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
24063      &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
24064       DATA (DL(K),K= 1531, 1615) /
24065      &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
24066      &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
24067      &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
24068      &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
24069      &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
24070      &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
24071      &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
24072      &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
24073      &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
24074      &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
24075      &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
24076      &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
24077      &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24078      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24079      &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
24080      &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
24081      &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
24082       DATA (DL(K),K= 1616, 1700) /
24083      &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
24084      &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
24085      &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
24086      &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
24087      &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
24088      &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
24089      &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
24090      &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
24091      &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
24092      &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
24093      &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
24094      &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
24095      &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
24096      &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
24097      &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
24098      &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
24099      &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
24100       DATA (DL(K),K= 1701, 1785) /
24101      &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
24102      &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
24103      &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
24104      &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
24105      &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
24106      &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
24107      &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
24108      &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
24109      &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
24110      &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
24111      &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24112      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24113      &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
24114      &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
24115      &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
24116      &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
24117      &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
24118       DATA (DL(K),K= 1786, 1870) /
24119      &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
24120      &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
24121      &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
24122      &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
24123      &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
24124      &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
24125      &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
24126      &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
24127      &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
24128      &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
24129      &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
24130      &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
24131      &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
24132      &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
24133      &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
24134      &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
24135      &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
24136       DATA (DL(K),K= 1871, 1955) /
24137      &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
24138      &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
24139      &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
24140      &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
24141      &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
24142      &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
24143      &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
24144      &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
24145      &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24146      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24147      &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
24148      &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
24149      &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
24150      &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
24151      &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
24152      &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
24153      &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
24154       DATA (DL(K),K= 1956, 2040) /
24155      &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
24156      &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
24157      &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
24158      &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
24159      &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
24160      &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
24161      &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
24162      &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
24163      &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
24164      &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
24165      &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
24166      &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
24167      &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
24168      &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
24169      &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
24170      &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
24171      &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
24172       DATA (DL(K),K= 2041, 2125) /
24173      &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
24174      &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
24175      &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
24176      &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
24177      &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
24178      &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
24179      &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24180      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24181      &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
24182      &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
24183      &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
24184      &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
24185      &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
24186      &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
24187      &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
24188      &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
24189      &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
24190       DATA (DL(K),K= 2126, 2210) /
24191      &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
24192      &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
24193      &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
24194      &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
24195      &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
24196      &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
24197      &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
24198      &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
24199      &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
24200      &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
24201      &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
24202      &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
24203      &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
24204      &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
24205      &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
24206      &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
24207      &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
24208       DATA (DL(K),K= 2211, 2295) /
24209      &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
24210      &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
24211      &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
24212      &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
24213      &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24214      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24215      &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
24216      &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
24217      &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
24218      &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
24219      &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
24220      &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
24221      &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
24222      &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
24223      &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
24224      &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
24225      &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
24226       DATA (DL(K),K= 2296, 2380) /
24227      &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
24228      &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
24229      &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
24230      &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
24231      &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
24232      &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
24233      &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
24234      &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
24235      &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
24236      &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
24237      &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
24238      &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
24239      &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
24240      &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
24241      &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
24242      &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
24243      &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
24244       DATA (DL(K),K= 2381, 2465) /
24245      &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
24246      &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
24247      &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24248      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24249      &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
24250      &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
24251      &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
24252      &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
24253      &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
24254      &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
24255      &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
24256      &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
24257      &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
24258      &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
24259      &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
24260      &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
24261      &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
24262       DATA (DL(K),K= 2466, 2550) /
24263      &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
24264      &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
24265      &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
24266      &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
24267      &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
24268      &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
24269      &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
24270      &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
24271      &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
24272      &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
24273      &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
24274      &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
24275      &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
24276      &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
24277      &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
24278      &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
24279      &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
24280       DATA (DL(K),K= 2551, 2635) /
24281      &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24282      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24283      &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
24284      &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
24285      &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
24286      &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
24287      &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
24288      &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
24289      &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
24290      &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
24291      &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
24292      &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
24293      &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
24294      &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
24295      &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
24296      &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
24297      &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
24298       DATA (DL(K),K= 2636, 2720) /
24299      &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
24300      &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
24301      &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
24302      &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
24303      &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
24304      &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
24305      &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
24306      &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
24307      &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
24308      &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
24309      &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
24310      &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
24311      &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
24312      &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
24313      &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
24314      &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24315      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24316       DATA (DL(K),K= 2721, 2805) /
24317      &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
24318      &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
24319      &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
24320      &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
24321      &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24322      &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24323      &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24324      &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24325      &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24326      &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24327      &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24328      &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24329      &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24330      &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24331      &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24332      &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24333      &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24334       DATA (DL(K),K= 2806, 2890) /
24335      &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24336      &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24337      &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24338      &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24339      &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24340      &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24341      &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24342      &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24343      &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24344      &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24345      &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24346      &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24347      &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24348      &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24349      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24350      &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24351      &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24352       DATA (DL(K),K= 2891, 2975) /
24353      &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24354      &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24355      &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24356      &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24357      &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24358      &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24359      &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24360      &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24361      &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24362      &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24363      &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24364      &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24365      &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24366      &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24367      &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24368      &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24369      &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24370       DATA (DL(K),K= 2976, 3060) /
24371      &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24372      &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24373      &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24374      &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24375      &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24376      &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24377      &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24378      &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24379      &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24380      &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24381      &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24382      &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24383      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24384      &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24385      &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24386      &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24387      &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24388       DATA (DL(K),K= 3061, 3145) /
24389      &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24390      &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24391      &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24392      &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24393      &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24394      &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24395      &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24396      &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24397      &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24398      &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24399      &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24400      &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24401      &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24402      &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24403      &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24404      &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24405      &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24406       DATA (DL(K),K= 3146, 3230) /
24407      &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24408      &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24409      &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24410      &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24411      &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24412      &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24413      &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24414      &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24415      &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24416      &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24417      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24418      &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24419      &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24420      &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24421      &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24422      &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24423      &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24424       DATA (DL(K),K= 3231, 3315) /
24425      &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24426      &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24427      &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24428      &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24429      &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24430      &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24431      &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24432      &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24433      &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24434      &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24435      &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24436      &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24437      &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24438      &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24439      &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24440      &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24441      &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24442       DATA (DL(K),K= 3316, 3400) /
24443      &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24444      &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24445      &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24446      &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24447      &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24448      &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24449      &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24450      &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24451      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24452      &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24453      &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24454      &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24455      &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24456      &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24457      &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24458      &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24459      &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24460       DATA (DL(K),K= 3401, 3485) /
24461      &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24462      &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24463      &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24464      &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24465      &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24466      &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24467      &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24468      &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24469      &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24470      &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24471      &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24472      &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24473      &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24474      &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24475      &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24476      &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24477      &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24478       DATA (DL(K),K= 3486, 3570) /
24479      &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24480      &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24481      &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24482      &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24483      &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24484      &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24485      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24486      &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24487      &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24488      &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24489      &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24490      &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24491      &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24492      &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24493      &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24494      &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24495      &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24496       DATA (DL(K),K= 3571, 3655) /
24497      &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24498      &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24499      &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24500      &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24501      &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24502      &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24503      &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24504      &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24505      &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24506      &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24507      &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24508      &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24509      &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24510      &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24511      &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24512      &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24513      &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24514       DATA (DL(K),K= 3656, 3740) /
24515      &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24516      &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24517      &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24518      &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24519      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24520      &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24521      &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24522      &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24523      &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24524      &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24525      &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24526      &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24527      &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24528      &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24529      &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24530      &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24531      &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24532       DATA (DL(K),K= 3741, 3825) /
24533      &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24534      &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24535      &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24536      &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24537      &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24538      &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24539      &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24540      &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24541      &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24542      &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24543      &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24544      &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24545      &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24546      &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24547      &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24548      &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24549      &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24550       DATA (DL(K),K= 3826, 3910) /
24551      &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24552      &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24553      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24554      &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24555      &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24556      &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24557      &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24558      &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24559      &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24560      &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24561      &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24562      &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24563      &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24564      &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24565      &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24566      &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24567      &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24568       DATA (DL(K),K= 3911, 3995) /
24569      &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24570      &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24571      &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24572      &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24573      &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24574      &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24575      &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24576      &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24577      &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24578      &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24579      &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24580      &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24581      &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24582      &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24583      &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24584      &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24585      &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24586       DATA (DL(K),K= 3996, 4000) /
24587      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24588 C
24589       ANS = 0.
24590       IF (X.GT.0.9985) RETURN
24591       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24592 C
24593       IS  = S/DELTA+1
24594       IS1 = IS+1
24595       DO 1 L=1,25
24596          KL    = L+NDRV*25
24597          F1(L) = GF(I,IS,KL)
24598          F2(L) = GF(I,IS1,KL)
24599     1 CONTINUE
24600       A1 = DT_CKMTFF(X,F1)
24601       A2 = DT_CKMTFF(X,F2)
24602 C      A1=ALOG(A1)
24603 C      A2=ALOG(A2)
24604       S1  = (IS-1)*DELTA
24605       S2  = S1+DELTA
24606       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24607 C      ANS=EXP(ANS)
24608       RETURN
24609       END
24610 C
24611
24612 *$ CREATE DT_CKMTFF.FOR
24613 *COPY DT_CKMTFF
24614       FUNCTION DT_CKMTFF(X,FVL)
24615 C**********************************************************************
24616 C
24617 C     LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24618 C     FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24619 C     NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24620 C     IN MAIN ROUTINE.
24621 C
24622 C**********************************************************************
24623
24624       SAVE
24625       DIMENSION FVL(25),XGRID(25)
24626       DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24627      *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24628 C
24629       DT_CKMTFF=0.
24630       DO 1 I=1,NX
24631       IF(X.LT.XGRID(I)) GO TO 2
24632     1 CONTINUE
24633     2 I=I-1
24634       IF(I.EQ.0) THEN
24635          I=I+1
24636       ELSE IF(I.GT.23) THEN
24637          I=23
24638       ENDIF
24639       J=I+1
24640       K=J+1
24641       AXI=LOG(XGRID(I))
24642       BXI=LOG(1.-XGRID(I))
24643       AXJ=LOG(XGRID(J))
24644       BXJ=LOG(1.-XGRID(J))
24645       AXK=LOG(XGRID(K))
24646       BXK=LOG(1.-XGRID(K))
24647       FI=LOG(ABS(FVL(I)) +1.E-15)
24648       FJ=LOG(ABS(FVL(J)) +1.E-16)
24649       FK=LOG(ABS(FVL(K)) +1.E-17)
24650       DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24651       ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24652      $ BXI))/DET
24653       ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24654       BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24655       IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24656      1RETURN
24657 C      IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24658 C         WRITE(6,2001) X,FVL
24659 C 2001    FORMAT(8E12.4)
24660 C         WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24661 C      ENDIF
24662       DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24663       RETURN
24664       END
24665
24666 *$ CREATE DT_FLUINI.FOR
24667 *COPY DT_FLUINI
24668 *
24669 *===fluini=============================================================*
24670 *
24671       SUBROUTINE DT_FLUINI
24672
24673 ************************************************************************
24674 * Initialisation of the nucleon-nucleon cross section fluctuation      *
24675 * treatment. The original version by J. Ranft.                         *
24676 * This version dated 21.04.95 is revised by S. Roesler.                *
24677 ************************************************************************
24678
24679       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24680       SAVE
24681       PARAMETER ( LINP = 10 ,
24682      &            LOUT = 6 ,
24683      &            LDAT = 9 )
24684       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24685
24686       PARAMETER ( A     = 0.1D0,
24687      &            B     = 0.893D0,
24688      &            OM    = 1.1D0,
24689      &            N     = 6,
24690      &            DX    = 0.003D0)
24691
24692 * n-n cross section fluctuations
24693       PARAMETER (NBINS = 1000)
24694       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24695       DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24696
24697       WRITE(LOUT,1000)
24698  1000 FORMAT(/,1X,'FLUINI:  hadronic cross section fluctuations ',
24699      &       'treated')
24700
24701       FLUSU  = ZERO
24702       FLUSUU = ZERO
24703
24704       DO 1 I=1,NBINS
24705          X        = DBLE(I)*DX
24706          FLUIX(I) = X
24707          FLUS     = ((X-B)/(OM*B))**N
24708          IF (FLUS.LE.20.0D0) THEN
24709             FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24710          ELSE
24711             FLUSI(I) = ZERO
24712          ENDIF
24713          FLUSU = FLUSU+FLUSI(I)
24714     1 CONTINUE
24715       DO 2 I=1,NBINS
24716          FLUSUU   = FLUSUU+FLUSI(I)/FLUSU
24717          FLUSI(I) = FLUSUU
24718     2 CONTINUE
24719
24720 C     WRITE(LOUT,1001)
24721 C1001 FORMAT(1X,'FLUCTUATIONS')
24722 C     CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24723
24724       DO 3 I=1,NBINS
24725          AF = DBLE(I)*0.001D0
24726          DO 4 J=1,NBINS
24727             IF (AF.LE.FLUSI(J)) THEN
24728                FLUIXX(I) = FLUIX(J)
24729                GOTO 5
24730             ENDIF
24731     4    CONTINUE
24732     5    CONTINUE
24733     3 CONTINUE
24734       FLUIXX(1)     = FLUIX(1)
24735       FLUIXX(NBINS) = FLUIX(NBINS)
24736
24737       RETURN
24738       END
24739
24740 *$ CREATE DT_SIGTBL.FOR
24741 *COPY DT_SIGTBL
24742 *
24743 *===sigtab=============================================================*
24744 *
24745       SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24746
24747 ************************************************************************
24748 * This version dated 18.11.95 is written by S. Roesler                 *
24749 ************************************************************************
24750
24751       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24752       SAVE
24753       PARAMETER ( LINP = 10 ,
24754      &            LOUT = 6 ,
24755      &            LDAT = 9 )
24756
24757       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24758      &           OHALF=0.5D0,ONE=1.0D0)
24759       PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24760
24761       LOGICAL LINIT
24762
24763 * particle properties (BAMJET index convention)
24764       CHARACTER*8  ANAME
24765       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24766      &                IICH(210),IIBAR(210),K1(210),K2(210)
24767
24768       DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24769       DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24770      &             0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24771      &             0, 0, 5/
24772       DATA LINIT /.FALSE./
24773
24774 * precalculation and tabulation of elastic cross sections
24775       IF (ABS(MODE).EQ.1) THEN
24776          IF (MODE.EQ.1)
24777      &      OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24778          PLABLX = LOG10(PLO)
24779          PLABHX = LOG10(PHI)
24780          DPLAB  = (PLABHX-PLABLX)/DBLE(NBINS)
24781          DO 1 I=1,NBINS+1
24782             PLAB = PLABLX+DBLE(I-1)*DPLAB
24783             PLAB = 10**PLAB
24784             DO 2 IPROJ=1,23
24785                IDX = IDSIG(IPROJ)
24786                IF (IDX.GT.0) THEN
24787 C                 CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24788 C                 CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24789                   DUMZER = ZERO
24790                   CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24791                   CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24792                ENDIF
24793     2       CONTINUE
24794             IF (MODE.EQ.1) THEN
24795                WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24796      &                                (SIGEN(IDX,I),IDX=1,5)
24797  1000          FORMAT(F5.1,10F7.2)
24798             ENDIF
24799     1    CONTINUE
24800          IF (MODE.EQ.1) CLOSE(LDAT)
24801          LINIT = .TRUE.
24802       ELSE
24803          SIGE = -ONE
24804          IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24805      &                           .AND.(PTOT.LE.PHI) ) THEN
24806             IDX = IDSIG(JP)
24807             IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24808                PLABX = LOG10(PTOT)
24809                IF (PLABX.LE.PLABLX) THEN
24810                   I1 = 1
24811                   I2 = 1
24812                ELSEIF (PLABX.GE.PLABHX) THEN
24813                   I1 = NBINS+1
24814                   I2 = NBINS+1
24815                ELSE
24816                   I1 = INT((PLABX-PLABLX)/DPLAB)+1
24817                   I2 = I1+1
24818                ENDIF
24819                PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24820                PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24821                PBIN   = PLAB2X-PLAB1X
24822                IF (PBIN.GT.TINY10) THEN
24823                   RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24824                ELSE
24825                   RATX = ZERO
24826                ENDIF
24827                IF (JT.EQ.1) THEN
24828                   SIG1 = SIGEP(IDX,I1)
24829                   SIG2 = SIGEP(IDX,I2)
24830                ELSE
24831                   SIG1 = SIGEN(IDX,I1)
24832                   SIG2 = SIGEN(IDX,I2)
24833                ENDIF
24834                SIGE = SIG1+RATX*(SIG2-SIG1)
24835             ENDIF
24836          ENDIF
24837       ENDIF
24838
24839       RETURN
24840       END
24841
24842 *$ CREATE DT_XSTABL.FOR
24843 *COPY DT_XSTABL
24844 *
24845 *===xstabl=============================================================*
24846 *
24847       SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24848
24849       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24850       SAVE
24851       PARAMETER ( LINP = 10 ,
24852      &            LOUT = 6 ,
24853      &            LDAT = 9 )
24854       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24855      &           OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24856       LOGICAL LLAB,LELOG,LQLOG
24857
24858 * particle properties (BAMJET index convention)
24859       CHARACTER*8  ANAME
24860       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24861      &                IICH(210),IIBAR(210),K1(210),K2(210)
24862 * properties of interacting particles
24863       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24864       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24865 * Glauber formalism: cross sections
24866       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24867      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24868      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24869      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24870      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24871      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24872      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24873      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24874      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24875      &                BSLOPE,NEBINI,NQBINI
24876 * emulsion treatment
24877       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24878      &                NCOMPO,IEMUL
24879
24880       DIMENSION WHAT(6)
24881
24882       LLAB   = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24883       ELO    = ABS(WHAT(1))
24884       EHI    = ABS(WHAT(2))
24885       IF (ELO.GT.EHI) ELO = EHI
24886       LELOG  = WHAT(3).LT.ZERO
24887       NEBINS = MAX(INT(ABS(WHAT(3))),1)
24888       DEBINS = (EHI-ELO)/DBLE(NEBINS)
24889       IF (LELOG) THEN
24890          AELO   = LOG10(ELO)
24891          AEHI   = LOG10(EHI)
24892          ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24893       ENDIF
24894       Q2LO   = WHAT(4)
24895       Q2HI   = WHAT(5)
24896       IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24897       LQLOG  = WHAT(6).LT.ZERO
24898       NQBINS = MAX(INT(ABS(WHAT(6))),1)
24899       DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24900       IF (LQLOG) THEN
24901          AQ2LO  = LOG10(Q2LO)
24902          AQ2HI  = LOG10(Q2HI)
24903          ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24904       ENDIF
24905
24906       IF ( ELO.EQ. EHI) NEBINS = 0
24907       IF (Q2LO.EQ.Q2HI) NQBINS = 0
24908
24909       WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24910  1000 FORMAT(/,1X,'XSTABL:  E_lo  =',E10.3,' GeV  E_hi  =',E10.3,
24911      &       ' GeV     Lab = ',L1,'  qel: ',I2,/,10X,'Q2_lo =',F10.5,
24912      &       ' GeV^2  Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24913      &       '   A_p = ',I3,'   A_t = ',I3,/)
24914
24915 C     IF (IJPROJ.NE.7) THEN
24916          WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24917 * normalize fractions of emulsion components
24918          IF (NCOMPO.GT.0) THEN
24919             SUMFRA = ZERO
24920             DO 10 I=1,NCOMPO
24921                SUMFRA = SUMFRA+EMUFRA(I)
24922    10       CONTINUE
24923             IF (SUMFRA.GT.ZERO) THEN
24924                DO 11 I=1,NCOMPO
24925                   EMUFRA(I) = EMUFRA(I)/SUMFRA
24926    11          CONTINUE
24927             ENDIF
24928          ENDIF
24929 C     ELSE
24930 C        WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24931 C     ENDIF
24932       DO 1 I=1,NEBINS+1
24933          IF (LELOG) THEN
24934             E = 10**(AELO+DBLE(I-1)*ADEBIN)
24935          ELSE
24936             E = ELO+DBLE(I-1)*DEBINS
24937          ENDIF
24938          DO 2 J=1,NQBINS+1
24939             IF (LQLOG) THEN
24940                Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24941             ELSE
24942                Q2 = Q2LO+DBLE(J-1)*DQBINS
24943             ENDIF
24944 c            IF (IJPROJ.NE.7) THEN
24945                IF (LLAB) THEN
24946                   PLAB = ZERO
24947                   ECM  = ZERO
24948                   CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24949                ELSE
24950                   ECM = E
24951                ENDIF
24952                XI  = ZERO
24953                Q2I = ZERO
24954                IF (IJPROJ.EQ.7) Q2I = Q2
24955                IF (NCOMPO.GT.0) THEN
24956                   DO 20 IC=1,NCOMPO
24957                      IIT = IEMUMA(IC)
24958                      CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
24959    20             CONTINUE
24960                ELSE
24961                   CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
24962 C                 CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
24963                ENDIF
24964                IF (NCOMPO.GT.0) THEN
24965                   XTOT = ZERO
24966                   ETOT = ZERO
24967                   XELA = ZERO
24968                   EELA = ZERO
24969                   XQEP = ZERO
24970                   EQEP = ZERO
24971                   XQET = ZERO
24972                   EQET = ZERO
24973                   XQE2 = ZERO
24974                   EQE2 = ZERO
24975                   XPRO = ZERO
24976                   EPRO = ZERO
24977                   XPRO1= ZERO
24978                   XDEL = ZERO
24979                   EDEL = ZERO
24980                   XDQE = ZERO
24981                   EDQE = ZERO
24982                   DO 21 IC=1,NCOMPO
24983                      XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
24984                      ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
24985                      XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
24986                      EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
24987                      XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
24988                      EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
24989                      XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
24990                      EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
24991                      XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
24992                      EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
24993                      XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
24994                      EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
24995                      XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
24996                      EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
24997                      XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
24998                      EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
24999                      YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
25000      &                     -XSQEP(1,1,IC)-XSQET(1,1,IC)
25001      &                     -XSQE2(1,1,IC)
25002                      XPRO1= XPRO1+EMUFRA(IC)*YPRO
25003    21             CONTINUE
25004                   ETOT = SQRT(ETOT)
25005                   EELA = SQRT(EELA)
25006                   EQEP = SQRT(EQEP)
25007                   EQET = SQRT(EQET)
25008                   EQE2 = SQRT(EQE2)
25009                   EPRO = SQRT(EPRO)
25010                   EDEL = SQRT(EDEL)
25011                   EDQE = SQRT(EDQE)
25012                   WRITE(LOUT,'(8E9.3)')
25013      &               E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
25014 C                 WRITE(LOUT,'(4E9.3)')
25015 C    &               E,XDEL,XDQE,XDEL+XDQE
25016                ELSE
25017                   WRITE(LOUT,'(11E10.3)')
25018      &              E,
25019      &              XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
25020      &              XSQE2(1,1,1),XSPRO(1,1,1),
25021      &              XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
25022      &             -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
25023      &              XSDEL(1,1,1)+XSDQE(1,1,1)
25024 C                 WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
25025 C    &                                    XSDEL(1,1,1)+XSDQE(1,1,1)
25026                ENDIF
25027 c            ELSE
25028 c               IF (LLAB) THEN
25029 c                  IF (IT.GT.1) THEN
25030 c                     IF (IXSQEL.EQ.0) THEN
25031 cC                       CALL DT_SIGGA(IT,  Q2, E,ZERO,ZERO,
25032 cC                       CALL DT_SIGGA(IT,   E,Q2,ZERO,ZERO,
25033 c                        CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
25034 c     &                             STOT,ETOT,SIN,EIN,STOT0)
25035 c                        IF (IRATIO.EQ.1) THEN
25036 c                           CALL DT_SIGGP(  Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
25037 cC                          CALL DT_SIGGP(   E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
25038 cC                          CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
25039 c*!! save cross sections
25040 c                           STOTA = STOT
25041 c                           ETOTA = ETOT
25042 c                           STOTP = STGP
25043 c*!!
25044 c                           STOT  = STOT/(DBLE(IT)*STGP)
25045 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
25046 c                           STOT0 = STGP
25047 c                           ETOT  = ZERO
25048 c                           EIN   = ZERO
25049 c                        ENDIF
25050 c                     ELSE
25051 c                        WRITE(LOUT,*)
25052 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
25053 c                        STOP
25054 c                     ENDIF
25055 c                  ELSE
25056 c                     ETOT = ZERO
25057 c                     EIN  = ZERO
25058 c                     STOT0= ZERO
25059 c                     IF (IXSQEL.EQ.0) THEN
25060 c                        CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
25061 c                     ELSE
25062 c                       SIN = ZERO
25063 c                       CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
25064 c                     ENDIF
25065 c                  ENDIF
25066 c               ELSE
25067 c                  IF (IT.GT.1) THEN
25068 c                     IF (IXSQEL.EQ.0) THEN
25069 c                        CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
25070 c     &                             STOT,ETOT,SIN,EIN,STOT0)
25071 c                        IF (IRATIO.EQ.1) THEN
25072 c                           CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
25073 c*!! save cross sections
25074 c                           STOTA = STOT
25075 c                           ETOTA = ETOT
25076 c                           STOTP = STGP
25077 c*!!
25078 c                           STOT  = STOT/(DBLE(IT)*STGP)
25079 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
25080 c                           STOT0 = STGP
25081 c                           ETOT  = ZERO
25082 c                           EIN   = ZERO
25083 c                        ENDIF
25084 c                     ELSE
25085 c                        WRITE(LOUT,*)
25086 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
25087 c                        STOP
25088 c                     ENDIF
25089 c                  ELSE
25090 c                     ETOT = ZERO
25091 c                     EIN  = ZERO
25092 c                     STOT0= ZERO
25093 c                     IF (IXSQEL.EQ.0) THEN
25094 c                        CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
25095 c                     ELSE
25096 c                       SIN = ZERO
25097 c                       CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
25098 c                     ENDIF
25099 c                  ENDIF
25100 c               ENDIF
25101 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
25102 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
25103 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
25104 c               WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
25105 c            ENDIF
25106     2    CONTINUE
25107     1 CONTINUE
25108
25109       RETURN
25110       END
25111
25112 *$ CREATE DT_TESTXS.FOR
25113 *COPY DT_TESTXS
25114 *
25115 *===testxs=============================================================*
25116 *
25117       SUBROUTINE DT_TESTXS
25118
25119       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25120       SAVE
25121
25122       DIMENSION XSTOT(26,2),XSELA(26,2)
25123
25124       OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
25125       OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
25126       OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
25127       OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
25128       DUMECM = 0.0D0
25129       PLABL = 0.01D0
25130       PLABH = 10000.0D0
25131       NBINS = 120
25132       APLABL = LOG10(PLABL)
25133       APLABH = LOG10(PLABH)
25134       ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
25135       DO 1 I=1,NBINS+1
25136          ADP = APLABL+DBLE(I-1)*ADPLAB
25137          P = 10.0D0**ADP
25138          DO 2 J=1,26
25139             CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
25140             CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
25141     2    CONTINUE
25142          WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
25143          WRITE(11,1000) P,(XSELA(K,1),K=1,26)
25144          WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
25145          WRITE(13,1000) P,(XSELA(K,2),K=1,26)
25146     1 CONTINUE
25147  1000 FORMAT(F8.3,26F9.3)
25148
25149       RETURN
25150       END
25151
25152 ************************************************************************
25153 *                                                                      *
25154 *  DTUNUC 2.0:   library routines                                      *
25155 *                                   processed by S. Roesler, 6.5.95    *
25156 *                                                                      *
25157 ************************************************************************
25158 *
25159 *     1) Handling of parton momenta
25160 *          SUBROUTINE MASHEL
25161 *          SUBROUTINE DFERMI
25162 *
25163 *     2) Handling of parton flavors and particle indices
25164 *          INTEGER FUNCTION IPDG2B
25165 *          INTEGER FUNCTION IB2PDG
25166 *          INTEGER FUNCTION IQUARK
25167 *          INTEGER FUNCTION IBJQUA
25168 *          INTEGER FUNCTION ICIHAD
25169 *          INTEGER FUNCTION IPDGHA
25170 *          INTEGER FUNCTION MCHAD
25171 *          SUBROUTINE FLAHAD
25172 *
25173 *     3) Energy-momentum and quantum number conservation check routines
25174 *          SUBROUTINE EMC1
25175 *          SUBROUTINE EMC2
25176 *          SUBROUTINE EVTEMC
25177 *          SUBROUTINE EVTFLC
25178 *          SUBROUTINE EVTCHG
25179 *
25180 *     4) Transformations
25181 *          SUBROUTINE LTINI
25182 *          SUBROUTINE LTRANS
25183 *          SUBROUTINE LTNUC
25184 *          SUBROUTINE DALTRA
25185 *          SUBROUTINE DTRAFO
25186 *          SUBROUTINE STTRAN
25187 *          SUBROUTINE MYTRAN
25188 *          SUBROUTINE LT2LAO
25189 *          SUBROUTINE LT2LAB
25190 *
25191 *     5) Sampling from distributions
25192 *          INTEGER FUNCTION NPOISS
25193 *          DOUBLE PRECISION FUNCTION SAMPXB
25194 *          DOUBLE PRECISION FUNCTION SAMPEX
25195 *          DOUBLE PRECISION FUNCTION SAMSQX
25196 *          DOUBLE PRECISION FUNCTION BETREJ
25197 *          DOUBLE PRECISION FUNCTION DGAMRN
25198 *          DOUBLE PRECISION FUNCTION DBETAR
25199 *          SUBROUTINE RANNOR
25200 *          SUBROUTINE DPOLI
25201 *          SUBROUTINE DSFECF
25202 *          SUBROUTINE RACO
25203 *
25204 *     6) Special functions, algorithms and service routines
25205 *          DOUBLE PRECISION FUNCTION YLAMB
25206 *          SUBROUTINE SORT
25207 *          SUBROUTINE SORT1
25208 *          SUBROUTINE DT_XTIME
25209 *
25210 *     7) Random number generator package
25211 *          DOUBLE PRECISION FUNCTION DT_RNDM
25212 *          SUBROUTINE DT_RNDMST
25213 *          SUBROUTINE DT_RNDMIN
25214 *          SUBROUTINE DT_RNDMOU
25215 *          SUBROUTINE DT_RNDMTE
25216 *
25217 ************************************************************************
25218 *                                                                      *
25219 *                 1) Handling of parton momenta                        *
25220 *                                                                      *
25221 ************************************************************************
25222 *$ CREATE DT_MASHEL.FOR
25223 *COPY DT_MASHEL
25224 *
25225 *===mashel=============================================================*
25226 *
25227       SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
25228
25229 ************************************************************************
25230 *                                                                      *
25231 *    rescaling of momenta of two partons to put both                   *
25232 *                                       on mass shell                  *
25233 *                                                                      *
25234 *    input:       PA1,PA2   input momentum vectors                     *
25235 *                 XM1,2     desired masses of particles afterwards     *
25236 *                 P1,P2     changed momentum vectors                   *
25237 *                                                                      *
25238 * The original version is written by R. Engel.                         *
25239 * This version dated 12.12.94 is modified by S. Roesler.               *
25240 ************************************************************************
25241
25242       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25243       SAVE
25244       PARAMETER ( LINP = 10 ,
25245      &            LOUT = 6 ,
25246      &            LDAT = 9 )
25247       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
25248
25249       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
25250
25251       IREJ = 0
25252
25253 * Lorentz transformation into system CMS
25254       PX  = PA1(1)+PA2(1)
25255       PY  = PA1(2)+PA2(2)
25256       PZ  = PA1(3)+PA2(3)
25257       EE  = PA1(4)+PA2(4)
25258       XPTOT = SQRT(PX**2+PY**2+PZ**2)
25259       XMS   = (EE-XPTOT)*(EE+XPTOT)
25260       IF(XMS.LT.(XM1+XM2)**2) THEN
25261 C        WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
25262          GOTO 9999
25263       ENDIF
25264       XMS = SQRT(XMS)
25265       BGX = PX/XMS
25266       BGY = PY/XMS
25267       BGZ = PZ/XMS
25268       GAM = EE/XMS
25269       CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
25270      &           PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
25271 * rotation angles
25272       COD = P1(3)/PTOT1
25273 C     SID = SQRT((ONE-COD)*(ONE+COD))
25274       PPT = SQRT(P1(1)**2+P1(2)**2)
25275       SID = PPT/PTOT1
25276       COF = ONE
25277       SIF = ZERO
25278       IF(PTOT1*SID.GT.TINY10) THEN
25279          COF   = P1(1)/(SID*PTOT1)
25280          SIF   = P1(2)/(SID*PTOT1)
25281          ANORF = SQRT(COF*COF+SIF*SIF)
25282          COF   = COF/ANORF
25283          SIF   = SIF/ANORF
25284       ENDIF
25285 * new CM momentum and energies (for masses XM1,XM2)
25286       XM12 = SIGN(XM1**2,XM1)
25287       XM22 = SIGN(XM2**2,XM2)
25288       SS   = XMS**2
25289       PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
25290       EE1  = SQRT(XM12+PCMP**2)
25291       EE2  = XMS-EE1
25292 * back rotation
25293       MODE = 1
25294       CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
25295       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
25296      &            PTOT1,P1(1),P1(2),P1(3),P1(4))
25297       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
25298      &            PTOT2,P2(1),P2(2),P2(3),P2(4))
25299 * check consistency
25300       DEL = XMS*0.0001D0
25301       IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
25302         IDEV = 1
25303       ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
25304         IDEV = 2
25305       ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
25306         IDEV = 3
25307       ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
25308         IDEV = 4
25309       ELSE
25310         IDEV = 0
25311       ENDIF
25312       IF (IDEV.NE.0) THEN
25313          WRITE(LOUT,'(/1X,A,I3)')
25314      &      'MASHEL: inconsistent transformation',IDEV
25315          WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25316          WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25317          WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25318          WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25319          WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25320          WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25321       ENDIF
25322       RETURN
25323
25324  9999 CONTINUE
25325       IREJ = 1
25326       RETURN
25327       END
25328
25329 *$ CREATE DT_DFERMI.FOR
25330 *COPY DT_DFERMI
25331 *
25332 *===dfermi=============================================================*
25333 *
25334       SUBROUTINE DT_DFERMI(GPART)
25335
25336 ************************************************************************
25337 * Find largest of three random numbers.                                *
25338 ************************************************************************
25339
25340       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25341       SAVE
25342
25343       DIMENSION G(3)
25344
25345       DO 10 I=1,3
25346         G(I)=DT_RNDM(GPART)
25347    10 CONTINUE
25348       IF (G(3).LT.G(2)) GOTO 40
25349       IF (G(3).LT.G(1)) GOTO 30
25350       GPART = G(3)
25351    20 RETURN
25352    30 GPART = G(1)
25353       GOTO 20
25354    40 IF (G(2).LT.G(1)) GOTO 30
25355       GPART = G(2)
25356       GOTO 20
25357
25358       END
25359
25360 ************************************************************************
25361 *                                                                      *
25362 *         2) Handling of parton flavors and particle indices           *
25363 *                                                                      *
25364 ************************************************************************
25365 *$ CREATE IDT_IPDG2B.FOR
25366 *COPY IDT_IPDG2B
25367 *
25368 *===ipdg2b=============================================================*
25369 *
25370       INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25371
25372 ************************************************************************
25373 *                                                                      *
25374 *     conversion of quark numbering scheme                             *
25375 *                                                                      *
25376 *     input:   PDG parton numbering                                    *
25377 *              for diquarks:  NN number of the constituent quark       *
25378 *                             (e.g. ID=2301,NN=1 -> ICONV2=1)          *
25379 *                                                                      *
25380 *     output:  BAMJET particle codes                                   *
25381 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
25382 *              2 d     8 a-d             -2 a-d                        *
25383 *              3 s     9 a-s             -3 a-s                        *
25384 *              4 c    10 a-c             -4 a-c                        *
25385 *                                                                      *
25386 * This is a modified version of ICONV2 written by R. Engel.            *
25387 * This version dated 13.12.94 is written by S. Roesler.                *
25388 ************************************************************************
25389
25390       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25391       SAVE
25392       PARAMETER ( LINP = 10 ,
25393      &            LOUT = 6 ,
25394      &            LDAT = 9 )
25395
25396       IDA = ABS(ID)
25397 * diquarks
25398       IF (IDA.GT.6) THEN
25399         KF  = 3
25400         IF (IDA.GE.1000) KF = 4
25401         IDA = IDA/(10**(KF-NN))
25402         IDA = MOD(IDA,10)
25403       ENDIF
25404 * exchange up and dn quarks
25405       IF (IDA.EQ.1) THEN
25406         IDA = 2
25407       ELSEIF (IDA.EQ.2) THEN
25408         IDA = 1
25409       ENDIF
25410 * antiquarks
25411       IF (ID.LT.0) THEN
25412          IF (MODE.EQ.1) THEN
25413             IDA = IDA+6
25414          ELSE
25415             IDA = -IDA
25416          ENDIF
25417       ENDIF
25418       IDT_IPDG2B = IDA
25419
25420       RETURN
25421       END
25422
25423 *$ CREATE IDT_IB2PDG.FOR
25424 *COPY IDT_IB2PDG
25425 *
25426 *===ib2pdg=============================================================*
25427 *
25428       INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25429
25430 ************************************************************************
25431 *                                                                      *
25432 *     conversion of quark numbering scheme                             *
25433 *                                                                      *
25434 *     input:   BAMJET particle codes                                   *
25435 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
25436 *              2 d     8 a-d             -2 a-d                        *
25437 *              3 s     9 a-s             -3 a-s                        *
25438 *              4 c    10 a-c             -4 a-c                        *
25439 *                                                                      *
25440 *     output:  PDG parton numbering                                    *
25441 *                                                                      *
25442 * This version dated 13.12.94 is written by S. Roesler.                *
25443 ************************************************************************
25444
25445       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25446       SAVE
25447       PARAMETER ( LINP = 10 ,
25448      &            LOUT = 6 ,
25449      &            LDAT = 9 )
25450
25451       DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25452       DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25453       DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25454      &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25455      &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25456
25457       IDA = ID1
25458       IDB = ID2
25459       IF (MODE.EQ.1) THEN
25460          IF (ID1.GT.6) IDA = -(ID1-6)
25461          IF (ID2.GT.6) IDB = -(ID2-6)
25462       ENDIF
25463       IF (ID2.EQ.0) THEN
25464          IDT_IB2PDG = IHKKQ(IDA)
25465       ELSE
25466          IDT_IB2PDG = IHKKQQ(IDA,IDB)
25467       ENDIF
25468
25469       RETURN
25470       END
25471
25472 *$ CREATE IDT_IQUARK.FOR
25473 *COPY IDT_IQUARK
25474 *
25475 *===ipdgqu=============================================================*
25476 *
25477       INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25478
25479 ************************************************************************
25480 *                                                                      *
25481 *     quark contents according to PDG conventions                      *
25482 *     (random selection in case of quark mixing)                       *
25483 *                                                                      *
25484 *     input:   IDBAMJ BAMJET particle code                             *
25485 *              K      1..3   quark number                              *
25486 *                                                                      *
25487 *     output:  1   d  (anti --> neg.)                                  *
25488 *              2   u                                                   *
25489 *              3   s                                                   *
25490 *              4   c                                                   *
25491 *                                                                      *
25492 * This version written by R. Engel.                                    *
25493 ************************************************************************
25494
25495       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25496       SAVE
25497
25498       IQ = IDT_IBJQUA(K,IDBAMJ)
25499 * quark-antiquark
25500       IF (IQ.GT.6) THEN
25501          IQ = 6-IQ
25502       ENDIF
25503 * exchange of up and down
25504       IF (ABS(IQ).EQ.1) THEN
25505          IQ = SIGN(2,IQ)
25506       ELSEIF (ABS(IQ).EQ.2) THEN
25507          IQ = SIGN(1,IQ)
25508       ENDIF
25509       IDT_IQUARK = IQ
25510
25511       RETURN
25512       END
25513
25514 *$ CREATE IDT_IBJQUA.FOR
25515 *COPY IDT_IBJQUA
25516 *
25517 *===ibamq==============================================================*
25518 *
25519       INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25520
25521 ************************************************************************
25522 *                                                                      *
25523 *     quark contents according to BAMJET conventions                   *
25524 *     (random selection in case of quark mixing)                       *
25525 *                                                                      *
25526 *     input:   IDBAMJ BAMJET particle code                             *
25527 *              K      1..3   quark number                              *
25528 *                                                                      *
25529 *     output:  1   u      7   u bar                                    *
25530 *              2   d      8   d bar                                    *
25531 *              3   s      9   s bar                                    *
25532 *              4   c     10   c bar                                    *
25533 *                                                                      *
25534 * This version written by R. Engel.                                    *
25535 ************************************************************************
25536
25537       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25538       SAVE
25539
25540       DIMENSION ITAB(3,210)
25541       DATA ((ITAB(I,K),I=1,3),K=1,30) /
25542      &    1,  1,  2,   7,  7,  8,   0,  0,  0,
25543      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25544      &    0,  0,  0,   1,  2,  2,   7,  8,  8,
25545 *sr 10.1.94
25546 C    &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25547      &    0,  0,  0,   0,  0,  0,   3,  8,  0,
25548 *
25549      &    1,  8,  0,   2,  7,  0,   1,  9,  0,
25550 *sr 10.1.94
25551 C    &    3,  7,  0,   0,  0,  0,   0,  0,  0,
25552      &    3,  7,  0,   3,  1,  2,   9,  7,  8,
25553 *sr 10.1.94
25554 C    &    0,  0,  0,   2,  2,  3,   1,  1,  3,
25555      &    2,  9,  0,   2,  2,  3,   1,  1,  3,
25556 *
25557      &    1,  2,  3, 201,202,  0,   2,  9,  0,
25558      &    3,  8,  0,   0,  0,  0,   0,  0,  0,
25559      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25560       DATA ((ITAB(I,K),I=1,3),K=31,60) /
25561      &    3,  9,  0,   1,  8,  0, 203,204,  0,
25562      &    2,  7,  0,   0,  0,  0,   1,  9,  0,
25563      &    2,  9,  0,   3,  7,  0,   3,  8,  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,   0,  0,  0,   0,  0,  0,
25568      &    0,  0,  0,   1,  1,  1,   1,  1,  2,
25569      &    1,  2,  2,   2,  2,  2,   0,  0,  0,
25570      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25571       DATA ((ITAB(I,K),I=1,3),K=61,90) /
25572      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25573      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25574      &    7,  7,  7,   7,  7,  8,   7,  8,  8,
25575      &    8,  8,  8,   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      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25582       DATA ((ITAB(I,K),I=1,3),K=91,120) /
25583      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25584      &    0,  0,  0,   0,  0,  0,   3,  9,  0,
25585      &    1,  3,  3,   2,  3,  3,   7,  7,  9,
25586      &    7,  8,  9,   8,  8,  9,   7,  9,  9,
25587      &    8,  9,  9,   1,  1,  3,   1,  2,  3,
25588      &    2,  2,  3,   1,  3,  3,   2,  3,  3,
25589      &    3,  3,  3,   7,  7,  9,   7,  8,  9,
25590      &    8,  8,  9,   7,  9,  9,   8,  9,  9,
25591      &    9,  9,  9,   4,  7,  0,   4,  8,  0,
25592      &    2, 10,  0,   1, 10,  0,   4,  9,  0 /
25593       DATA ((ITAB(I,K),I=1,3),K=121,150) /
25594      &    3, 10,  0,   4, 10,  0,   4,  7,  0,
25595      &    4,  8,  0,   2, 10,  0,   1, 10,  0,
25596      &    4,  9,  0,   3, 10,  0,   4, 10,  0,
25597      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25598      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25599      &    0,  0,  0,   1,  2,  4,   1,  3,  4,
25600      &    2,  3,  4,   1,  1,  4,   0,  0,  0,
25601      &    2,  2,  4,   0,  0,  0,   0,  0,  0,
25602      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
25603      &    3,  4,  4,   7,  8, 10,   7,  9, 10 /
25604       DATA ((ITAB(I,K),I=1,3),K=151,180) /
25605      &    8,  9, 10,   7,  7, 10,   0,  0,  0,
25606      &    8,  8, 10,   0,  0,  0,   0,  0,  0,
25607      &    9,  9, 10,   7, 10, 10,   8, 10, 10,
25608      &    9, 10, 10,   1,  1,  4,   1,  2,  4,
25609      &    2,  2,  4,   1,  3,  4,   2,  3,  4,
25610      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
25611      &    3,  4,  4,   4,  4,  4,   7,  7, 10,
25612      &    7,  8, 10,   8,  8, 10,   7,  9, 10,
25613      &    8,  9, 10,   9,  9, 10,   7, 10, 10,
25614      &    8, 10, 10,   9, 10, 10,  10, 10, 10 /
25615       DATA ((ITAB(I,K),I=1,3),K=181,210) /
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,   0,  0,  0,
25622      &    0,  0,  0,   0,  0,  0,   1,  7,  0,
25623      &    2,  8,  0,   1,  7,  0,   2,  8,  0,
25624      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25625      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25626       DATA IDOLD /0/
25627
25628       ONE = 1.0D0
25629       IF (ITAB(1,IDBAMJ).LE.200) THEN
25630          ID = ITAB(K,IDBAMJ)
25631       ELSE
25632          IF(IDOLD.NE.IDBAMJ) THEN
25633             IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25634      &           DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25635         ELSE
25636            IDOLD = 0
25637         ENDIF
25638         ID = ITAB(K,IT)
25639       ENDIF
25640       IDOLD  = IDBAMJ
25641       IDT_IBJQUA = ID
25642
25643       RETURN
25644       END
25645
25646 *$ CREATE IDT_ICIHAD.FOR
25647 *COPY IDT_ICIHAD
25648 *
25649 *===icihad=============================================================*
25650 *
25651       INTEGER FUNCTION IDT_ICIHAD(MCIND)
25652
25653 ************************************************************************
25654 * Conversion of particle index PDG proposal --> BAMJET-index scheme    *
25655 * This is a completely new version dated 25.10.95.                     *
25656 * Renamed to be not in conflict with the modified PHOJET-version       *
25657 ************************************************************************
25658
25659       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25660       SAVE
25661
25662 * hadron index conversion (BAMJET <--> PDG)
25663       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25664      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25665      &                IAMCIN(210)
25666
25667       IDT_ICIHAD = 0
25668       KPDG   = ABS(MCIND)
25669       IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25670       IF (MCIND.LT.0) THEN
25671          JSIGN = 1
25672       ELSE
25673          JSIGN = 2
25674       ENDIF
25675       IF (KPDG.GE.10000) THEN
25676          DO 1 I=1,19
25677             IDT_ICIHAD = IBAM5(JSIGN,I)
25678             IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25679             IDT_ICIHAD = 0
25680     1    CONTINUE
25681       ELSEIF (KPDG.GE.1000) THEN
25682          DO 2 I=1,29
25683             IDT_ICIHAD = IBAM4(JSIGN,I)
25684             IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25685             IDT_ICIHAD = 0
25686     2    CONTINUE
25687       ELSEIF (KPDG.GE.100) THEN
25688          DO 3 I=1,22
25689             IDT_ICIHAD = IBAM3(JSIGN,I)
25690             IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25691             IDT_ICIHAD = 0
25692     3    CONTINUE
25693       ELSEIF (KPDG.GE.10) THEN
25694          DO 4 I=1,7
25695             IDT_ICIHAD = IBAM2(JSIGN,I)
25696             IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25697             IDT_ICIHAD = 0
25698     4    CONTINUE
25699       ENDIF
25700     5 CONTINUE
25701
25702       RETURN
25703       END
25704
25705 *$ CREATE IDT_IPDGHA.FOR
25706 *COPY IDT_IPDGHA
25707 *
25708 *===ipdgha=============================================================*
25709 *
25710       INTEGER FUNCTION IDT_IPDGHA(MCIND)
25711
25712 ************************************************************************
25713 * Conversion of particle index BAMJET-index scheme --> PDG proposal    *
25714 * Adopted from the original by S. Roesler. This version dated 12.5.95  *
25715 * Renamed to be not in conflict with the modified PHOJET-version       *
25716 ************************************************************************
25717
25718       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25719       SAVE
25720
25721 * hadron index conversion (BAMJET <--> PDG)
25722       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25723      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25724      &                IAMCIN(210)
25725
25726       IDT_IPDGHA = IAMCIN(MCIND)
25727
25728       RETURN
25729       END
25730
25731 *$ CREATE DT_FLAHAD.FOR
25732 *COPY DT_FLAHAD
25733 *
25734 *===flahad=============================================================*
25735 *
25736       SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25737
25738 ************************************************************************
25739 * sampling of FLAvor composition for HADrons/photons                   *
25740 *              ID         BAMJET-id of hadron                          *
25741 *              IF1,2,3    flavor content                               *
25742 *                         (u,d,s: 1,2,3;  au,ad,as: -1,-1,-3)          *
25743 * Note:  -  u,d numbering as in BAMJET                                 *
25744 *        -  ID .le. 30 !!                                              *
25745 * This version dated 12.03.96 is written by S. Roesler                 *
25746 ************************************************************************
25747
25748       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25749       SAVE
25750
25751 * auxiliary common for reggeon exchange (DTUNUC 1.x)
25752       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25753      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25754      &                IQTCHR(-6:6),MQUARK(3,39)
25755
25756       DIMENSION JSEL(3,6)
25757       DATA JSEL/ 1,2,3,  2,3,1,  3,1,2,  1,3,2,   2,1,3,   3,2,1/
25758
25759       ONE = 1.0D0
25760       IF (ID.EQ.7) THEN
25761 * photon (charge dependent flavour sampling)
25762          K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25763          IF (K.LE.4) THEN
25764             IF1 = 2
25765             IF2 = -2
25766          ELSE IF(K.EQ.5) THEN
25767             IF1 = 1
25768             IF2 = -1
25769          ELSE
25770             IF1 = 3
25771             IF2 = -3
25772          ENDIF
25773          IF(DT_RNDM(ONE).LT.0.5D0) THEN
25774             K   = IF1
25775             IF1 = IF2
25776             IF2 = K
25777          ENDIF
25778          IF3 = 0
25779       ELSE
25780 * hadron
25781          IX  = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25782          IF1 = MQUARK(JSEL(1,IX),ID)
25783          IF2 = MQUARK(JSEL(2,IX),ID)
25784          IF3 = MQUARK(JSEL(3,IX),ID)
25785          IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25786             IF1 = IF3
25787             IF3 = 0
25788          ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25789             IF2 = IF3
25790             IF3 = 0
25791          ENDIF
25792       ENDIF
25793
25794       RETURN
25795       END
25796
25797 *$ CREATE IDT_MCHAD.FOR
25798 *COPY IDT_MCHAD
25799 *
25800 *===mchad==============================================================*
25801 *
25802       INTEGER FUNCTION IDT_MCHAD(ITDTU)
25803
25804 ************************************************************************
25805 * Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25806 * Adopted from the original by S. Roesler. This version dated 6.5.95   *
25807 *                                                                      *
25808 * Last change 28.12.2006 by S. Roesler.                                *
25809 ************************************************************************
25810
25811       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25812       SAVE
25813
25814       DIMENSION ITRANS(210)
25815       DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25816      &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25817      &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25818      &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25819      &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25820      &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25821      &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25822
25823       IF ( ITDTU .GT. 0 ) THEN
25824          IDT_MCHAD = ITRANS(ITDTU)
25825       ELSE
25826          IDT_MCHAD = -1
25827       END IF
25828
25829       RETURN
25830       END
25831
25832 ************************************************************************
25833 *                                                                      *
25834 *   3) Energy-momentum and quantum number conservation check routines  *
25835 *                                                                      *
25836 ************************************************************************
25837 *$ CREATE DT_EMC1.FOR
25838 *COPY DT_EMC1
25839 *
25840 *===emc1===============================================================*
25841 *
25842       SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25843
25844 ************************************************************************
25845 * This version dated 15.12.94 is written by S. Roesler                 *
25846 ************************************************************************
25847
25848       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25849       SAVE
25850       PARAMETER ( LINP = 10 ,
25851      &            LOUT = 6 ,
25852      &            LDAT = 9 )
25853       PARAMETER (TINY10=1.0D-10)
25854
25855       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25856
25857       IREJ = 0
25858
25859       IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25860      &   WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25861
25862       IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25863          IF (MODE.EQ.1) THEN
25864             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25865          ELSEIF (MODE.EQ.2) THEN
25866             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25867          ENDIF
25868          CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25869          CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25870          CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25871       ELSEIF (MODE.LT.0) THEN
25872          IF (MODE.EQ.-1) THEN
25873             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
25874          ELSEIF (MODE.EQ.-2) THEN
25875             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
25876          ENDIF
25877          CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
25878          CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
25879          CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
25880       ENDIF
25881
25882       IF (ABS(MODE).EQ.3) THEN
25883          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25884          IF (IREJ1.NE.0) GOTO 9999
25885       ENDIF
25886       RETURN
25887
25888  9999 CONTINUE
25889       IREJ = 1
25890       RETURN
25891       END
25892
25893 *$ CREATE DT_EMC2.FOR
25894 *COPY DT_EMC2
25895 *
25896 *===emc2===============================================================*
25897 *
25898       SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25899      &                                                MODE,IPOS,IREJ)
25900
25901 ************************************************************************
25902 *             MODE = 1   energy-momentum cons. check                   *
25903 *                  = 2   flavor-cons. check                            *
25904 *                  = 3   energy-momentum & flavor cons. check          *
25905 *                  = 4   energy-momentum & charge cons. check          *
25906 *                  = 5   energy-momentum & flavor & charge cons. check *
25907 * This version dated 16.01.95 is written by S. Roesler                 *
25908 ************************************************************************
25909
25910       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25911       SAVE
25912       PARAMETER ( LINP = 10 ,
25913      &            LOUT = 6 ,
25914      &            LDAT = 9 )
25915       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25916
25917 * event history
25918       PARAMETER (NMXHKK=200000)
25919       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25920      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25921      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25922 * extended event history
25923       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25924      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25925      &                IHIST(2,NMXHKK)
25926
25927       IREJ  = 0
25928       IREJ1 = 0
25929       IREJ2 = 0
25930       IREJ3 = 0
25931
25932       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25933      &                CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25934       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25935      &                                CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25936       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25937       DO 1 I=1,NHKK
25938          IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25939      &       (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25940      &       (ISTHKK(I).EQ.IP5))                          THEN
25941             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25942      &                                    .OR.(MODE.EQ.5))
25943      &      CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25944      &                                               2,IDUM,IDUM)
25945             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25946      &         CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25947             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25948      &                            CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25949          ENDIF
25950          IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25951      &       (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25952      &       (ISTHKK(I).EQ.IN5))                          THEN
25953             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25954      &                                    .OR.(MODE.EQ.5))
25955      &      CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25956      &                                                   2,IDUM,IDUM)
25957             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25958      &         CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25959             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25960      &                            CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
25961          ENDIF
25962     1 CONTINUE
25963       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25964      &   CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
25965       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25966      &   CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
25967       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
25968       IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
25969
25970       RETURN
25971
25972  9999 CONTINUE
25973       IREJ = 1
25974       RETURN
25975       END
25976
25977 *$ CREATE DT_EVTEMC.FOR
25978 *COPY DT_EVTEMC
25979 *
25980 *===evtemc=============================================================*
25981 *
25982       SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
25983
25984 ************************************************************************
25985 * This version dated 13.12.94 is written by S. Roesler                 *
25986 ************************************************************************
25987
25988       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25989       SAVE
25990       PARAMETER ( LINP = 10 ,
25991      &            LOUT = 6 ,
25992      &            LDAT = 9 )
25993       PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
25994      &           ZERO=0.0D0)
25995
25996 * event history
25997       PARAMETER (NMXHKK=200000)
25998       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25999      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26000      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26001 * flags for input different options
26002       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
26003       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
26004      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
26005
26006       IREJ = 0
26007
26008       MODE = IMODE
26009       CHKLEV = TINY10
26010       IF (MODE.EQ.4) THEN
26011          CHKLEV = TINY2
26012          MODE   = 3
26013       ELSEIF (MODE.EQ.5) THEN
26014          CHKLEV = TINY1
26015          MODE   = 3
26016       ELSEIF (MODE.EQ.-1) THEN
26017          CHKLEV = EIO
26018          MODE   = 3
26019       ENDIF
26020
26021       IF (ABS(MODE).EQ.3) THEN
26022          PXDEV = PX
26023          PYDEV = PY
26024          PZDEV = PZ
26025          EDEV  = E
26026          IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
26027          IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
26028      &       (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
26029             IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
26030      &         'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
26031      &         '  event  ',NEVHKK,
26032      &         ' ! ',PXDEV,PYDEV,PZDEV,EDEV
26033             PX   = 0.0D0
26034             PY   = 0.0D0
26035             PZ   = 0.0D0
26036             E    = 0.0D0
26037             GOTO 9999
26038          ENDIF
26039          PX   = 0.0D0
26040          PY   = 0.0D0
26041          PZ   = 0.0D0
26042          E    = 0.0D0
26043          RETURN
26044       ENDIF
26045
26046       IF (MODE.EQ.1) THEN
26047          PX = 0.0D0
26048          PY = 0.0D0
26049          PZ = 0.0D0
26050          E  = 0.0D0
26051       ENDIF
26052
26053       PX = PX+PXIO
26054       PY = PY+PYIO
26055       PZ = PZ+PZIO
26056       E  = E+EIO
26057
26058       RETURN
26059
26060  9999 CONTINUE
26061       IREJ = 1
26062       RETURN
26063       END
26064
26065 *$ CREATE DT_EVTFLC.FOR
26066 *COPY DT_EVTFLC
26067 *
26068 *===evtflc=============================================================*
26069 *
26070       SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
26071
26072 ************************************************************************
26073 * Flavor conservation check.                                           *
26074 *        ID       identity of particle                                 *
26075 *        ID1 = 1  ID for q,aq,qq,aqaq in PDG-numbering scheme          *
26076 *            = 2  ID for particle/resonance in BAMJET numbering scheme *
26077 *            = 3  ID for particle/resonance in PDG    numbering scheme *
26078 *        MODE = 1 initialization and add ID                            *
26079 *             =-1 initialization and subtract ID                       *
26080 *             = 2 add ID                                               *
26081 *             =-2 subtract ID                                          *
26082 *             = 3 check flavor cons.                                   *
26083 *        IPOS     flag to give position of call of EVTFLC to output    *
26084 *                 unit in case of violation                            *
26085 * This version dated 10.01.95 is written by S. Roesler                 *
26086 ************************************************************************
26087
26088       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26089       SAVE
26090       PARAMETER ( LINP = 10 ,
26091      &            LOUT = 6 ,
26092      &            LDAT = 9 )
26093       PARAMETER (TINY10=1.0D-10)
26094
26095       IREJ = 0
26096
26097       IF (MODE.EQ.3) THEN
26098          IF (IFL.NE.0) THEN
26099             WRITE(LOUT,'(1X,A,I3,A,I3)')
26100      &         'EVTFLC: flavor-conservation failure at pos. ',IPOS,
26101      &         ' !  IFL = ',IFL
26102             IFL = 0
26103             GOTO 9999
26104          ENDIF
26105          IFL = 0
26106          RETURN
26107       ENDIF
26108
26109       IF (MODE.EQ.1) IFL = 0
26110       IF (ID.EQ.0)   RETURN
26111
26112       IF (ID1.EQ.1) THEN
26113          IDD = ABS(ID)
26114          NQ  = 1
26115          IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
26116          IF (IDD.GE.1000) NQ = 3
26117          DO 1 I=1,NQ
26118             IFBAM = IDT_IPDG2B(ID,I,2)
26119             IF (ABS(IFBAM).EQ.1) THEN
26120                IFBAM = SIGN(2,IFBAM)
26121             ELSEIF (ABS(IFBAM).EQ.2) THEN
26122                IFBAM = SIGN(1,IFBAM)
26123             ENDIF
26124             IF (MODE.GT.0) THEN
26125                IFL = IFL+IFBAM
26126             ELSE
26127                IFL = IFL-IFBAM
26128             ENDIF
26129     1    CONTINUE
26130          RETURN
26131       ENDIF
26132
26133       IDD = ID
26134       IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
26135       IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
26136          DO 2 I=1,3
26137             IF (MODE.GT.0) THEN
26138                IFL = IFL+IDT_IQUARK(I,IDD)
26139             ELSE
26140                IFL = IFL-IDT_IQUARK(I,IDD)
26141             ENDIF
26142     2    CONTINUE
26143       ENDIF
26144       RETURN
26145
26146  9999 CONTINUE
26147       IREJ = 1
26148       RETURN
26149       END
26150
26151 *$ CREATE DT_EVTCHG.FOR
26152 *COPY DT_EVTCHG
26153 *
26154 *===evtchg=============================================================*
26155 *
26156       SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
26157
26158 ************************************************************************
26159 * Charge conservation check.                                           *
26160 *        ID       identity of particle (PDG-numbering scheme)          *
26161 *        MODE = 1 initialization                                       *
26162 *             =-2 subtract ID-charge                                   *
26163 *             = 2 add ID-charge                                        *
26164 *             = 3 check charge cons.                                   *
26165 *        IPOS     flag to give position of call of EVTCHG to output    *
26166 *                 unit in case of violation                            *
26167 * This version dated 10.01.95 is written by S. Roesler                 *
26168 * Last change: s.r. 21.01.01                                           *
26169 ************************************************************************
26170
26171       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26172       SAVE
26173       PARAMETER ( LINP = 10 ,
26174      &            LOUT = 6 ,
26175      &            LDAT = 9 )
26176
26177 * event history
26178       PARAMETER (NMXHKK=200000)
26179       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26180      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26181      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26182 * particle properties (BAMJET index convention)
26183       CHARACTER*8  ANAME
26184       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26185      &                IICH(210),IIBAR(210),K1(210),K2(210)
26186
26187       IREJ = 0
26188
26189       IF (MODE.EQ.1) THEN
26190          ICH  = 0
26191          IBAR = 0
26192          RETURN
26193       ENDIF
26194
26195       IF (MODE.EQ.3) THEN
26196          IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
26197             WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
26198      &         'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
26199      &         '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
26200             ICH  = 0
26201             IBAR = 0
26202             GOTO 9999
26203          ENDIF
26204          ICH  = 0
26205          IBAR = 0
26206          RETURN
26207       ENDIF
26208
26209       IF (ID.EQ.0)   RETURN
26210
26211       IDD = IDT_ICIHAD(ID)
26212 * modification 21.1.01: use intrinsic phojet-functions to determine charge
26213 * and baryon number
26214 C     IF (IDD.GT.0) THEN
26215 C        IF (MODE.EQ.2) THEN
26216 C           ICH  = ICH+IICH(IDD)
26217 C           IBAR = IBAR+IIBAR(IDD)
26218 C        ELSEIF (MODE.EQ.-2) THEN
26219 C           ICH  = ICH-IICH(IDD)
26220 C           IBAR = IBAR-IIBAR(IDD)
26221 C        ENDIF
26222 C     ELSE
26223 C        WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
26224 C        CALL DT_EVTOUT(4)
26225 C        STOP
26226 C     ENDIF
26227       IF (MODE.EQ.2) THEN
26228          ICH  = ICH+IPHO_CHR3(ID,1)/3
26229          IBAR = IBAR+IPHO_BAR3(ID,1)/3
26230       ELSEIF (MODE.EQ.-2) THEN
26231          ICH  = ICH-IPHO_CHR3(ID,1)/3
26232          IBAR = IBAR-IPHO_BAR3(ID,1)/3
26233       ENDIF
26234
26235       RETURN
26236
26237  9999 CONTINUE
26238       IREJ = 1
26239       RETURN
26240       END
26241
26242 ************************************************************************
26243 *                                                                      *
26244 *                 4) Transformations                                   *
26245 *                                                                      *
26246 ************************************************************************
26247 *$ CREATE DT_LTINI.FOR
26248 *COPY DT_LTINI
26249 *
26250 *===ltini==============================================================*
26251 *
26252       SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
26253
26254 ************************************************************************
26255 * Initializations of Lorentz-transformations, calculation of Lorentz-  *
26256 * parameters.                                                          *
26257 * This version dated 13.11.95 is written by  S. Roesler.               *
26258 ************************************************************************
26259
26260       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26261       SAVE
26262       PARAMETER ( LINP = 10 ,
26263      &            LOUT = 6 ,
26264      &            LDAT = 9 )
26265       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
26266      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
26267
26268 * Lorentz-parameters of the current interaction
26269       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26270      &                UMO,PPCM,EPROJ,PPROJ
26271 * properties of photon/lepton projectiles
26272       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
26273 * particle properties (BAMJET index convention)
26274       CHARACTER*8  ANAME
26275       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26276      &                IICH(210),IIBAR(210),K1(210),K2(210)
26277 * nucleon-nucleon event-generator
26278       CHARACTER*8 CMODEL
26279       LOGICAL LPHOIN
26280       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26281
26282       Q2   = VIRT
26283       IDP  = IDPR
26284       IF (MCGENE.NE.3) THEN
26285 * lepton-projectiles and PHOJET: initialize real photon instead
26286          IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26287      &       (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26288      &       (IDPR.EQ. 5).OR.(IDPR.EQ. 6))   THEN
26289             IDP = 7
26290             Q2  = ZERO
26291          ENDIF
26292       ENDIF
26293       IDT  = IDTA
26294       EPN  = EPN0
26295       PPN  = PPN0
26296       ECM  = ECM0
26297       AMP  = AAM(IDP)-SQRT(ABS(Q2))
26298       AMT  = AAM(IDT)
26299       AMP2 = SIGN(AMP**2,AMP)
26300       AMT2 = AMT**2
26301       IF (ECM0.GT.ZERO) THEN
26302          EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26303          IF (AMP2.GT.ZERO) THEN
26304             PPN = SQRT((EPN+AMP)*(EPN-AMP))
26305          ELSE
26306             PPN = SQRT(EPN**2-AMP2)
26307          ENDIF
26308       ELSE
26309          IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26310             IF (IDP.EQ.7) EPN = ABS(EPN)
26311             IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26312             IF (AMP2.GT.ZERO) THEN
26313                PPN = SQRT((EPN+AMP)*(EPN-AMP))
26314             ELSE
26315                PPN = SQRT(EPN**2-AMP2)
26316             ENDIF
26317          ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26318             IF (AMP2.GT.ZERO) THEN
26319                EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26320             ELSE
26321                EPN = SQRT(PPN**2+AMP2)
26322             ENDIF
26323          ENDIF
26324          ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26325       ENDIF
26326       UMO   = ECM
26327       EPROJ = EPN
26328       PPROJ = PPN
26329       IF (AMP2.GT.ZERO) THEN
26330          ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26331          PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26332       ELSE
26333          ETARG = TINY10
26334          PTARG = TINY10
26335       ENDIF
26336 * photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26337       IF (IDP.EQ.7) THEN
26338          PGAMM(1) = ZERO
26339          PGAMM(2) = ZERO
26340          AMGAM  = AMP
26341          AMGAM2 = AMP2
26342          IF (ECM0.GT.ZERO) THEN
26343             S = ECM0**2
26344          ELSE
26345             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26346                S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26347             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26348                S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26349             ENDIF
26350          ENDIF
26351          PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26352      &                     +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26353          PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26354          IF (MODE.EQ.1) THEN
26355             PNUCL(1) = ZERO
26356             PNUCL(2) = ZERO
26357             PNUCL(3) = -PGAMM(3)
26358             PNUCL(4) = SQRT(S)-PGAMM(4)
26359          ENDIF
26360       ENDIF
26361       IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26362      &    (IDPR.EQ.10).OR.(IDPR.EQ.11))   THEN
26363          PLEPT0(1) = ZERO
26364          PLEPT0(2) = ZERO
26365 * neglect lepton masses
26366 C        AMLPT2   = AAM(IDPR)**2
26367          AMLPT2   = ZERO
26368 *
26369          IF (ECM0.GT.ZERO) THEN
26370             S = ECM0**2
26371          ELSE
26372             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26373                S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26374             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26375                S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26376             ENDIF
26377          ENDIF
26378          PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26379      &                     +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26380          PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26381          PNUCL(1) = ZERO
26382          PNUCL(2) = ZERO
26383          PNUCL(3) = -PLEPT0(3)
26384          PNUCL(4) = SQRT(S)-PLEPT0(4)
26385       ENDIF
26386 * Lorentz-parameter for transformation Lab. - projectile rest system
26387       IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26388          GALAB = TINY10
26389          BGLAB = TINY10
26390          BLAB  = TINY10
26391       ELSE
26392          GALAB = EPROJ/AMP
26393          BGLAB = PPROJ/AMP
26394          BLAB  = BGLAB/GALAB
26395       ENDIF
26396 * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26397       IF (IDP.EQ.7) THEN
26398          GACMS(1) = TINY10
26399          BGCMS(1) = TINY10
26400       ELSE
26401          GACMS(1) = (ETARG+AMP)/UMO
26402          BGCMS(1) = PTARG/UMO
26403       ENDIF
26404 * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26405       GACMS(2) = (EPROJ+AMT)/UMO
26406       BGCMS(2) = PPROJ/UMO
26407       PPCM     = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26408
26409       EPN0 = EPN
26410       PPN0 = PPN
26411       ECM0 = ECM
26412
26413       RETURN
26414       END
26415
26416 *$ CREATE DT_LTRANS.FOR
26417 *COPY DT_LTRANS
26418 *
26419 *===ltrans=============================================================*
26420 *
26421       SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26422
26423 ************************************************************************
26424 * Lorentz-transformations.                                             *
26425 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
26426 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
26427 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
26428 * This version dated 01.11.95 is written by  S. Roesler.               *
26429 ************************************************************************
26430
26431       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26432       SAVE
26433       PARAMETER ( LINP = 10 ,
26434      &            LOUT = 6 ,
26435      &            LDAT = 9 )
26436       PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26437
26438       PARAMETER (SQTINF=1.0D+15)
26439
26440 * particle properties (BAMJET index convention)
26441       CHARACTER*8  ANAME
26442       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26443      &                IICH(210),IIBAR(210),K1(210),K2(210)
26444
26445       PXO = PXI
26446       PYO = PYI
26447       CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26448
26449 * check particle mass for consistency (numerical rounding errors)
26450       PO     = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26451       AMO2   = (PEO-PO)*(PEO+PO)
26452       AMORQ2 = AAM(ID)**2
26453       AMDIF2 = ABS(AMO2-AMORQ2)
26454       IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26455          DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26456          PEO   = PEO+DELTA
26457          PO1   = PO -DELTA
26458          PXO   = PXO*PO1/PO
26459          PYO   = PYO*PO1/PO
26460          PZO   = PZO*PO1/PO
26461 C        WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26462       ENDIF
26463
26464       RETURN
26465       END
26466
26467 *$ CREATE DT_LTNUC.FOR
26468 *COPY DT_LTNUC
26469 *
26470 *===ltnuc==============================================================*
26471 *
26472       SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26473
26474 ************************************************************************
26475 * Lorentz-transformations.                                             *
26476 *   PIN        longitudnal momentum       (input)                      *
26477 *   EIN        energy                     (input)                      *
26478 *   POUT       transformed long. momentum (output)                     *
26479 *   EOUT       transformed energy         (output)                     *
26480 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
26481 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
26482 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
26483 * This version dated 01.11.95 is written by  S. Roesler.               *
26484 ************************************************************************
26485
26486       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26487       SAVE
26488       PARAMETER ( LINP = 10 ,
26489      &            LOUT = 6 ,
26490      &            LDAT = 9 )
26491       PARAMETER (ZERO=0.0D0)
26492
26493 * Lorentz-parameters of the current interaction
26494       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26495      &                UMO,PPCM,EPROJ,PPROJ
26496
26497       BDUM1 = ZERO
26498       BDUM2 = ZERO
26499       PDUM1 = ZERO
26500       PDUM2 = ZERO
26501       IF (ABS(MODE).EQ.1) THEN
26502          BG = -SIGN(BGLAB,DBLE(MODE))
26503          CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26504      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26505       ELSEIF (ABS(MODE).EQ.2) THEN
26506          BG = SIGN(BGCMS(1),DBLE(MODE))
26507          CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26508      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26509       ELSEIF (ABS(MODE).EQ.3) THEN
26510          BG = -SIGN(BGCMS(2),DBLE(MODE))
26511          CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26512      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26513       ELSE
26514          WRITE(LOUT,1000) MODE
26515  1000    FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26516          EOUT = EIN
26517          POUT = PIN
26518       ENDIF
26519
26520       RETURN
26521       END
26522
26523 *$ CREATE DT_DALTRA.FOR
26524 *COPY DT_DALTRA
26525 *
26526 *===daltra=============================================================*
26527 *
26528       SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26529
26530 ************************************************************************
26531 * Arbitrary Lorentz-transformation.                                    *
26532 * Adopted from the original by S. Roesler. This version dated 15.01.95 *
26533 ************************************************************************
26534
26535       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26536       SAVE
26537       PARAMETER (ONE=1.0D0)
26538
26539       EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26540       PE = EP/(GA+ONE)+EC
26541       PX = PCX+BGX*PE
26542       PY = PCY+BGY*PE
26543       PZ = PCZ+BGZ*PE
26544       P  = SQRT(PX*PX+PY*PY+PZ*PZ)
26545       E  = GA*EC+EP
26546
26547       RETURN
26548       END
26549
26550 *$ CREATE DT_DTRAFO.FOR
26551 *COPY DT_DTRAFO
26552 *
26553 *====dtrafo============================================================*
26554 *
26555       SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26556      &                                    PL,CXL,CYL,CZL,EL)
26557
26558 C     LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26559
26560       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26561       SAVE
26562
26563       IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26564       SID  = SQRT(1.D0-COD*COD)
26565       PLX  = P*SID*COF
26566       PLY  = P*SID*SIF
26567       PCMZ = P*COD
26568       PLZ  = GAM*PCMZ+BGAM*ECM
26569       PL   = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26570       EL   = GAM*ECM+BGAM*PCMZ
26571 C     ROTATION INTO THE ORIGINAL DIRECTION
26572       COZ  = PLZ/PL
26573       SIZ  = SQRT(1.D0-COZ**2)
26574       CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26575
26576       RETURN
26577       END
26578
26579 *$ CREATE DT_STTRAN.FOR
26580 *COPY DT_STTRAN
26581 *
26582 *====sttran============================================================*
26583 *
26584       SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26585
26586       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26587       SAVE
26588       DATA ANGLSQ/1.D-30/
26589 ************************************************************************
26590 *     VERSION BY                     J. RANFT                          *
26591 *                                    LEIPZIG                           *
26592 *                                                                      *
26593 *     THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES      *
26594 *                                                                      *
26595 *     INPUT VARIABLES:                                                 *
26596 *        XO,YO,ZO = ORIGINAL DIRECTION COSINES                         *
26597 *        CDE,SDE  = COSINE AND SINE OF THE POLAR (THETA)               *
26598 *                   ANGLE OF "SCATTERING"                              *
26599 *        SDE      = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING"    *
26600 *        SFE,CFE  = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE       *
26601 *                   OF "SCATTERING"                                    *
26602 *                                                                      *
26603 *     OUTPUT VARIABLES:                                                *
26604 *        X,Y,Z     = NEW DIRECTION COSINES                             *
26605 *                                                                      *
26606 *     ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 )                  *
26607 ************************************************************************
26608 *
26609 *
26610 *  Changed by A. Ferrari
26611 *
26612 *     IF (ABS(XO)-0.0001D0) 1,1,2
26613 *   1 IF (ABS(YO)-0.0001D0) 3,3,2
26614 *   3 CONTINUE
26615       A = XO**2 + YO**2
26616       IF ( A .LT. ANGLSQ ) THEN
26617          X=SDE*CFE
26618          Y=SDE*SFE
26619          Z=CDE*ZO
26620       ELSE
26621          XI=SDE*CFE
26622          YI=SDE*SFE
26623          ZI=CDE
26624          A=SQRT(A)
26625          X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26626          Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26627          Z=A*YI+ZO*ZI
26628       ENDIF
26629
26630       RETURN
26631       END
26632
26633 *$ CREATE DT_MYTRAN.FOR
26634 *COPY DT_MYTRAN
26635 *
26636 *===mytran=============================================================*
26637 *
26638       SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26639
26640 ************************************************************************
26641 * This subroutine rotates the coordinate frame                         *
26642 *    a) theta  around y                                                *
26643 *    b) phi    around z      if IMODE = 1                              *
26644 *                                                                      *
26645 *     x'          cos(ph) -sin(ph) 0      cos(th)  0  sin(th)   x      *
26646 *     y' = A B =  sin(ph) cos(ph)  0  .   0        1        0   y      *
26647 *     z'          0       0        1     -sin(th)  0  cos(th)   z      *
26648 *                                                                      *
26649 * and vice versa if IMODE = 0.                                         *
26650 * This version dated 5.4.94 is based on the original version DTRAN     *
26651 * by J. Ranft and is written by S. Roesler.                            *
26652 ************************************************************************
26653
26654       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26655       SAVE
26656       PARAMETER ( LINP = 10 ,
26657      &            LOUT = 6 ,
26658      &            LDAT = 9 )
26659
26660       IF (IMODE.EQ.1) THEN
26661          X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26662          Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26663          Z=-SDE    *XO       +CDE    *ZO
26664       ELSE
26665          X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26666          Y= -SFE*XO+CFE*YO
26667          Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26668       ENDIF
26669       RETURN
26670       END
26671
26672 *$ CREATE DT_LT2LAO.FOR
26673 *COPY DT_LT2LAO
26674 *
26675 *===lt2lab=============================================================*
26676 *
26677       SUBROUTINE DT_LT2LAO
26678
26679 ************************************************************************
26680 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
26681 * for final state particles/fragments defined in nucleon-nucleon-cms   *
26682 * and transforms them back to the lab.                                 *
26683 * This version dated 16.11.95 is written by S. Roesler                 *
26684 ************************************************************************
26685
26686       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26687       SAVE
26688       PARAMETER ( LINP = 10 ,
26689      &            LOUT = 6 ,
26690      &            LDAT = 9 )
26691
26692 * event history
26693       PARAMETER (NMXHKK=200000)
26694       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26695      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26696      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26697 * extended event history
26698       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26699      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26700      &                IHIST(2,NMXHKK)
26701
26702       NEND      = NHKK
26703       NPOINT(5) = NHKK+1
26704       IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26705       DO 1 I=NPOINT(4),NEND
26706 C     DO 1 I=1,NEND
26707          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26708      &                                (ISTHKK(I).EQ.1001)) THEN
26709             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26710             NOB = NOBAM(I)
26711             CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26712      &                            PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26713             IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26714                ISTHKK(I) = 3*ISTHKK(I)
26715                NOBAM(NHKK)  = NOB
26716             ELSE
26717                IF (ISTHKK(I).EQ.-1) NOBAM(NHKK)  = NOB
26718                ISTHKK(I) = SIGN(3,ISTHKK(I))
26719             ENDIF
26720             JDAHKK(1,I) = NHKK
26721          ENDIF
26722     1 CONTINUE
26723
26724       RETURN
26725       END
26726
26727 *$ CREATE DT_LT2LAB.FOR
26728 *COPY DT_LT2LAB
26729 *
26730 *===lt2lab=============================================================*
26731 *
26732       SUBROUTINE DT_LT2LAB
26733
26734 ************************************************************************
26735 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
26736 * for final state particles/fragments defined in nucleon-nucleon-cms   *
26737 * and transforms them to the lab.                                      *
26738 * This version dated 07.01.96 is written by S. Roesler                 *
26739 ************************************************************************
26740
26741       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26742       SAVE
26743       PARAMETER ( LINP = 10 ,
26744      &            LOUT = 6 ,
26745      &            LDAT = 9 )
26746
26747 * event history
26748       PARAMETER (NMXHKK=200000)
26749       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26750      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26751      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26752 * extended event history
26753       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26754      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26755      &                IHIST(2,NMXHKK)
26756
26757       IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26758       DO 1 I=NPOINT(4),NHKK
26759          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26760      &                                (ISTHKK(I).EQ.1001)) THEN
26761             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26762             PHKK(3,I) = PZ
26763             PHKK(4,I) = PE
26764          ENDIF
26765     1 CONTINUE
26766
26767       RETURN
26768       END
26769
26770 ************************************************************************
26771 *                                                                      *
26772 *                 5) Sampling from distributions                       *
26773 *                                                                      *
26774 ************************************************************************
26775 *$ CREATE IDT_NPOISS.FOR
26776 *COPY IDT_NPOISS
26777 *
26778 *===npoiss=============================================================*
26779 *
26780       INTEGER FUNCTION IDT_NPOISS(AVN)
26781
26782 ************************************************************************
26783 * Sample according to Poisson distribution with Poisson parameter AVN. *
26784 * The original version written by J. Ranft.                            *
26785 * This version dated 11.1.95 is written by S. Roesler.                 *
26786 ************************************************************************
26787
26788       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26789       SAVE
26790       PARAMETER ( LINP = 10 ,
26791      &            LOUT = 6 ,
26792      &            LDAT = 9 )
26793
26794       EXPAVN = EXP(-AVN)
26795       K = 1
26796       A = 1.0D0
26797
26798    10 CONTINUE
26799       A = DT_RNDM(A)*A
26800       IF (A.GE.EXPAVN) THEN
26801          K = K+1
26802          GOTO 10
26803       ENDIF
26804       IDT_NPOISS = K-1
26805
26806       RETURN
26807       END
26808
26809 *$ CREATE DT_SAMPXB.FOR
26810 *COPY DT_SAMPXB
26811 *
26812 *===sampxb=============================================================*
26813 *
26814       DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26815
26816 ************************************************************************
26817 * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2.             *
26818 * Processed by S. Roesler, 6.5.95                                      *
26819 ************************************************************************
26820
26821       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26822       SAVE
26823       PARAMETER (TWO=2.0D0)
26824
26825       A1 = LOG(X1+SQRT(X1**2+B**2))
26826       A2 = LOG(X2+SQRT(X2**2+B**2))
26827       AN = A2-A1
26828       A  = AN*DT_RNDM(A1)+A1
26829       BB = EXP(A)
26830       DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26831
26832       RETURN
26833       END
26834
26835 *$ CREATE DT_SAMPEX.FOR
26836 *COPY DT_SAMPEX
26837 *
26838 *===sampex=============================================================*
26839 *
26840       DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26841
26842 ************************************************************************
26843 * Sampling from f(x)=1./x between x1 and x2.                           *
26844 * Processed by S. Roesler, 6.5.95                                      *
26845 ************************************************************************
26846
26847       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26848       SAVE
26849       PARAMETER (ONE=1.0D0)
26850
26851       R   = DT_RNDM(X1)
26852       AL1 = LOG(X1)
26853       AL2 = LOG(X2)
26854       DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26855
26856       RETURN
26857       END
26858
26859 *$ CREATE DT_SAMSQX.FOR
26860 *COPY DT_SAMSQX
26861 *
26862 *===samsqx=============================================================*
26863 *
26864       DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26865
26866 ************************************************************************
26867 * Sampling from f(x)=1./x^0.5 between x1 and x2.                       *
26868 * Processed by S. Roesler, 6.5.95                                      *
26869 ************************************************************************
26870
26871       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26872       SAVE
26873       PARAMETER (ONE=1.0D0)
26874
26875       R = DT_RNDM(X1)
26876       DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26877
26878       RETURN
26879       END
26880
26881 *$ CREATE DT_SAMPLW.FOR
26882 *COPY DT_SAMPLW
26883 *
26884 *===samplw=============================================================*
26885 *
26886       DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26887
26888 ************************************************************************
26889 * Sampling from f(x)=1/x^b between x_min and x_max.                    *
26890 * S. Roesler, 18.4.98                                                  *
26891 ************************************************************************
26892
26893       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26894       SAVE
26895       PARAMETER (ONE=1.0D0)
26896
26897       R = DT_RNDM(B)
26898       IF (B.EQ.ONE) THEN
26899          DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26900       ELSE
26901          ONEMB  = ONE-B
26902          DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26903       ENDIF
26904
26905       RETURN
26906       END
26907
26908 *$ CREATE DT_BETREJ.FOR
26909 *COPY DT_BETREJ
26910 *
26911 *===betrej=============================================================*
26912 *
26913       DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26914
26915       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26916       SAVE
26917
26918       PARAMETER ( LINP = 10 ,
26919      &            LOUT = 6 ,
26920      &            LDAT = 9 )
26921       PARAMETER (ONE=1.0D0)
26922
26923       IF (XMIN.GE.XMAX)THEN
26924          WRITE (LOUT,500) XMIN,XMAX
26925   500    FORMAT(1X,'DT_BETREJ:  XMIN<XMAX execution stopped ',2F10.5)
26926          STOP
26927       ENDIF
26928
26929    10 CONTINUE
26930       XX     = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26931       BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26932       YY     = BETMAX*DT_RNDM(XX)
26933       BETXX  = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26934       IF (YY.GT.BETXX) GOTO 10
26935       DT_BETREJ = XX
26936
26937       RETURN
26938       END
26939
26940 *$ CREATE DT_DGAMRN.FOR
26941 *COPY DT_DGAMRN
26942 *
26943 *===dgamrn=============================================================*
26944 *
26945       DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26946
26947 ************************************************************************
26948 * Sampling from Gamma-distribution.                                    *
26949 *       F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)            *
26950 * Processed by S. Roesler, 6.5.95                                      *
26951 ************************************************************************
26952
26953       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26954       SAVE
26955       PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
26956
26957       NCOU = 0
26958       N    = INT(ETA)
26959       F    = ETA-DBLE(N)
26960       IF (F.EQ.ZERO) GOTO 20
26961    10 R = DT_RNDM(F)
26962       NCOU = NCOU+1
26963       IF (NCOU.GE.11) GOTO 20
26964       IF (R.LT.F/(F+2.71828D0)) GOTO 30
26965       YYY = LOG(DT_RNDM(R)+TINY9)/F
26966       IF (ABS(YYY).GT.50.0D0) GOTO 20
26967       Y = EXP(YYY)
26968       IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
26969       GOTO 40
26970    20 Y = 0.0D0
26971       GOTO 50
26972    30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
26973       IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
26974    40 IF (N.EQ.0) GOTO 70
26975    50 Z = 1.0D0
26976       DO 60 I = 1,N
26977    60 Z = Z*DT_RNDM(Z)
26978       Y = Y-LOG(Z+TINY9)
26979    70 DT_DGAMRN = Y/ALAM
26980
26981       RETURN
26982       END
26983
26984 *$ CREATE DT_DBETAR.FOR
26985 *COPY DT_DBETAR
26986 *
26987 *===dbetar=============================================================*
26988 *
26989       DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
26990
26991 ************************************************************************
26992 * Sampling from Beta -distribution between 0.0 and 1.0                 *
26993 *  F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
26994 * Processed by S. Roesler, 6.5.95                                      *
26995 ************************************************************************
26996
26997       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26998       SAVE
26999
27000       Y = DT_DGAMRN(1.0D0,GAM)
27001       Z = DT_DGAMRN(1.0D0,ETA)
27002       DT_DBETAR = Y/(Y+Z)
27003
27004       RETURN
27005       END
27006
27007 *$ CREATE DT_RANNOR.FOR
27008 *COPY DT_RANNOR
27009 *
27010 *===rannor=============================================================*
27011 *
27012       SUBROUTINE DT_RANNOR(X,Y)
27013
27014 ************************************************************************
27015 * Sampling from Gaussian distribution.                                 *
27016 * Processed by S. Roesler, 6.5.95                                      *
27017 ************************************************************************
27018
27019       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27020       SAVE
27021       PARAMETER (TINY10=1.0D-10)
27022
27023       CALL DT_DSFECF(SFE,CFE)
27024       V = MAX(TINY10,DT_RNDM(X))
27025       A = SQRT(-2.D0*LOG(V))
27026       X = A*SFE
27027       Y = A*CFE
27028
27029       RETURN
27030       END
27031
27032 *$ CREATE DT_DPOLI.FOR
27033 *COPY DT_DPOLI
27034 *
27035 *===dpoli==============================================================*
27036 *
27037       SUBROUTINE DT_DPOLI(CS,SI)
27038
27039       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27040       SAVE
27041
27042       U  = DT_RNDM(CS)
27043       CS = DT_RNDM(U)
27044       IF (U.LT.0.5D0) CS=-CS
27045       SI = SQRT(1.0D0-CS*CS+1.0D-10)
27046
27047       RETURN
27048       END
27049
27050 *$ CREATE DT_DSFECF.FOR
27051 *COPY DT_DSFECF
27052 *
27053 *===dsfecf=============================================================*
27054 *
27055       SUBROUTINE DT_DSFECF(SFE,CFE)
27056
27057       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27058       SAVE
27059       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27060
27061     1 CONTINUE
27062       X  = DT_RNDM(SFE)
27063       Y  = DT_RNDM(X)
27064       XX = X*X
27065       YY = Y*Y
27066       XY = XX+YY
27067       IF (XY.GT.ONE) GOTO 1
27068       CFE = (XX-YY)/XY
27069       SFE = TWO*X*Y/XY
27070       IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
27071       RETURN
27072       END
27073
27074 *$ CREATE DT_RACO.FOR
27075 *COPY DT_RACO
27076 *
27077 *===raco===============================================================*
27078 *
27079       SUBROUTINE DT_RACO(WX,WY,WZ)
27080
27081 ************************************************************************
27082 * Direction cosines of random uniform (isotropic) direction in three   *
27083 * dimensional space                                                    *
27084 * Processed by S. Roesler, 20.11.95                                    *
27085 ************************************************************************
27086
27087       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27088       SAVE
27089       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27090
27091   10  CONTINUE
27092       X  = TWO*DT_RNDM(WX)-ONE
27093       Y  = DT_RNDM(X)
27094       X2 = X*X
27095       Y2 = Y*Y
27096       IF (X2+Y2.GT.ONE) GOTO 10
27097
27098       CFE = (X2-Y2)/(X2+Y2)
27099       SFE = TWO*X*Y/(X2+Y2)
27100 * z = 1/2 [ 1 + cos (theta) ]
27101       Z   = DT_RNDM(X)
27102 * 1/2 sin (theta)
27103       WZ = SQRT(Z*(ONE-Z))
27104       WX = TWO*WZ*CFE
27105       WY = TWO*WZ*SFE
27106       WZ = TWO*Z-ONE
27107
27108       RETURN
27109       END
27110
27111 ************************************************************************
27112 *                                                                      *
27113 *           6) Special functions, algorithms and service routines      *
27114 *                                                                      *
27115 ************************************************************************
27116 *$ CREATE DT_YLAMB.FOR
27117 *COPY DT_YLAMB
27118 *
27119 *===ylamb==============================================================*
27120 *
27121       DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
27122
27123 ************************************************************************
27124 *                                                                      *
27125 *     auxiliary function for three particle decay mode                 *
27126 *     (standard LAMBDA**(1/2) function)                                *
27127 *                                                                      *
27128 * Adopted from an original version written by R. Engel.                *
27129 * This version dated 12.12.94 is written by S. Roesler.                *
27130 ************************************************************************
27131
27132       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27133       SAVE
27134
27135       YZ   = Y-Z
27136       XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
27137       IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
27138       DT_YLAMB = SQRT(XLAM)
27139
27140       RETURN
27141       END
27142
27143 *$ CREATE DT_SORT.FOR
27144 *COPY DT_SORT
27145 *
27146 *===sort1==============================================================*
27147 *
27148       SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
27149
27150 ************************************************************************
27151 * This subroutine sorts entries in A in increasing/decreasing order    *
27152 * of A(3,i).                                                           *
27153 *              MODE  = 1     increasing in A(3,i=1..N)                 *
27154 *                    = 2     decreasing in A(3,i=1..N)                 *
27155 * This version dated 21.04.95 is revised by S. Roesler                 *
27156 ************************************************************************
27157
27158       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27159       SAVE
27160
27161       DIMENSION A(3,N)
27162
27163       M = I1
27164    10 CONTINUE
27165       M = I1-1
27166       IF (M.LE.0) RETURN
27167       L = 0
27168       DO 20 I=I0,M
27169          J = I+1
27170          IF (MODE.EQ.1) THEN
27171             IF (A(3,I).LE.A(3,J)) GOTO 20
27172          ELSE
27173             IF (A(3,I).GE.A(3,J)) GOTO 20
27174          ENDIF
27175          B = A(3,I)
27176          C = A(1,I)
27177          D = A(2,I)
27178          A(3,I) = A(3,J)
27179          A(2,I) = A(2,J)
27180          A(1,I) = A(1,J)
27181          A(3,J) = B
27182          A(1,J) = C
27183          A(2,J) = D
27184          L = 1
27185    20 CONTINUE
27186       IF (L.EQ.1) GOTO 10
27187
27188       RETURN
27189       END
27190
27191 *$ CREATE DT_SORT1.FOR
27192 *COPY DT_SORT1
27193 *
27194 *===sort1==============================================================*
27195 *
27196       SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
27197
27198 ************************************************************************
27199 * This subroutine sorts entries in A in increasing/decreasing order    *
27200 * of A(i).                                                             *
27201 *              MODE  = 1     increasing in A(i=1..N)                   *
27202 *                    = 2     decreasing in A(i=1..N)                   *
27203 * This version dated 21.04.95 is revised by S. Roesler                 *
27204 ************************************************************************
27205
27206       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27207       SAVE
27208
27209       DIMENSION A(N),IDX(N)
27210
27211       M = I1
27212    10 CONTINUE
27213       M = I1-1
27214       IF (M.LE.0) RETURN
27215       L = 0
27216       DO 20 I=I0,M
27217          J = I+1
27218          IF (MODE.EQ.1) THEN
27219             IF (A(I).LE.A(J)) GOTO 20
27220          ELSE
27221             IF (A(I).GE.A(J)) GOTO 20
27222          ENDIF
27223          B    = A(I)
27224          A(I) = A(J)
27225          A(J) = B
27226          IX     = IDX(I)
27227          IDX(I) = IDX(J)
27228          IDX(J) = IX
27229          L = 1
27230    20 CONTINUE
27231       IF (L.EQ.1) GOTO 10
27232
27233       RETURN
27234       END
27235
27236 *$ CREATE DT_XTIME.FOR
27237 *COPY DT_XTIME
27238 *
27239 *===xtime==============================================================*
27240 *
27241       SUBROUTINE DT_XTIME
27242
27243       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27244       SAVE
27245       PARAMETER ( LINP = 10 ,
27246      &            LOUT = 6 ,
27247      &            LDAT = 9 )
27248
27249       CHARACTER DAT*9,TIM*11
27250
27251       DAT = '         '
27252       TIM = '           '
27253 C     CALL GETDAT(IYEAR,IMONTH,IDAY)
27254 C     CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
27255
27256 C     CALL DATE(DAT)
27257 C     CALL TIME(TIM)
27258 C     WRITE(LOUT,1000) DAT,TIM
27259  1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
27260
27261       RETURN
27262       END
27263
27264 ************************************************************************
27265 *                                                                      *
27266 *                 7) Random number generator package                   *
27267 *                                                                      *
27268 *    THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND        *
27269 *    SERVICE ROUTINES.                                                 *
27270 *    THE ALGORITHM IS FROM                                             *
27271 *      'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR'                     *
27272 *      G.MARSAGLIA, A.ZAMAN ;  FSU-SCRI-87-50                          *
27273 *    IMPLEMENTATION BY K. HAHN  DEC. 88,                               *
27274 *    THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27275 *    AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ),        *
27276 *    THE PERIOD IS ABOUT 2**144,                                       *
27277 *    TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS,            *
27278 *    THE PACKAGE CONTAINS                                              *
27279 *      FUNCTION DT_RNDM(I)                  : GENERATOR                *
27280 *      SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION           *
27281 *      SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)  : PUT SEED TO GENERATOR    *
27282 *      SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)  : TAKE SEED FROM GENERATOR *
27283 *      SUBROUTINE DT_RNDMTE(IO)             : TEST OF GENERATOR        *
27284 *---                                                                   *
27285 *    FUNCTION DT_RNDM(I)                                               *
27286 *       GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS  IN (0..1)          *
27287 *       I  - DUMMY VARIABLE, NOT USED                                  *
27288 *    SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)                             *
27289 *       INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27290 *       NA1,NA2,NA3,NB1  - VALUES FOR INITIALIZING THE GENERATOR       *
27291 *                          NA? MUST BE IN 1..178 AND NOT ALL 1         *
27292 *                          12,34,56  ARE THE STANDARD VALUES           *
27293 *                          NB1 MUST BE IN 1..168                       *
27294 *                          78  IS THE STANDARD VALUE                   *
27295 *    SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)                               *
27296 *       PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS   *
27297 *       AS AFTER THE LAST DT_RNDMOU CALL )                             *
27298 *       U(97),C,CD,CM,I,J  - SEED VALUES AS TAKEN FROM DT_RNDMOU       *
27299 *    SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)                               *
27300 *       TAKES SEED FROM GENERATOR                                      *
27301 *       U(97),C,CD,CM,I,J  - SEED VALUES                               *
27302 *    SUBROUTINE DT_RNDMTE(IO)                                          *
27303 *       TEST OF THE GENERATOR                                          *
27304 *       IO     - DEFINES OUTPUT                                        *
27305 *                  = 0  OUTPUT ONLY IF AN ERROR IS DETECTED            *
27306 *                  = 1  OUTPUT INDEPENDEND ON AN ERROR                 *
27307 *       DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO   *
27308 *       SAME STATUS                                                    *
27309 *       AS BEFORE CALL OF DT_RNDMTE                                    *
27310 ************************************************************************
27311 *$ CREATE DT_RNDM.FOR
27312 *COPY DT_RNDM
27313 *
27314 c$$$*===rndm===============================================================*
27315 c$$$*
27316 c$$$      DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27317 c$$$
27318 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27319 c$$$      SAVE
27320 c$$$
27321 c$$$* random number generator
27322 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27323 c$$$
27324 c$$$* counter of calls to random number generator
27325 c$$$* uncomment if needed
27326 c$$$C     COMMON /DTRNCT/ IRNCT0,IRNCT1
27327 c$$$C     LOGICAL LFIRST
27328 c$$$C     DATA LFIRST /.TRUE./
27329 c$$$
27330 c$$$* counter of calls to random number generator
27331 c$$$* uncomment if needed
27332 c$$$C     IF (LFIRST) THEN
27333 c$$$C        IRNCT0 = 0
27334 c$$$C        IRNCT1 = 0
27335 c$$$C        LFIRST = .FALSE.
27336 c$$$C     ENDIF
27337 c$$$ 100  CONTINUE
27338 c$$$      DT_RNDM = U(I)-U(J)
27339 c$$$      IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27340 c$$$      U(I) = DT_RNDM
27341 c$$$      I    = I-1
27342 c$$$      IF ( I.EQ.0 ) I = 97
27343 c$$$      J    = J-1
27344 c$$$      IF ( J.EQ.0 ) J = 97
27345 c$$$      C    = C-CD
27346 c$$$      IF ( C.LT.0.0D0 ) C = C+CM
27347 c$$$      DT_RNDM = DT_RNDM-C
27348 c$$$      IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27349 c$$$
27350 c$$$      IF ((DT_RNDM.EQ.0.D0).OR.(DT_RNDM.EQ.1.D0)) GOTO 100
27351 c$$$
27352 c$$$* counter of calls to random number generator
27353 c$$$* uncomment if needed
27354 c$$$C     IRNCT0 = IRNCT0+1
27355 c$$$
27356 c$$$      RETURN
27357 c$$$      END
27358 c$$$
27359 c$$$*$ CREATE DT_RNDMST.FOR
27360 c$$$*COPY DT_RNDMST
27361 c$$$*
27362 c$$$*===rndmst=============================================================*
27363 c$$$*
27364 c$$$      SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27365 c$$$
27366 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27367 c$$$      SAVE
27368 c$$$
27369 c$$$* random number generator
27370 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27371 c$$$
27372 c$$$      MA1 = NA1
27373 c$$$      MA2 = NA2
27374 c$$$      MA3 = NA3
27375 c$$$      MB1 = NB1
27376 c$$$      I   = 97
27377 c$$$      J   = 33
27378 c$$$      DO 20 II2 = 1,97
27379 c$$$        S = 0
27380 c$$$        T = 0.5D0
27381 c$$$        DO 10 II1 = 1,24
27382 c$$$          MAT  = MOD(MOD(MA1*MA2,179)*MA3,179)
27383 c$$$          MA1  = MA2
27384 c$$$          MA2  = MA3
27385 c$$$          MA3  = MAT
27386 c$$$          MB1  = MOD(53*MB1+1,169)
27387 c$$$          IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27388 c$$$   10   T = 0.5D0*T
27389 c$$$   20 U(II2) = S
27390 c$$$      C  =   362436.0D0/16777216.0D0
27391 c$$$      CD =  7654321.0D0/16777216.0D0
27392 c$$$      CM = 16777213.0D0/16777216.0D0
27393 c$$$      RETURN
27394 c$$$      END
27395 c$$$
27396 c$$$*$ CREATE DT_RNDMIN.FOR
27397 c$$$*COPY DT_RNDMIN
27398 c$$$*
27399 c$$$*===rndmin=============================================================*
27400 c$$$*
27401 c$$$      SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27402 c$$$
27403 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27404 c$$$      SAVE
27405 c$$$
27406 c$$$* random number generator
27407 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27408 c$$$
27409 c$$$      DIMENSION UIN(97)
27410 c$$$
27411 c$$$      DO 10 KKK = 1,97
27412 c$$$   10 U(KKK) = UIN(KKK)
27413 c$$$      C  = CIN
27414 c$$$      CD = CDIN
27415 c$$$      CM = CMIN
27416 c$$$      I  = IIN
27417 c$$$      J  = JIN
27418 c$$$
27419 c$$$      RETURN
27420 c$$$      END
27421 c$$$
27422 c$$$*$ CREATE DT_RNDMOU.FOR
27423 c$$$*COPY DT_RNDMOU
27424 c$$$*
27425 c$$$*===rndmou=============================================================*
27426 c$$$*
27427 c$$$      SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
27428 c$$$
27429 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27430 c$$$      SAVE
27431 c$$$
27432 c$$$* random number generator
27433 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27434 c$$$
27435 c$$$      DIMENSION UOUT(97)
27436 c$$$
27437 c$$$      DO 10 KKK = 1,97
27438 c$$$   10 UOUT(KKK) = U(KKK)
27439 c$$$      COUT  = C
27440 c$$$      CDOUT = CD
27441 c$$$      CMOUT = CM
27442 c$$$      IOUT  = I
27443 c$$$      JOUT  = J
27444 c$$$
27445 c$$$      RETURN
27446 c$$$      END
27447 c$$$
27448 c$$$*$ CREATE DT_RNDMTE.FOR
27449 c$$$*COPY DT_RNDMTE
27450 c$$$*
27451 c$$$*===rndmte=============================================================*
27452 c$$$*
27453 c$$$      SUBROUTINE DT_RNDMTE(IO)
27454 c$$$
27455 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27456 c$$$      SAVE
27457 c$$$
27458 c$$$      DIMENSION UU(97),U(6),X(6),D(6)
27459 c$$$      DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27460 c$$$     +8354498.D0, 10633180.D0/
27461 c$$$
27462 c$$$      CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27463 c$$$      CALL DT_RNDMST(12,34,56,78)
27464 c$$$      DO 10 II1 = 1,20000
27465 c$$$   10 XX = DT_RNDM(XX)
27466 c$$$      SD        = 0.0D0
27467 c$$$      DO 20 II2 = 1,6
27468 c$$$        X(II2)  = 4096.D0*(4096.D0*DT_RNDM(SD))
27469 c$$$        D(II2)  = X(II2)-U(II2)
27470 c$$$   20 SD = SD+D(II2)
27471 c$$$      CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27472 c$$$**sr 24.01.95
27473 c$$$C     IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27474 c$$$      IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27475 c$$$C        WRITE(6,1000)
27476 c$$$ 1000    FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27477 c$$$     &          ' passed')
27478 c$$$      ENDIF
27479 c$$$**
27480 c$$$      RETURN
27481 c$$$  500 FORMAT('  === TEST OF THE RANDOM-GENERATOR ===',/,
27482 c$$$     &'    EXPECTED VALUE    CALCULATED VALUE     DIFFERENCE',/, 6(F17.
27483 c$$$     &1,F20.1,F15.3,/), '  === END OF TEST ;',
27484 c$$$     &'  GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27485 c$$$      END
27486 *
27487 *$ CREATE PHO_RNDM.FOR
27488 *COPY PHO_RNDM
27489 *
27490 *===pho_rndm===========================================================*
27491 *
27492       DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27493
27494       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27495       SAVE
27496
27497       PHO_RNDM = DT_RNDM(DUMMY)
27498
27499       RETURN
27500       END
27501
27502 *$ CREATE PYR.FOR
27503 *COPY PYR
27504 *
27505 *===pyr================================================================*
27506 *
27507       DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27508
27509       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27510       SAVE
27511
27512       DUMMY = DBLE(IDUMMY)
27513       PYR = DT_RNDM(DUMMY)
27514
27515       RETURN
27516       END
27517
27518 *$ CREATE DT_TITLE.FOR
27519 *COPY DT_TITLE
27520 *
27521 *===title==============================================================*
27522 *
27523       SUBROUTINE DT_TITLE
27524
27525       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27526       SAVE
27527       PARAMETER ( LINP = 10 ,
27528      &            LOUT = 6 ,
27529      &            LDAT = 9 )
27530
27531       CHARACTER*6 CVERSI
27532       CHARACTER*11 CCHANG
27533       DATA CVERSI,CCHANG /'3.0-5 ','08 Jan 2007'/
27534
27535       CALL DT_XTIME
27536       WRITE(LOUT,1000) CVERSI,CCHANG
27537  1000 FORMAT(1X,'+-------------------------------------------------',
27538      &                  '----------------------+',/,
27539      &     1X,'|',71X,'|',/,
27540      &     1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27541      &     1X,'|',71X,'|',/,
27542      &     1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27543      &     1X,'|',71X,'|',/,
27544      &     1X,'|',12X,'Authors: Stefan Roesler   (CERN)',27X,'|',/,
27545      &     1X,'|',21X,'Ralph Engel      (FZ Karlsruhe)',19X,'|',/,
27546      &     1X,'|',21X,'Johannes Ranft   (Siegen Univ.)',19X,'|',/,
27547      &     1X,'|',71X,'|',/,
27548      &     1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27549      &                                              17X,'|',/,
27550      &     1X,'|',71X,'|',/,
27551      &     1X,'+-------------------------------------------------',
27552      &                '----------------------+',/,
27553      &     1X,'| Please send suggestions, bug reports, etc. to: ',
27554      &                                  'Stefan.Roesler@cern.ch |',/,
27555      &     1X,'+-------------------------------------------------',
27556      &                '----------------------+',/)
27557
27558       RETURN
27559       END
27560
27561 *$ CREATE DT_EVTINI.FOR
27562 *COPY DT_EVTINI
27563 *
27564 *===evtini=============================================================*
27565 *
27566       SUBROUTINE DT_EVTINI
27567
27568 ************************************************************************
27569 * Initialization of DTEVT1.                                            *
27570 * This version dated 15.01.94 is written by S. Roesler                 *
27571 ************************************************************************
27572
27573       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27574       SAVE
27575       PARAMETER ( LINP = 10 ,
27576      &            LOUT = 6 ,
27577      &            LDAT = 9 )
27578
27579 * event history
27580       PARAMETER (NMXHKK=200000)
27581       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27582      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27583      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27584 * extended event history
27585       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27586      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27587      &                IHIST(2,NMXHKK)
27588 * event flag
27589       COMMON /DTEVNO/ NEVENT,ICASCA
27590       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27591 * emulsion treatment
27592       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27593      &                NCOMPO,IEMUL
27594
27595 * initialization of DTEVT1/DTEVT2
27596       NEND = NHKK
27597       IF (NEVENT.EQ.1) NEND = NMXHKK
27598       NHKK   = 0
27599       NEVHKK = NEVENT
27600       DO 1 I=1,NEND
27601          ISTHKK(I)   = 0
27602          IDHKK(I)    = 0
27603          JMOHKK(1,I) = 0
27604          JMOHKK(2,I) = 0
27605          JDAHKK(1,I) = 0
27606          JDAHKK(2,I) = 0
27607          IDRES(I)    = 0
27608          IDXRES(I)   = 0
27609          NOBAM(I)    = 0
27610          IDCH(I)     = 0
27611          IHIST(1,I)  = 0
27612          IHIST(2,I)  = 0
27613          DO 2 J=1,4
27614             PHKK(J,I) = 0.0D0
27615             VHKK(J,I) = 0.0D0
27616             WHKK(J,I) = 0.0D0
27617     2    CONTINUE
27618          PHKK(5,I) = 0.0D0
27619     1 CONTINUE
27620       DO 3 I=1,10
27621          NPOINT(I) = 0
27622     3 CONTINUE
27623       CALL DT_CHASTA(-1)
27624
27625 C* initialization of DTLTRA
27626 C      IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27627
27628       RETURN
27629       END
27630
27631 *$ CREATE DT_STATIS.FOR
27632 *COPY DT_STATIS
27633 *
27634 *===statis=============================================================*
27635 *
27636       SUBROUTINE DT_STATIS(MODE)
27637
27638 ************************************************************************
27639 * Initialization and output of run-statistics.                         *
27640 *              MODE  = 1     initialization                            *
27641 *                    = 2     output                                    *
27642 * This version dated 23.01.94 is written by S. Roesler                 *
27643 ************************************************************************
27644
27645       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27646       SAVE
27647       PARAMETER ( LINP = 10 ,
27648      &            LOUT = 6 ,
27649      &            LDAT = 9 )
27650       PARAMETER (TINY3=1.0D-3)
27651
27652 * statistics
27653       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27654      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27655      &                ICEVTG(8,0:30)
27656 * rejection counter
27657       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27658      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27659      &                IREXCI(3),IRDIFF(2),IRINC
27660 * central particle production, impact parameter biasing
27661       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27662 * various options for treatment of partons (DTUNUC 1.x)
27663 * (chain recombination, Cronin,..)
27664       LOGICAL LCO2CR,LINTPT
27665       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27666      &                LCO2CR,LINTPT
27667 * nucleon-nucleon event-generator
27668       CHARACTER*8 CMODEL
27669       LOGICAL LPHOIN
27670       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27671 * flags for particle decays
27672       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27673      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27674      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27675 * diquark-breaking mechanism
27676       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27677
27678       DIMENSION PP(4),PT(4)
27679
27680       GOTO (1,2) MODE
27681
27682 * initialization
27683     1 CONTINUE
27684
27685 *   initialize statistics counter
27686       ICREQU = 0
27687       ICSAMP = 0
27688       ICCPRO = 0
27689       ICDPR  = 0
27690       ICDTA  = 0
27691       ICRJSS = 0
27692       ICVV2S = 0
27693       DO 10 I=1,9
27694          ICRES(I)    = 0
27695          ICCHAI(1,I) = 0
27696          ICCHAI(2,I) = 0
27697    10 CONTINUE
27698 *   initialize rejection counter
27699       IRPT      = 0
27700       IRHHA     = 0
27701       LOMRES    = 0
27702       LOBRES    = 0
27703       IRFRAG    = 0
27704       IREVT     = 0
27705       IRRES(1)  = 0
27706       IRRES(2)  = 0
27707       IRCHKI(1) = 0
27708       IRCHKI(2) = 0
27709       IRCRON(1) = 0
27710       IRCRON(2) = 0
27711       IRCRON(3) = 0
27712       IRDIFF(1) = 0
27713       IRDIFF(2) = 0
27714       IRINC     = 0
27715       DO 11 I=1,5
27716          ICDIFF(I) = 0
27717    11 CONTINUE
27718       DO 12 I=1,8
27719          DO 13 J=0,30
27720             ICEVTG(I,J) = 0
27721    13    CONTINUE
27722    12 CONTINUE
27723
27724       RETURN
27725
27726 * output
27727     2 CONTINUE
27728
27729 *   statistics counter
27730       WRITE(LOUT,1000)
27731  1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27732      &       28X,'---------------------')
27733       IF (ICREQU.GT.0) THEN
27734       WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27735  1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27736      &       I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27737      &       'event',11X,F9.1)
27738       ENDIF
27739       IF (ICDIFF(1).NE.0) THEN
27740          WRITE(LOUT,1009) ICDIFF
27741  1009    FORMAT(/,1X,'diffractive events:    total   ',I8,/,49X,
27742      &          'low mass   high mass',/,24X,'single diffraction',
27743      &          7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27744       ENDIF
27745       IF (ICENTR.GT.0.AND.ICSAMP.GT.0.AND.ICCPRO.GT.0) THEN
27746          WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27747      &                    DBLE(ICSAMP)/DBLE(ICCPRO)
27748  1002    FORMAT(/,1X,'central production:',/,2X,'mean number',
27749      &          ' of sampled Glauber-events per event',9X,F9.1,/,
27750      &          2X,'fraction of production cross section',21X,F10.6)
27751       ENDIF
27752       IF (ICSAMP.GT.0) THEN
27753       WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27754      &                 DBLE(ICDTA)/DBLE(ICSAMP)
27755  1003 FORMAT(/,54X,'proj.    targ.',/,1X,'average number of wounded',
27756      &       ' nucleons after x-sampling',2(4X,F6.2))
27757       ENDIF
27758
27759       IF (MCGENE.EQ.1) THEN
27760          IF (ICSAMP.GT.0) THEN
27761          WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27762  1004    FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27763      &          ' event',3X,F9.1)
27764          IF (ISICHA.EQ.1) THEN
27765             WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27766  1005       FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27767      &             'of single chains  per event',13X,F9.1)
27768          ENDIF
27769          ENDIF
27770          IF (ICSAMP.GT.0.AND.ICREQU.GT.0) THEN
27771          WRITE(LOUT,1006)
27772  1006    FORMAT(/,1X,'chain system statistics:  (per event)',/,
27773      &       23X,'mean number of chains      mean number of chains',/,
27774      &       23X,'sampled    hadronized      having mass of a reso.')
27775          WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27776      &                     DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27777      &                     DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27778      &                  DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27779  1007    FORMAT(1X,'sea     - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27780      &          1X,'disea   - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27781      &          1X,'sea     - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27782      &          1X,'sea     - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27783      &          1X,'disea   - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27784      &          1X,'valence - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27785      &          1X,'valence - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27786      &          1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27787      &          1X,'fused chains      ',18X,F4.1,17X,F4.1,/)
27788          WRITE(LOUT,1008)
27789      &     (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27790      &     DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27791      &     DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27792      &     (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27793      &     (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27794      &     DBLE(IRHHA)/DBLE(ICREQU),
27795      &     DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27796      &     (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27797  1008    FORMAT(/,1X,'Rejection counter:  (NEVT = no. of events)',/,/,
27798      &       1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27799      &       F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27800      &       'Intrins. p_t (GETSPT)',21X,'IRPT     /NEVT = ',F7.2,/,
27801      &       1X,'Chain mass corr. for resonances (EVTRES)',2X,
27802      &       'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES)  IRRES(2) /',
27803      &       'NEVT = ',F7.2,/,43X,'LOMRES   /NEVT = ',F7.2,/,
27804      &       43X,'LOBRES   /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27805      &       ' 2-chain systems (CHKINE)  IRCHKI(1)/NEVT = ',F7.2,/,
27806      &       43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27807      &       'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27808      &       F7.2,/,1X,'Total no. of rej.',
27809      &       ' in chain-systems treatment (GETCSY)',/,43X,
27810      &       'IRHHA    /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27811      &       ' (not yet used!)',4X,'IRFRAG   /NEVT = ',F7.2,/,
27812      &       1X,'Total no. of rej. in DPM-treatment of one event',
27813      &       ' (EVENTA)',/,43X,'IREVT    /NEVT = ',F7.2,/,1X,
27814      &       'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27815      &       ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27816      &       'IREXCI(3) = ',I5,/)
27817          ENDIF
27818       ELSEIF (MCGENE.EQ.2) THEN
27819          WRITE(LOUT,1010) ELOJET
27820  1010    FORMAT(/,/,1X,'PHOJET-treatment of chain systems above  ',
27821      &          F4.1,' GeV')
27822          WRITE(LOUT,1011)
27823  1011    FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27824      &          30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27825      &          5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27826          WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27827      &                    (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27828      &                    (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27829      &                    ((ICEVTG(I,J),I=1,8),J=3,7),
27830      &                    ((ICEVTG(I,J),I=1,8),J=19,21),
27831      &                    (ICEVTG(I,8),I=1,8),
27832      &                    ((ICEVTG(I,J),I=1,8),J=22,24),
27833      &                    (ICEVTG(I,9),I=1,8),
27834      &                    ((ICEVTG(I,J),I=1,8),J=25,28),
27835      &                    ((ICEVTG(I,J),I=1,8),J=10,18)
27836  1012    FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27837      &          8I8,/,/,1X,'PHOJET ',8I8,/,'   sngl ',8I8,/,/,
27838      &          ' no-dif.',8I8,/,
27839      &          ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27840      &          ' diff-1 ',8I8,/,'  low   ',8I8,/,'  high  ',8I8,/,
27841      &          '  h-diff',8I8,/,' diff-2 ',8I8,/,'  low   ',8I8,/,
27842      &          '  high  ',8I8,/,'  h-diff',8I8,/,' dbl-di.',8I8,/,
27843      &          '  lo-lo ',8I8,/,'  hi-hi ',8I8,/,'  lo-hi ',8I8,/,
27844      &          '  hi-lo ',8I8,/,
27845      &          ' dir-ga.',8I8,/,/,' dir-1  ',8I8,/,' dir-2  ',8I8,/,
27846      &          ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27847      &          ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27848          WRITE(LOUT,1013)
27849  1013    FORMAT(/,1X,'2. chain system statistics -',
27850      &          ' mean numbers per evt:',/,30X,'---------------------',
27851      &          /,/,16X,'s-s',7X,'d-s',7X,'s-d')
27852          IF (ICSAMP.GT.0) THEN
27853          WRITE(LOUT,1014)
27854      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27855      &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27856      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27857  1014    FORMAT(/,1X,'req.to.    ',3E10.2,/,/,1X,'low rq.    ',3E10.2,/,
27858      &          1X,'low ac.    ',3E10.2,/,/,1X,'PHOJET     ',3E10.2,/,/,
27859      &          ' no-dif.    ',3E10.2,/,' el-sca.    ',3E10.2,/,
27860      &          ' qel-sc.    ',3E10.2,/,' dbl-Po.    ',3E10.2,/,
27861      &          ' diff-1     ',3E10.2,/,' diff-2     ',3E10.2,/,
27862      &          ' dbl-di.    ',3E10.2,/,' dir-ga.    ',3E10.2,/,/,
27863      &          ' dir-1      ',3E10.2,/,' dir-2      ',3E10.2,/,
27864      &          ' dbl-dir    ',3E10.2,/,' s-Pom.     ',3E10.2,/,
27865      &          ' h-Pom.     ',3E10.2,/,' s-Reg.     ',3E10.2,/,
27866      &          ' enh-trg    ',3E10.2,/,' enh-log    ',3E10.2)
27867          ENDIF
27868          WRITE(LOUT,1015)
27869  1015    FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
27870          IF (ICSAMP.GT.0) THEN
27871          WRITE(LOUT,1016)
27872      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27873      &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27874      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27875  1016    FORMAT(/,1X,'req.to.    ',5E10.2,/,/,1X,'low rq.    ',5E10.2,/,
27876      &          1X,'low ac.    ',5E10.2,/,/,1X,'PHOJET     ',5E10.2,/,/,
27877      &          ' no-dif.    ',5E10.2,/,' el-sca.    ',5E10.2,/,
27878      &          ' qel-sc.    ',5E10.2,/,' dbl-Po.    ',5E10.2,/,
27879      &          ' diff-1     ',5E10.2,/,' diff-2     ',5E10.2,/,
27880      &          ' dbl-di.    ',5E10.2,/,' dir-ga.    ',5E10.2,/,/,
27881      &          ' dir-1      ',5E10.2,/,' dir-2      ',5E10.2,/,
27882      &          ' dbl-dir    ',5E10.2,/,' s-Pom.     ',5E10.2,/,
27883      &          ' h-Pom.     ',5E10.2,/,' s-Reg.     ',5E10.2,/,
27884      &          ' enh-trg    ',5E10.2,/,' enh-log    ',5E10.2)
27885          ENDIF
27886
27887       ENDIF
27888       CALL DT_CHASTA(1)
27889
27890       IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27891      &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
27892          WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27893      &    DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27894      &    DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27895          WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27896      &    DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27897      &    DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27898          WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27899      &    DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27900      &    DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27901          WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27902      &    DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27903      &    DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27904          WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27905      &    DBRKA(3,1),DBRKA(3,2),
27906      &    DBRKA(3,3),DBRKA(3,4)
27907          WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27908      &    DBRKR(3,1),DBRKR(3,2),
27909      &    DBRKR(3,3),DBRKR(3,4)
27910          WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27911      &    DBRKA(3,5),DBRKA(3,6),
27912      &    DBRKA(3,7),DBRKA(3,8)
27913          WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27914      &    DBRKR(3,5),DBRKR(3,6),
27915      &    DBRKR(3,7),DBRKR(3,8)
27916       ENDIF
27917
27918       FAC = 1.0D0
27919       IF (MCGENE.EQ.2) THEN
27920 C        CALL PHO_PHIST(-2,SIGMAX)
27921          CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27922       ENDIF
27923
27924       CALL DT_XTIME
27925
27926       RETURN
27927       END
27928
27929 *$ CREATE DT_EVTOUT.FOR
27930 *COPY DT_EVTOUT
27931 *
27932 *===evtout=============================================================*
27933 *
27934       SUBROUTINE DT_EVTOUT(MODE)
27935
27936 ************************************************************************
27937 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
27938 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
27939 *                    4  plot entries of DTEVT1 and DTEVT2              *
27940 * This version dated 11.12.94 is written by S. Roesler                 *
27941 ************************************************************************
27942
27943       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27944       SAVE
27945       PARAMETER ( LINP = 10 ,
27946      &            LOUT = 6 ,
27947      &            LDAT = 9 )
27948 * event history
27949       PARAMETER (NMXHKK=200000)
27950       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27951      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27952      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27953
27954       DIMENSION IRANGE(NMXHKK)
27955
27956       IF (MODE.EQ.2) RETURN
27957
27958       CALL DT_EVTPLO(IRANGE,MODE)
27959
27960       RETURN
27961       END
27962
27963 *$ CREATE DT_EVTPLO.FOR
27964 *COPY DT_EVTPLO
27965 *
27966 *===evtplo=============================================================*
27967 *
27968       SUBROUTINE DT_EVTPLO(IRANGE,MODE)
27969
27970 ************************************************************************
27971 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
27972 *                    2  plot entries of DTEVT1 given by IRANGE         *
27973 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
27974 *                    4  plot entries of DTEVT1 and DTEVT2              *
27975 *                    5  plot rejection counter                         *
27976 * This version dated 11.12.94 is written by S. Roesler                 *
27977 ************************************************************************
27978
27979       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27980       SAVE
27981       PARAMETER ( LINP = 10 ,
27982      &            LOUT = 6 ,
27983      &            LDAT = 9 )
27984
27985       CHARACTER*16 CHAU
27986
27987 * event history
27988       PARAMETER (NMXHKK=200000)
27989       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27990      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27991      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27992 * extended event history
27993       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27994      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27995      &                IHIST(2,NMXHKK)
27996 * rejection counter
27997       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27998      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27999      &                IREXCI(3),IRDIFF(2),IRINC
28000
28001       DIMENSION IRANGE(NMXHKK)
28002
28003       IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
28004          WRITE(LOUT,1000)
28005  1000    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTEVT1/',/,
28006      &         15X,'           --------------------------',/,/,
28007      &             '       ST    ID  M1   M2   D1   D2     PX     PY',
28008      &             '     PZ      E       M',/)
28009          DO 1 I=1,NHKK
28010             WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28011      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28012      &                       PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28013      &                       PHKK(5,I)
28014 C           WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28015 C    &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28016 C    &                       PHKK(3,I),PHKK(4,I)
28017 C           WRITE(LOUT,'(4E15.4)')
28018 C    &         VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
28019  1001       FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
28020  1011       FORMAT(I5,I5,I6,4I5,2E15.5)
28021     1    CONTINUE
28022          WRITE(LOUT,*)
28023 C        DO 4 I=1,NHKK
28024 C           WRITE(LOUT,1006) I,ISTHKK(I),
28025 C    &                    VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
28026 C    &                    WHKK(2,I),WHKK(3,I)
28027 C1006       FORMAT(1X,I4,I6,6E10.3)
28028 C   4    CONTINUE
28029       ENDIF
28030
28031       IF (MODE.EQ.2) THEN
28032          WRITE(LOUT,1000)
28033          NC = 0
28034     2    CONTINUE
28035          NC = NC+1
28036          IF (IRANGE(NC).EQ.-100) GOTO 9999
28037          I = IRANGE(NC)
28038          WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28039      &                    JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28040      &                    PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28041      &                    PHKK(5,I)
28042          GOTO 2
28043       ENDIF
28044
28045       IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
28046          WRITE(LOUT,1002)
28047  1002    FORMAT(/,1X,'EVTPLO:',14X,
28048      &         ' content of COMMON /DTEVT1/,/DTEVT2/',/,
28049      &         15X,'        -----------------------------------',/,/,
28050      &             '       ST    ID   M1   M2   D1   D2  IDR  IDXR',
28051      &             ' NOBAM IDCH    M',/)
28052          DO 3 I=1,NHKK
28053 C           IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
28054                KF    = IDHKK(I)
28055                IDCHK = KF/10000
28056                IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28057      &            (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
28058                CALL PYNAME(KF,CHAU)
28059                WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28060      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28061      &                       IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
28062      &                       PHKK(5,I),CHAU
28063  1003          FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
28064 C           ENDIF
28065     3    CONTINUE
28066       ENDIF
28067
28068       IF (MODE.EQ.5) THEN
28069          WRITE(LOUT,1004)
28070  1004    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTREJC/',/,
28071      &         15X,'           --------------------------',/)
28072          WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
28073      &                    IRSEA,IRCRON
28074  1005    FORMAT(1X,'IRPT   = ',I5,'  IRHHA = ',I5,/,
28075      &          1X,'IRRES  = ',2I5,'  LOMRES = ',I5,'  LOBRES = ',I5,/,
28076      &          1X,'IREMC  = ',10I5,/,
28077      &          1X,'IRFRAG = ',I5,'  IRSEA = ',I5,' IRCRON = ',I5,/)
28078       ENDIF
28079
28080  9999 RETURN
28081       END
28082
28083 *$ CREATE DT_EVTPUT.FOR
28084 *COPY DT_EVTPUT
28085 *
28086 *===evtput=============================================================*
28087 *
28088       SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
28089
28090       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28091       SAVE
28092       PARAMETER ( LINP = 10 ,
28093      &            LOUT = 6 ,
28094      &            LDAT = 9 )
28095       PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
28096      &           TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
28097
28098 * event history
28099       PARAMETER (NMXHKK=200000)
28100       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28101      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28102      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28103 * extended event history
28104       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28105      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28106      &                IHIST(2,NMXHKK)
28107 * Lorentz-parameters of the current interaction
28108       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28109      &                UMO,PPCM,EPROJ,PPROJ
28110 * particle properties (BAMJET index convention)
28111       CHARACTER*8  ANAME
28112       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28113      &                IICH(210),IIBAR(210),K1(210),K2(210)
28114
28115 C     IF (MODE.GT.100) THEN
28116 C        WRITE(LOUT,'(1X,A,I5,A,I5)')
28117 C    &        'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
28118 C        NHKK = NHKK-MODE+100
28119 C        RETURN
28120 C     ENDIF
28121       MO1  = M1
28122       MO2  = M2
28123       NHKK = NHKK+1
28124
28125       IF (NHKK.GT.NMXHKK) THEN
28126          WRITE(LOUT,1000) NHKK
28127  1000    FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
28128      &             '! program execution stopped..')
28129          STOP
28130       ENDIF
28131       IF (M1.LT.0) MO1 = NHKK+M1
28132       IF (M2.LT.0) MO2 = NHKK+M2
28133       ISTHKK(NHKK)   = IST
28134       IDHKK(NHKK)    = ID
28135       JMOHKK(1,NHKK) = MO1
28136       JMOHKK(2,NHKK) = MO2
28137       JDAHKK(1,NHKK) = 0
28138       JDAHKK(2,NHKK) = 0
28139       IDRES(NHKK)    = IDR
28140       IDXRES(NHKK)   = IDXR
28141       IDCH(NHKK)     = IDC
28142 ** here we need to do something..
28143       IF (ID.EQ.88888) THEN
28144          IDMO1 = ABS(IDHKK(MO1))
28145          IDMO2 = ABS(IDHKK(MO2))
28146          IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
28147          IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
28148          IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
28149          IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
28150       ELSE
28151          NOBAM(NHKK) = 0
28152       ENDIF
28153       IDBAM(NHKK) = IDT_ICIHAD(ID)
28154       IF (MO1.GT.0) THEN
28155          IF (JDAHKK(1,MO1).NE.0) THEN
28156             JDAHKK(2,MO1) = NHKK
28157          ELSE
28158             JDAHKK(1,MO1) = NHKK
28159          ENDIF
28160       ENDIF
28161       IF (MO2.GT.0) THEN
28162          IF (JDAHKK(1,MO2).NE.0) THEN
28163             JDAHKK(2,MO2) = NHKK
28164          ELSE
28165             JDAHKK(1,MO2) = NHKK
28166          ENDIF
28167       ENDIF
28168 C      IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
28169 C         PTOT   = SQRT(PX**2+PY**2+PZ**2)
28170 C         AM0    = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
28171 C         AMRQ   = AAM(IDBAM(NHKK))
28172 C         AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
28173 C         IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
28174 C     &       (PTOT.GT.ZERO)) THEN
28175 C            DELTA = -AMDIF2/(2.0D0*(E+PTOT))
28176 CC           DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
28177 C            E     = E+DELTA
28178 C            PTOT1 = PTOT-DELTA
28179 C            PX    = PX*PTOT1/PTOT
28180 C            PY    = PY*PTOT1/PTOT
28181 C            PZ    = PZ*PTOT1/PTOT
28182 C         ENDIF
28183 C      ENDIF
28184       PHKK(1,NHKK) = PX
28185       PHKK(2,NHKK) = PY
28186       PHKK(3,NHKK) = PZ
28187       PHKK(4,NHKK) = E
28188       PTOT = SQRT( PX**2+PY**2+PZ**2 )
28189       IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
28190          PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
28191          PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
28192       ELSE
28193          PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
28194 C        IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
28195 C    &      WRITE(LOUT,'(1X,A,G10.3)')
28196 C    &        'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
28197          PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
28198       ENDIF
28199       IDCHK = ID/10000
28200       IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
28201 * special treatment for chains:
28202 *    z coordinate of chain in Lab  = pos. of target nucleon
28203 *    time of chain-creation in Lab = time of passage of projectile
28204 *                                    nucleus at pos. of taget nucleus
28205 C        VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
28206 C        VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
28207          VHKK(1,NHKK) = VHKK(1,MO2)
28208          VHKK(2,NHKK) = VHKK(2,MO2)
28209          VHKK(3,NHKK) = VHKK(3,MO2)
28210          VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
28211 C        WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
28212 C        WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
28213          WHKK(1,NHKK) = WHKK(1,MO1)
28214          WHKK(2,NHKK) = WHKK(2,MO1)
28215          WHKK(3,NHKK) = WHKK(3,MO1)
28216          WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
28217       ELSE
28218          IF (MO1.GT.0) THEN
28219             DO 1 I=1,4
28220                VHKK(I,NHKK) = VHKK(I,MO1)
28221                WHKK(I,NHKK) = WHKK(I,MO1)
28222     1       CONTINUE
28223          ELSE
28224             DO 2 I=1,4
28225                VHKK(I,NHKK) = ZERO
28226                WHKK(I,NHKK) = ZERO
28227     2       CONTINUE
28228          ENDIF
28229       ENDIF
28230
28231       RETURN
28232       END
28233
28234 *$ CREATE DT_CHASTA.FOR
28235 *COPY DT_CHASTA
28236 *
28237 *===chasta=============================================================*
28238 *
28239       SUBROUTINE DT_CHASTA(MODE)
28240
28241 ************************************************************************
28242 * This subroutine performs CHAin STAtistics and checks sequence of     *
28243 * partons in dtevt1 and sorts them with projectile partons coming      *
28244 * first if necessary.                                                  *
28245 *                                                                      *
28246 * This version dated  8.5.00  is written by S. Roesler.                *
28247 ************************************************************************
28248
28249       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28250       SAVE
28251       PARAMETER ( LINP = 10 ,
28252      &            LOUT = 6 ,
28253      &            LDAT = 9 )
28254
28255       CHARACTER*5 CCHTYP
28256
28257 * event history
28258       PARAMETER (NMXHKK=200000)
28259       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28260      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28261      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28262 * extended event history
28263       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28264      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28265      &                IHIST(2,NMXHKK)
28266 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28267       PARAMETER (MAXCHN=10000)
28268       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28269
28270       DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28271      &          CCHTYP(9),ICHSTA(10),ITOT(10)
28272       DATA ICHCFG /1800*0/
28273       DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28274       DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28275       DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28276       DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28277       DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28278       DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28279       DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28280      &              'ad aq',' d ad','ad d ',' g g '/
28281 *
28282 * initialization
28283 *
28284       IF (MODE.EQ.-1) THEN
28285          NCHAIN = 0
28286 *
28287 * loop over DTEVT1 and analyse chain configurations
28288 *
28289       ELSEIF (MODE.EQ.0) THEN
28290          DO 21 IDX=NPOINT(3),NHKK
28291             IDCHK = IDHKK(IDX)/10000
28292             IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28293      &          (IDHKK(IDX).NE.80000).AND.
28294      &          (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28295                IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28296                   WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28297      &                          ' at entry ',IDX
28298                   GOTO 21
28299                ENDIF
28300 *
28301                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28302                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28303                IMO1 = IST1/10
28304                IMO1 = IST1-10*IMO1
28305                IMO2 = IST2/10
28306                IMO2 = IST2-10*IMO2
28307 *   swop parton entries if necessary since we need projectile partons
28308 *   to come first in the common
28309                IF (IMO1.GT.IMO2) THEN
28310                   NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28311                   DO 22 K=1,NPTN/2
28312                      I0 = JMOHKK(1,IDX)-1+K
28313                      I1 = JMOHKK(2,IDX)+1-K
28314                      ITMP = ISTHKK(I0)
28315                      ISTHKK(I0) = ISTHKK(I1)
28316                      ISTHKK(I1) = ITMP
28317                      ITMP = IDHKK(I0)
28318                      IDHKK(I0) = IDHKK(I1)
28319                      IDHKK(I1) = ITMP
28320                      IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28321      &                  JDAHKK(1,JMOHKK(1,I0)) = I1
28322                      IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28323      &                  JDAHKK(2,JMOHKK(1,I0)) = I1
28324                      IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28325      &                  JDAHKK(1,JMOHKK(2,I0)) = I1
28326                      IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28327      &                  JDAHKK(2,JMOHKK(2,I0)) = I1
28328                      IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28329      &                  JDAHKK(1,JMOHKK(1,I1)) = I0
28330                      IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28331      &                  JDAHKK(2,JMOHKK(1,I1)) = I0
28332                      IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28333      &                  JDAHKK(1,JMOHKK(2,I1)) = I0
28334                      IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28335      &                  JDAHKK(2,JMOHKK(2,I1)) = I0
28336                      ITMP = JMOHKK(1,I0)
28337                      JMOHKK(1,I0) = JMOHKK(1,I1)
28338                      JMOHKK(1,I1) = ITMP
28339                      ITMP = JMOHKK(2,I0)
28340                      JMOHKK(2,I0) = JMOHKK(2,I1)
28341                      JMOHKK(2,I1) = ITMP
28342                      ITMP = JDAHKK(1,I0)
28343                      JDAHKK(1,I0) = JDAHKK(1,I1)
28344                      JDAHKK(1,I1) = ITMP
28345                      ITMP = JDAHKK(2,I0)
28346                      JDAHKK(2,I0) = JDAHKK(2,I1)
28347                      JDAHKK(2,I1) = ITMP
28348                      DO 23 J=1,4
28349                         RTMP1 = PHKK(J,I0)
28350                         RTMP2 = VHKK(J,I0)
28351                         RTMP3 = WHKK(J,I0)
28352                         PHKK(J,I0) = PHKK(J,I1)
28353                         VHKK(J,I0) = VHKK(J,I1)
28354                         WHKK(J,I0) = WHKK(J,I1)
28355                         PHKK(J,I1) = RTMP1
28356                         VHKK(J,I1) = RTMP2
28357                         WHKK(J,I1) = RTMP3
28358    23                CONTINUE
28359                      RTMP1 = PHKK(5,I0)
28360                      PHKK(5,I0) = PHKK(5,I1)
28361                      PHKK(5,I1) = RTMP1
28362                      ITMP = IDRES(I0)
28363                      IDRES(I0) = IDRES(I1)
28364                      IDRES(I1) = ITMP
28365                      ITMP = IDXRES(I0)
28366                      IDXRES(I0) = IDXRES(I1)
28367                      IDXRES(I1) = ITMP
28368                      ITMP = NOBAM(I0)
28369                      NOBAM(I0) = NOBAM(I1)
28370                      NOBAM(I1) = ITMP
28371                      ITMP = IDBAM(I0)
28372                      IDBAM(I0) = IDBAM(I1)
28373                      IDBAM(I1) = ITMP
28374                      ITMP = IDCH(I0)
28375                      IDCH(I0) = IDCH(I1)
28376                      IDCH(I1) = ITMP
28377                      ITMP = IHIST(1,I0)
28378                      IHIST(1,I0) = IHIST(1,I1)
28379                      IHIST(1,I1) = ITMP
28380                      ITMP = IHIST(2,I0)
28381                      IHIST(2,I0) = IHIST(2,I1)
28382                      IHIST(2,I1) = ITMP
28383    22             CONTINUE
28384                ENDIF
28385                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28386                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28387 *
28388 *   parton 1 (projectile side)
28389                IF (IST1.EQ.21) THEN
28390                   IDX1 = 1
28391                ELSEIF (IST1.EQ.22) THEN
28392                   IDX1 = 2
28393                ELSEIF (IST1.EQ.31) THEN
28394                   IDX1 = 3
28395                ELSEIF (IST1.EQ.32) THEN
28396                   IDX1 = 4
28397                ELSEIF (IST1.EQ.41) THEN
28398                   IDX1 = 5
28399                ELSEIF (IST1.EQ.42) THEN
28400                   IDX1 = 6
28401                ELSEIF (IST1.EQ.51) THEN
28402                   IDX1 = 7
28403                ELSEIF (IST1.EQ.52) THEN
28404                   IDX1 = 8
28405                ELSEIF (IST1.EQ.61) THEN
28406                   IDX1 = 9
28407                ELSEIF (IST1.EQ.62) THEN
28408                   IDX1 = 10
28409                ELSE
28410 c                 WRITE(LOUT,*)
28411 c    &               ' CHASTA: unknown parton status flag (',
28412 c    &               IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28413                   GOTO 21
28414                ENDIF
28415                ID = IDHKK(JMOHKK(1,IDX))
28416                IF (ABS(ID).LE.4) THEN
28417                   IF (ID.GT.0) THEN
28418                      ITYP1 = 1
28419                   ELSE
28420                      ITYP1 = 2
28421                   ENDIF
28422                ELSEIF (ABS(ID).GE.1000) THEN
28423                   IF (ID.GT.0) THEN
28424                      ITYP1 = 3
28425                   ELSE
28426                      ITYP1 = 4
28427                   ENDIF
28428                ELSEIF (ID.EQ.21) THEN
28429                   ITYP1 = 5
28430                ELSE
28431                   WRITE(LOUT,*)
28432      &               ' CHASTA: inconsistent parton identity (',
28433      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28434                   GOTO 21
28435                ENDIF
28436 *
28437 *   parton 2 (target side)
28438                IF (IST2.EQ.21) THEN
28439                   IDX2 = 1
28440                ELSEIF (IST2.EQ.22) THEN
28441                   IDX2 = 2
28442                ELSEIF (IST2.EQ.31) THEN
28443                   IDX2 = 3
28444                ELSEIF (IST2.EQ.32) THEN
28445                   IDX2 = 4
28446                ELSEIF (IST2.EQ.41) THEN
28447                   IDX2 = 5
28448                ELSEIF (IST2.EQ.42) THEN
28449                   IDX2 = 6
28450                ELSEIF (IST2.EQ.51) THEN
28451                   IDX2 = 7
28452                ELSEIF (IST2.EQ.52) THEN
28453                   IDX2 = 8
28454                ELSEIF (IST2.EQ.61) THEN
28455                   IDX2 = 9
28456                ELSEIF (IST2.EQ.62) THEN
28457                   IDX2 = 10
28458                ELSE
28459 c                 WRITE(LOUT,*)
28460 c    &               ' CHASTA: unknown parton status flag (',
28461 c    &               IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28462                   GOTO 21
28463                ENDIF
28464                ID = IDHKK(JMOHKK(2,IDX))
28465                IF (ABS(ID).LE.4) THEN
28466                   IF (ID.GT.0) THEN
28467                      ITYP2 = 1
28468                   ELSE
28469                      ITYP2 = 2
28470                   ENDIF
28471                ELSEIF (ABS(ID).GE.1000) THEN
28472                   IF (ID.GT.0) THEN
28473                      ITYP2 = 3
28474                   ELSE
28475                      ITYP2 = 4
28476                   ENDIF
28477                ELSEIF (ID.EQ.21) THEN
28478                   ITYP2 = 5
28479                ELSE
28480                   WRITE(LOUT,*)
28481      &               ' CHASTA: inconsistent parton identity (',
28482      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28483                   GOTO 21
28484                ENDIF
28485 *
28486 *   fill counter
28487                ITYPE = ICHTYP(ITYP1,ITYP2)
28488                IF (ITYPE.NE.0) THEN
28489                   ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28490                   NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28491                   ICHCFG(IDX1,IDX2,ITYPE,2) =
28492      &               ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28493
28494                   NCHAIN = NCHAIN+1
28495                   IF (NCHAIN.GT.MAXCHN) THEN
28496                      WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28497      &                  NCHAIN,MAXCHN
28498                      STOP
28499                   ENDIF
28500                   IDXCHN(1,NCHAIN) = IDX
28501                   IDXCHN(2,NCHAIN) = ITYPE
28502                ELSE
28503                   WRITE(LOUT,*)
28504      &               ' CHASTA: inconsistent chain at entry ',IDX
28505                   GOTO 21
28506                ENDIF
28507             ENDIF
28508    21    CONTINUE
28509 *
28510 * write statistics to output unit
28511 *
28512       ELSEIF (MODE.EQ.1) THEN
28513          WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28514          DO 31 I=1,10
28515             WRITE(LOUT,'(/,2A)')
28516      &         ' -----------------------------------------',
28517      &         '------------------------------------'
28518             WRITE(LOUT,'(2A)')
28519      &         ' p\\t         21     22     31     32     41',
28520      &         '     42     51     52     61     62'
28521             WRITE(LOUT,'(2A)')
28522      &         ' -----------------------------------------',
28523      &         '------------------------------------'
28524             DO 32 J=1,10
28525                ITOT(J) = 0
28526                DO 33 K=1,9
28527                   ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28528    33          CONTINUE
28529    32       CONTINUE
28530             WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28531             DO 34 K=1,9
28532                ISUM = 0
28533                DO 35 J=1,10
28534                   ISUM = ISUM+ICHCFG(I,J,K,1)
28535    35          CONTINUE
28536                IF (ISUM.GT.0)
28537      &            WRITE(LOUT,'(1X,A5,2X,10I7)')
28538      &               CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28539    34       CONTINUE
28540 C           WRITE(LOUT,'(2A)')
28541 C    &         ' -----------------------------------------',
28542 C    &         '-------------------------------'
28543    31    CONTINUE
28544 *
28545       ELSE
28546          WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28547          STOP
28548       ENDIF
28549
28550       RETURN
28551       END
28552 *$ CREATE PHO_PHIST.FOR
28553 *COPY PHO_PHIST
28554 *
28555 *===pohist=============================================================*
28556 *
28557       SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28558
28559       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28560       SAVE
28561
28562       PARAMETER ( LINP = 10 ,
28563      &            LOUT = 6 ,
28564      &            LDAT = 9 )
28565       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28566 * Glauber formalism: cross sections
28567       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28568      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28569      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28570      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28571      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28572      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28573      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28574      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28575      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28576      &                BSLOPE,NEBINI,NQBINI
28577
28578       ILAB = 0
28579       IF (IMODE.EQ.10) THEN
28580          IMODE = 1
28581          ILAB  = 1
28582       ENDIF
28583       IF (ABS(IMODE).LT.1000) THEN
28584 * PHOJET-statistics
28585 C        CALL POHISX(IMODE,WEIGHT)
28586          IF (IMODE.EQ.-1) THEN
28587             MODE = 1
28588             XSTOT(1,1,1) = WEIGHT
28589          ENDIF
28590          IF (IMODE.EQ. 1) MODE = 2
28591          IF (IMODE.EQ.-2) MODE = 3
28592          IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28593 C        IF (MODE.EQ.3) WRITE(LOUT,*)
28594 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
28595          CALL DT_HISTOG(MODE)
28596          CALL DT_USRHIS(MODE)
28597       ELSE
28598 * DTUNUC-statistics
28599          MODE = IMODE/1000
28600 C        IF (MODE.EQ.3) WRITE(LOUT,*)
28601 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
28602          CALL DT_HISTOG(MODE)
28603          CALL DT_USRHIS(MODE)
28604       ENDIF
28605
28606       RETURN
28607       END
28608
28609 *$ CREATE DT_SWPPHO.FOR
28610 *COPY DT_SWPPHO
28611 *
28612 *===swppho=============================================================*
28613 *
28614       SUBROUTINE DT_SWPPHO(ILAB)
28615
28616       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28617       SAVE
28618       PARAMETER ( LINP = 10 ,
28619      &            LOUT = 6 ,
28620      &            LDAT = 9 )
28621       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28622
28623       LOGICAL LSTART
28624
28625 * event history
28626       PARAMETER (NMXHKK=200000)
28627       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28628      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28629      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28630 * extended event history
28631       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28632      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28633      &                IHIST(2,NMXHKK)
28634 * flags for input different options
28635       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28636       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28637      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28638 * properties of photon/lepton projectiles
28639       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28640
28641 **PHOJET105a
28642 C     PARAMETER (NMXHEP=2000)
28643 C     COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28644 C    &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28645 C     COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28646 C     COMMON /PLASAV/ PLAB
28647 **PHOJET110
28648 C  standard particle data interface
28649       INTEGER NMXHEP
28650       PARAMETER (NMXHEP=4000)
28651       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28652       DOUBLE PRECISION PHEP,VHEP
28653       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28654      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28655      &                VHEP(4,NMXHEP)
28656 C  extension to standard particle data interface (PHOJET specific)
28657       INTEGER IMPART,IPHIST,ICOLOR
28658       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28659 C  global event kinematics and particle IDs
28660       INTEGER IFPAP,IFPAB
28661       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28662       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28663 **
28664       DATA ICOUNT/0/
28665
28666       DATA LSTART /.TRUE./
28667
28668 C     IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28669       IF ((IFRAME.EQ.1).AND.LSTART) THEN
28670          UMO  = ECM
28671          ELA  = ZERO
28672          PLA  = ZERO
28673          IDP  = IDT_ICIHAD(IFPAP(1))
28674          IDT  = IDT_ICIHAD(IFPAP(2))
28675          VIRT = PVIRT(1)
28676          CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28677          PLAB = PLA
28678          LSTART = .FALSE.
28679       ENDIF
28680
28681       NHKK   = 0
28682       ICOUNT = ICOUNT+1
28683 C     NEVHKK = NEVHEP
28684       NEVHKK = ICOUNT
28685       IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28686       DO 1 I=3,NHEP
28687          IF (ISTHEP(I).EQ.1) THEN
28688             NHKK = NHKK+1
28689             ISTHKK(NHKK) = 1
28690             IDHKK(NHKK)  = IDHEP(I)
28691             JMOHKK(1,NHKK) = 0
28692             JMOHKK(2,NHKK) = 0
28693             JDAHKK(1,NHKK) = 0
28694             JDAHKK(2,NHKK) = 0
28695             DO 2 K=1,4
28696                PHKK(K,NHKK) = PHEP(K,I)
28697                VHKK(K,NHKK) = ZERO
28698                WHKK(K,NHKK) = ZERO
28699     2       CONTINUE
28700             IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28701      &         CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28702      &                    PHKK(3,NHKK),PHKK(4,NHKK),-3)
28703             PHKK(5,NHKK) = PHEP(5,I)
28704             IDRES(NHKK)  = 0
28705             IDXRES(NHKK) = 0
28706             NOBAM(NHKK)  = 0
28707             IDBAM(NHKK)  = IDT_ICIHAD(IDHEP(I))
28708             IDCH(NHKK)   = 0
28709          ENDIF
28710     1 CONTINUE
28711
28712       RETURN
28713       END
28714
28715 *$ CREATE DT_HISTOG.FOR
28716 *COPY DT_HISTOG
28717 *
28718 *===histog=============================================================*
28719 *
28720       SUBROUTINE DT_HISTOG(MODE)
28721
28722 ************************************************************************
28723 * This version dated 25.03.96 is written by S. Roesler                 *
28724 ************************************************************************
28725
28726       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28727       SAVE
28728       PARAMETER ( LINP = 10 ,
28729      &            LOUT = 6 ,
28730      &            LDAT = 9 )
28731
28732       LOGICAL LFSP,LRNL
28733
28734 * event history
28735       PARAMETER (NMXHKK=200000)
28736       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28737      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28738      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28739 * extended event history
28740       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28741      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28742      &                IHIST(2,NMXHKK)
28743 * event flag used for histograms
28744       COMMON /DTNORM/ ICEVT,IEVHKK
28745 * flags for activated histograms
28746       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28747
28748       IEVHKK = NEVHKK
28749       GOTO (1,2,3) MODE
28750
28751 *------------------------------------------------------------------
28752 * initialization
28753     1 CONTINUE
28754       ICEVT = 0
28755       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28756       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28757
28758       RETURN
28759 *------------------------------------------------------------------
28760 * filling of histogram with event-record
28761     2 CONTINUE
28762       ICEVT = ICEVT+1
28763
28764       DO 20 I=1,NHKK
28765          CALL DT_SWPFSP(I,LFSP,LRNL)
28766          IF (LFSP) THEN
28767             IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28768             IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28769          ENDIF
28770          IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28771    20 CONTINUE
28772       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28773
28774       RETURN
28775 *------------------------------------------------------------------
28776 * output
28777     3 CONTINUE
28778       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28779       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28780
28781       RETURN
28782       END
28783
28784 *$ CREATE DT_SWPFSP.FOR
28785 *COPY DT_SWPFSP
28786 *
28787 *===swpfsp=============================================================*
28788 *
28789       SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28790
28791       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28792       SAVE
28793       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28794       PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28795      &           PI   =TWOPI/TWO,
28796      &           BOG  =TWOPI/360.0D0)
28797
28798 * event history
28799       PARAMETER (NMXHKK=200000)
28800       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28801      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28802      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28803 * extended event history
28804       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28805      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28806      &                IHIST(2,NMXHKK)
28807 * particle properties (BAMJET index convention)
28808       CHARACTER*8  ANAME
28809       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28810      &                IICH(210),IIBAR(210),K1(210),K2(210)
28811 * Lorentz-parameters of the current interaction
28812       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28813      &                UMO,PPCM,EPROJ,PPROJ
28814 * flags for input different options
28815       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28816       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28817      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28818 * (original name: PAREVT)
28819       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28820      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
28821       PARAMETER ( NALLWP = 39   )
28822       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
28823      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28824      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28825      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
28826 * temporary storage for one final state particle
28827       LOGICAL LFRAG,LGREY,LBLACK
28828       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28829      &                SINTHE,COSTHE,THETA,THECMS,
28830      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28831      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28832      &                LFRAG,LGREY,LBLACK
28833
28834       LOGICAL LFSP,LRNL
28835
28836       LFSP = .FALSE.
28837       LRNL = .FALSE.
28838       ISTRNL = 1000
28839       MULDEF = 1
28840       IF (LEVPRT) ISTRNL = 1001
28841
28842       IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28843          IST    = ISTHKK(IDX)
28844          IDPDG  = IDHKK(IDX)
28845          LFRAG  = .FALSE.
28846          IF (IDHKK(IDX).LT.80000) THEN
28847             IDBJT  = IDBAM(IDX)
28848             IBARY  = IIBAR(IDBJT)
28849             ICHAR  = IICH(IDBJT)
28850             AMASS  = AAM(IDBJT)
28851          ELSEIF (IDHKK(IDX).EQ.80000) THEN
28852             IDBJT  = 0
28853             IBARY  = IDRES(IDX)
28854             ICHAR  = IDXRES(IDX)
28855             AMASS  = PHKK(5,IDX)
28856             INUT   = IBARY-ICHAR
28857             IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28858             IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28859             IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28860             IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28861             IF (IDBJT.EQ.0) LFRAG = .TRUE.
28862          ELSE
28863             GOTO 9999
28864          ENDIF
28865          PE     = PHKK(4,IDX)
28866          PX     = PHKK(1,IDX)
28867          PY     = PHKK(2,IDX)
28868          PZ     = PHKK(3,IDX)
28869          PT2    = PX**2+PY**2
28870          PT     = SQRT(PT2)
28871          PTOT   = SQRT(PT2+PZ**2)
28872          SINTHE = PT/MAX(PTOT,TINY14)
28873          COSTHE = PZ/MAX(PTOT,TINY14)
28874          IF (COSTHE.GT.ONE) THEN
28875             THETA = ZERO
28876          ELSEIF (COSTHE.LT.-ONE) THEN
28877             THETA = TWOPI/2.0D0
28878          ELSE
28879             THETA = ACOS(COSTHE)
28880          ENDIF
28881          EKIN   = PE-AMASS
28882 **sr 15.4.96 new E_t-definition
28883          IF (IBARY.GT.0) THEN
28884             ET = EKIN*SINTHE
28885          ELSEIF (IBARY.LT.0) THEN
28886             ET = (EKIN+TWO*AMASS)*SINTHE
28887          ELSE
28888             ET = PE*SINTHE
28889          ENDIF
28890 **
28891          XLAB   = PZ/MAX(PPROJ,TINY14)
28892 C        XLAB   = PE/MAX(EPROJ,TINY14)
28893          BETA   = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28894      &                     *(ONE+AMASS/MAX(PE,TINY14)) ))
28895          PPLUS  = PE+PZ
28896          PMINUS = PE-PZ
28897          IF (PMINUS.GT.TINY14) THEN
28898             YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28899          ELSE
28900             YY = 100.0D0
28901          ENDIF
28902          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28903             ETA = -LOG(TAN(THETA/TWO))
28904          ELSE
28905             ETA = 100.0D0
28906          ENDIF
28907          IF (IFRAME.EQ.1) THEN
28908             CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28909             PPLUS  = EECMS+PZCMS
28910             PMINUS = EECMS-PZCMS
28911             IF ((PPLUS*PMINUS).GT.TINY14) THEN
28912                YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28913             ELSE
28914                YYCMS = 100.0D0
28915             ENDIF
28916             PTOTCM = SQRT(PT2+PZCMS**2)
28917             COSTH = PZCMS/MAX(PTOTCM,TINY14)
28918             IF (COSTH.GT.ONE) THEN
28919                THECMS = ZERO
28920             ELSEIF (COSTH.LT.-ONE) THEN
28921                THECMS = TWOPI/2.0D0
28922             ELSE
28923                THECMS = ACOS(COSTH)
28924             ENDIF
28925             IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28926                ETACMS = -LOG(TAN(THECMS/TWO))
28927             ELSE
28928                ETACMS = 100.0D0
28929             ENDIF
28930             XF = PZCMS/MAX(PPCM,TINY14)
28931             THECMS = THECMS/BOG
28932          ELSE
28933             PZCMS  = PZ
28934             EECMS  = PE
28935             YYCMS  = YY
28936             ETACMS = ETA
28937             XF     = XLAB
28938             THECMS = THETA/BOG
28939          ENDIF
28940          THETA  = THETA/BOG
28941
28942 * set flag for "grey/black"
28943          LGREY  = .FALSE.
28944          LBLACK = .FALSE.
28945          EK     = EKIN
28946          IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28947          IF (MULDEF.EQ.1) THEN
28948 *  EMU01-Def.
28949             IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28950      &                              (EK.LE.375.0D-3)      ).OR.
28951      &           ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28952      &                              (EK.LE. 56.0D-3)      ).OR.
28953      &           ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28954      &                              (EK.LE. 56.0D-3)      ).OR.
28955      &           ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28956      &                              (EK.LE.198.0D-3)      ).OR.
28957      &           ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28958      &                              (EK.LE.198.0D-3)      ).OR.
28959      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28960      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28961      &             (IDBJT.NE.16).AND.
28962      &             (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)    ) )
28963      &         LGREY = .TRUE.
28964             IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
28965      &           ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
28966      &           ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
28967      &           ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
28968      &           ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
28969      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28970      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28971      &             (IDBJT.NE.16).AND.(BETA.LE.0.23D0)  ) )
28972      &         LBLACK = .TRUE.
28973          ELSE
28974 *  common Def.
28975             IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
28976             IF (BETA.LE.0.23D0) LBLACK=.TRUE.
28977          ENDIF
28978          LFSP = .TRUE.
28979       ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
28980          IST    = ISTHKK(IDX)
28981          IDPDG  = IDHKK(IDX)
28982          LFRAG  = .TRUE.
28983          IDBJT  = 0
28984          IBARY  = IDRES(IDX)
28985          ICHAR  = IDXRES(IDX)
28986          AMASS  = PHKK(5,IDX)
28987          PE     = PHKK(4,IDX)
28988          PX     = PHKK(1,IDX)
28989          PY     = PHKK(2,IDX)
28990          PZ     = PHKK(3,IDX)
28991          PT2    = PX**2+PY**2
28992          PT     = SQRT(PT2)
28993          PTOT   = SQRT(PT2+PZ**2)
28994          SINTHE = PT/MAX(PTOT,TINY14)
28995          COSTHE = PZ/MAX(PTOT,TINY14)
28996          IF (COSTHE.GT.ONE) THEN
28997             THETA = ZERO
28998          ELSEIF (COSTHE.LT.-ONE) THEN
28999             THETA = TWOPI/2.0D0
29000          ELSE
29001             THETA  = ACOS(COSTHE)
29002          ENDIF
29003          EKIN   = PE-AMASS
29004 **sr 15.4.96 new E_t-definition
29005 C        ET     = PE*SINTHE
29006          ET     = EKIN*SINTHE
29007 **
29008          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
29009             ETA = -LOG(TAN(THETA/TWO))
29010          ELSE
29011             ETA = 100.0D0
29012          ENDIF
29013          THETA  = THETA/BOG
29014          LRNL   = .TRUE.
29015       ENDIF
29016
29017  9999 CONTINUE
29018       RETURN
29019       END
29020
29021 *$ CREATE DT_HIMULT.FOR
29022 *COPY DT_HIMULT
29023 *
29024 *===himult=============================================================*
29025 *
29026       SUBROUTINE DT_HIMULT(MODE)
29027
29028 ************************************************************************
29029 * Tables of average energies/multiplicities.                           *
29030 * This version dated 30.08.2000 is written by S. Roesler               *
29031 ************************************************************************
29032
29033       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29034       SAVE
29035       PARAMETER ( LINP = 10 ,
29036      &            LOUT = 6 ,
29037      &            LDAT = 9 )
29038       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29039
29040       PARAMETER (SWMEXP=1.7D0)
29041
29042       CHARACTER*8 ANAMEH(4)
29043
29044 * particle properties (BAMJET index convention)
29045       CHARACTER*8  ANAME
29046       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29047      &                IICH(210),IIBAR(210),K1(210),K2(210)
29048 * temporary storage for one final state particle
29049       LOGICAL LFRAG,LGREY,LBLACK
29050       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29051      &                SINTHE,COSTHE,THETA,THECMS,
29052      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29053      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29054      &                LFRAG,LGREY,LBLACK
29055 * event flag used for histograms
29056       COMMON /DTNORM/ ICEVT,IEVHKK
29057 * Lorentz-parameters of the current interaction
29058       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
29059      &                UMO,PPCM,EPROJ,PPROJ
29060
29061       PARAMETER (NOPART=210)
29062       DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
29063      &          AVPT(4,NOPART),IAVPT(4,NOPART)
29064       DATA ANAMEH /'DEUTERON','3-H     ','3-HE    ','4-HE    '/
29065
29066       GOTO (1,2,3) MODE
29067
29068 *------------------------------------------------------------------
29069 * initialization
29070     1 CONTINUE
29071       DO 10 I=1,NOPART
29072          DO 11 J=1,4
29073             AVMULT(J,I) = ZERO
29074             AVE(J,I)    = ZERO
29075             AVSWM(J,I)  = ZERO
29076             AVPT(J,I)   = ZERO
29077             IAVPT(J,I)  = 0
29078    11    CONTINUE
29079    10 CONTINUE
29080
29081       RETURN
29082
29083 *------------------------------------------------------------------
29084 * filling of histogram with event-record
29085     2 CONTINUE
29086       IF (PE.LT.0.0D0) THEN
29087          WRITE(LOUT,*) ' HIMULT:  PE < 0 ! ',PE
29088          RETURN
29089       ENDIF
29090       IF (.NOT.LFRAG) THEN
29091          IVEL = 2
29092          IF (LGREY)  IVEL = 3
29093          IF (LBLACK) IVEL = 4
29094          AVE(1,IDBJT)       = AVE(1,IDBJT)   +PE
29095          AVE(IVEL,IDBJT)    = AVE(IVEL,IDBJT)+PE
29096          AVPT(1,IDBJT)     = AVPT(1,IDBJT)   +PT
29097          AVPT(IVEL,IDBJT)  = AVPT(IVEL,IDBJT)+PT
29098          IAVPT(1,IDBJT)    = IAVPT(1,IDBJT)   +1
29099          IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
29100          AVSWM(1,IDBJT)     = AVSWM(1,IDBJT)   +PE**SWMEXP
29101          AVSWM(IVEL,IDBJT)  = AVSWM(IVEL,IDBJT)+PE**SWMEXP
29102          AVMULT(1,IDBJT)    = AVMULT(1,IDBJT)   +ONE
29103          AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
29104          IF (IDBJT.LT.116) THEN
29105 *   total energy, multiplicity
29106             AVE(1,30)       = AVE(1,30)   +PE
29107             AVE(IVEL,30)    = AVE(IVEL,30)+PE
29108             AVPT(1,30)     = AVPT(1,30)   +PT
29109             AVPT(IVEL,30)  = AVPT(IVEL,30)+PT
29110             IAVPT(1,30)    = IAVPT(1,30)   +1
29111             IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
29112             AVSWM(1,30)     = AVSWM(1,30)+PE**SWMEXP
29113             AVSWM(IVEL,30)  = AVSWM(IVEL,30)+PE**SWMEXP
29114             AVMULT(1,30)    = AVMULT(1,30)   +ONE
29115             AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
29116 *   charged energy, multiplicity
29117             IF (ICHAR.LT.0) THEN
29118                AVE(1,26)       = AVE(1,26)   +PE
29119                AVE(IVEL,26)    = AVE(IVEL,26)+PE
29120                AVPT(1,26)     = AVPT(1,26)   +PT
29121                AVPT(IVEL,26)  = AVPT(IVEL,26)+PT
29122                IAVPT(1,26)    = IAVPT(1,26)   +1
29123                IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
29124                AVSWM(1,26)     = AVSWM(1,26)   +PE**SWMEXP
29125                AVSWM(IVEL,26)  = AVSWM(IVEL,26)+PE**SWMEXP
29126                AVMULT(1,26)    = AVMULT(1,26)   +ONE
29127                AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
29128             ENDIF
29129             IF (ICHAR.NE.0) THEN
29130                AVE(1,27)       = AVE(1,27)   +PE
29131                AVE(IVEL,27)    = AVE(IVEL,27)+PE
29132                AVPT(1,27)     = AVPT(1,27)   +PT
29133                AVPT(IVEL,27)  = AVPT(IVEL,27)+PT
29134                IAVPT(1,27)    = IAVPT(1,27)   +1
29135                IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
29136                AVSWM(1,27)     = AVSWM(1,27)   +PE**SWMEXP
29137                AVSWM(IVEL,27)  = AVSWM(IVEL,27)+PE**SWMEXP
29138                AVMULT(1,27)    = AVMULT(1,27)   +ONE
29139                AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
29140             ENDIF
29141          ENDIF
29142       ENDIF
29143
29144       RETURN
29145
29146 *------------------------------------------------------------------
29147 * output
29148     3 CONTINUE
29149       WRITE(LOUT,3000)
29150  3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
29151      &       29X,'---------------------',/)
29152       IF (MULDEF.EQ.1) THEN
29153          WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
29154       ELSE
29155          BETGRE = 0.7D0
29156          BETBLC = 0.23D0
29157          WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
29158  3002    FORMAT(1X,'fast:  beta > ',F4.2,'    grey:  ',F4.2,' > beta > '
29159      &          ,F4.2,'    black:  beta < ',F4.2,/)
29160       ENDIF
29161       WRITE(LOUT,3003) SWMEXP
29162  3003 FORMAT(1X,'particle    |',12X,'average multiplicity',/,
29163      &      13X,'|     total         fast',
29164 C    &      '       grey     black      K      f(',F3.1,')',/,1X,
29165      &      '       grey     black    <pt>     f(',F3.1,')',/,1X,
29166      &      '------------+--------------',
29167      &      '-------------------------------------------------')
29168       DO 30 I=1,NOPART
29169          DO 31 J=1,4
29170             AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
29171             AVE(J,I)    = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
29172             AVPT(J,I)   = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
29173             AVSWM(J,I)  = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
29174    31    CONTINUE
29175          IF (I.LE.115) THEN
29176             WRITE(LOUT,3004) ANAME(I),I,
29177      &                       AVMULT(1,I),AVMULT(2,I),
29178      &                       AVMULT(3,I),AVMULT(4,I),
29179 C    &                       AVE(1,I),AVSWM(1,I)
29180      &                       AVPT(1,I),AVSWM(1,I)
29181          ELSEIF (I.LE.119) THEN
29182             WRITE(LOUT,3004) ANAMEH(I-115),I,
29183      &                       AVMULT(1,I),AVMULT(2,I),
29184      &                       AVMULT(3,I),AVMULT(4,I),
29185 C    &                       AVE(1,I),AVSWM(1,I)
29186      &                       AVPT(1,I),AVSWM(1,I)
29187          ENDIF
29188  3004    FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29189    30 CONTINUE
29190 **temporary
29191 C     WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29192 C    &               AVMULT(3,27)+AVMULT(4,27)
29193 **
29194
29195       RETURN
29196       END
29197
29198 *$ CREATE DT_HISTAT.FOR
29199 *COPY DT_HISTAT
29200 *
29201 *===histat=============================================================*
29202 *
29203       SUBROUTINE DT_HISTAT(IDX,MODE)
29204
29205 ************************************************************************
29206 * This version dated 26.02.96 is written by S. Roesler                 *
29207 *                                                                      *
29208 * Last change 27.12.2006 by S. Roesler.                                *
29209 ************************************************************************
29210
29211       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29212       SAVE
29213       PARAMETER ( LINP = 10 ,
29214      &            LOUT = 6 ,
29215      &            LDAT = 9 )
29216       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29217       PARAMETER (NDIM=199)
29218
29219 * event history
29220       PARAMETER (NMXHKK=200000)
29221       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29222      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29223      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29224 * extended event history
29225       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29226      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29227      &                IHIST(2,NMXHKK)
29228 * particle properties (BAMJET index convention)
29229       CHARACTER*8  ANAME
29230       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29231      &                IICH(210),IIBAR(210),K1(210),K2(210)
29232       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29233 * Glauber formalism: cross sections
29234       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29235      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29236      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29237      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29238      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29239      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29240      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29241      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29242      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29243      &                BSLOPE,NEBINI,NQBINI
29244 * emulsion treatment
29245       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29246      &                NCOMPO,IEMUL
29247 * properties of interacting particles
29248       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29249 * rejection counter
29250       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29251      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29252      &                IREXCI(3),IRDIFF(2),IRINC
29253 * statistics: residual nuclei
29254       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29255      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29256      &                NINCST(2,4),NINCEV(2),
29257      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29258      &                NRESPB(2),NRESCH(2),NRESEV(4),
29259      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29260      &                NEVAFI(2,2)
29261 * parameter for intranuclear cascade
29262       LOGICAL LPAULI
29263       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29264 * (original name: PAREVT)
29265       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29266      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
29267       PARAMETER ( NALLWP = 39   )
29268       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
29269      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29270      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29271      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
29272 * (original name: FRBKCM)
29273       PARAMETER ( MXFFBK =     6 )
29274       PARAMETER ( MXZFBK =     9 )
29275       PARAMETER ( MXNFBK =    10 )
29276       PARAMETER ( MXAFBK =    16 )
29277       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
29278       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
29279       PARAMETER ( NXAFBK = MXAFBK + 1 )
29280       PARAMETER ( MXPSST =   300 )
29281       PARAMETER ( MXPSFB = 41000 )
29282       LOGICAL LFRMBK, LNCMSS
29283       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29284      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
29285      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
29286      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
29287      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29288      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
29289      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29290      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
29291      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
29292 * (original name: INPFLG)
29293       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
29294 * temporary storage for one final state particle
29295       LOGICAL LFRAG,LGREY,LBLACK
29296       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29297      &                SINTHE,COSTHE,THETA,THECMS,
29298      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29299      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29300      &                LFRAG,LGREY,LBLACK
29301 * event flag used for histograms
29302       COMMON /DTNORM/ ICEVT,IEVHKK
29303 * statistics: double-Pomeron exchange
29304       COMMON /DTFLG2/ INTFLG,IPOPO
29305
29306       DIMENSION EMUSAM(NCOMPX)
29307
29308       CHARACTER*13 CMSG(3)
29309       DATA CMSG /'not requested','not requested','not requested'/
29310
29311       GOTO (1,2,3,4,5) MODE
29312
29313 *------------------------------------------------------------------
29314 * initialization
29315     1 CONTINUE
29316 *  emulsion treatment
29317       IF (NCOMPO.GT.0) THEN
29318          DO 10 I=1,NCOMPX
29319             EMUSAM(I) = ZERO
29320    10    CONTINUE
29321       ENDIF
29322 * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29323       NINCGE = 0
29324       DO 11 I=1,2
29325          EXCDPM(I)   = ZERO
29326          EXCDPM(I+2) = ZERO
29327          EXCEVA(I)   = ZERO
29328          NINCWO(I)   = 0
29329          NINCEV(I)   = 0
29330          NRESTO(I)   = 0
29331          NRESPR(I)   = 0
29332          NRESNU(I)   = 0
29333          NRESBA(I)   = 0
29334          NRESPB(I)   = 0
29335          NRESCH(I)   = 0
29336          NRESEV(I)   = 0
29337          NRESEV(I+2) = 0
29338          NEVAGA(I)   = 0
29339          NEVAHT(I)   = 0
29340          NEVAFI(1,I) = 0
29341          NEVAFI(2,I) = 0
29342          DO 12 J=1,6
29343             IF (J.LE.2) NINCHR(I,J) = 0
29344             IF (J.LE.3) NINCCO(I,J) = 0
29345             IF (J.LE.4) NINCST(I,J) = 0
29346             NEVA(I,J) = 0
29347    12    CONTINUE
29348          DO 13 J=1,210
29349             NEVAHY(1,I,J) = 0
29350             NEVAHY(2,I,J) = 0
29351    13    CONTINUE
29352    11 CONTINUE
29353       MAXGEN = 0
29354 **dble Po statistics.
29355       KPOPO = 0
29356
29357       RETURN
29358 *------------------------------------------------------------------
29359 * filling of histogram with event-record
29360     2 CONTINUE
29361       IF (IST.EQ.-1) THEN
29362          IF (.NOT.LFRAG) THEN
29363             IF (IDPDG.EQ.2212) THEN
29364                NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29365             ELSEIF (IDPDG.EQ.2112) THEN
29366                NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29367             ELSEIF (IDPDG.EQ.22) THEN
29368                NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29369             ELSEIF (IDPDG.EQ.80000) THEN
29370                IF (IDBJT.EQ.116) THEN
29371                   NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29372                ELSEIF (IDBJT.EQ.117) THEN
29373                   NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29374                ELSEIF (IDBJT.EQ.118) THEN
29375                   NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29376                ELSEIF (IDBJT.EQ.119) THEN
29377                   NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29378                ENDIF
29379             ENDIF
29380          ELSE
29381 *   heavy fragments (here: fission products only)
29382             NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29383             NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29384             NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29385          ENDIF
29386       ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29387          IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29388       ENDIF
29389
29390       RETURN
29391 *------------------------------------------------------------------
29392 * output
29393     3 CONTINUE
29394
29395 **dble Po statistics.
29396 C     WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29397 C    &   '# evts. / # dble-Po. evts / s_in / s_popo :',
29398 C    & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29399
29400 *  emulsion treatment
29401       IF (NCOMPO.GT.0) THEN
29402          WRITE(LOUT,3000)
29403  3000    FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29404      &          22X,'----------------------------',/,/,19X,
29405      &          'mass    charge          fraction',/,39X,
29406      &          'input     treated',/)
29407          DO 30 I=1,NCOMPO
29408             WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29409      &                       EMUSAM(I)/DBLE(ICEVT)
29410  3013       FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29411    30    CONTINUE
29412       ENDIF
29413
29414 *  i.n.c. statistics: output
29415       WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29416  3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29417      &       22X,'---------------------------------',/,/,1X,
29418      &       'no. of events for normalization: (accepted final events,',
29419      &       ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29420      &       /,1X,'no. of rejected events due to intranuclear',
29421      &       ' cascade',15X,I6,/)
29422       ICEV  = MAX(ICEVT,1)
29423       ICEV1 = ICEV
29424       IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29425       WRITE(LOUT,3002)
29426      &     (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29427      &     ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29428      &     KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29429      &    (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29430      &     (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29431      &     (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29432      &     (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29433  3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29434      &       5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29435      &       ' proj./ target (mean per evt)',/,8X,'baryons:  pos. ',
29436      &       F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,/,8X,
29437      &       'mesons:   pos. ',F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,
29438      &       /,1X,'maximum no. of generations treated (maximum allowed:'
29439      &       ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29440      &       ' interactions in proj./ target (mean per evt1)',
29441      &       F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29442      &       ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29443      &       'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29444      &       '(ap, K-, pi- only)     ',F7.3,' /',F7.3,/)
29445       WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29446      &                 IREXCI(1)+IREXCI(2)+IREXCI(3)
29447  3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29448      &       'evaporation',/,22X,'-----------------------------',
29449      &       '------------',/,/,1X,'no. of events for normal.: ',
29450      &       '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29451      &       ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29452      &       ' rejected events     (',I4,',',I4,',',I4,')',22X,I6,/)
29453
29454       WRITE(LOUT,3004)
29455  3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29456       ICEV  = MAX(NRESEV(2),1)
29457       WRITE(LOUT,3005)
29458      &     (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29459      &     (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29460      &     (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29461      &     (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29462      &     (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29463      &     (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29464      &     (EXCDPM(I)/DBLE(ICEV),I=1,2),
29465      &     (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29466  3005    FORMAT(1X,'residual nuclei:  (mean values per evt)',12X,
29467      &       'proj. / target',/,/,8X,'total number of particles',15X,
29468      &       2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29469      &       'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29470      &       'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29471      &       /,8X,'excitation energy (bef. evap.-step)   ',2E11.3,/,
29472      &       8X,'excitation energy per nucleon         ',2E11.3,/,/)
29473
29474 * evaporation / fission / fragmentation statistics: output
29475       ICEV  = MAX(NRESEV(2),1)
29476       ICEV1 = MAX(NRESEV(4),1)
29477       NTEVA1 =
29478      &   NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29479       NTEVA2 =
29480      &   NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29481       IF (LEVPRT) THEN
29482          IF (IFISS.EQ.1) CMSG(1) = 'requested    '
29483          IF (LFRMBK)     CMSG(2) = 'requested    '
29484          IF (LDEEXG)     CMSG(3) = 'requested    '
29485          WRITE(LOUT,3006)
29486      &        CMSG,
29487      &        DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29488      &        (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29489      &        (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29490      &        (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29491      &        (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29492      &        (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29493      &        (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29494      &        (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29495      &        (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29496  3006    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,'Fission:',
29497      &       13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29498      &       'deexcitation:',2X,A13,/,/,
29499      &       1X,'evaporation/deexcitation:  (mean values per evt1)  ',
29500      &       'proj. / target',/,/,8X,'total number of evap. particles',
29501      &       9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29502      &       'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29503      &       '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29504      &       2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29505      &       'heavy fragments',25X,2F9.3,/)
29506          IF (IFISS.EQ.1) THEN
29507             WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29508      &                       NEVAFI(2,1),NEVAFI(2,2),
29509      &             DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29510      &             DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29511  3007       FORMAT(1X,'Fission:   total number of events',14X,2I9,/
29512      &             12X,'out of which fission occured',8X,2I9,/,
29513      &             50X,'(',F5.2,'%) (',F5.2,'%)',/)
29514          ENDIF
29515 C        IF ((LFRMBK).OR.(IFISS.EQ.1)) THEN
29516 C           WRITE(LOUT,3008)
29517 C3008       FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29518 C    &             '       proj.   / target',/)
29519 C           DO 31 I=1,210
29520 C              IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29521 C                 WRITE(LOUT,3009) I,
29522 C    &            (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29523 C3009             FORMAT(38X,I3,3X,2E12.3)
29524 C              ENDIF
29525 C  31       CONTINUE
29526 C           WRITE(LOUT,3010)
29527 C3010       FORMAT(1X,'heavy fragments - statistics:',7X,'mass  ',
29528 C    &             '       proj.   / target',/)
29529 C           DO 32 I=1,210
29530 C              IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29531 C                 WRITE(LOUT,3011) I,
29532 C    &            (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29533 C3011             FORMAT(38X,I3,3X,2E12.3)
29534 C              ENDIF
29535 C  32       CONTINUE
29536 C           WRITE(LOUT,*)
29537 C        ENDIF
29538       ELSE
29539          WRITE(LOUT,3012)
29540  3012    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,
29541      &       'Evaporation:         not requested',/)
29542       ENDIF
29543
29544       RETURN
29545 *------------------------------------------------------------------
29546 * filling of histogram with event-record
29547     4 CONTINUE
29548 *  emulsion treatment
29549       IF (NCOMPO.GT.0) THEN
29550          DO 40 I=1,NCOMPO
29551             IF (IT.EQ.IEMUMA(I)) THEN
29552                EMUSAM(I) = EMUSAM(I)+ONE
29553             ENDIF
29554    40    CONTINUE
29555       ENDIF
29556       NINCGE = NINCGE+MAXGEN
29557       MAXGEN = 0
29558 **dble Po statistics.
29559       IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29560
29561       RETURN
29562 *------------------------------------------------------------------
29563 * filling of histogram with event-record
29564     5 CONTINUE
29565       IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29566          IB = IIBAR(IDBAM(IDX))
29567          IC = IICH(IDBAM(IDX))
29568          J  = ISTHKK(IDX)-14
29569          IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29570             NINCST(J,1) = NINCST(J,1)+1
29571          ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29572             NINCST(J,2) = NINCST(J,2)+1
29573          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29574             NINCST(J,3) = NINCST(J,3)+1
29575          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29576             NINCST(J,4) = NINCST(J,4)+1
29577          ENDIF
29578       ELSEIF (ISTHKK(IDX).EQ.17) THEN
29579          NINCWO(1) = NINCWO(1)+1
29580       ELSEIF (ISTHKK(IDX).EQ.18) THEN
29581          NINCWO(2) = NINCWO(2)+1
29582       ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29583          IB = IDRES(IDX)
29584          IC = IDXRES(IDX)
29585          IF (IC.GT.0) THEN
29586             NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29587             NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29588          ENDIF
29589          NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29590       ENDIF
29591
29592       RETURN
29593       END
29594
29595 *$ CREATE DT_NEWHGR.FOR
29596 *COPY DT_NEWHGR
29597 *
29598 *===newhgr=============================================================*
29599 *
29600       SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29601
29602 ************************************************************************
29603 *                                                                      *
29604 *     Histogram initialization.                                        *
29605 *                                                                      *
29606 *     input:  XLIM1/XLIM2  lower/upper edge of histogram-window        *
29607 *             XLIM3        bin size                                    *
29608 *             IBIN    > 0  number of bins in equidistant lin. binning  *
29609 *                     = -1 reset histograms                            *
29610 *                     < -1 |IBIN| number of bins in equidistant log.   *
29611 *                          binning or log. binning in user def. struc. *
29612 *             XLIMB(*)     user defined bin structure                  *
29613 *                                                                      *
29614 *     The bin structure is sensitive to                                *
29615 *             XLIM1, XLIM3, IBIN     if     XLIM3 > 0   (lin.)         *
29616 *             XLIM1, XLIM2, IBIN     if     XLIM3 = 0   (lin. & log.)  *
29617 *             XLIMB, IBIN            if     XLIM3 < 0                  *
29618 *                                                                      *
29619 *                                                                      *
29620 *     output: IREFN        histogram index                             *
29621 *                          (= -1 for inconsistent histogr. request)    *
29622 *                                                                      *
29623 * This subroutine is based on a original version by R. Engel.          *
29624 * This version dated 22.4.95 is written  by S. Roesler.                *
29625 ************************************************************************
29626
29627       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29628       SAVE
29629       PARAMETER ( LINP = 10 ,
29630      &            LOUT = 6 ,
29631      &            LDAT = 9 )
29632
29633       LOGICAL LSTART
29634
29635       PARAMETER (ZERO   =  0.0D0,
29636      &           TINY   =  1.0D-10)
29637
29638       DIMENSION XLIMB(*)
29639
29640 * histograms
29641       PARAMETER (NHIS=150, NDIM=250)
29642       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29643      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29644 * auxiliary common for histograms
29645       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29646
29647       DATA LSTART /.TRUE./
29648
29649 * reset histogram counter
29650       IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29651          IHISL  = 0
29652          IF (IBIN.EQ.-1) RETURN
29653          LSTART = .FALSE.
29654       ENDIF
29655
29656       IHIS  = IHISL+1
29657 * check for maximum number of allowed histograms
29658       IF (IHIS.GT.NHIS) THEN
29659          WRITE(LOUT,1003) IHIS,NHIS,IHIS
29660  1003    FORMAT(1X,'NEWHGR:   warning!  number of histograms (',
29661      &          I4,') exceeds array size (',I4,')',/,21X,
29662      &          'histogram',I3,' skipped!')
29663          GOTO 9999
29664       ENDIF
29665
29666       IREFN = IHIS
29667       IBINS(IHIS) = ABS(IBIN)
29668 * check requested number of bins
29669       IF (IBINS(IHIS).GE.NDIM) THEN
29670          WRITE(LOUT,1000) IBIN,NDIM,NDIM
29671  1000    FORMAT(1X,'NEWHGR:   warning!  number of bins (',
29672      &          I3,') exceeds array size (',I3,')',/,21X,
29673      &          'and will be reset to ',I3)
29674          IBINS(IHIS) = NDIM
29675       ENDIF
29676       IF (IBINS(IHIS).EQ.0) THEN
29677          WRITE(LOUT,1001) IBIN,IHIS
29678  1001    FORMAT(1X,'NEWHGR:   warning!  inconsistent number of',
29679      &          ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29680          GOTO 9999
29681       ENDIF
29682
29683 * initialize arrays
29684       DO 1 I=1,NDIM
29685          DO 2 K=1,3
29686             HIST(K,IHIS,I)   = ZERO
29687             HIST(K+3,IHIS,I) = ZERO
29688             TMPHIS(K,IHIS,I) = ZERO
29689     2    CONTINUE
29690          HIST(7,IHIS,I)   = ZERO
29691     1 CONTINUE
29692       DENTRY(1,IHIS)= ZERO
29693       DENTRY(2,IHIS)= ZERO
29694       OVERF(IHIS)   = ZERO
29695       UNDERF(IHIS)  = ZERO
29696       TMPUFL(IHIS)  = ZERO
29697       TMPOFL(IHIS)  = ZERO
29698
29699 * bin str. sensitive to lower edge, bin size, and numb. of bins
29700       IF (XLIM3.GT.ZERO) THEN
29701          DO 3 K=1,IBINS(IHIS)+1
29702             HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29703     3    CONTINUE
29704          ISWI(IHIS) = 1
29705 * bin str. sensitive to lower/upper edge and numb. of bins
29706       ELSEIF (XLIM3.EQ.ZERO) THEN
29707 *   linear binning
29708          IF (IBIN.GT.0) THEN
29709             XLOW = XLIM1
29710             XHI  = XLIM2
29711             IF (XLIM2.LE.XLIM1) THEN
29712                WRITE(LOUT,1002) XLIM1,XLIM2
29713  1002          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
29714      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29715                GOTO 9999
29716             ENDIF
29717             ISWI(IHIS) = 1
29718          ELSEIF (IBIN.LT.-1) THEN
29719 *   logarithmic binning
29720             IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29721                WRITE(LOUT,1004) XLIM1,XLIM2
29722  1004          FORMAT(1X,'NEWHGR:   warning!  inconsistent log. ',
29723      &                'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29724                GOTO 9999
29725             ENDIF
29726             IF (XLIM2.LE.XLIM1) THEN
29727                WRITE(LOUT,1005) XLIM1,XLIM2
29728  1005          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
29729      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29730                GOTO 9999
29731             ENDIF
29732             XLOW = LOG10(XLIM1)
29733             XHI  = LOG10(XLIM2)
29734             ISWI(IHIS) = 3
29735          ENDIF
29736          DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29737          DO 4 K=1,IBINS(IHIS)+1
29738             HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29739     4    CONTINUE
29740       ELSE
29741 * user defined bin structure
29742          DO 5 K=1,IBINS(IHIS)+1
29743             IF (IBIN.GT.0) THEN
29744                HIST(1,IHIS,K) = XLIMB(K)
29745                ISWI(IHIS) = 2
29746             ELSEIF (IBIN.LT.-1) THEN
29747                HIST(1,IHIS,K) = LOG10(XLIMB(K))
29748                ISWI(IHIS) = 4
29749             ENDIF
29750     5    CONTINUE
29751       ENDIF
29752
29753 * histogram accepted
29754       IHISL = IHIS
29755
29756       RETURN
29757
29758  9999 CONTINUE
29759       IREFN = -1
29760       RETURN
29761       END
29762
29763 *$ CREATE DT_FILHGR.FOR
29764 *COPY DT_FILHGR
29765 *
29766 *===filhgr=============================================================*
29767 *
29768       SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29769
29770 ************************************************************************
29771 *                                                                      *
29772 *     Scoring for histogram IHIS.                                      *
29773 *                                                                      *
29774 * This subroutine is based on a original version by R. Engel.          *
29775 * This version dated 23.4.95 is written  by S. Roesler.                *
29776 ************************************************************************
29777
29778       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29779       SAVE
29780       PARAMETER ( LINP = 10 ,
29781      &            LOUT = 6 ,
29782      &            LDAT = 9 )
29783
29784       PARAMETER (ZERO = 0.0D0,
29785      &           ONE  = 1.0D0,
29786      &           TINY = 1.0D-10)
29787
29788 * histograms
29789       PARAMETER (NHIS=150, NDIM=250)
29790       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29791      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29792 * auxiliary common for histograms
29793       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29794
29795       DATA NCEVT /1/
29796
29797       X = XI
29798       Y = YI
29799
29800 * dump content of temorary arrays into histograms
29801       IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29802          CALL DT_EVTHIS(IDUM)
29803          NCEVT = NEVT
29804       ENDIF
29805
29806 * check histogram index
29807       IF (IHIS.EQ.-1) RETURN
29808       IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29809 C        WRITE(LOUT,1000) IHIS,IHISL
29810  1000    FORMAT(1X,'FILHGR:   warning!  histogram index',I4,
29811      &          ' out of range (1..',I3,')')
29812          RETURN
29813       ENDIF
29814
29815       IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29816 * bin structure not explicitly given
29817          IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29818          DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29819          IF (X.LT.HIST(1,IHIS,1)) THEN
29820             I1 = 0
29821          ELSE
29822             I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29823          ENDIF
29824
29825       ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29826 * user defined bin structure
29827          IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29828          IF (X.LT.HIST(1,IHIS,1)) THEN
29829             I1 = 0
29830          ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29831             I1 = IBINS(IHIS)+1
29832          ELSE
29833 *   binary sort algorithm
29834             KMIN = 0
29835             KMAX = IBINS(IHIS)+1
29836     1       CONTINUE
29837             IF ((KMAX-KMIN).EQ.1) GOTO 2
29838             KK = (KMAX+KMIN)/2
29839             IF (X.LE.HIST(1,IHIS,KK)) THEN
29840                KMAX=KK
29841             ELSE
29842                KMIN=KK
29843             ENDIF
29844             GOTO 1
29845     2       CONTINUE
29846             I1 = KMIN
29847          ENDIF
29848
29849       ELSE
29850          WRITE(LOUT,1001)
29851  1001    FORMAT(1X,'FILHGR:   warning!  histogram not initialized')
29852          RETURN
29853       ENDIF
29854
29855 * scoring
29856       IF (I1.LE.0) THEN
29857          TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29858       ELSEIF (I1.LE.IBINS(IHIS)) THEN
29859          TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29860          IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29861             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29862          ELSE
29863             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29864          ENDIF
29865          TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29866       ELSE
29867          TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29868       ENDIF
29869
29870       RETURN
29871       END
29872
29873 *$ CREATE DT_EVTHIS.FOR
29874 *COPY DT_EVTHIS
29875 *
29876 *===evthis=============================================================*
29877 *
29878       SUBROUTINE DT_EVTHIS(NEVT)
29879
29880 ************************************************************************
29881 * Dump content of temorary histograms into /DTHIS1/. This subroutine   *
29882 * is called after each event and for the last event before any call    *
29883 * to OUTHGR.                                                           *
29884 *         NEVT   number of events dumped, this is only needed to       *
29885 *                get the normalization after the last event            *
29886 * This version dated 23.4.95 is written  by S. Roesler.                *
29887 ************************************************************************
29888
29889       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29890       SAVE
29891       PARAMETER ( LINP = 10 ,
29892      &            LOUT = 6 ,
29893      &            LDAT = 9 )
29894
29895       LOGICAL LNOETY
29896
29897       PARAMETER (ZERO = 0.0D0,
29898      &           ONE  = 1.0D0,
29899      &           TINY = 1.0D-10)
29900
29901 * histograms
29902       PARAMETER (NHIS=150, NDIM=250)
29903       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29904      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29905 * auxiliary common for histograms
29906       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29907
29908       DATA NCEVT /0/
29909
29910       NCEVT = NCEVT+1
29911       NEVT  = NCEVT
29912
29913       DO 1 I=1,IHISL
29914          LNOETY = .TRUE.
29915          DO 2 J=1,IBINS(I)
29916             IF (TMPHIS(1,I,J).GT.ZERO) THEN
29917                LNOETY = .FALSE.
29918                HIST(2,I,J)   = HIST(2,I,J)+ONE
29919                HIST(7,I,J)   = HIST(7,I,J)+TMPHIS(1,I,J)
29920                DENTRY(2,I)   = DENTRY(2,I)+TMPHIS(1,I,J)
29921                AVX           = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29922                HIST(3,I,J)   = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29923                HIST(4,I,J)   = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29924                HIST(5,I,J)   = HIST(5,I,J)+TMPHIS(3,I,J)
29925                HIST(6,I,J)   = HIST(6,I,J)+TMPHIS(3,I,J)**2
29926                TMPHIS(1,I,J) = ZERO
29927                TMPHIS(2,I,J) = ZERO
29928                TMPHIS(3,I,J) = ZERO
29929             ENDIF
29930     2    CONTINUE
29931          IF (LNOETY) THEN
29932             IF (TMPUFL(I).GT.ZERO) THEN
29933                UNDERF(I) = UNDERF(I)+ONE
29934                TMPUFL(I) = ZERO
29935             ELSEIF (TMPOFL(I).GT.ZERO) THEN
29936                OVERF(I)  = OVERF(I)+ONE
29937                TMPOFL(I) = ZERO
29938             ENDIF
29939          ELSE
29940             DENTRY(1,I) = DENTRY(1,I)+ONE
29941          ENDIF
29942     1 CONTINUE
29943
29944       RETURN
29945       END
29946
29947 *$ CREATE DT_OUTHGR.FOR
29948 *COPY DT_OUTHGR
29949 *
29950 *===outhgr=============================================================*
29951 *
29952       SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29953      &                  ILOGY,INORM,NMODE)
29954
29955 ************************************************************************
29956 *                                                                      *
29957 *     Plot histogram(s) to standard output unit                        *
29958 *                                                                      *
29959 *         I1..6         indices of histograms to be plotted            *
29960 *         CHEAD,IHEAD   header string,integer                          *
29961 *         NEVTS         number of events                               *
29962 *         FAC           scaling factor                                 *
29963 *         ILOGY   = 1   logarithmic y-axis                             *
29964 *         INORM         normalization                                  *
29965 *                 = 0   no further normalization (FAC is obsolete)     *
29966 *                 = 1   per event and bin width                        *
29967 *                 = 2   per entry and bin width                        *
29968 *                 = 3   per bin entry                                  *
29969 *                 = 4   per event and "bin width" x1^2...x2^2          *
29970 *                 = 5   per event and "log. bin width" ln x1..ln x2    *
29971 *                 = 6   per event                                      *
29972 *         MODE    = 0   no output but normalization applied            *
29973 *                 = 1   all valid histograms separately (small frame)  *
29974 *                       all valid histograms separately (small frame)  *
29975 *                 = -1  and tables as histograms                       *
29976 *                 = 2   all valid histograms (one plot, wide frame)    *
29977 *                       all valid histograms (one plot, wide frame)    *
29978 *                 = -2  and tables as histograms                       *
29979 *                                                                      *
29980 *                                                                      *
29981 *     Note: All histograms to be plotted with one call to this         *
29982 *           subroutine and |MODE|=2 must have the same bin structure!  *
29983 *           There is no test included ensuring this fact.              *
29984 *                                                                      *
29985 * This version dated 23.4.95 is written  by S. Roesler.                *
29986 ************************************************************************
29987
29988       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29989       SAVE
29990       PARAMETER ( LINP = 10 ,
29991      &            LOUT = 6 ,
29992      &            LDAT = 9 )
29993
29994       CHARACTER*72 CHEAD
29995
29996       PARAMETER (ZERO   =  0.0D0,
29997      &           IZERO  =  0,
29998      &           ONE    =  1.0D0,
29999      &           TWO    =  2.0D0,
30000      &           OHALF  =  0.5D0,
30001      &           EPS    =  1.0D-5,
30002      &           TINY   =  1.0D-8,
30003      &           SMALL  =  -1.0D8,
30004      &           RLARGE =  1.0D8 )
30005
30006 * histograms
30007       PARAMETER (NHIS=150, NDIM=250)
30008       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30009      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30010
30011       PARAMETER (NDIM2 = 2*NDIM)
30012       DIMENSION XX(NDIM2),YY(NDIM2)
30013
30014       PARAMETER (NHISTO = 6)
30015       DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
30016      &          IDX(NHISTO)
30017
30018       CHARACTER*43 CNORM(0:8)
30019       DATA CNORM /'no further normalization                   ',
30020      &            'per event and bin width                    ',
30021      &            'per entry1 and bin width                   ',
30022      &            'per bin entry                              ',
30023      &            'per event and "bin width" x1^2...x2^2      ',
30024      &            'per event and "log. bin width" ln x1..ln x2',
30025      &            'per event                                  ',
30026      &            'per bin entry1                             ',
30027      &            'per entry2 and bin width                   '/
30028
30029       IDX1(1) = I1
30030       IDX1(2) = I2
30031       IDX1(3) = I3
30032       IDX1(4) = I4
30033       IDX1(5) = I5
30034       IDX1(6) = I6
30035
30036       MODE = NMODE
30037
30038 * initialization if "wide frame" is requested
30039       IF (ABS(MODE).EQ.2) THEN
30040          DO 1 I=1,NHISTO
30041             DO 2 J=1,NDIM
30042                XX1(J,I) = ZERO
30043                YY1(J,I) = ZERO
30044     2       CONTINUE
30045     1    CONTINUE
30046       ENDIF
30047
30048 * plot header
30049       WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
30050
30051 * check histogram indices
30052       NHI = 0
30053       DO 3 I=1,NHISTO
30054          IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
30055             IF (ISWI(IDX1(I)).NE.0) THEN
30056                IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
30057                   WRITE(LOUT,1000)
30058      &                 IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
30059  1000             FORMAT(/,1X,'OUTHGR:   warning!  no entries in',
30060      &                   ' histogram ',I3,/,21X,'underflows:',F10.0,
30061      &                   '   overflows:  ',F10.0)
30062                ELSE
30063                   NHI = NHI+1
30064                   IDX(NHI) = IDX1(I)
30065                ENDIF
30066             ENDIF
30067          ENDIF
30068     3 CONTINUE
30069       IF (NHI.EQ.0) THEN
30070          WRITE(LOUT,1001)
30071  1001    FORMAT(/,1X,'OUTHGR:   warning!  histogram indices not valid')
30072          RETURN
30073       ENDIF
30074
30075 * check normalization request
30076       IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30077      &     ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30078      &                        (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30079      &     (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30080          WRITE(LOUT,1002) NEVTS,INORM,FAC
30081  1002    FORMAT(/,1X,'OUTHGR:   warning!  normalization request not ',
30082      &          'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30083      &          'FAC = ',E11.4)
30084          RETURN
30085       ENDIF
30086
30087       WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30088
30089 * apply normalization
30090       DO 4 N=1,NHI
30091
30092          I = IDX(N)
30093
30094          IF (ISWI(I).EQ.1) THEN
30095             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30096  1003       FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30097      &             ' to',2X,E10.4,',',2X,I3,' bins')
30098          ELSEIF (ISWI(I).EQ.2) THEN
30099             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30100             WRITE(LOUT,1007)
30101  1007       FORMAT(1X,'user defined bin structure')
30102          ELSEIF (ISWI(I).EQ.3) THEN
30103             WRITE(LOUT,1004)
30104      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30105  1004       FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30106      &             ' to',2X,E10.4,',',2X,I3,' bins')
30107          ELSEIF (ISWI(I).EQ.4) THEN
30108             WRITE(LOUT,1004)
30109      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30110             WRITE(LOUT,1007)
30111          ELSE
30112             WRITE(LOUT,1008) ISWI(I)
30113  1008       FORMAT(/,1X,'warning!  inconsistent bin structure flag ',I4)
30114          ENDIF
30115          WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30116  1005    FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30117      &          ' overfl.:',F8.0)
30118          WRITE(LOUT,1009) CNORM(INORM)
30119  1009    FORMAT(1X,'normalization: ',A,/)
30120
30121          DO 5 K=1,IBINS(I)
30122             CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30123             YMEAN = FAC*YMEAN
30124             YERR  = FAC*YERR
30125             WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30126             WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30127  1006       FORMAT(1X,5E11.3)
30128 *    small frame
30129             II = 2*K
30130             XX(II-1) = HIST(1,I,K)
30131             XX(II)   = HIST(1,I,K+1)
30132             YY(II-1) = YMEAN
30133             YY(II)   = YMEAN
30134 *    wide frame
30135             XX1(K,N) = XMEAN
30136             IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30137      &         XX1(K,N) = LOG10(XMEAN)
30138             YY1(K,N) = YMEAN
30139     5    CONTINUE
30140
30141 * plot small frame
30142          IF (ABS(MODE).EQ.1) THEN
30143             IBIN2 = 2*IBINS(I)
30144             WRITE(LOUT,'(/,1X,A)') 'Preview:'
30145             IF(ILOGY.EQ.1) THEN
30146               CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30147             ELSE
30148               CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30149             ENDIF
30150          ENDIF
30151
30152     4 CONTINUE
30153
30154 * plot wide frame
30155       IF (ABS(MODE).EQ.2) THEN
30156          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30157          NSIZE = NDIM*NHISTO
30158          DXLOW = HIST(1,IDX(1),1)
30159          DDX   = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30160          YLOW  = RLARGE
30161          YHI   = SMALL
30162          DO 6 I=1,NHISTO
30163             DO 7 J=1,NDIM
30164                IF (YY1(J,I).LT.YLOW) THEN
30165                   IF (ILOGY.EQ.1) THEN
30166                      IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30167                   ELSE
30168                      YLOW = YY1(J,I)
30169                   ENDIF
30170                ENDIF
30171                IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30172     7       CONTINUE
30173     6    CONTINUE
30174          DY = (YHI-YLOW)/DBLE(NDIM)
30175          IF (DY.LE.ZERO) THEN
30176             WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30177      &         'OUTHGR:   warning! zero bin width for histograms ',
30178      &         IDX,': ',YLOW,YHI
30179             RETURN
30180          ENDIF
30181          IF (ILOGY.EQ.1) THEN
30182             YLOW = LOG10(YLOW)
30183             DY   = (LOG10(YHI)-YLOW)/100.0D0
30184             DO 8 I=1,NHISTO
30185                DO 9 J=1,NDIM
30186                   IF (YY1(J,I).LE.ZERO) THEN
30187                      YY1(J,I) = YLOW
30188                   ELSE
30189                      YY1(J,I) = LOG10(YY1(J,I))
30190                   ENDIF
30191     9          CONTINUE
30192     8       CONTINUE
30193          ENDIF
30194          CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30195       ENDIF
30196
30197       RETURN
30198       END
30199
30200 *$ CREATE DT_GETBIN.FOR
30201 *COPY DT_GETBIN
30202 *
30203 *===getbin=============================================================*
30204 *
30205       SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30206      &                  XMEAN,YMEAN,YERR)
30207
30208 ************************************************************************
30209 * This version dated 23.4.95 is written  by S. Roesler.                *
30210 ************************************************************************
30211
30212       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30213       SAVE
30214       PARAMETER ( LINP = 10 ,
30215      &            LOUT = 6 ,
30216      &            LDAT = 9 )
30217
30218       PARAMETER (ZERO   = 0.0D0,
30219      &           ONE    = 1.0D0,
30220      &           TINY35 = 1.0D-35)
30221
30222 * histograms
30223       PARAMETER (NHIS=150, NDIM=250)
30224       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30225      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30226
30227       XLOW = HIST(1,IHIS,IBIN)
30228       XHI  = HIST(1,IHIS,IBIN+1)
30229       IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30230          XLOW = 10**XLOW
30231          XHI  = 10**XHI
30232       ENDIF
30233       IF (NORM.EQ.2) THEN
30234          DX   = XHI-XLOW
30235          NEVT = INT(DENTRY(1,IHIS))
30236       ELSEIF (NORM.EQ.3) THEN
30237          DX   = ONE
30238          NEVT = INT(HIST(2,IHIS,IBIN))
30239       ELSEIF (NORM.EQ.4) THEN
30240          DX   = XHI**2-XLOW**2
30241          NEVT = KEVT
30242       ELSEIF (NORM.EQ.5) THEN
30243          DX   = LOG(ABS(XHI))-LOG(ABS(XLOW))
30244          NEVT = KEVT
30245       ELSEIF (NORM.EQ.6) THEN
30246          DX   = ONE
30247          NEVT = KEVT
30248       ELSEIF (NORM.EQ.7) THEN
30249          DX   = ONE
30250          NEVT = INT(HIST(7,IHIS,IBIN))
30251       ELSEIF (NORM.EQ.8) THEN
30252          DX   = XHI-XLOW
30253          NEVT = INT(DENTRY(2,IHIS))
30254       ELSE
30255          DX   = ABS(XHI-XLOW)
30256          NEVT = KEVT
30257       ENDIF
30258       IF (ABS(DX).LT.TINY35) DX = ONE
30259       NEVT   = MAX(NEVT,1)
30260       YMEAN  = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30261       YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30262       YERR   = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30263       YSUM   = HIST(5,IHIS,IBIN)
30264       IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30265 C     XMEAN  = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30266       XMEAN  = HIST(3,IHIS,IBIN)/YSUM
30267       IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30268
30269       RETURN
30270       END
30271
30272 *$ CREATE DT_JOIHIS.FOR
30273 *COPY DT_JOIHIS
30274 *
30275 *===joihis=============================================================*
30276 *
30277       SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30278
30279 ************************************************************************
30280 *                                                                      *
30281 *     Operation on histograms.                                         *
30282 *                                                                      *
30283 *     input:  IH1,IH2      histogram indices to be joined              *
30284 *             COPER        character defining the requested operation, *
30285 *                          i.e. '+', '-', '*', '/'                     *
30286 *             FAC1,FAC2    factors for joining, i.e.                   *
30287 *                          FAC1*histo1 COPER FAC2*histo2               *
30288 *                                                                      *
30289 * This version dated 23.4.95 is written  by S. Roesler.                *
30290 ************************************************************************
30291
30292       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30293       SAVE
30294       PARAMETER ( LINP = 10 ,
30295      &            LOUT = 6 ,
30296      &            LDAT = 9 )
30297
30298       CHARACTER COPER*1
30299
30300       PARAMETER (ZERO   =  0.0D0,
30301      &           ONE    =  1.0D0,
30302      &           OHALF  =  0.5D0,
30303      &           TINY8  =  1.0D-8,
30304      &           SMALL  =  -1.0D8,
30305      &           RLARGE =  1.0D8 )
30306
30307 * histograms
30308       PARAMETER (NHIS=150, NDIM=250)
30309       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30310      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30311
30312       PARAMETER (NDIM2 = 2*NDIM)
30313       DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30314
30315       CHARACTER*43 CNORM(0:6)
30316       DATA CNORM /'no further normalization                   ',
30317      &            'per event and bin width                    ',
30318      &            'per entry and bin width                    ',
30319      &            'per bin entry                              ',
30320      &            'per event and "bin width" x1^2...x2^2      ',
30321      &            'per event and "log. bin width" ln x1..ln x2',
30322      &            'per event                                  '/
30323
30324 * check histogram indices
30325       IF ((IH1.LT.    1).OR.(IH2.LT.    1).OR.
30326      &    (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30327          WRITE(LOUT,1000) IH1,IH2,IHISL
30328  1000    FORMAT(1X,'JOIHIS:   warning!  inconsistent histogram ',
30329      &          'indices (',I3,',',I3,'),',/,21X,'valid range:  1,',I3)
30330          GOTO 9999
30331       ENDIF
30332
30333 * check bin structure of histograms to be joined
30334       IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30335          WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30336  1001    FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
30337      &          ' and ',I3,' failed',/,21X,
30338      &          'due to different numbers of bins (',I3,',',I3,')')
30339          GOTO 9999
30340       ENDIF
30341       DO 1 K=1,IBINS(IH1)+1
30342          IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30343             WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30344  1002       FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
30345      &             ' and ',I3,' failed at bin edge ',I3,/,21X,
30346      &             'X1,X2 = ',2E11.4)
30347             GOTO 9999
30348          ENDIF
30349     1 CONTINUE
30350
30351       WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30352  1003 FORMAT(1X,'JOIHIS:   joining histograms ',I3,',',I3,' with ',
30353      &       'operation ',A,/,11X,'and factors ',2E11.4)
30354       WRITE(LOUT,1004) CNORM(NORM)
30355  1004 FORMAT(1X,'normalization: ',A,/)
30356
30357       DO 2 K=1,IBINS(IH1)
30358          CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30359          CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30360          XLOW  = XLOW1
30361          XHI   = XHI1
30362          XMEAN = OHALF*(XMEAN1+XMEAN2)
30363          IF (COPER.EQ.'+') THEN
30364             YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30365          ELSEIF (COPER.EQ.'*') THEN
30366             YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30367          ELSEIF (COPER.EQ.'/') THEN
30368             IF (YMEAN2.EQ.ZERO) THEN
30369                YMEAN = ZERO
30370             ELSE
30371                IF (FAC2.EQ.ZERO) FAC2 = ONE
30372                YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30373             ENDIF
30374          ELSE
30375             GOTO 9998
30376          ENDIF
30377          WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30378          WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30379  1006    FORMAT(1X,5E11.3)
30380 *    small frame
30381          II = 2*K
30382          XX(II-1) = HIST(1,IH1,K)
30383          XX(II)   = HIST(1,IH1,K+1)
30384          YY(II-1) = YMEAN
30385          YY(II)   = YMEAN
30386 *    wide frame
30387          XX1(K) = XMEAN
30388          IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30389          YY1(K) = YMEAN
30390     2 CONTINUE
30391
30392 * plot small frame
30393       IF (ABS(MODE).EQ.1) THEN
30394          IBIN2 = 2*IBINS(IH1)
30395          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30396          IF(ILOGY.EQ.1) THEN
30397            CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30398          ELSE
30399            CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30400          ENDIF
30401       ENDIF
30402
30403 * plot wide frame
30404       IF (ABS(MODE).EQ.2) THEN
30405          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30406          NSIZE = NDIM
30407          DXLOW = HIST(1,IH1,1)
30408          DDX   = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30409          YLOW  = RLARGE
30410          YHI   = SMALL
30411          DO 3 I=1,NDIM
30412             IF (YY1(I).LT.YLOW) THEN
30413                IF (ILOGY.EQ.1) THEN
30414                   IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30415                ELSE
30416                   YLOW = YY1(I)
30417                ENDIF
30418             ENDIF
30419             IF (YY1(I).GT.YHI) YHI = YY1(I)
30420     3    CONTINUE
30421          DY = (YHI-YLOW)/DBLE(NDIM)
30422          IF (DY.LE.ZERO) THEN
30423             WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30424      &         'JOIHIS:   warning! zero bin width for histograms ',
30425      &         IH1,IH2,': ',YLOW,YHI
30426             RETURN
30427          ENDIF
30428          IF (ILOGY.EQ.1) THEN
30429             YLOW = LOG10(YLOW)
30430             DY   = (LOG10(YHI)-YLOW)/100.0D0
30431             DO 4 I=1,NDIM
30432                IF (YY1(I).LE.ZERO) THEN
30433                   YY1(I) = YLOW
30434                ELSE
30435                   YY1(I) = LOG10(YY1(I))
30436                ENDIF
30437     4       CONTINUE
30438          ENDIF
30439          CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30440       ENDIF
30441
30442       RETURN
30443
30444  9998 CONTINUE
30445       WRITE(LOUT,1005) COPER
30446  1005 FORMAT(1X,'JOIHIS:   unknown operation ',A)
30447
30448  9999 CONTINUE
30449       RETURN
30450       END
30451
30452 *$ CREATE DT_XGRAPH.FOR
30453 *COPY DT_XGRAPH
30454 *
30455 *===qgraph=============================================================*
30456 *
30457       SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30458 C***********************************************************************
30459 C
30460 C     calculate quasi graphic picture with 25 lines and 79 columns
30461 C     ranges will be chosen automatically
30462 C
30463 C     input     N          dimension of input fields
30464 C               IARG       number of curves (fields) to plot
30465 C               X          field of X
30466 C               Y1         field of Y1
30467 C               Y2         field of Y2
30468 C
30469 C This subroutine is written by R. Engel.
30470 C***********************************************************************
30471       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30472       SAVE
30473
30474       PARAMETER ( LINP = 10 ,
30475      &            LOUT = 6 ,
30476      &            LDAT = 9 )
30477 C
30478       DIMENSION X(N),Y1(N),Y2(N)
30479       PARAMETER (EPS=1.D-30)
30480       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30481       CHARACTER SYMB(5)
30482       CHARACTER COL(0:149,0:49)
30483 C
30484       DATA SYMB /'0','e','z','#','x'/
30485 C
30486       ISPALT=IBREIT-10
30487 C
30488 C***  automatic range fitting
30489 C
30490       XMAX=X(1)
30491       XMIN=X(1)
30492       DO 600 I=1,N
30493          XMAX=MAX(X(I),XMAX)
30494          XMIN=MIN(X(I),XMIN)
30495  600  CONTINUE
30496       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30497 C
30498       ITEST=0
30499       DO 1100 K=0,IZEIL-1
30500          ITEST=ITEST+1
30501          IF (ITEST.EQ.IYRAST) THEN
30502             DO 1010 L=1,ISPALT-1
30503                COL(L,K)='-'
30504 1010        CONTINUE
30505             COL(ISPALT,K)='+'
30506             ITEST=0
30507             DO 1020 L=0,ISPALT-1,IXRAST
30508                COL(L,K)='+'
30509 1020        CONTINUE
30510          ELSE
30511             DO 1030 L=1,ISPALT-1
30512                COL(L,K)=' '
30513 1030        CONTINUE
30514             DO 1040 L=0,ISPALT-1,IXRAST
30515                COL(L,K)='|'
30516 1040        CONTINUE
30517             COL(ISPALT,K)='|'
30518          ENDIF
30519 1100  CONTINUE
30520 C
30521 C***  plot curve Y1
30522 C
30523       YMAX=Y1(1)
30524       YMIN=Y1(1)
30525       DO 500 I=1,N
30526          YMAX=MAX(Y1(I),YMAX)
30527          YMIN=MIN(Y1(I),YMIN)
30528 500   CONTINUE
30529       IF(IARG.GT.1) THEN
30530         DO 550 I=1,N
30531            YMAX=MAX(Y2(I),YMAX)
30532            YMIN=MIN(Y2(I),YMIN)
30533 550     CONTINUE
30534       ENDIF
30535       YMAX=(YMAX-YMIN)/40.0D0+YMAX
30536       YMIN=YMIN-(YMAX-YMIN)/40.0D0
30537       YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30538       IF(YZOOM.LT.EPS) THEN
30539         WRITE(LOUT,'(1X,A)')
30540      &    'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30541         RETURN
30542       ENDIF
30543 C
30544 C***  plot curve Y1
30545 C
30546       ILAST=-1
30547       LLAST=-1
30548       DO 1200 K=1,N
30549          L=NINT((X(K)-XMIN)/XZOOM)
30550          I=NINT((YMAX-Y1(K))/YZOOM)
30551          IF(ILAST.GE.0) THEN
30552            LD = L-LLAST
30553            ID = I-ILAST
30554            DO 55 II=0,LD,SIGN(1,LD)
30555              DO 66 KK=0,ID,SIGN(1,ID)
30556                COL(II+LLAST,KK+ILAST)=SYMB(1)
30557  66          CONTINUE
30558  55        CONTINUE
30559          ELSE
30560            COL(L,I)=SYMB(1)
30561          ENDIF
30562          ILAST = I
30563          LLAST = L
30564 1200  CONTINUE
30565 C
30566       IF(IARG.GT.1) THEN
30567 C
30568 C***  plot curve Y2
30569 C
30570         DO 1250 K=1,N
30571            L=NINT((X(K)-XMIN)/XZOOM)
30572            I=NINT((YMAX-Y2(K))/YZOOM)
30573            COL(L,I)=SYMB(2)
30574 1250    CONTINUE
30575       ENDIF
30576 C
30577 C***  write it
30578 C
30579       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30580 C
30581 C***  write range of X
30582 C
30583       XZOOM = (XMAX-XMIN)/DBLE(7)
30584       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30585 C
30586       DO 1300 K=0,IZEIL-1
30587          YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30588          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30589  110     FORMAT(1X,1PE9.2,70A1)
30590 1300  CONTINUE
30591 C
30592 C***  write range of X
30593 C
30594       XZOOM = (XMAX-XMIN)/DBLE(7)
30595       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30596       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30597  120  FORMAT(6X,7(1PE10.3))
30598       END
30599
30600 *$ CREATE DT_XGLOGY.FOR
30601 *COPY DT_XGLOGY
30602 *
30603 *===qglogy=============================================================*
30604 *
30605       SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30606 C***********************************************************************
30607 C
30608 C     calculate quasi graphic picture with 25 lines and 79 columns
30609 C     logarithmic y axis
30610 C     ranges will be chosen automatically
30611 C
30612 C     input     N          dimension of input fields
30613 C               IARG       number of curves (fields) to plot
30614 C               X          field of X
30615 C               Y1         field of Y1
30616 C               Y2         field of Y2
30617 C
30618 C This subroutine is written by R. Engel.
30619 C***********************************************************************
30620 C
30621       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30622       SAVE
30623
30624       PARAMETER ( LINP = 10 ,
30625      &            LOUT = 6 ,
30626      &            LDAT = 9 )
30627       DIMENSION X(N),Y1(N),Y2(N)
30628       PARAMETER (EPS=1.D-30)
30629       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30630       CHARACTER SYMB(5)
30631       CHARACTER COL(0:149,0:49)
30632       PARAMETER (DEPS = 1.D-10)
30633 C
30634       DATA SYMB /'0','e','z','#','x'/
30635 C
30636       ISPALT=IBREIT-10
30637 C
30638 C***  automatic range fitting
30639 C
30640       XMAX=X(1)
30641       XMIN=X(1)
30642       DO 600 I=1,N
30643          XMAX=MAX(X(I),XMAX)
30644          XMIN=MIN(X(I),XMIN)
30645  600  CONTINUE
30646       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30647 C
30648       ITEST=0
30649       DO 1100 K=0,IZEIL-1
30650          ITEST=ITEST+1
30651          IF (ITEST.EQ.IYRAST) THEN
30652             DO 1010 L=1,ISPALT-1
30653                COL(L,K)='-'
30654 1010        CONTINUE
30655             COL(ISPALT,K)='+'
30656             ITEST=0
30657             DO 1020 L=0,ISPALT-1,IXRAST
30658                COL(L,K)='+'
30659 1020        CONTINUE
30660          ELSE
30661             DO 1030 L=1,ISPALT-1
30662                COL(L,K)=' '
30663 1030        CONTINUE
30664             DO 1040 L=0,ISPALT-1,IXRAST
30665                COL(L,K)='|'
30666 1040        CONTINUE
30667             COL(ISPALT,K)='|'
30668          ENDIF
30669 1100  CONTINUE
30670 C
30671 C***  plot curve Y1
30672 C
30673       YMAX=Y1(1)
30674       YMIN=MAX(Y1(1),EPS)
30675       DO 500 I=1,N
30676          YMAX =MAX(Y1(I),YMAX)
30677          IF(Y1(I).GT.EPS) THEN
30678            IF(YMIN.EQ.EPS) THEN
30679              YMIN = Y1(I)/10.D0
30680            ELSE
30681              YMIN = MIN(Y1(I),YMIN)
30682            ENDIF
30683          ENDIF
30684 500   CONTINUE
30685       IF(IARG.GT.1) THEN
30686         DO 550 I=1,N
30687            YMAX=MAX(Y2(I),YMAX)
30688            IF(Y2(I).GT.EPS) THEN
30689              IF(YMIN.EQ.EPS) THEN
30690                YMIN = Y2(I)
30691              ELSE
30692                YMIN = MIN(Y2(I),YMIN)
30693              ENDIF
30694            ENDIF
30695 550     CONTINUE
30696       ENDIF
30697 C
30698       DO 560 I=1,N
30699         Y1(I) = MAX(Y1(I),YMIN)
30700  560  CONTINUE
30701       IF(IARG.GT.1) THEN
30702         DO 570 I=1,N
30703           Y2(I) = MAX(Y2(I),YMIN)
30704  570    CONTINUE
30705       ENDIF
30706 C
30707       IF(YMAX.LE.YMIN) THEN
30708         WRITE(LOUT,'(/1X,A,2E12.3,/)')
30709      &     'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30710         WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30711         RETURN
30712       ENDIF
30713 C
30714       YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30715       YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30716       YZOOM=(YMA-YMI)/DBLE(IZEIL)
30717       IF(YZOOM.LT.EPS) THEN
30718         WRITE(LOUT,'(1X,A)')
30719      &    'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30720         RETURN
30721       ENDIF
30722 C
30723 C***  plot curve Y1
30724 C
30725       ILAST=-1
30726       LLAST=-1
30727       DO 1200 K=1,N
30728          L=NINT((X(K)-XMIN)/XZOOM)
30729          I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30730          IF(ILAST.GE.0) THEN
30731            LD = L-LLAST
30732            ID = I-ILAST
30733            DO 55 II=0,LD,SIGN(1,LD)
30734              DO 66 KK=0,ID,SIGN(1,ID)
30735                COL(II+LLAST,KK+ILAST)=SYMB(1)
30736  66          CONTINUE
30737  55        CONTINUE
30738          ELSE
30739            COL(L,I)=SYMB(1)
30740          ENDIF
30741          ILAST = I
30742          LLAST = L
30743 1200  CONTINUE
30744 C
30745       IF(IARG.GT.1) THEN
30746 C
30747 C***  plot curve Y2
30748 C
30749         DO 1250 K=1,N
30750            L=NINT((X(K)-XMIN)/XZOOM)
30751            I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30752            COL(L,I)=SYMB(2)
30753 1250    CONTINUE
30754       ENDIF
30755 C
30756 C***  write it
30757 C
30758       WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30759       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30760 C
30761 C***  write range of X
30762 C
30763       XZOOM1 = (XMAX-XMIN)/DBLE(7)
30764       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30765 C
30766       DO 1300 K=0,IZEIL-1
30767          YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30768          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30769  110     FORMAT(1X,1PE9.2,70A1)
30770 1300  CONTINUE
30771 C
30772 C***  write range of X
30773 C
30774       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30775       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30776  120  FORMAT(6X,7(1PE10.3))
30777 C
30778       END
30779
30780 *$ CREATE DT_SRPLOT.FOR
30781 *COPY DT_SRPLOT
30782 *
30783 *===plot===============================================================*
30784 *
30785       SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30786
30787       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30788       SAVE
30789
30790       PARAMETER ( LINP = 10 ,
30791      &            LOUT = 6 ,
30792      &            LDAT = 9 )
30793 *
30794 *     initial version
30795 *     J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30796 *     This is a subroutine of fluka to plot Y across the page
30797 *     as a function of X down the page. Up to 37 curves can be
30798 *     plotted in the same picture with different plotting characters.
30799 *     Output of first 10 overprinted characters addad by FB 88
30800 *  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30801 *
30802 *     Input Variables:
30803 *        X   = array containing the values of X
30804 *        Y   = array containing the values of Y
30805 *        N   = number of values in X and in Y
30806 *              can exceed the fixed number of lines
30807 *        M   = number of different curves X,Y are containing
30808 *        MM  = number of points in each curve i.e. N=M*MM
30809 *        XO  = smallest value of X to be plotted
30810 *        DX  = increment of X between subsequent lines
30811 *        YO  = smallest value of Y to be plotted
30812 *        DY  = increment of Y between subsequent character spaces
30813 *
30814 *        other variables used inside:
30815 *        XX  = numbers along the X-coordinate axis
30816 *        YY  = numbers along the Y-coordinate axis
30817 *        LL  = ten lines temporary storage for the plot
30818 *        L   = character set used to plot different curves
30819 *        LOV = memorizes overprinted symbols
30820 *              the first 10 overprinted symbols are printed on
30821 *              the end of the line to avoid ambiguities
30822 *              (added by FB as considered quite helpful)
30823 *
30824 *********************************************************************
30825 *
30826       DIMENSION XX(61),YY(61),LL(101,10)
30827       DIMENSION X(N),Y(N),L(40),LOV(40,10)
30828       INTEGER*4 LL, L, LOV
30829       DATA  L/
30830      11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30831      21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30832      31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30833      41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H  /
30834 *
30835 *
30836       MN=51
30837       DO 10 I=1,MN
30838         AI=I-1
30839    10 XX(I)=XO+AI*DX
30840       DO 20 I=1,11
30841         AI=I-1
30842    20 YY(I)=YO+10.0D0*AI*DY
30843       WRITE(LOUT, 500) (YY(I),I=1,11)
30844       MMN=MN-1
30845 *
30846 *
30847       DO 90 JJ=1,MMN,10
30848         JJJ=JJ-1
30849         DO 30 I=1,101
30850           DO 30 J=1,10
30851    30   LL(I,J)=L(40)
30852         DO 40 I=1,101
30853    40   LL(I,1)=L(39)
30854         DO 50 I=1,101,10
30855           DO 50 J=1,10
30856    50   LL(I,J)=L(38)
30857         DO 60 I=1,40
30858           DO 60 J=1,10
30859    60   LOV(I,J)=L(40)
30860 *
30861 *
30862         DO 70 I=1,M
30863           DO 70 J=1,MM
30864             II=J+(I-1)*MM
30865             AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30866             AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30867             AIX=AIX-DBLE(JJJ)
30868 *           changed Sept.88 by FB to avoid INTEGER OVERFLOW
30869             IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30870      +      . AIY .LT. 102.D0) THEN
30871               IX=INT(AIX)
30872               IY=INT(AIY)
30873               IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30874      +        THEN
30875                 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30876      +          =LL(IY,IX)
30877                 LL(IY,IX)=L(I)
30878               ENDIF
30879             ENDIF
30880    70   CONTINUE
30881 *
30882 *
30883         DO 80 I=1,10
30884           II=I+JJJ
30885           III=II+1
30886           WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30887      &                    (LOV(J,I),J=1,10)
30888    80   CONTINUE
30889    90 CONTINUE
30890 *
30891 *
30892       WRITE(LOUT, 520)
30893       WRITE(LOUT, 500) (YY(I),I=1,11)
30894       RETURN
30895 *
30896   500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30897   510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30898   520 FORMAT(20X,10('1---------'),'1')
30899       END
30900
30901 *$ CREATE DT_DEFSET.FOR
30902 *COPY DT_DEFSET
30903 *
30904 *===defset=============================================================*
30905 *
30906       BLOCK DATA DT_DEFSET
30907
30908       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30909       SAVE
30910
30911 * flags for input different options
30912       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30913       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30914      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30915       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30916 * emulsion treatment
30917       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30918      &                NCOMPO,IEMUL
30919
30920 * / DTFLG1 /
30921       DATA IFRAG  / 2, 1 /
30922       DATA IRESCO / 1 /
30923       DATA IMSHL  / 1 /
30924       DATA IRESRJ / 0 /
30925       DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30926       DATA LEMCCK / .FALSE. /
30927       DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30928      &              .TRUE.,.TRUE.,.TRUE./
30929       DATA LSEADI / .TRUE. /
30930       DATA LEVAPO / .TRUE. /
30931       DATA IFRAME / 1 /
30932       DATA ITRSPT / 0 /
30933
30934 * / DTCOMP /
30935       DATA EMUFRA / NCOMPX*0.0D0 /
30936       DATA IEMUMA / NCOMPX*1 /
30937       DATA IEMUCH / NCOMPX*1 /
30938       DATA NCOMPO / 0 /
30939       DATA IEMUL  / 0 /
30940
30941       END
30942
30943 *$ CREATE DT_HADPRP.FOR
30944 *COPY DT_HADPRP
30945 *
30946 *===hadprp=============================================================*
30947 *
30948       BLOCK DATA DT_HADPRP
30949
30950       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30951       SAVE
30952
30953 * auxiliary common for reggeon exchange (DTUNUC 1.x)
30954       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30955      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30956      &                IQTCHR(-6:6),MQUARK(3,39)
30957 * hadron index conversion (BAMJET <--> PDG)
30958       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30959      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
30960      &                IAMCIN(210)
30961 * names of hadrons used in input-cards
30962       CHARACTER*8 BTYPE
30963       COMMON /DTPAIN/ BTYPE(30)
30964
30965 * / DTQUAR /
30966 *----------------------------------------------------------------------*
30967 *                                                                      *
30968 *     Quark content of particles:                                      *
30969 *          index   quark   el. charge  bar. charge  isospin  isospin3  *
30970 *              1 = u          2/3          1/3        1/2       1/2    *
30971 *             -1 = ubar      -2/3         -1/3        1/2      -1/2    *
30972 *              2 = d         -1/3          1/3        1/2      -1/2    *
30973 *             -2 = dbar       1/3         -1/3        1/2       1/2    *
30974 *              3 = s         -1/3          1/3         0         0     *
30975 *             -3 = sbar       1/3         -1/3         0         0     *
30976 *              4 = c          2/3          1/3         0         0     *
30977 *             -4 = cbar      -2/3         -1/3         0         0     *
30978 *              5 = b         -1/3          1/3         0         0     *
30979 *             -5 = bbar       1/3         -1/3         0         0     *
30980 *              6 = t          2/3          1/3         0         0     *
30981 *             -6 = tbar      -2/3         -1/3         0         0     *
30982 *                                                                      *
30983 *         Mquark = particle quark composition (Paprop numbering)       *
30984 *         Iqechr = electric charge ( in 1/3 unit )                     *
30985 *         Iqbchr = baryonic charge ( in 1/3 unit )                     *
30986 *         Iqichr = isospin ( in 1/2 unit ), z component                *
30987 *         Iqschr = strangeness                                         *
30988 *         Iqcchr = charm                                               *
30989 *         Iquchr = beauty                                              *
30990 *         Iqtchr = ......                                              *
30991 *                                                                      *
30992 *----------------------------------------------------------------------*
30993       DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
30994       DATA IQBCHR / 6*-1, 0, 6*1 /
30995       DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
30996       DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
30997       DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
30998       DATA IQUCHR / 0, 1, 9*0, -1, 0 /
30999       DATA IQTCHR / -1, 11*0, 1 /
31000       DATA MQUARK /
31001      &   2, 1, 1,   -2,-1,-1,    0, 0, 0,    0, 0, 0,    0, 0, 0,
31002      &   0, 0, 0,    0, 0, 0,    2, 2, 1,   -2,-2,-1,    0, 0, 0,
31003      &   0, 0, 0,    0, 0, 0,    1,-2, 0,    2,-1, 0,    1,-3, 0,
31004      &   3,-1, 0,    1, 2, 3,   -1,-2,-3,    0, 0, 0,    2, 2, 3,
31005      &   1, 1, 3,    1, 2, 3,    1,-1, 0,    2,-3, 0,    3,-2, 0,
31006      &   2,-2, 0,    3,-3, 0,    0, 0, 0,    0, 0, 0,    0, 0, 0,
31007      &  -1,-1,-3,   -1,-2,-3,   -2,-2,-3,    1, 3, 3,   -1,-3,-3,
31008      &   2, 3, 3,   -2,-3,-3,    3, 3, 3,   -3,-3,-3 /
31009
31010 * / DTHAIC /
31011 * (renamed) (HAdron InDex COnversion)
31012 * translation table version filled up by r.e. 25.01.94                 *
31013       DATA IAMCIN /
31014      &2212,-2212,11,-11,12,              -12,22,2112,-2112,-13,
31015      &13,130,211,-211,321,               -321,3122,-3122,310,3112,
31016      &3222,3212,111,311,-311,            0,0,0,0,0,
31017      &221,213,113,-213,223,              323,313,-323,-313,10323,
31018      &10313,-10323,-10313,30323,30313,   -30323,-30313,3224,3214,3114,
31019      &3216,3218,2224,2214,2114,          1114,12224,12214,12114,11114,
31020      &99999,99999,22212,22112,32124,     31214,-2224,-2214,-2114,-1114,
31021      &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
31022      &5*99999,                           5*99999,
31023      &4*99999,331,                       333,3322,3312,-3222,-3212,
31024      &-3112,-3322,-3312,3224,3214,       3114,3324,3314,3334,-3224,
31025      &-3214,-3114,-3324,-3314,-3334,     421,411,-411,-421,431,
31026      &-431,441,423,413,-413,             -423,433,-433,20443,443,
31027      &-15,15,16,-16,14,                  -14,4122,4232,4132,4222,
31028      &4212,4112,3*99999,                 3*99999,-4122,-4232,
31029      &-4132,-4222,-4212,-4112,99999,     5*99999,
31030      &5*99999,                           5*99999,
31031      &10*99999,
31032      &5*99999 , 20211,20111,-20211,99999,20321,
31033      &-20321,20311,-20311,7*99999 ,
31034      &7*99999,12212,12112,99999/
31035
31036 * / DTHAIC /
31037 * (HAdron InDex COnversion)
31038       DATA (IPDG2(1,K),K=1,7)
31039      &   /   -11,   -12,   -13,   -15,   -16,   -14,     0/
31040       DATA (IBAM2(1,K),K=1,7)
31041      &   /     4,     6,    10,   131,   134,   136,     0/
31042       DATA (IPDG2(2,K),K=1,7)
31043      &   /    11,    12,    22,    13,    15,    16,    14/
31044       DATA (IBAM2(2,K),K=1,7)
31045      &   /     3,     5,     7,    11,   132,   133,   135/
31046       DATA (IPDG3(1,K),K=1,22)
31047      &   /  -211,  -321,  -311,  -213,  -323,  -313,  -411,  -421,
31048      &      -431,  -413,  -423,  -433,     0,     0,     0,     0,
31049      &         0,     0,     0,     0,     0,     0/
31050       DATA (IBAM3(1,K),K=1,22)
31051      &   /    14,    16,    25,    34,    38,    39,   118,   119,
31052      &       121,   125,   126,   128,     0,     0,     0,     0,
31053      &         0,     0,     0,     0,     0,     0/
31054       DATA (IPDG3(2,K),K=1,22)
31055      &   /   130,   211,   321,   310,   111,   311,   221,   213,
31056      &       113,   223,   323,   313,   331,   333,   421,   411,
31057      &       431,   441,   423,   413,   433,   443/
31058       DATA (IBAM3(2,K),K=1,22)
31059      &   /    12,    13,    15,    19,    23,    24,    31,    32,
31060      &        33,    35,    36,    37,    95,    96,   116,   117,
31061      &       120,   122,   123,   124,   127,   130/
31062       DATA (IPDG4(1,K),K=1,29)
31063      &   / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
31064      &     -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31065      &     -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31066      &     -4212, -4112,     0,     0,     0/
31067       DATA (IBAM4(1,K),K=1,29)
31068      &   /     2,     9,    18,    67,    68,    69,    70,    75,
31069      &        76,    99,   100,   101,   102,   103,   110,   111,
31070      &       112,   113,   114,   115,   149,   150,   151,   152,
31071      &       153,   154,     0,     0,     0/
31072       DATA (IPDG4(2,K),K=1,29)
31073      &   /  2212,  2112,  3122,  3112,  3222,  3212,  3224,  3214,
31074      &      3114,  3216,  3218,  2224,  2214,  2114,  1114,  3322,
31075      &      3312,  3224,  3214,  3114,  3324,  3314,  3334,  4122,
31076      &      4232,  4132,  4222,  4212,  4112/
31077       DATA (IBAM4(2,K),K=1,29)
31078      &   /     1,     8,    17,    20,    21,    22,    48,    49,
31079      &        50,    51,    52,    53,    54,    55,    56,    97,
31080      &        98,   104,   105,   106,   107,   108,   109,   137,
31081      &       138,   139,   140,   141,   142/
31082       DATA (IPDG5(1,K),K=1,19)
31083      &   /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31084      &    -20211,-20321,-20311,     0,     0,     0,     0,     0,
31085      &         0,     0,     0/
31086       DATA (IBAM5(1,K),K=1,19)
31087      &   /    42,    43,    46,    47,    71,    72,    73,    74,
31088      &       188,   191,   193,     0,     0,     0,     0,     0,
31089      &         0,     0,     0/
31090       DATA (IPDG5(2,K),K=1,19)
31091      &   / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31092      &     22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31093      &     20311, 12212, 12112/
31094       DATA (IBAM5(2,K),K=1,19)
31095      &   /    40,    41,    44,    45,    57,    58,    59,    60,
31096      &        63,    64,    65,    66,   129,   186,   187,   190,
31097      &       192,   208,   209/
31098
31099 * / DTPAIN /
31100 * internal particle names
31101       DATA BTYPE / 'PROTON  ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31102      &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON  ' , 'NEUTRON ' , 'ANEUTRON' ,
31103      &'MUON+   ' , 'MUON-   ' , 'KAONLONG' , 'PION+   ' , 'PION-   ' ,
31104      &'KAON+   ' , 'KAON-   ' , 'LAMBDA  ' , 'ALAMBDA ' , 'KAONSHRT' ,
31105      &'SIGMA-  ' , 'SIGMA+  ' , 'SIGMAZER' , 'PIZERO  ' , 'KAONZERO' ,
31106      &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31107      &'BLANK   ' /
31108
31109       END
31110
31111 *$ CREATE DT_BLKD46.FOR
31112 *COPY DT_BLKD46
31113 *
31114 *===blkd46=============================================================*
31115 *
31116       BLOCK DATA DT_BLKD46
31117
31118       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31119       SAVE
31120
31121       PARAMETER ( AMELCT = 0.51099906         D-03 )
31122       PARAMETER ( AMMUON = 0.105658389        D+00 )
31123
31124 * particle properties (BAMJET index convention)
31125       CHARACTER*8  ANAME
31126       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31127      &                IICH(210),IIBAR(210),K1(210),K2(210)
31128
31129 * / DTPART /
31130 * Particle  masses Engel version JETSET compatible
31131 C     DATA (AAM(K),K=1,85) /
31132 C    &   .9383D+00, .9383D+00,  AMELCT  ,  AMELCT  , .0000D+00,
31133 C    &   .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON   ,
31134 C    &   AMMUON   , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31135 C    &   .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31136 C    &   .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31137 C    &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31138 C    &   .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31139 C    &   .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31140 C    &   .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31141 C    &   .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31142 C    &   .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31143 C    &   .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31144 C    &   .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31145 C    &   .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31146 C    &   .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31147 C    &   .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31148 C    &   .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01  /
31149 C     DATA (AAM(K),K=86,183) /
31150 C    &   .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31151 C    &   .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31152 C    &   .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31153 C    &   .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31154 C    &   .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31155 C    &   .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31156 C    &   .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31157 C    &   .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31158 C    &   .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31159 C    &   .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31160 C    &   .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31161 C    &   .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31162 C    &   .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31163 C    &   .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31164 C    &   .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31165 C    &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31166 C    &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31167 C    &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31168 C    &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31169 C    &   .1250D+01, .1250D+01, .1250D+01  /
31170 C     DATA (AAM ( I ), I = 184,210 ) /
31171 C    & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31172 C    & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31173 C    & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31174 C    & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31175 C    & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31176 C    & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31177 C    & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31178 C    & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31179 C    & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31180 * sr 25.1.06: particle masses adjusted to Pythia
31181       DATA (AAM(K),K=1,85) /
31182      &   .938270E+00,.938270E+00, AMELCT    , AMELCT    ,.000000E+00,
31183      &   .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON    ,
31184      &    AMMUON    ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31185      &   .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31186      &   .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31187      &     .0000D+00,  .0000D+00,  .0000D+00 , .0000D+00,  .0000D+00,
31188      &   .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31189      &   .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31190      &   .129000E+01,.129000E+01,.129000E+01,  .1421D+01,  .1421D+01,
31191      &     .1421D+01,  .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31192      &     .1820D+01,  .2030D+01,  .1231D+01,  .1232D+01,  .1233D+01,
31193      &     .1234D+01,  .1675D+01,  .1675D+01,  .1675D+01,  .1675D+01,
31194      &     .1500D+01,  .1500D+01,  .1515D+01,  .1515D+01,  .1775D+01,
31195      &     .1775D+01,  .1231D+01,  .1232D+01,  .1233D+01,  .1234D+01,
31196      &     .1675D+01,  .1675D+01,  .1675D+01,  .1675D+01,  .1515D+01,
31197      &     .1515D+01,  .2500D+01,  .4890D+00,  .4890D+00,  .4890D+00,
31198      &     .1300D+01,  .1300D+01,  .1300D+01,  .1300D+01,  .2200D+01  /
31199       DATA (AAM(K),K=86,183) /
31200      &     .2200D+01,  .2200D+01,  .2200D+01,  .1700D+01,  .1700D+01,
31201      &     .1700D+01,  .1700D+01,  .1820D+01,  .2030D+01,.957770E+00,
31202      &   .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31203      &   .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31204      &   .138720E+01,.153180E+01,  .1535D+01,.167245E+01,.138280E+01,
31205      &   .138370E+01,.138720E+01,.153180E+01,  .1535D+01,.167245E+01,
31206      &   .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31207      &   .196850E+01,.297980E+01,.200670E+01,  .2010D+01,  .2010D+01,
31208      &   .200670E+01,.211240E+01,.211240E+01,  .3686D+01,.309688E+01,
31209      &   .177700E+01,.177700E+01,  .0000D+00,  .0000D+00,  .0000D+00,
31210      &     .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31211      &   .245350E+01,.245210E+01,  .2560D+01,  .2560D+01,  .2730D+01,
31212      &     .3610D+01,  .3610D+01,  .3790D+01,.228490E+01,.246560E+01,
31213      &     .2460D+01,.245290E+01,.245350E+01,.245210E+01,  .2560D+01,
31214      &     .2560D+01,  .2730D+01,  .3610D+01,  .3610D+01,  .3790D+01,
31215      &     .2490D+01,  .2490D+01,  .2490D+01,  .2610D+01,  .2610D+01,
31216      &     .2770D+01,  .3670D+01,  .3670D+01,  .3850D+01,  .4890D+01,
31217      &     .2490D+01,  .2490D+01,  .2490D+01,  .2610D+01,  .2610D+01,
31218      &     .2770D+01,  .3670D+01,  .3670D+01,  .3850D+01,  .4890D+01,
31219      &     .1250D+01,  .1250D+01,  .1250D+01  /
31220       DATA (AAM ( I ), I = 184,210 ) /
31221      & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31222      & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31223      & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31224      & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31225      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31226      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31227      & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31228      & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31229      & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31230 * Particle  mean lives
31231       DATA (TAU(K),K=1,183) /
31232      &   .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31233      &   .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31234      &   .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31235      &   .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31236      &   .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31237      &   70*.0000D+00,
31238      &   .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31239      &   .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31240      &   .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31241      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31242      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31243      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31244      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31245      &   .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31246      &   .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31247      &   40*.0000D+00,
31248      &   .0000D+00, .0000D+00, .0000D+00  /
31249       DATA ( TAU ( I ), I = 184,210 ) /
31250      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31251      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31252      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31253      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31254      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31255      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31256      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31257      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31258      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
31259 * Resonance width Gamma in GeV
31260       DATA (GA(K),K=  1,85) /
31261      &    30*.0000D+00,
31262      &   .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31263      &   .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31264      &   .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31265      &   .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31266      &   .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31267      &   .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31268      &   .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31269      &   .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31270      &   .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31271      &   .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31272      &   .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00  /
31273       DATA (GA(K),K= 86,183) /
31274      &   .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31275      &   .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31276      &   .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31277      &   .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31278      &   .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31279      &   .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31280      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31281      &   .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31282      &   .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31283      &   50*.0000D+00,
31284      &   .3000D+00, .3000D+00, .3000D+00  /
31285       DATA ( GA ( I ), I = 184,210 ) /
31286      & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31287      & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31288      & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31289      & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31290      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31291      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31292      & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31293      & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31294      & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31295 * Particle  names
31296 * S+1385+Sigma+(1385)    L02030+Lambda0(2030)
31297 * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31298 * designation N*@@ means N*@1(@2)
31299       DATA (ANAME(K),K=1,85) /
31300      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
31301      &  'ANUE    ','GAM     ','NEU     ','ANEU    ','MUE+    ',
31302      &  'MUE-    ','K0L     ','PI+     ','PI-     ','K+      ',
31303      &  'K-      ','LAM     ','ALAM    ','K0S     ','SIGM-   ',
31304      &  'SIGM+   ','SIGM0   ','PI0     ','K0      ','AK0     ',
31305      &  'BLANK   ','BLANK   ','BLANK   ','BLANK   ','BLANK   ',
31306      &  'ETA550  ','RHO+77  ','RHO077  ','RHO-77  ','OM0783  ',
31307      &  'K*+892  ','K*0892  ','K*-892  ','AK*089  ','KA+125  ',
31308      &  'KA0125  ','KA-125  ','AKA012  ','K*+142  ','K*0142  ',
31309      &  'K*-142  ','AK*014  ','S+1385  ','S01385  ','S-1385  ',
31310      &  'L01820  ','L02030  ','N*++12  ','N*+ 12  ','N*012   ',
31311      &  'N*-12   ','N*++16  ','N*+16   ','N*016   ','N*-16   ',
31312      &  'N*+14   ','N*014   ','N*+15   ','N*015   ','N*+18   ',
31313      &  'N*018   ','AN--12  ','AN*-12  ','AN*012  ','AN*+12  ',
31314      &  'AN--16  ','AN*-16  ','AN*016  ','AN*+16  ','AN*-15  ',
31315      &  'AN*015  ','DE*=24  ','RPI+49  ','RPI049  ','RPI-49  ',
31316      &  'PIN++   ','PIN+0   ','PIN+-   ','PIN-0   ','PPPI    ' /
31317       DATA (ANAME(K),K=86,183) /
31318      &  'PNPI    ','APPPI   ','APNPI   ','K+PPI   ','K-PPI   ',
31319      &  'K+NPI   ','K-NPI   ','S+1820  ','S-2030  ','ETA*    ',
31320      &  'PHI     ','TETA0   ','TETA-   ','ASIG-   ','ASIG0   ',
31321      &  'ASIG+   ','ATETA0  ','ATETA+  ','SIG*+   ','SIG*0   ',
31322      &  'SIG*-   ','TETA*0  ','TETA*   ','OMEGA-  ','ASIG*-  ',
31323      &  'ASIG*0  ','ASIG*+  ','ATET*0  ','ATET*+  ','OMEGA+  ',
31324      &  'D0      ','D+      ','D-      ','AD0     ','F+      ',
31325      &  'F-      ','ETAC    ','D*0     ','D*+     ','D*-     ',
31326      &  'AD*0    ','F*+     ','F*-     ','PSI     ','JPSI    ',
31327      &  'TAU+    ','TAU-    ','NUET    ','ANUET   ','NUEM    ',
31328      &  'ANUEM   ','C0+     ','A+      ','A0      ','C1++    ',
31329      &  'C1+     ','C10     ','S+      ','S0      ','T0      ',
31330      &  'XU++    ','XD+     ','XS+     ','AC0-    ','AA-     ',
31331      &  'AA0     ','AC1--   ','AC1-    ','AC10    ','AS-     ',
31332      &  'AS0     ','AT0     ','AXU--   ','AXD-    ','AXS     ',
31333      &  'C1*++   ','C1*+    ','C1*0    ','S*+     ','S*0     ',
31334      &  'T*0     ','XU*++   ','XD*+    ','XS*+    ','TETA++  ',
31335      &  'AC1*--  ','AC1*-   ','AC1*0   ','AS*-    ','AS*0    ',
31336      &  'AT*0    ','AXU*--  ','AXD*-   ','AXS*-   ','ATET--  ',
31337      &  'RO      ','R+      ','R-      '  /
31338       DATA (    ANAME ( I ), I = 184,210 ) /
31339      &'AN*-14  ','AN*014  ','PI+130  ','PI0130  ','PI-130  ','F01400  ',
31340      &'K*+146  ','K*-146  ','K*0146  ','AK0146  ','L01600  ','AL0160  ',
31341      &'S+1660  ','S01660  ','S-1660  ','AS-166  ','AS0166  ','AS+166  ',
31342      &'X01950  ','X-1950  ','AX0195  ','AX+195  ','OM-225  ','AOM+22  ',
31343      &'N*+14   ','N*014   ','BLANK   '/
31344 * Charge of particles and resonances
31345       DATA (IICH ( I ), I =   1,210 ) /
31346      &  1, -1, -1,  1,  0,  0,  0,  0,  0,  1, -1,  0,  1, -1,  1,
31347      & -1,  0,  0,  0, -1,  1,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31348      &  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0,
31349      & -1,  0,  1,  0, -1,  0,  0,  2,  1,  0, -1,  2,  1,  0, -1,
31350      &  1,  0,  1,  0,  1,  0, -2, -1,  0,  1, -2, -1,  0,  1, -1,
31351      &  0,  1,  1,  0, -1,  2,  1,  0, -1,  2,  1,  0, -1,  2,  0,
31352      &  1, -1,  1, -1,  0,  0,  0, -1, -1,  0,  1,  0,  1,  1,  0,
31353      & -1,  0, -1, -1, -1,  0,  1,  0,  1,  1,  0,  1, -1,  0,  1,
31354      & -1,  0,  0,  1, -1,  0,  1, -1,  0,  0,  1, -1,  0,  0,  0,
31355      &  0,  1,  1,  0,  2,  1,  0,  1,  0,  0,  2,  1,  1, -1, -1,
31356      &  0, -2, -1,  0, -1,  0,  0, -2, -1, -1,  2,  1,  0,  1,  0,
31357      &  0,  2,  1,  1,  2, -2, -1,  0, -1,  0,  0, -2, -1, -1, -2,
31358      &  0,  1, -1, -1,  0,  1,  0, -1,  0,  1, -1,  0,  0,  0,  0,
31359      &  1,  0, -1, -1,  0,  1,  0, -1,  0,  1, -1,  1,  1,  0,  0/
31360 * Particle  baryonic charges
31361       DATA (IIBAR ( I ), I =   1,210 ) /
31362      &  1, -1,  0,  0,  0,  0,  0,  1, -1,  0,  0,  0,  0,  0,  0,
31363      &  0,  1, -1,  0,  1,  1,  1,  0,  0,  0,  0,  0,  0,  0,  0,
31364      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31365      &  0,  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
31366      &  1,  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31367      & -1,  2,  0,  0,  0,  1,  1,  1,  1,  2,  2,  0,  0,  1,  1,
31368      &  1,  1,  1,  1,  0,  0,  1,  1, -1, -1, -1, -1, -1,  1,  1,
31369      &  1,  1,  1,  1, -1, -1, -1, -1, -1, -1,  0,  0,  0,  0,  0,
31370      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31371      &  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1, -1, -1,
31372      & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,  1,  1,  1,  1,  1,
31373      &  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31374      &  0,  0,  0, -1, -1,  0,  0,  0,  0,  0,  0,  0,  0,  1, -1,
31375      &  1,  1,  1, -1, -1, -1,  1,  1, -1, -1,  1, -1,  1,  1,  0/
31376 * First number of decay channels used for resonances
31377 * and decaying particles
31378       DATA K1/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 16, 17,
31379      &  18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31380      &   2*330, 46, 51, 52, 54, 55, 58,
31381 *                                                             50
31382      &  60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31383      & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31384      & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31385 *                                         85
31386      & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31387      & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31388      & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31389      & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31390      & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31391      & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31392      & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31393      & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31394      & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31395      & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31396      & 590, 596, 602 /
31397 * Last number of decay channels used for resonances
31398 * and decaying particles
31399       DATA K2/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 15, 16, 17,
31400      & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31401      & 2* 330, 50, 51, 53, 54, 57,
31402 *                                                                 50
31403      & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31404      & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31405      & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31406 *                                              85
31407      & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31408      & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31409      & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31410      & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31411      & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31412      & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31413      & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31414      & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31415      & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31416      & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31417      & 589, 595, 601, 602 /
31418
31419        END
31420
31421 *$ CREATE DT_BLKD47.FOR
31422 *COPY DT_BLKD47
31423 *
31424 *===blkd47=============================================================*
31425 *
31426       BLOCK DATA DT_BLKD47
31427
31428       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31429       SAVE
31430
31431 * HADRIN: decay channel information
31432       PARAMETER (IDMAX9=602)
31433       CHARACTER*8 ZKNAME
31434       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31435
31436 * Name of decay channel
31437 * Designation N*@ means N*@1(1236)
31438 * @1=# means ++,  @1 = = means --
31439 * Designation  P+/0/- means Pi+/Pi0/Pi- , respectively
31440       DATA (ZKNAME(K),K=  1, 85) /
31441      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
31442      &  'ANUE    ','GAM     ','PE-NUE  ','APEANU  ','EANUNU  ',
31443      &  'E-NUAN  ','3PI0    ','PI+-0   ','PIMUNU  ','PIE-NU  ',
31444      &  'MU+NUE  ','MU-NUE  ','MU+NUE  ','PI+PI0  ','PI++-   ',
31445      &  'PI+00   ','M+P0NU  ','E+P0NU  ','MU-NU   ','PI-0    ',
31446      &  'PI+--   ','PI-00   ','M-P0NU  ','E-P0NU  ','PPI-    ',
31447      &  'NPI0    ','PD-NUE  ','PM-NUE  ','APPI+   ','ANPI0   ',
31448      &  'APE+NU  ','APM+NU  ','PI+PI-  ','PI0PI0  ','NPI-    ',
31449      &  'PPI0    ','NPI+    ','LAGA    ','GAGA    ','GAE+E-  ',
31450      &  'GAGA    ','GAGAP0  ','PI000   ','PI+-0   ','PI+-GA  ',
31451      &  'PI+0    ','PI+-    ','PI00    ','PI-0    ','PI+-0   ',
31452      &  'PI+-    ','PI0GA   ','K+PI0   ','K0PI+   ','KOPI0   ',
31453      &  'K+PI-   ','K-PI0   ','AK0PI-  ','AK0PI0  ','K-PI+   ',
31454      &  'K+PI0   ','K0PI+   ','K0PI0   ','K+PI-   ','K-PI0   ',
31455      &  'K0PI-   ','AK0PI0  ','K-PI+   ','K+PI0   ','K0PI+   ',
31456      &  'K+89P0  ','K08PI+  ','K+RO77  ','K0RO+7  ','K+OM07  ',
31457      &  'K+E055  ','K0PI0   ','K+PI+   ','K089P0  ','K+8PI-  '  /
31458       DATA (ZKNAME(K),K= 86,170) /
31459      &  'K0R077  ','K+R-77  ','K+R-77  ','K0OM07  ','K0E055  ',
31460      &  'K-PI0   ','K0PI-   ','K-89P0  ','AK08P-  ','K-R077  ',
31461      &  'AK0R-7  ','K-OM07  ','K-E055  ','AK0PI0  ','K-PI+   ',
31462      &  'AK08P0  ','K-8PI+  ','AK0R07  ','AK0OM7  ','AK0E05  ',
31463      &  'LA0PI+  ','SI0PI+  ','SI+PI0  ','LA0PI0  ','SI+PI-  ',
31464      &  'SI-PI+  ','LA0PI-  ','SI0PI-  ','NEUAK0  ','PK-     ',
31465      &  'SI+PI-  ','SI0PI0  ','SI-PI+  ','LA0ET0  ','S+1PI-  ',
31466      &  'S-1PI+  ','SO1PI0  ','NEUAK0  ','PK-     ','LA0PI0  ',
31467      &  'LA0OM0  ','LA0RO0  ','SI+RO-  ','SI-RO+  ','SI0RO0  ',
31468      &  'LA0ET0  ','SI0ET0  ','SI+PI-  ','SI-PI+  ','SI0PI0  ',
31469      &  'K0S     ','K0L     ','K0S     ','K0L     ','P PI+   ',
31470      &  'P PI0   ','N PI+   ','P PI-   ','N PI0   ','N PI-   ',
31471      &  'P PI+   ','N*#PI0  ','N*+PI+  ','PRHO+   ','P PI0   ',
31472      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
31473      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
31474      &  'N*-PI+  ','PRHO-   ','NRHO0   ','N PI-   ','N*0PI-  ',
31475      &  'N*-PI0  ','NRHO-   ','PETA0   ','N*#PI-  ','N*+PI0  '  /
31476       DATA (ZKNAME(K),K=171,255) /
31477      &  'N*0PI+  ','PRHO0   ','NRHO+   ','NETA0   ','N*+PI-  ',
31478      &  'N*0PI0  ','N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ',
31479      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
31480      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
31481      &  'N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ','N PI+   ',
31482      &  'PRHO0   ','NRHO+   ','LAMK+   ','S+ K0   ','S0 K+   ',
31483      &  'PETA0   ','P PI-   ','N PI0   ','PRHO-   ','NRHO0   ',
31484      &  'LAMK0   ','S0 K0   ','S- K+   ','NETA/   ','APPI-   ',
31485      &  'APPI0   ','ANPI-   ','APPI+   ','ANPI0   ','ANPI+   ',
31486      &  'APPI-   ','AN*=P0  ','AN*-P-  ','APRHO-  ','APPI0   ',
31487      &  'ANPI-   ','AN*=P+  ','AN*-P0  ','AN*0P-  ','APRHO0  ',
31488      &  'ANRHO-  ','APPI+   ','ANPI0   ','AN*-P+  ','AN*0P0  ',
31489      &  'AN*+P-  ','APRHO+  ','ANRHO0  ','ANPI+   ','AN*0P+  ',
31490      &  'AN*+P0  ','ANRHO+  ','APPI0   ','ANPI-   ','AN*=P+  ',
31491      &  'AN*-P0  ','AN*0P-  ','APRHO0  ','ANRHO-  ','APPI+,  ',
31492      &  'ANPI0   ','AN*-P+  ','AN*0P0  ','AN*+P-  ','APRHO+  ',
31493      &  'ANRHO0  ','PN*014  ','NN*=14  ','PI+0    ','PI+-    '  /
31494       DATA (ZKNAME(K),K=256,340) /
31495      &  'PI-0    ','P+0     ','N++     ','P+-     ','P00     ',
31496      &  'N+0     ','N+-     ','N00     ','P-0     ','N-0     ',
31497      &  'P--     ','PPPI0   ','PNPI+   ','PNPI0   ','PPPI-   ',
31498      &  'NNPI+   ','APPPI0  ','APNPI+  ','ANNPI0  ','ANPPI-  ',
31499      &  'APNPI0  ','APPPI-  ','ANNPI-  ','K+PPI0  ','K+NPI+  ',
31500      &  'K0PPI0  ','K-PPI0  ','K-NPI+  ','AKPPI-  ','AKNPI0  ',
31501      &  'K+NPI0  ','K+PPI-  ','K0PPI0  ','K0NPI+  ','K-NPI0  ',
31502      &  'K-PPI-  ','AKNPI-  ','PAK0    ','SI+PI0  ','SI0PI+  ',
31503      &  'SI+ETA  ','S+1PI0  ','S01PI+  ','NEUK-   ','LA0PI-  ',
31504      &  'SI-OM0  ','LA0RO-  ','SI0RO-  ','SI-RO0  ','SI-ET0  ',
31505      &  'SI0PI-  ','SI-0    ','BLANC   ','BLANC   ','BLANC   ',
31506      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31507      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31508      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31509      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31510      &  'EPI+-   ','EPI00   ','GAPI+-  ','GAGA*   ','K+-     ',
31511      &  'KLKS    ','PI+-0   ','EGA     ','LPI0    ','LPI     '  /
31512       DATA (ZKNAME(K),K=341,425) /
31513      &  'APPI0   ','ANPI-   ','ALAGA   ','ANPI    ','ALPI0   ',
31514      &  'ALPI+   ','LAPI+   ','SI+PI0  ','SI0PI+  ','LAPI0   ',
31515      &  'SI+PI-  ','SI-PI+  ','LAPI-   ','SI-PI0  ','SI0PI-  ',
31516      &  'TE0PI0  ','TE-PI+  ','TE0PI-  ','TE-PI0  ','TE0PI   ',
31517      &  'TE-PI   ','LAK-    ','ALPI-   ','AS-PI0  ','AS0PI-  ',
31518      &  'ALPI0   ','AS+PI-  ','AS-PI+  ','ALPI+   ','AS+PI0  ',
31519      &  'AS0PI+  ','AT0PI0  ','AT+PI-  ','AT0PI+  ','AT+PI0  ',
31520      &  'AT0PI   ','AT+PI   ','ALK+    ','K-PI+   ','K-PI+0  ',
31521      &  'K0PI+-  ','K0PI0   ','K-PI++  ','AK0PI+  ','K+PI--  ',
31522      &  'K0PI-   ','K+PI-   ','K+PI-0  ','AKPI-+  ','AK0PI0  ',
31523      &  'ETAPIF  ','K++-    ','K+AK0   ','ETAPI-  ','K--+    ',
31524      &  'K-K0    ','PI00    ','PI+-    ','GAGA    ','D0PI0   ',
31525      &  'D0GA    ','D0PI+   ','D+PI0   ','DFGA    ','AD0PI-  ',
31526      &  'D-PI0   ','D-GA    ','AD0PI0  ','AD0GA   ','F+GA    ',
31527      &  'F+GA    ','F-GA    ','F-GA    ','PSPI+-  ','PSPI00  ',
31528      &  'PSETA   ','E+E-    ','MUE+-   ','PI+-0   ','M+NN    ',
31529      &  'E+NN    ','RHO+NT  ','PI+ANT  ','K*+ANT  ','M-NN    '  /
31530       DATA (ZKNAME(K),K=426,510) /
31531      &  'E-NN    ','RHO-NT  ','PI-NT   ','K*-NT   ','NUET    ',
31532      &  'ANUET   ','NUEM    ','ANUEM   ','SI+ETA  ','SI+ET*  ',
31533      &  'PAK0    ','TET0K+  ','SI*+ET  ','N*+AK0  ','N*++K-  ',
31534      &  'LAMRO+  ','SI0RO+  ','SI+RO0  ','SI+OME  ','PAK*0   ',
31535      &  'N*+AK*  ','N*++K*  ','SI+AK0  ','TET0PI  ','SI+AK*  ',
31536      &  'TET0RO  ','SI0AK*  ','SI+K*-  ','TET0OM  ','TET-RO  ',
31537      &  'SI*0AK  ','C0+PI+  ','C0+PI0  ','C0+PI-  ','A+GAM   ',
31538      &  'A0GAM   ','TET0AK  ','TET0K*  ','OM-RO+  ','OM-PI+  ',
31539      &  'C1++AK  ','A+PI+   ','C0+AK0  ','A0PI+   ','A+AK0   ',
31540      &  'T0PI+   ','ASI-ET  ','ASI-E*  ','APK0    ','ATET0K  ',
31541      &  'ASI*-E  ','AN*-K0  ','AN*--K  ','ALAMRO  ','ASI0RO  ',
31542      &  'ASI-RO  ','ASI-OM  ','APK*0   ','AN*-K*  ','AN*--K  ',
31543      &  'ASI-K0  ','ATETPI  ','ASI-K*  ','ATETRO  ','ASI0K*  ',
31544      &  'ASI-K*  ','ATE0OM  ','ATE+RO  ','ASI*0K  ','AC-PI-  ',
31545      &  'AC-PI0  ','AC-PI+  ','AA-GAM  ','AA0GAM  ','ATET0K  ',
31546      &  'ATE0K*  ','AOM+RO  ','AOM+PI  ','AC1--K  ','AA-PI-  ',
31547      &  'AC0-K0  ','AA0PI-  ','AA-K0   ','AT0PI-  ','C1++GA  '  /
31548       DATA (ZKNAME(K),K=511,540) /
31549      &  'C1++GA  ','C10GAM  ','S+GAM   ','S0GAM   ','T0GAM   ',
31550      &  'XU++GA  ','XD+GAM  ','XS+GAM  ','A+AKPI  ','T02PI+  ',
31551      &  'C1++2K  ','AC1--G  ','AC1-GA  ','AC10GA  ','AS-GAM  ',
31552      &  'AS0GAM  ','AT0GAM  ','AXU--G  ','AXD-GA  ','AXS-GA  ',
31553      &  'AA-KPI  ','AT02PI  ','AC1--K  ','RH-PI+  ','RH+PI-  ',
31554      &  'RH3PI0  ','RH0PI+  ','RH+PI0  ','RH0PI-  ','RH-PI0  '  /
31555       DATA (ZKNAME(I),I=541,602)/
31556      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31557      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31558      & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31559      & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31560      & 'PI+PI-','K+K-  ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31561      & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31562      & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31563      & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31564      & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31565 * Weight of decay channel
31566       DATA (WT(K),K=  1, 85) /
31567      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31568      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31569      &   .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31570      &   .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31571      &   .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31572      &   .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31573      &   .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31574      &   .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31575      &   .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31576      &   .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31577      &   .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31578      &   .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31579      &   .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31580      &   .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31581      &   .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31582      &   .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31583      &   .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00  /
31584       DATA (WT(K),K= 86,170) /
31585      &   .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31586      &   .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31587      &   .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31588      &   .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31589      &   .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31590      &   .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31591      &   .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31592      &   .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31593      &   .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31594      &   .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31595      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31596      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31597      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31598      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31599      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31600      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31601      &   .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00  /
31602       DATA (WT(K),K=171,255) /
31603      &   .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31604      &   .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31605      &   .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31606      &   .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31607      &   .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31608      &   .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31609      &   .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31610      &   .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31611      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31612      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31613      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31614      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31615      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31616      &   .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31617      &   .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31618      &   .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31619      &   .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01  /
31620       DATA (WT(K),K=256,340) /
31621      &   .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31622      &   .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31623      &   .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31624      &   .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31625      &   .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31626      &   .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31627      &   .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31628      &   .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31629      &   .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31630      &   .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31631      &   .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31632      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31633      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31634      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31635      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31636      &   .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31637      &   .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01  /
31638       DATA (WT(K),K=341,425) /
31639      &   .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31640      &   .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31641      &   .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31642      &   .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31643      &   .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31644      &   .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31645      &   .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31646      &   .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31647      &   .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31648      &   .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31649      &   .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31650      &   .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31651      &   .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31652      &   .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31653      &   .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31654      &   .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31655      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00  /
31656       DATA (WT(K),K=426,510) /
31657      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31658      &   .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31659      &   .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31660      &   .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31661      &   .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31662      &   .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31663      &   .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31664      &   .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31665      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31666      &   .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31667      &   .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31668      &   .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31669      &   .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31670      &   .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31671      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31672      &   .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31673      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01  /
31674       DATA (WT(K),K=511,540) /
31675      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31676      &   .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31677      &   .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31678      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31679      &   .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31680      &   .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00  /
31681 C
31682       DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31683      & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31684      & .125D+00,  0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31685      & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31686      & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31687      & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31688      & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31689 * Particle numbers in decay channel
31690       DATA (NZK(K,1),K=  1,170) /
31691      &     1,   2,   3,   4,   5,   6,   7,   1,   2,   4,
31692      &     3,  23,  13,  13,  13,  10,  11,  10,  13,  13,
31693      &    13,  10,   4,  11,  14,  14,  14,  11,   3,   1,
31694      &     8,   1,   1,   2,   9,   2,   2,  13,  23,   8,
31695      &     1,   8,  17,   7,   7,   7,  23,  23,  13,  13,
31696      &    13,  13,  23,  14,  13,  13,  23,  15,  24,  24,
31697      &    15,  16,  25,  25,  16,  15,  24,  24,  15,  16,
31698      &    24,  25,  16,  15,  24,  36,  37,  15,  24,  15,
31699      &    15,  24,  15,  37,  36,  24,  15,  24,  24,  16,
31700      &    24,  38,  39,  16,  25,  16,  16,  25,  16,  39,
31701      &    38,  25,  16,  25,  25,  17,  22,  21,  17,  21,
31702      &    20,  17,  22,   8,   1,  21,  22,  20,  17,  48,
31703      &    50,  49,   8,   1,  17,  17,  17,  21,  20,  22,
31704      &    17,  22,  21,  20,  22,  19,  12,  19,  12,   1,
31705      &     1,   8,   1,   8,   8,   1,  53,  54,   1,   1,
31706      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
31707      &    56,   1,   8,   8,  55,  56,   8,   1,  53,  54  /
31708       DATA (NZK(K,1),K=171,340) /
31709      &    55,   1,   8,   8,  54,  55,  56,   1,   8,   1,
31710      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
31711      &    56,   1,   8,   1,   8,   1,   8,  17,  21,  22,
31712      &     1,   1,   8,   1,   8,  17,  22,  20,   8,   2,
31713      &     2,   9,   2,   9,   9,   2,  67,  68,   2,   2,
31714      &     9,  67,  68,  69,   2,   9,   2,   9,  68,  69,
31715      &    70,   2,   9,   9,  69,  70,   9,   2,   9,  67,
31716      &    68,  69,   2,   9,   2,   9,  68,  69,  70,   2,
31717      &     9,   1,   8,  13,  13,  14,   1,   8,   1,   1,
31718      &     8,   8,   8,   1,   8,   1,   1,   1,   1,   1,
31719      &     8,   2,   2,   9,   9,   2,   2,   9,  15,  15,
31720      &    24,  16,  16,  25,  25,  15,  15,  24,  24,  16,
31721      &    16,  25,   1,  21,  22,  21,  48,  49,   8,  17,
31722      &    20,  17,  22,  20,  20,  22,  20,   0,   0,   0,
31723      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31724      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31725      &    31,  31,  13,   7,  15,  12,  13,  31,  17,  17  /
31726       DATA (NZK(K,1),K=341,510) /
31727      &     2,   9,  18,   9,  18,  18,  17,  21,  22,  17,
31728      &    21,  20,  17,  20,  22,  97,  98,  97,  98,  97,
31729      &    98,  17,  18,  99, 100,  18, 101,  99,  18, 101,
31730      &   100, 102, 103, 102, 103, 102, 103,  18,  16,  16,
31731      &    24,  24,  16,  25,  15,  24,  15,  15,  25,  25,
31732      &    31,  15,  15,  31,  16,  16,  23,  13,   7, 116,
31733      &   116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31734      &   120, 121, 121, 130, 130, 130,   4,  10,  13,  10,
31735      &     4,  32,  13,  36,  11,   3,  34,  14,  38, 133,
31736      &   134, 135, 136,  21,  21,   1,  97, 104,  54,  53,
31737      &    17,  22,  21,  21,   1,  54,  53,  21,  97,  21,
31738      &    97,  22,  21,  97,  98, 105, 137, 137, 137, 138,
31739      &   139,  97,  97, 109, 109, 140, 138, 137, 139, 138,
31740      &   145,  99,  99,   2, 102, 110,  68,  67,  18, 100,
31741      &    99,  99,   2,  68,  67,  99, 102,  99, 102, 100,
31742      &    99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31743      &   113, 115, 115, 152, 150, 149, 151, 150, 157, 140  /
31744       DATA (NZK(K,1),K=511,540) /
31745      &   141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31746      &   140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31747      &   150, 157, 152,  34,  32,  33,  33,  32,  33,  34  /
31748       DATA (NZK(I,1),I=541,602) /  2, 67, 68, 69,  2,  9,  9, 68, 69,
31749      & 70,  2,  9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31750      & 14, 189, 23, 13, 15, 24,  36,  38,  37,  39, 194, 195, 196, 197,
31751      & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31752      & 55, 8, 1, 8, 8, 54, 55, 210/
31753       DATA (NZK(K,2),K=  1,170) /
31754      &     0,   0,   0,   0,   0,   0,   0,   3,   4,   6,
31755      &     5,  23,  14,  11,   3,   5,   5,   5,  23,  13,
31756      &    23,  23,  23,   5,  23,  13,  23,  23,  23,  14,
31757      &    23,   3,  11,  13,  23,   4,  10,  14,  23,  14,
31758      &    23,  13,   7,   7,   4,   7,   7,  23,  14,  14,
31759      &    23,  14,  23,  23,  14,  14,   7,  23,  13,  23,
31760      &    14,  23,  14,  23,  13,  23,  13,  23,  14,  23,
31761      &    14,  23,  13,  23,  13,  23,  13,  33,  32,  35,
31762      &    31,  23,  14,  23,  14,  33,  34,  35,  31,  23,
31763      &    14,  23,  14,  33,  34,  35,  31,  23,  13,  23,
31764      &    13,  33,  32,  35,  31,  13,  13,  23,  23,  14,
31765      &    13,  14,  14,  25,  16,  14,  23,  13,  31,  14,
31766      &    13,  23,  25,  16,  23,  35,  33,  34,  32,  33,
31767      &    31,  31,  14,  13,  23,   0,   0,   0,   0,  13,
31768      &    23,  13,  14,  23,  14,  13,  23,  13,  78,  23,
31769      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
31770      &    13,  80,  79,  14,  14,  23,  80,  31,  14,  23  /
31771       DATA (NZK(K,2),K=171,340) /
31772      &    13,  79,  78,  31,  14,  23,  13,  80,  79,  23,
31773      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
31774      &    13,  80,  79,  23,  13,  33,  32,  15,  24,  15,
31775      &    31,  14,  23,  34,  33,  24,  24,  15,  31,  14,
31776      &    23,  14,  13,  23,  13,  14,  23,  14,  80,  23,
31777      &    14,  13,  23,  14,  79,  80,  13,  23,  13,  23,
31778      &    14,  78,  79,  13,  13,  23,  78,  23,  14,  13,
31779      &    23,  14,  79,  80,  13,  23,  13,  23,  14,  78,
31780      &    79,  62,  61,  23,  14,  23,  13,  13,  13,  23,
31781      &    13,  13,  23,  14,  14,  14,   1,   8,   8,   1,
31782      &     8,   1,   8,   8,   1,   8,   1,   8,   1,   8,
31783      &     1,   1,   8,   1,   8,   8,   1,   1,   8,   8,
31784      &     1,   8,  25,  23,  13,  31,  23,  13,  16,  14,
31785      &    35,  34,  34,  33,  31,  14,  23,   0,   0,   0,
31786      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31787      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31788      &    13,  23,  14,   7,  16,  19,  14,   7,  23,  14  /
31789       DATA (NZK(K,2),K=341,510) /
31790      &    23,  14,   7,  13,  23,  13,  13,  23,  13,  23,
31791      &    14,  13,  14,  23,  14,  23,  13,  14,  23,  14,
31792      &    23,  16,  14,  23,  14,  23,  14,  13,  13,  23,
31793      &    13,  23,  14,  13,  23,  13,  23,  15,  13,  13,
31794      &    13,  23,  13,  13,  14,  14,  14,  14,  14,  23,
31795      &    13,  16,  25,  14,  15,  24,  23,  14,   7,  23,
31796      &     7,  13,  23,   7,  14,  23,   7,  23,   7,   7,
31797      &     7,   7,   7,  13,  23,  31,   3,  11,  14, 135,
31798      &     5, 134, 134, 134, 136,   6, 133, 133, 133,   0,
31799      &     0,   0,   0,  31,  95,  25,  15,  31,  95,  16,
31800      &    32,  32,  33,  35,  39,  39,  38,  25,  13,  39,
31801      &    32,  39,  38,  35,  32,  39,  13,  23,  14,   7,
31802      &     7,  25,  37,  32,  13,  25,  13,  25,  13,  25,
31803      &    13,  31,  95,  24,  16,  31,  24,  15,  34,  34,
31804      &    33,  35,  37,  37,  36,  24,  14,  37,  34,  37,
31805      &    36,  35,  34,  37,  14,  23,  13,   7,   7,  24,
31806      &    39,  34,  14,  24,  14,  24,  14,  24,  14,   7  /
31807       DATA (NZK(K,2),K=511,540) /
31808      &     7,   7,   7,   7,   7,   7,   7,   7,  25,  13,
31809      &    25,   7,   7,   7,   7,   7,   7,   7,   7,   7,
31810      &    24,  14,  24,  13,  14,  23,  13,  23,  14,  23  /
31811       DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31812      & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31813      & 14, 14, 23, 14, 16, 25,
31814      & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31815      & 23, 13, 14, 23,  0 /
31816       DATA (NZK(K,3),K=  1,170) /
31817      &     0,   0,   0,   0,   0,   0,   0,   5,   6,   5,
31818      &     6,  23,  23,   5,   5,   0,   0,   0,   0,  14,
31819      &    23,   5,   5,   0,   0,  14,  23,   5,   5,   0,
31820      &     0,   5,   5,   0,   0,   5,   5,   0,   0,   0,
31821      &     0,   0,   0,   0,   3,   0,   7,  23,  23,   7,
31822      &     0,   0,   0,   0,  23,   0,   0,   0,   0,   0,
31823      &     110*0   /
31824       DATA (NZK(K,3),K=171,340) /
31825      &     80*0,
31826      &     0,   0,   0,   0,   0,   0,  23,  13,  14,  23,
31827      &    23,  14,  23,  23,  23,  14,  23,  13,  23,  14,
31828      &    13,  23,  13,  23,  14,  23,  14,  14,  23,  13,
31829      &    13,  23,  13,  14,  23,  23,  14,  23,  13,  23,
31830      &    14,  14,   0,   0,   0,   0,   0,   0,   0,   0,
31831      &     30*0,
31832      &    14,  23,   7,   0,   0,   0,  23,   0,   0,   0  /
31833       DATA (NZK(K,3),K=341,510) /
31834      &     30*0,
31835      &     0,   0,   0,   0,   0,   0,   0,   0,   0,  23,
31836      &    14,   0,  13,   0,  14,   0,   0,  23,  13,   0,
31837      &     0,  15,   0,   0,  16,   0,   0,   0,   0,   0,
31838      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31839      &     0,   0,   0,  14,  23,   0,   0,   0,  23, 134,
31840      &   134,   0,   0,   0, 133, 133,   0,   0,   0,   0,
31841      &     80*0  /
31842       DATA (NZK(K,3),K=511,540) /
31843      &     0,   0,   0,   0,   0,   0,   0,   0,  13,  13,
31844      &    25,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31845      &    14,  14,  24,   0,   0,   0,   0,   0,   0,   0  /
31846       DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31847      & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31848
31849       END
31850
31851 *$ CREATE DT_BDEVAP.FOR
31852 *COPY DT_BDEVAP
31853 *
31854 *=== bdevap ===========================================================*
31855 *
31856       BLOCK DATA DT_BDEVAP
31857
31858 C     INCLUDE '(DBLPRC)'
31859 * DBLPRC.ADD
31860       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31861       SAVE
31862 * (original name: GLOBAL)
31863       PARAMETER ( KALGNM = 2 )
31864       PARAMETER ( ANGLGB = 5.0D-16 )
31865       PARAMETER ( ANGLSQ = 2.5D-31 )
31866       PARAMETER ( AXCSSV = 0.2D+16 )
31867       PARAMETER ( ANDRFL = 1.0D-38 )
31868       PARAMETER ( AVRFLW = 1.0D+38 )
31869       PARAMETER ( AINFNT = 1.0D+30 )
31870       PARAMETER ( AZRZRZ = 1.0D-30 )
31871       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
31872       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
31873       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
31874       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
31875       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
31876       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
31877       PARAMETER ( CSNNRM = 2.0D-15 )
31878       PARAMETER ( DMXTRN = 1.0D+08 )
31879       PARAMETER ( ZERZER = 0.D+00 )
31880       PARAMETER ( ONEONE = 1.D+00 )
31881       PARAMETER ( TWOTWO = 2.D+00 )
31882       PARAMETER ( THRTHR = 3.D+00 )
31883       PARAMETER ( FOUFOU = 4.D+00 )
31884       PARAMETER ( FIVFIV = 5.D+00 )
31885       PARAMETER ( SIXSIX = 6.D+00 )
31886       PARAMETER ( SEVSEV = 7.D+00 )
31887       PARAMETER ( EIGEIG = 8.D+00 )
31888       PARAMETER ( ANINEN = 9.D+00 )
31889       PARAMETER ( TENTEN = 10.D+00 )
31890       PARAMETER ( HLFHLF = 0.5D+00 )
31891       PARAMETER ( ONETHI = ONEONE / THRTHR )
31892       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
31893       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
31894       PARAMETER ( THRTWO = THRTHR / TWOTWO )
31895       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
31896       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
31897       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
31898       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
31899       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
31900       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
31901       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
31902       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
31903       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
31904       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
31905       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
31906       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
31907       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
31908       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
31909       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
31910       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
31911       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
31912       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
31913       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
31914       PARAMETER ( CLIGHT = 2.99792458         D+10 )
31915       PARAMETER ( AVOGAD = 6.0221367          D+23 )
31916       PARAMETER ( BOLTZM = 1.380658           D-23 )
31917       PARAMETER ( AMELGR = 9.1093897          D-28 )
31918       PARAMETER ( PLCKBR = 1.05457266         D-27 )
31919       PARAMETER ( ELCCGS = 4.8032068          D-10 )
31920       PARAMETER ( ELCMKS = 1.60217733         D-19 )
31921       PARAMETER ( AMUGRM = 1.6605402          D-24 )
31922       PARAMETER ( AMMUMU = 0.113428913        D+00 )
31923       PARAMETER ( AMPRMU = 1.007276470        D+00 )
31924       PARAMETER ( AMNEMU = 1.008664904        D+00 )
31925       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
31926       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
31927       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
31928       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
31929       PARAMETER ( PLABRC = 0.197327053        D+00 )
31930       PARAMETER ( AMELCT = 0.51099906         D-03 )
31931       PARAMETER ( AMUGEV = 0.93149432         D+00 )
31932       PARAMETER ( AMMUON = 0.105658389        D+00 )
31933       PARAMETER ( AMPRTN = 0.93827231         D+00 )
31934       PARAMETER ( AMNTRN = 0.93956563         D+00 )
31935       PARAMETER ( AMDEUT = 1.87561339         D+00 )
31936       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
31937      &                   * 1.D-09 )
31938       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
31939       PARAMETER ( BLTZMN = 8.617385           D-14 )
31940       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
31941       PARAMETER ( GFOHB3 = 1.16639            D-05 )
31942       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
31943       PARAMETER ( SIN2TW = 0.2319             D+00 )
31944       PARAMETER ( GEVMEV = 1.0                D+03 )
31945       PARAMETER ( EMVGEV = 1.0                D-03 )
31946       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
31947       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
31948       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
31949       LOGICAL LGBIAS, LGBANA
31950       COMMON /FKGLOB/ LGBIAS, LGBANA
31951 C     INCLUDE '(DIMPAR)'
31952 * DIMPAR.ADD
31953       PARAMETER ( MXXRGN = 5000 )
31954       PARAMETER ( MXXMDF = 82   )
31955       PARAMETER ( MXXMDE = 54   )
31956       PARAMETER ( MFSTCK = 1000 )
31957       PARAMETER ( MESTCK = 100  )
31958       PARAMETER ( NELEMX = 80   )
31959       PARAMETER ( MPDPDX = 8    )
31960       PARAMETER ( ICOMAX = 180  )
31961       PARAMETER ( NSTBIS = 304  )
31962       PARAMETER ( IDMAXP = 220  )
31963       PARAMETER ( IDMXDC = 640  )
31964       PARAMETER ( MKBMX1 = 1    )
31965       PARAMETER ( MKBMX2 = 1    )
31966 C     INCLUDE '(IOUNIT)'
31967 * IOUNIT.ADD
31968       PARAMETER ( LUNIN  =  5 )
31969       PARAMETER ( LUNOUT =  6 )
31970 **sr 19.5. set error output-unit from 15 to 6
31971       PARAMETER ( LUNERR = 6  )
31972       PARAMETER ( LUNBER = 14 )
31973       PARAMETER ( LUNECH =  8 )
31974       PARAMETER ( LUNFLU = 13 )
31975       PARAMETER ( LUNGEO = 16 )
31976       PARAMETER ( LUNPMF = 12 )
31977       PARAMETER ( LUNRAN =  2 )
31978       PARAMETER ( LUNXSC =  9 )
31979       PARAMETER ( LUNDET = 17 )
31980       PARAMETER ( LUNRAY = 10 )
31981       PARAMETER ( LUNRDB =  1 )
31982       PARAMETER ( LUNPGO =  7 )
31983       PARAMETER ( LUNPGS =  4 )
31984       PARAMETER ( LUNSCR =  3 )
31985 *
31986 *----------------------------------------------------------------------*
31987 *                                                                      *
31988 *     Block Data for the EVAPoration routines:                         *
31989 *                                                                      *
31990 *     Created on    20 may 1990    by    Alfredo Ferrari & Paola Sala  *
31991 *                                                   Infn - Milan       *
31992 *                                                                      *
31993 *     Modified from the original version of J.M.Zazula                 *
31994 *     and, for cookcm, from a LAHET block data kindly provided by      *
31995 *     R.E.Prael-LANL                                                   *
31996 *                                                                      *
31997 *     Last change on  20-feb-95    by    Alfredo Ferrari               *
31998 *                                                                      *
31999 *                                                                      *
32000 *----------------------------------------------------------------------*
32001 *
32002 * (original name: COOKCM)
32003       PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
32004       LOGICAL LDEFOZ, LDEFON
32005       PARAMETER ( INCOOK = 150, IZCOOK = 98 )
32006       COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
32007      &                SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
32008      &                PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
32009 * (original name: EVA0)
32010       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
32011      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
32012      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
32013      *                T (4,7), RMASS (297), ALPH (297), BET (297),
32014      *                APRIME (250), IA (6), IZ (6)
32015 * (original name: HETTP)
32016       COMMON /FKHETP/  NHSTP,NBERTP,IOSUB,INSRS
32017 * (original name: HETC7)
32018       COMMON /FKHET7/ COSKS,SINKS, COSTH,SINTH, COSPHI,SINPHI
32019 * (original name: INPFLG)
32020       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
32021 *
32022       DATA B0   / 8.D+00 /, Y0 / 1.5D+00 /
32023       DATA IANG / 1 /, IFISS / 1 /,  IB0 / 2 /, IGEOM / 0 /
32024       DATA ISTRAG /0/, KEYDK /0/
32025       DATA NBERTP /LUNBER/
32026       DATA COSTH /ONEONE/, SINTH /ZERZER/, COSPHI /ONEONE/,
32027      &     SINPHI/ZERZER/
32028 *  /cookcm/
32029        DATA ( PZCOOK(I),I =  1, IZCOOK ) /
32030      & 0.000D+00, 5.440D+00, 0.000D+00, 2.760D+00, 0.000D+00, 3.340D+00,
32031      & 0.000D+00, 2.700D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.460D+00,
32032      & 0.000D+00, 2.090D+00, 0.000D+00, 1.620D+00, 0.000D+00, 1.620D+00,
32033      & 0.000D+00, 1.830D+00, 0.000D+00, 1.730D+00, 0.000D+00, 1.350D+00,
32034      & 0.000D+00, 1.540D+00, 0.000D+00, 1.280D+00, 2.600D-01, 8.800D-01,
32035      & 1.900D-01, 1.350D+00,-5.000D-02, 1.520D+00,-9.000D-02, 1.170D+00,
32036      & 4.000D-02, 1.240D+00, 2.900D-01, 1.090D+00, 2.600D-01, 1.170D+00,
32037      & 2.300D-01, 1.150D+00,-8.000D-02, 1.350D+00, 3.400D-01, 1.050D+00,
32038      & 2.800D-01, 1.270D+00, 0.000D+00, 1.050D+00, 0.000D+00, 1.000D+00,
32039      & 9.000D-02, 1.200D+00, 2.000D-01, 1.400D+00, 9.300D-01, 1.000D+00,
32040      &-2.000D-01, 1.190D+00, 9.000D-02, 9.700D-01, 0.000D+00, 9.200D-01,
32041      & 1.100D-01, 6.800D-01, 5.000D-02, 6.800D-01,-2.200D-01, 7.900D-01,
32042      & 9.000D-02, 6.900D-01, 1.000D-02, 7.200D-01, 0.000D+00, 4.000D-01,
32043      & 1.600D-01, 7.300D-01, 0.000D+00, 4.600D-01, 1.700D-01, 8.900D-01,
32044      & 0.000D+00, 7.900D-01, 0.000D+00, 8.900D-01, 0.000D+00, 8.100D-01,
32045      &-6.000D-02, 6.900D-01,-2.000D-01, 7.100D-01,-1.200D-01, 7.200D-01,
32046      & 0.000D+00, 7.700D-01/
32047        DATA ( PNCOOK(I),I =  1, 90 ) /
32048      & 0.000D+00, 5.980D+00, 0.000D+00, 2.770D+00, 0.000D+00, 3.160D+00,
32049      & 0.000D+00, 3.010D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.670D+00,
32050      & 0.000D+00, 1.800D+00, 0.000D+00, 1.670D+00, 0.000D+00, 1.860D+00,
32051      & 0.000D+00, 2.040D+00, 0.000D+00, 1.640D+00, 0.000D+00, 1.440D+00,
32052      & 0.000D+00, 1.540D+00, 0.000D+00, 1.300D+00, 0.000D+00, 1.270D+00,
32053      & 0.000D+00, 1.290D+00, 8.000D-02, 1.410D+00,-8.000D-02, 1.500D+00,
32054      &-5.000D-02, 2.240D+00,-4.700D-01, 1.430D+00,-1.500D-01, 1.440D+00,
32055      & 6.000D-02, 1.560D+00, 2.500D-01, 1.570D+00,-1.600D-01, 1.460D+00,
32056      & 0.000D+00, 9.300D-01, 1.000D-02, 6.200D-01,-5.000D-01, 1.420D+00,
32057      & 1.300D-01, 1.520D+00,-6.500D-01, 8.000D-01,-8.000D-02, 1.290D+00,
32058      &-4.700D-01, 1.250D+00,-4.400D-01, 9.700D-01, 8.000D-02, 1.650D+00,
32059      &-1.100D-01, 1.260D+00,-4.600D-01, 1.060D+00, 2.200D-01, 1.550D+00,
32060      &-7.000D-02, 1.370D+00, 1.000D-01, 1.200D+00,-2.700D-01, 9.200D-01,
32061      &-3.500D-01, 1.190D+00, 0.000D+00, 1.050D+00,-2.500D-01, 1.610D+00,
32062      &-2.100D-01, 9.000D-01,-2.100D-01, 7.400D-01,-3.800D-01, 7.200D-01/
32063        DATA ( PNCOOK(I),I = 91, INCOOK ) /
32064      &-3.400D-01, 9.200D-01,-2.600D-01, 9.400D-01, 1.000D-02, 6.500D-01,
32065      &-3.600D-01, 8.300D-01, 1.100D-01, 6.700D-01, 5.000D-02, 1.000D+00,
32066      & 5.100D-01, 1.040D+00, 3.300D-01, 6.800D-01,-2.700D-01, 8.100D-01,
32067      & 9.000D-02, 7.500D-01, 1.700D-01, 8.600D-01, 1.400D-01, 1.100D+00,
32068      &-2.200D-01, 8.400D-01,-4.700D-01, 4.800D-01, 2.000D-02, 8.800D-01,
32069      & 2.400D-01, 5.200D-01, 2.700D-01, 4.100D-01,-5.000D-02, 3.800D-01,
32070      & 1.500D-01, 6.700D-01, 0.000D+00, 6.100D-01, 0.000D+00, 7.800D-01,
32071      & 0.000D+00, 6.700D-01, 0.000D+00, 6.700D-01, 0.000D+00, 7.900D-01,
32072      & 0.000D+00, 6.000D-01, 4.000D-02, 6.400D-01,-6.000D-02, 4.500D-01,
32073      & 5.000D-02, 2.600D-01,-2.200D-01, 3.900D-01, 0.000D+00, 3.900D-01/
32074        DATA ( SZCOOK(I),I =  1, 98) /
32075      & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32076      & 0.000D+00, 0.000D+00,-1.100D-01,-8.100D-01,-2.910D+00,-4.170D+00,
32077      &-5.720D+00,-7.800D+00,-8.970D+00,-9.700D+00,-1.010D+01,-1.070D+01,
32078      &-1.138D+01,-1.207D+01,-1.255D+01,-1.324D+01,-1.393D+01,-1.471D+01,
32079      &-1.553D+01,-1.637D+01,-1.736D+01,-1.860D+01,-1.870D+01,-1.801D+01,
32080      &-1.787D+01,-1.708D+01,-1.660D+01,-1.675D+01,-1.650D+01,-1.635D+01,
32081      &-1.622D+01,-1.641D+01,-1.689D+01,-1.643D+01,-1.668D+01,-1.673D+01,
32082      &-1.745D+01,-1.729D+01,-1.744D+01,-1.782D+01,-1.862D+01,-1.827D+01,
32083      &-1.939D+01,-1.991D+01,-1.914D+01,-1.826D+01,-1.740D+01,-1.642D+01,
32084      &-1.577D+01,-1.437D+01,-1.391D+01,-1.310D+01,-1.311D+01,-1.143D+01,
32085      &-1.089D+01,-1.075D+01,-1.062D+01,-1.041D+01,-1.021D+01,-9.850D+00,
32086      &-9.470D+00,-9.030D+00,-8.610D+00,-8.130D+00,-7.460D+00,-7.480D+00,
32087      &-7.200D+00,-7.130D+00,-7.060D+00,-6.780D+00,-6.640D+00,-6.640D+00,
32088      &-7.680D+00,-7.890D+00,-8.410D+00,-8.490D+00,-7.880D+00,-6.300D+00,
32089      &-5.470D+00,-4.780D+00,-4.370D+00,-4.170D+00,-4.130D+00,-4.320D+00,
32090      &-4.550D+00,-5.040D+00,-5.280D+00,-6.060D+00,-6.280D+00,-6.870D+00,
32091      &-7.200D+00,-7.740D+00/
32092        DATA ( SNCOOK(I),I =  1, 90 ) /
32093      & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32094      & 0.000D+00, 0.000D+00, 1.030D+01, 5.660D+00, 6.800D+00, 7.530D+00,
32095      & 7.550D+00, 7.210D+00, 7.440D+00, 8.070D+00, 8.940D+00, 9.810D+00,
32096      & 1.060D+01, 1.139D+01, 1.254D+01, 1.368D+01, 1.434D+01, 1.419D+01,
32097      & 1.383D+01, 1.350D+01, 1.300D+01, 1.213D+01, 1.260D+01, 1.326D+01,
32098      & 1.413D+01, 1.492D+01, 1.552D+01, 1.638D+01, 1.716D+01, 1.755D+01,
32099      & 1.803D+01, 1.759D+01, 1.903D+01, 1.871D+01, 1.880D+01, 1.899D+01,
32100      & 1.846D+01, 1.825D+01, 1.776D+01, 1.738D+01, 1.672D+01, 1.562D+01,
32101      & 1.438D+01, 1.288D+01, 1.323D+01, 1.381D+01, 1.490D+01, 1.486D+01,
32102      & 1.576D+01, 1.620D+01, 1.762D+01, 1.773D+01, 1.816D+01, 1.867D+01,
32103      & 1.969D+01, 1.951D+01, 2.017D+01, 1.948D+01, 1.998D+01, 1.983D+01,
32104      & 2.020D+01, 1.972D+01, 1.987D+01, 1.924D+01, 1.844D+01, 1.761D+01,
32105      & 1.710D+01, 1.616D+01, 1.590D+01, 1.533D+01, 1.476D+01, 1.354D+01,
32106      & 1.263D+01, 1.065D+01, 1.010D+01, 8.890D+00, 1.025D+01, 9.790D+00,
32107      & 1.139D+01, 1.172D+01, 1.243D+01, 1.296D+01, 1.343D+01, 1.337D+01/
32108        DATA ( SNCOOK(I),I = 91, INCOOK ) /
32109      & 1.296D+01, 1.211D+01, 1.192D+01, 1.100D+01, 1.080D+01, 1.042D+01,
32110      & 1.039D+01, 9.690D+00, 9.270D+00, 8.930D+00, 8.570D+00, 8.020D+00,
32111      & 7.590D+00, 7.330D+00, 7.230D+00, 7.050D+00, 7.420D+00, 6.750D+00,
32112      & 6.600D+00, 6.380D+00, 6.360D+00, 6.490D+00, 6.250D+00, 5.850D+00,
32113      & 5.480D+00, 4.530D+00, 4.300D+00, 3.390D+00, 2.350D+00, 1.660D+00,
32114      & 8.100D-01, 4.600D-01,-9.600D-01,-1.690D+00,-2.530D+00,-3.160D+00,
32115      &-1.870D+00,-4.100D-01, 7.100D-01, 1.660D+00, 2.620D+00, 3.220D+00,
32116      & 3.760D+00, 4.100D+00, 4.460D+00, 4.830D+00, 5.090D+00, 5.180D+00,
32117      & 5.170D+00, 5.100D+00, 5.010D+00, 4.970D+00, 5.090D+00, 5.030D+00,
32118      & 4.930D+00, 5.280D+00, 5.490D+00, 5.500D+00, 5.370D+00, 5.300D+00/
32119       DATA LDEFOZ / 53*.FALSE.,25*.TRUE.,7*.FALSE.,13*.TRUE. /
32120       DATA LDEFON / 85*.FALSE.,37*.TRUE.,7*.FALSE.,21*.TRUE. /
32121 *=== End of Block Data Bdevap =========================================*
32122       END
32123
32124 *$ CREATE DT_BDNOPT.FOR
32125 *COPY DT_BDNOPT
32126 *
32127 *=== bdnopt ===========================================================*
32128 *==                                                                    *
32129       BLOCK DATA DT_BDNOPT
32130
32131 C     INCLUDE '(DBLPRC)'
32132 * DBLPRC.ADD
32133       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32134       SAVE
32135 * (original name: GLOBAL)
32136       PARAMETER ( KALGNM = 2 )
32137       PARAMETER ( ANGLGB = 5.0D-16 )
32138       PARAMETER ( ANGLSQ = 2.5D-31 )
32139       PARAMETER ( AXCSSV = 0.2D+16 )
32140       PARAMETER ( ANDRFL = 1.0D-38 )
32141       PARAMETER ( AVRFLW = 1.0D+38 )
32142       PARAMETER ( AINFNT = 1.0D+30 )
32143       PARAMETER ( AZRZRZ = 1.0D-30 )
32144       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32145       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32146       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32147       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32148       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
32149       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
32150       PARAMETER ( CSNNRM = 2.0D-15 )
32151       PARAMETER ( DMXTRN = 1.0D+08 )
32152       PARAMETER ( ZERZER = 0.D+00 )
32153       PARAMETER ( ONEONE = 1.D+00 )
32154       PARAMETER ( TWOTWO = 2.D+00 )
32155       PARAMETER ( THRTHR = 3.D+00 )
32156       PARAMETER ( FOUFOU = 4.D+00 )
32157       PARAMETER ( FIVFIV = 5.D+00 )
32158       PARAMETER ( SIXSIX = 6.D+00 )
32159       PARAMETER ( SEVSEV = 7.D+00 )
32160       PARAMETER ( EIGEIG = 8.D+00 )
32161       PARAMETER ( ANINEN = 9.D+00 )
32162       PARAMETER ( TENTEN = 10.D+00 )
32163       PARAMETER ( HLFHLF = 0.5D+00 )
32164       PARAMETER ( ONETHI = ONEONE / THRTHR )
32165       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32166       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32167       PARAMETER ( THRTWO = THRTHR / TWOTWO )
32168       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32169       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32170       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32171       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32172       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32173       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32174       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32175       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
32176       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
32177       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
32178       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
32179       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32180       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32181       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32182       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32183       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32184       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32185       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32186       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32187       PARAMETER ( CLIGHT = 2.99792458         D+10 )
32188       PARAMETER ( AVOGAD = 6.0221367          D+23 )
32189       PARAMETER ( BOLTZM = 1.380658           D-23 )
32190       PARAMETER ( AMELGR = 9.1093897          D-28 )
32191       PARAMETER ( PLCKBR = 1.05457266         D-27 )
32192       PARAMETER ( ELCCGS = 4.8032068          D-10 )
32193       PARAMETER ( ELCMKS = 1.60217733         D-19 )
32194       PARAMETER ( AMUGRM = 1.6605402          D-24 )
32195       PARAMETER ( AMMUMU = 0.113428913        D+00 )
32196       PARAMETER ( AMPRMU = 1.007276470        D+00 )
32197       PARAMETER ( AMNEMU = 1.008664904        D+00 )
32198       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32199       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32200       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32201       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32202       PARAMETER ( PLABRC = 0.197327053        D+00 )
32203       PARAMETER ( AMELCT = 0.51099906         D-03 )
32204       PARAMETER ( AMUGEV = 0.93149432         D+00 )
32205       PARAMETER ( AMMUON = 0.105658389        D+00 )
32206       PARAMETER ( AMPRTN = 0.93827231         D+00 )
32207       PARAMETER ( AMNTRN = 0.93956563         D+00 )
32208       PARAMETER ( AMDEUT = 1.87561339         D+00 )
32209       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32210      &                   * 1.D-09 )
32211       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32212       PARAMETER ( BLTZMN = 8.617385           D-14 )
32213       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32214       PARAMETER ( GFOHB3 = 1.16639            D-05 )
32215       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32216       PARAMETER ( SIN2TW = 0.2319             D+00 )
32217       PARAMETER ( GEVMEV = 1.0                D+03 )
32218       PARAMETER ( EMVGEV = 1.0                D-03 )
32219       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
32220       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32221       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32222       LOGICAL LGBIAS, LGBANA
32223       COMMON /FKGLOB/ LGBIAS, LGBANA
32224 C     INCLUDE '(DIMPAR)'
32225 * DIMPAR.ADD
32226       PARAMETER ( MXXRGN = 5000 )
32227       PARAMETER ( MXXMDF = 82   )
32228       PARAMETER ( MXXMDE = 54   )
32229       PARAMETER ( MFSTCK = 1000 )
32230       PARAMETER ( MESTCK = 100  )
32231       PARAMETER ( NELEMX = 80   )
32232       PARAMETER ( MPDPDX = 8    )
32233       PARAMETER ( ICOMAX = 180  )
32234       PARAMETER ( NSTBIS = 304  )
32235       PARAMETER ( IDMAXP = 220  )
32236       PARAMETER ( IDMXDC = 640  )
32237       PARAMETER ( MKBMX1 = 1    )
32238       PARAMETER ( MKBMX2 = 1    )
32239 C     INCLUDE '(IOUNIT)'
32240 * IOUNIT.ADD
32241       PARAMETER ( LUNIN  =  5 )
32242       PARAMETER ( LUNOUT =  6 )
32243 **sr 19.5. set error output-unit from 15 to 6
32244       PARAMETER ( LUNERR = 6  )
32245       PARAMETER ( LUNBER = 14 )
32246       PARAMETER ( LUNECH =  8 )
32247       PARAMETER ( LUNFLU = 13 )
32248       PARAMETER ( LUNGEO = 16 )
32249       PARAMETER ( LUNPMF = 12 )
32250       PARAMETER ( LUNRAN =  2 )
32251       PARAMETER ( LUNXSC =  9 )
32252       PARAMETER ( LUNDET = 17 )
32253       PARAMETER ( LUNRAY = 10 )
32254       PARAMETER ( LUNRDB =  1 )
32255       PARAMETER ( LUNPGO =  7 )
32256       PARAMETER ( LUNPGS =  4 )
32257       PARAMETER ( LUNSCR =  3 )
32258 *
32259 *----------------------------------------------------------------------*
32260 *                                                                      *
32261 *   Created on  20 september 1989    by  Alfredo Ferrari - Infn Milan  *
32262 *                                                                      *
32263 *         Last change on 20-apr-95   by  Alfredo Ferrari               *
32264 *                                                                      *
32265 *----------------------------------------------------------------------*
32266 *
32267 C     INCLUDE '(BLNKCM)'
32268 * BLNKCM.ADD
32269 **sr 17.5. commented since not used here
32270 C     PARAMETER ( NBLNMX = 1100000 )
32271 C     DIMENSION GMSTOR ( NBLNMX ), BRMBRR ( NBLNMX ), BRMEXP ( NBLNMX ),
32272 C    &          BRMSIG ( NBLNMX ), SIGGTT ( KALGNM*NBLNMX ),
32273 C    &          COMSCO ( NBLNMX ), LBSTOR ( KALGNM*NBLNMX )
32274 C     REAL SIGGTT
32275 C     LOGICAL LBSTOR
32276 C     COMMON   NSTOR  ( KALGNM*NBLNMX )
32277 **
32278 **sr 18.5. commented since not used for evap.
32279 C     COMMON / ADDRCM / MBLNMX, KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST,
32280 C    &                  KISBGN, KISLST, KDTBGN, KDTLST, KUBBGN, KUBLST,
32281 C    &                  KUXBGN, KUXLST, KTCBGN, KTCLST, KRNBGN, KRNLST,
32282 C    &                  KYLBGN, KYLLST, KXSBGN, KXSLST, KIHBGN, KIHLST,
32283 C    &                  KINBGN, KINLST, KIEBGN, KIELST, KETBGN, KETLST,
32284 C    &                  KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32285 C    &                  KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST,
32286 C    &                  KWLBGN, KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST,
32287 C    &                  KWSBGN, KWSLST, KNDBGN, KNDLST, KDPBGN, KDPLST,
32288 C    &                  KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN, KBRLST,
32289 C    &                  KTMBGN
32290 **
32291
32292 C     EQUIVALENCE ( NSTOR (1), GMSTOR (1) )
32293 C     EQUIVALENCE ( NSTOR (1), BRMBRR (1) )
32294 C     EQUIVALENCE ( NSTOR (1), BRMEXP (1) )
32295 C     EQUIVALENCE ( NSTOR (1), BRMSIG (1) )
32296 C     EQUIVALENCE ( NSTOR (1), COMSCO (1) )
32297 C     EQUIVALENCE ( NSTOR (1), SIGGTT (1) )
32298 C     EQUIVALENCE ( NSTOR (1), LBSTOR (1) )
32299 C     INCLUDE '(BLNTMP)'
32300 * BLNTMP.ADD
32301 **sr 18.5. commented since not used for evap.
32302 C     COMMON / BLNTMP / KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM,
32303 C    &                  KGCBTM, KGDWTM, KBDWTM, KWLOTM, KWHITM, KWMUTM,
32304 C    &                  KWSHTM, KEXTTM, KSTXTM, KSTNTM, KECTTM, KPCTTM,
32305 C    &                  KLPBTM, NXXRGN
32306 **
32307 C     INCLUDE '(CMMDNR)'
32308 * CMMDNR.ADD
32309 **sr 18.5. commented since not used for evap.
32310 C     LOGICAL LFLDNR
32311 C     COMMON / CMMDNR / DDNEAR, LFLDNR
32312 **
32313 C     INCLUDE '(CTITLE)'
32314 * CTITLE.ADD
32315 **sr 18.5. commented since not used for evap.
32316 C     CHARACTER RUNTIT*80, RUNTIM*32, RUNKEY*10
32317 C     COMMON / CTITLE / RUNTIT, RUNTIM, RUNKEY
32318 C     COMMON / CEXPCK / ITEXPI, ITEXMX
32319 **
32320 C     INCLUDE '(DETECT)'
32321 * DETECT.ADD
32322 **sr 18.5. commented since not used for evap.
32323 C     PARAMETER (NRGNMX = 10)
32324 C     PARAMETER (NDTCMX = 10)
32325 C     PARAMETER (NSCRMX = 10)
32326 C     PARAMETER (NDTBIN = 1024)
32327 C     CHARACTER*10 TITDET,TITSCO
32328 C     LOGICAL LDTCTR
32329 C     COMMON /DETCT/  EDTMIN(NDTCMX), EDTBIN(NDTCMX), EDTCUT(NDTCMX),
32330 C    &                KDTREG(NRGNMX,NDTCMX), KDTDET(NDTCMX,NSCRMX),
32331 C    &                NDTSCO, NDTDET, LDTCTR, IDTREG(MXXRGN),
32332 C    &                KDTSCD(NSCRMX)
32333 C     COMMON /DETCH/  TITDET(NDTCMX), TITSCO(NSCRMX)
32334 **
32335 C     INCLUDE '(DETLOC)'
32336 * DETLOC.ADD
32337 **sr 18.5. commented since not used for evap.
32338 C     PARAMETER (NDTCM2 = 10)
32339 C     COMMON /DETLOC/ ACCUMP (NDTCM2), ACCUMN (NDTCM2),
32340 C    &                ICOINC(NDTCM2), NCLAS
32341 **
32342 C     INCLUDE '(EMGTRN)'
32343 * EMGTRN.ADD
32344 **sr 18.5. commented since not used for evap.
32345 C     LOGICAL LMCSMG
32346 C     COMMON / EMGTRN / UMCSMG, VMCSMG, WMCSMG, LMCSMG
32347 **
32348 C     INCLUDE '(EMSHO)'
32349 * EMSHO.ADD
32350 **sr 18.5. commented since not used for evap.
32351 C     LOGICAL EMFLO, EMFHLO, EMFELO, LIMPRE, LEXPTE
32352 C     COMMON /EMSHO/ EMFETH, EMFPTH, EMFHET, EMFHPT, EMFBIA, EMFLO,
32353 C    &               EMFHLO, EMFELO, LIMPRE, LEXPTE
32354 **
32355 C     INCLUDE '(EPISOR)'
32356 * EPISOR.ADD
32357 **sr 18.5. commented since not used for evap.
32358 C     LOGICAL LUSSRC
32359 C     COMMON/EPISOR/TKESUM,LUSSRC
32360 **
32361 * (original name: FHEAVY,FHEAVC)
32362       PARAMETER ( MXHEAV = 100 )
32363       CHARACTER*8 ANHEAV
32364       COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
32365      &                CZHEAV (MXHEAV), TKHEAV (MXHEAV),
32366      &                PHEAVY (MXHEAV), WHEAVY (MXHEAV),
32367      &                AMHEAV  ( 12 ) , AMNHEA  ( 12 ) ,
32368      &                KHEAVY (MXHEAV), ICHEAV  ( 12 ) ,
32369      &                IBHEAV  ( 12 ) , NPHEAV
32370       COMMON /FKFHVC/ ANHEAV  ( 12 )
32371 * (original name: FINUC)
32372       PARAMETER (MXP=999)
32373       COMMON /FKFINU/ CXR    (MXP), CYR    (MXP), CZR    (MXP),
32374      &                CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
32375      &                TKI    (MXP), PLR    (MXP), WEI    (MXP),
32376      &                TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
32377      &                KPART  (MXP)
32378 C     INCLUDE '(GENTHR)'
32379 * GENTHR.ADD
32380 **sr 18.5. commented since not used for evap.
32381 C     COMMON / GENTHR / PEANCT, PEAPIT, PLDNCT, PTHRSH (NALLWP),
32382 C    &                  PTHDFF (NALLWP), IJNUCR (NALLWP)
32383 **
32384 C     INCLUDE '(LOWNEU)'
32385 * LOWNEU.ADD
32386 **sr 18.5. commented since not used for evap.
32387 C     PARAMETER ( MXGTHN =  15 )
32388 C     PARAMETER ( MXGLWN = 200 )
32389 C     PARAMETER ( MXSHPP =   5 )
32390 C     LOGICAL LCOMPN, LIMPRN, LBIASN, LDOWNN, LRECPR, LLOWWW, LLOWET
32391 C     CHARACTER*10 TITLOW
32392 C     COMMON / LOWNEU / ATOLOW (MXXMDF), WSHPLN (MXGLWN,MXSHPP), EXTWWL,
32393 C    &                  SHPIMP (MXGLWN), EXTETL (MXGLWN), WWAMFL,
32394 C    &                  VLLNTH (MXGTHN,MXXMDF), ABLNTH (MXGTHN,MXXMDF),
32395 C    &                  STLNTH (MXGTHN,MXXMDF), TMRTLN (MXXMDF),
32396 C    &                  TMNMLN (MXXMDF), ICHCPT (MXXMDF),
32397 C    &                  IGTMRT (MXXMDF), NEUMED (MXXMDF),
32398 C    &                  ID1MED (MXXMDF), ID2MED (MXXMDF),
32399 C    &                  ID3MED (MXXMDF), MGTMED (MXXMDF),
32400 C    &                  LCOMPN (MXXMDF), LRECPR (MXXMDF), KPRLOW, NMGP,
32401 C    &                  NMTG  , IGRTHN, LIMPRN, LBIASN, LDOWNN, LLOWWW,
32402 C    &                  LLOWET, ICLMED, IKRBGN, INABGN, IDWBGN, IETBGN,
32403 C    &                  I0XSEC, IDXSEC, ISENAV, ISVELN, ISPNAV, IWWLWB,
32404 C    &                  IWWLWT, IPXBGN, NPXSEC
32405 C     COMMON / CHLWNT / TITLOW (MXXMDF)
32406 **
32407 C     INCLUDE '(LTCLCM)'
32408 * LTCLCM.ADD
32409 **sr 18.5. commented since not used for evap.
32410 C     COMMON / LTCLCM / MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1
32411 **
32412 C     INCLUDE '(MULBOU)'
32413 * MULBOU.ADD
32414 **sr 18.5. commented since not used for evap.
32415 C     LOGICAL LLDA  , LAGAIN, LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32416 C     COMMON / MULBOU / UOLD  , VOLD  , WOLD  , UMAG  , VMAG  , WMAG  ,
32417 C    &                  UNORML, VNORML, WNORML, USENSE, VSENSE, WSENSE,
32418 C    &                  TSENSE, DDSENS, DSMALL, NSSENS, LLDA  , LAGAIN,
32419 C    &                  LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32420 **
32421 C     INCLUDE '(MULHD)'
32422 * MULHD.ADD
32423 **sr 18.5. commented since not used for evap.
32424 C     PARAMETER ( MXXPT1 = 1 )
32425 C     PARAMETER ( TIMESS = 2.00D+00 )
32426 C     PARAMETER ( TMSRLX = 1.50D+00 )
32427 C     PARAMETER ( EPSINS = 0.15D+00 )
32428 C     PARAMETER ( EPSRLX = 0.50D+00 )
32429 C     PARAMETER ( SQEPSN = 0.3872983346207417 D+00 )
32430 C     PARAMETER ( SQEPSR = 0.7071067811865475 D+00 )
32431 C     PARAMETER ( PARNSI = 1.732050807568877 D+00 * SQEPSN )
32432 C     PARAMETER ( PRNSR0 = 1.732050807568877 D+00 * SQEPSR )
32433 C     PARAMETER ( R0NCMS = 1.20 D+00 )
32434 C     LOGICAL LTOPT, LSRCRH, LNSCRH
32435 C     COMMON / MULHD / BLCC   ( MXXMDF ), BLCCRA ( MXXMDF ),
32436 C    &                 XCC    ( MXXMDF ), ZTILDE ( MXXMDF, 0:MXXPT1 ),
32437 C    &                 ALPZTL ( MXXMDF, 0:MXXPT1 ), RLDU   ( MXXMDF ),
32438 C    &                 ALPZT2 ( MXXMDF, 0:MXXPT1 ), TEFF0  ( MXXMDF ),
32439 C    &                 XR0    ( MXXMDF ), ECUTM  ( MXXMDF, 39, 2 ),
32440 C    &                 ESTEPF ( MXXMDF ), HTHNSZ ( MXXMDF, 39 ),
32441 C    &                 AE1O3  ( MXXMDF ), PARNSR ( MXXMDF ),
32442 C    &                 HEESLI ( MXXMDF ), THMSPR, THMSSC, HMSAMP,
32443 C    &                 HMREJE, LSRCRH ( MXXMDF ), LNSCRH ( MXXMDF ),
32444 C    &                 LTOPT  ( MXXMDF ), NFSCAT
32445 **
32446 * (original name: PAREVT)
32447       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
32448      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
32449       PARAMETER ( NALLWP = 39   )
32450       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
32451      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
32452      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
32453      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
32454 * (original name: RESNUC)
32455       LOGICAL LRNFSS, LFRAGM
32456       COMMON /FKRESN/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
32457      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
32458      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
32459      &                  PYRES,  PZRES, PTRES2,  KTARP,  KTARN, IGREYP,
32460      &                 IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
32461      &                  ICRES,  IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
32462      &                 IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
32463      &                  IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
32464      &                 LFRAGM
32465 C     INCLUDE '(SCOHLP)'
32466 * SCOHLP.ADD
32467 **sr 18.5. commented since not used for evap.
32468 C     LOGICAL LSCZER
32469 C     COMMON / SCOHLP / ISCRNG, JSCRNG, LSCZER
32470 **
32471 C     INCLUDE '(TRACKR)'
32472 * TRACKR.ADD
32473 **sr 18.5. commented since not used for evap.
32474 C     PARAMETER ( MXTRCK = 2500 )
32475 C     LOGICAL LFSSSC
32476 C     COMMON / TRACKR /  XTRACK ( 0:MXTRCK ), YTRACK ( 0:MXTRCK ),
32477 C    &                   ZTRACK ( 0:MXTRCK ), TTRACK   ( MXTRCK ),
32478 C    &                   DTRACK   ( MXTRCK ), ETRACK, PTRACK, WTRACK,
32479 C    &                   ATRACK, CTRACK, AKSHRT, AKLONG, WSCRNG,
32480 C    &                   NTRACK, MTRACK, JTRACK, KTRACK, MMTRCK,
32481 C    &                   LT1TRK, LT2TRK, LTRACK, LLOUSE, LFSSSC
32482 **
32483 C     INCLUDE '(USRBDX)'
32484 * USRBDX.ADD
32485 **sr 18.5. commented since not used for evap.
32486 C     PARAMETER ( MXUSBX = 600 )
32487 C     LOGICAL LUSBDX, LFUSBX, LWUSBX, LLNUSX
32488 C     CHARACTER*10 TITUSX
32489 C     COMMON /USRBX/  EBXLOW(MXUSBX), EBXHGH(MXUSBX), ABXLOW(MXUSBX),
32490 C    &                ABXHGH(MXUSBX), DEBXBN(MXUSBX), DABXBN(MXUSBX),
32491 C    &                AUSBDX(MXUSBX),
32492 C    &                NEBXBN(MXUSBX), NABXBN(MXUSBX), NR1USX(MXUSBX),
32493 C    &                NR2USX(MXUSBX), ITUSBX(MXUSBX), IDUSBX(MXUSBX),
32494 C    &                KBUSBX(MXUSBX), IPUSBX(MXUSBX), IGMUSX(MXUSBX),
32495 C    &                LFUSBX(MXUSBX), LWUSBX(MXUSBX), LLNUSX(MXUSBX),
32496 C    &                NUSRBX, LUSBDX
32497 C     COMMON /USXCH/  TITUSX(MXUSBX)
32498 **
32499 C     INCLUDE '(USRBIN)'
32500 * USRBIN.ADD
32501 **sr 18.5. commented since not used for evap.
32502 C     PARAMETER ( MXUSBN = 100 )
32503 C     LOGICAL LUSBIN, LEVTBN, LNTZER, LUSEVT, LUSTKB, LTRKBN
32504 C     CHARACTER*10 TITUSB
32505 C     COMMON /USRBN/  XLOW  (MXUSBN), XHIGH (MXUSBN), YLOW  (MXUSBN),
32506 C    &                YHIGH (MXUSBN), ZLOW  (MXUSBN), ZHIGH (MXUSBN),
32507 C    &                DXUSBN(MXUSBN), DYUSBN(MXUSBN), DZUSBN(MXUSBN),
32508 C    &                TCUSBN(MXUSBN), BKUSBN(MXUSBN), B2USBN(MXUSBN),
32509 C    &                NXBIN (MXUSBN), NYBIN (MXUSBN), NZBIN (MXUSBN),
32510 C    &                ITUSBN(MXUSBN), IDUSBN(MXUSBN), KBUSBN(MXUSBN),
32511 C    &                IPUSBN(MXUSBN), LEVTBN(MXUSBN), LNTZER(MXUSBN),
32512 C    &                LTRKBN(MXUSBN), NUSRBN, LUSBIN, LUSEVT, LUSTKB
32513 C     COMMON /USRCH/  TITUSB(MXUSBN)
32514 **
32515 C     INCLUDE '(USRSNC)'
32516 * USRSNC.ADD
32517 **sr 18.5. commented since not used for evap.
32518 C     PARAMETER ( MXRSNC = 400 )
32519 C     PARAMETER ( NMZMIN =  -5 )
32520 C     LOGICAL LURSNC
32521 C     CHARACTER*10 TIURSN
32522 C     COMMON /USRSNC/  VURSNC(MXRSNC), IZRHGH(MXRSNC), IMRHGH(MXRSNC),
32523 C    &                 NRURSN(MXRSNC), ITURSN(MXRSNC), KBURSN(MXRSNC),
32524 C    &                 IPURSN(MXRSNC), NURSNC, LURSNC
32525 C     COMMON /USRSCH/  TIURSN(MXRSNC)
32526 C     INCLUDE '(USRTRC)'
32527 * USRTRC.ADD
32528 **sr 18.5. commented since not used for evap.
32529 C     PARAMETER ( MXUSTC = 400 )
32530 C     LOGICAL LUSRTC, LUSTRK, LUSCLL, LLNUTC
32531 C     CHARACTER*10 TITUTC
32532 C     COMMON /USRTC/  ETCLOW(MXUSTC), ETCHGH(MXUSTC), DETCBN(MXUSTC),
32533 C    &                VUSRTC(MXUSTC),
32534 C    &                IUSTRK(MXUSTC), IUSCLL(MXUSTC), NETCBN(MXUSTC),
32535 C    &                NRUSTC(MXUSTC), ITUSTC(MXUSTC), IDUSTC(MXUSTC),
32536 C    &                KBUSTC(MXUSTC), IPUSTC(MXUSTC), IGMUTC(MXUSTC),
32537 C    &                LLNUTC(MXUSTC), NUSRTC, NUSTRK, NUSCLL, LUSRTC,
32538 C    &                LUSTRK, LUSCLL
32539 C     COMMON /USTCH/  TITUTC(MXUSTC)
32540 **
32541 C     INCLUDE '(USRYLD)'
32542 * USRYLD.ADD
32543 **sr 18.5. commented since not used for evap.
32544 C     PARAMETER ( MXUSYL = 500 )
32545 C     LOGICAL LUSRYL, LLNUYL, LSCUYL
32546 C     CHARACTER*10 TITUYL
32547 C     COMMON /USRYL/  EYLLOW(MXUSYL), EYLHGH(MXUSYL), DEYLBN(MXUSYL),
32548 C    &                USNRYL(MXUSYL), SGUSYL(MXUSYL), AYLLOW(MXUSYL),
32549 C    &                AYLHGH(MXUSYL), PUSRYL, UUSRYL, VUSRYL, WUSRYL,
32550 C    &                ETXUYL, ETYUYL, ETZUYL, GAMUYL, SQSUYL, UCMUYL,
32551 C    &                VCMUYL, WCMUYL, IJUSYL, JTUSYL,
32552 C    &                NEYLBN(MXUSYL), NR1UYL(MXUSYL), NR2UYL(MXUSYL),
32553 C    &                IXUSYL(MXUSYL), ITUSYL(MXUSYL), IDUSYL(MXUSYL),
32554 C    &                KBUSYL(MXUSYL), IPUSYL(MXUSYL), IGMUYL(MXUSYL),
32555 C    &                IEUSYL(MXUSYL), IAUSYL(MXUSYL), LLNUYL(MXUSYL),
32556 C    &                NUSRYL, LUSRYL, LSCUYL
32557 C     COMMON /USYCH/  TITUYL(MXUSYL)
32558 **
32559 C     INCLUDE '(WWINDW)'
32560 * WWINDW.ADD
32561 **sr 18.5. commented since not used for evap.
32562 C     PARAMETER ( MXWWSP = 3 )
32563 C     PARAMETER ( WWSPMX = 50.D+00 )
32564 C     LOGICAL LWWNDW, LWWPRM
32565 C     COMMON / WWINDW / ETHWW1 (NALLWP), ETHWW2 (NALLWP),
32566 C    &                  WWEXWD (NALLWP), EXTWWN (NALLWP),
32567 C    &                  IWLBGN, IWHBGN, IWMBGN, LWWNDW, LWWPRM
32568 **
32569
32570 * /blnkcm/
32571 * *** If blank common dimension has to be superseded substitute in the
32572 * *** following two lines the new dimension in real*8 units to Nblnmx
32573 **sr 18.5. commented since not used for evap.
32574 C     PARAMETER (MXDUMM = KALGNM * NBLNMX)
32575 C     DATA KTMBGN / NBLNMX /
32576 C     DATA MBLNMX / MXDUMM /
32577 C     DATA KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST, KISBGN, KISLST,
32578 C    &     KDTBGN, KDTLST, KUBBGN, KUBLST, KUXBGN, KUXLST, KTCBGN,
32579 C    &     KTCLST, KRNBGN, KRNLST, KYLBGN, KYLLST, KXSBGN, KXSLST,
32580 C    &     KIHBGN, KIHLST, KINBGN, KINLST, KIEBGN, KIELST, KETBGN,
32581 C    &     KETLST, KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32582 C    &     KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST, KWLBGN,
32583 C    &     KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST, KWSBGN, KWSLST,
32584 C    &     KDPBGN, KDPLST, KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN,
32585 C    &     KBRLST / 57*0 /
32586
32587 * /blntmp/
32588 **sr 18.5. commented since not used for evap.
32589 C     DATA KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM, KGDWTM,
32590 C    &     KBDWTM, KGCBTM, KWLOTM, KWHITM, KWMUTM, KWSHTM, KEXTTM,
32591 C    &     KSTXTM, KSTNTM, KECTTM, KPCTTM, KLPBTM / 19*0 /
32592
32593 * /cmmdnr/
32594 **sr 18.5. commented since not used for evap.
32595 C     DATA DDNEAR / 0.D+00 /, LFLDNR / .FALSE. /
32596
32597 * /ctitle/
32598 **sr 18.5. commented since not used for evap.
32599 C     DATA RUNTIT (1:40) / '****************************************' /
32600 C     DATA RUNTIT(41:80) / '****************************************' /
32601 C     DATA ITEXPI, ITEXMX / 100000000, 150 /
32602 * /detect/
32603 **sr 18.5. commented since not used for evap.
32604 C     PARAMETER (NNN1 = NRGNMX*NDTCMX)
32605 C     PARAMETER (NNN2 = NSCRMX*NDTCMX)
32606 C     DATA LDTCTR /.FALSE./, NDTSCO /0/, NDTDET /0/
32607 C     DATA EDTMIN/NDTCMX*0.D0/, EDTBIN/NDTCMX*0.D0/, EDTCUT/NDTCMX*0.D0/
32608 C     DATA KDTREG/NNN1*0/, KDTDET/NNN2*0/, KDTSCD/NSCRMX*0/
32609 C     DATA TITDET/NDTCMX*'          '/, TITSCO/NSCRMX*'          '/
32610
32611 * /detloc/
32612 **sr 18.5. commented since not used for evap.
32613 C     DATA ACCUMP /NDTCM2*0.D0/, ACCUMN /NDTCM2*0.D0/, ICOINC /NDTCM2*0/
32614 C     DATA NCLAS /0/
32615
32616 * /emgtrn/
32617 **sr 18.5. commented since not used for evap.
32618 C     DATA LMCSMG / .FALSE. /
32619
32620 * /emsho/
32621 **sr 18.5. commented since not used for evap.
32622 C     DATA LIMPRE, LEXPTE / 2 * .FALSE. /
32623
32624 * /episor/
32625 **sr 18.5. commented since not used for evap.
32626 C     DATA TKESUM / 0.D+00 /, LUSSRC / .FALSE. /
32627
32628 * /fheavy/
32629       DATA AMHEAV / 12 * 0.D+00 /
32630       DATA ANHEAV / 'NEUTRON ', 'PROTON  ', 'DEUTERON', '3-H     ',
32631      &              '3-He    ', '4-He    ', 'H-FRAG-1', 'H-FRAG-2',
32632      &              'H-FRAG-3', 'H-FRAG-4', 'H-FRAG-5', 'H-FRAG-6'/
32633       DATA ICHEAV / 0, 1, 1, 1, 2, 2, 6*0 /,
32634      &     IBHEAV / 1, 1, 2, 3, 3, 4, 6*0 /
32635       DATA NPHEAV / 0 /
32636
32637 * /finuc/
32638       DATA NP / 0 /, TV / 0.D+00 /, TVCMS / 0.D+00 /, TVRECL / 0.D+00/,
32639      &     TVHEAV / 0.D+00 /, TVBIND / 0.D+00 /
32640
32641 * /genthr/
32642 * Up to 20-apr-'95
32643 *     DATA PEANCT, PEAPIT / 2*1.D+00 /
32644 *     DATA PTHRSH / 16*5.D+00,2*2.5D+00,5.D+00,3*2.5D+00,8*5.D+00,
32645 *    &              9*2.5D+00 /
32646 *     DATA PTHDFF / 39*5.D+00 /
32647 *    &              9*2.5D+00 /
32648 * New values:
32649 **sr 18.5. commented since not used for evap.
32650 C     DATA PEANCT, PEAPIT / 1.3D+00, 1.1D+00 /
32651 C     DATA PTHRSH / 12*5.D+00, 2*3.5D+00, 2*5.D+00, 2*2.5D+00, 5.D+00,
32652 C    &              3*2.5D+00, 3.5D+00, 2*5.D+00, 3.5D+00, 4*5.D+00,
32653 C    &              9*2.5D+00 /
32654 C     DATA PTHDFF / 12*5.D+00, 2*3.5D+00, 8*5.D+00, 3.5D+00, 2*5.D+00,
32655 C    &              3.5D+00, 13*5.D+00 /
32656 C     DATA PLDNCT / 0.26D+00 /
32657 C     DATA IJNUCR / 16*1, 2*0, 1, 3*0, 8*1, 9*0 /
32658
32659 * /lowneu/
32660 **sr 18.5. commented since not used for evap.
32661 C     DATA WWAMFL / 10.D+00 /, EXTWWL / 1.D+00 /
32662 C     DATA IWWLWB, IWWLWT / 2 * 100000000 /
32663 C     DATA ICLMED, INABGN, IDWBGN, IETBGN / 4*0 /
32664 C     DATA IGRTHN / 1 /
32665 C     DATA LIMPRN / .FALSE. /, LBIASN / .FALSE. /, LDOWNN / .FALSE. /,
32666 C    &     LLOWWW / .FALSE. /, LLOWET / .FALSE. /
32667
32668 * /ltclcm/
32669 **sr 18.5. commented since not used for evap.
32670 C     DATA MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1 / 6*0 /
32671
32672 * /mulbou/
32673 **sr 18.5. commented since not used for evap.
32674 C     DATA LLDA, LAGAIN, LSTNEW, LARTEF, LSENSE, LNORML, LMGNOR
32675 C    &     / 7 * .FALSE. /
32676 C     DATA TSENSE / AINFNT /, NSSENS / -1 /
32677 C     DATA DSMALL / ANGLGB /
32678
32679 * /mulhd/
32680 **sr 18.5. commented since not used for evap.
32681 C     DATA LTOPT  / MXXMDF * .FALSE. /, NFSCAT / 0 /
32682 C     DATA ESTEPF / MXXMDF * 0.1D+00 /
32683 C     DATA LSRCRH / MXXMDF * .FALSE. /, LNSCRH / MXXMDF * .FALSE. /
32684 C     DATA THMSPR / 0.02D+00 /, THMSSC / 1.D+00 /
32685
32686 * /parevt/
32687       DATA DPOWER /-13.D+00 /, FSPRD0 / 0.6D+00 /, FSHPFN / 0.0D+00 /,
32688      &     RN1GSC /-1.0D+00 /, RN2GSC /-1.0D+00 /
32689       DATA LDIFFR /  .TRUE., .TRUE., 6 * .TRUE., .TRUE., 8 * .TRUE.,
32690      &               .TRUE., 4 * .TRUE., .TRUE., 3 * .TRUE.,
32691      &              4 * .FALSE., 9 * .TRUE./
32692 **sr 17.5.95
32693 * default value for LEVPRT changed (reset sr 25.7.97)
32694 * default value for LHEAVY changed 25.7.97
32695 C     DATA LPOWER / .TRUE.  /, LINCTV / .TRUE.  /, LEVPRT / .TRUE.  /,
32696 C    &     LHEAVY / .FALSE. /, LDEEXG / .TRUE.  /, LGDHPR / .TRUE.  /,
32697 C    &     LPREEX / .TRUE.  /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32698 C    &     LPARWV / .TRUE.  /, LSNGCH / .TRUE.  /, LSCHDF / .TRUE.  /
32699       DATA LPOWER / .TRUE.  /, LINCTV / .TRUE.  /, LEVPRT / .TRUE.  /,
32700      &     LHEAVY / .TRUE.  /, LDEEXG / .TRUE.  /, LGDHPR / .TRUE.  /,
32701      &     LPREEX / .TRUE.  /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32702      &     LPARWV / .TRUE.  /, LSNGCH / .TRUE.  /, LSCHDF / .TRUE.  /
32703 **
32704 **sr 27.5.97
32705 * default value for ILVMOD changed
32706 C     DATA ILVMOD / 0 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32707       DATA ILVMOD / 1 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32708 **
32709
32710 * /resnuc/
32711       DATA IPREEH / 0 /, IPRTRI / 0 /, IPRDEU / 0 /, IPR3HE / 0 /,
32712      &     IPR4HE / 0 /
32713       DATA IEVAPL / 0 /, IEVAPH / 0 /, IEVNEU / 0 /, IEVPRO / 0 /,
32714      &     IEVTRI / 0 /, IEVDEU / 0 /, IEV3HE / 0 /, IEV4HE / 0 /,
32715      &     IDEEXG / 0 /
32716       DATA LRNFSS / .FALSE. /
32717
32718 * /scohlp/
32719 **sr 18.5. commented since not used for evap.
32720 C     DATA ISCRNG, JSCRNG / 2*0 /, LSCZER / .FALSE. /
32721
32722 * /trackr/
32723 **sr 18.5. commented since not used for evap.
32724 C     DATA ETRACK /0.D+00/, WTRACK /0.D+00/, ATRACK /0.D+00/,
32725 C    &     CTRACK /0.D+00/, NTRACK /0/, MTRACK /0/, JTRACK /0/
32726
32727 * /usrbin/
32728 **sr 18.5. commented since not used for evap.
32729 C     DATA LUSBIN, LUSEVT, LUSTKB /3*.FALSE./, NUSRBN /0/
32730
32731 * /usrbdx/
32732 **sr 18.5. commented since not used for evap.
32733 C     DATA LUSBDX /.FALSE./, NUSRBX /0/
32734
32735 * /usrsnc/
32736 **sr 18.5. commented since not used for evap.
32737 C     DATA LURSNC /.FALSE./, NURSNC /0/
32738
32739 * /usrtrc/
32740 **sr 18.5. commented since not used for evap.
32741 C     DATA LUSRTC, LUSTRK, LUSCLL / 3*.FALSE. /
32742 C     DATA NUSRTC, NUSTRK, NUSCLL / 3*0 /
32743
32744 * /usryld/
32745 **sr 18.5. commented since not used for evap.
32746 C     DATA LUSRYL / .FALSE./, LSCUYL / .FALSE. /, NUSRYL /0/,
32747 C    &     IJUSYL /0/, JTUSYL /0/
32748 C     DATA PUSRYL, UUSRYL, VUSRYL, WUSRYL / 4*ZERZER /
32749
32750 * /wwindw/
32751 **sr 18.5. commented since not used for evap.
32752 C     DATA IWLBGN, IWHBGN, IWMBGN / 3*0 /
32753 C     DATA LWWPRM / .TRUE. /
32754
32755 *=                                               end*block.bdnopt      *
32756       END
32757
32758 *$ CREATE DT_BDPREE.FOR
32759 *COPY DT_BDPREE
32760 *
32761 *=== bdpree ===========================================================*
32762 *
32763       BLOCK DATA DT_BDPREE
32764
32765 C     INCLUDE '(DBLPRC)'
32766 * DBLPRC.ADD
32767       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32768       SAVE
32769 * (original name: GLOBAL)
32770       PARAMETER ( KALGNM = 2 )
32771       PARAMETER ( ANGLGB = 5.0D-16 )
32772       PARAMETER ( ANGLSQ = 2.5D-31 )
32773       PARAMETER ( AXCSSV = 0.2D+16 )
32774       PARAMETER ( ANDRFL = 1.0D-38 )
32775       PARAMETER ( AVRFLW = 1.0D+38 )
32776       PARAMETER ( AINFNT = 1.0D+30 )
32777       PARAMETER ( AZRZRZ = 1.0D-30 )
32778       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32779       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32780       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32781       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32782       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
32783       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
32784       PARAMETER ( CSNNRM = 2.0D-15 )
32785       PARAMETER ( DMXTRN = 1.0D+08 )
32786       PARAMETER ( ZERZER = 0.D+00 )
32787       PARAMETER ( ONEONE = 1.D+00 )
32788       PARAMETER ( TWOTWO = 2.D+00 )
32789       PARAMETER ( THRTHR = 3.D+00 )
32790       PARAMETER ( FOUFOU = 4.D+00 )
32791       PARAMETER ( FIVFIV = 5.D+00 )
32792       PARAMETER ( SIXSIX = 6.D+00 )
32793       PARAMETER ( SEVSEV = 7.D+00 )
32794       PARAMETER ( EIGEIG = 8.D+00 )
32795       PARAMETER ( ANINEN = 9.D+00 )
32796       PARAMETER ( TENTEN = 10.D+00 )
32797       PARAMETER ( HLFHLF = 0.5D+00 )
32798       PARAMETER ( ONETHI = ONEONE / THRTHR )
32799       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32800       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32801       PARAMETER ( THRTWO = THRTHR / TWOTWO )
32802       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32803       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32804       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32805       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32806       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32807       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32808       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32809       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
32810       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
32811       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
32812       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
32813       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32814       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32815       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32816       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32817       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32818       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32819       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32820       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32821       PARAMETER ( CLIGHT = 2.99792458         D+10 )
32822       PARAMETER ( AVOGAD = 6.0221367          D+23 )
32823       PARAMETER ( BOLTZM = 1.380658           D-23 )
32824       PARAMETER ( AMELGR = 9.1093897          D-28 )
32825       PARAMETER ( PLCKBR = 1.05457266         D-27 )
32826       PARAMETER ( ELCCGS = 4.8032068          D-10 )
32827       PARAMETER ( ELCMKS = 1.60217733         D-19 )
32828       PARAMETER ( AMUGRM = 1.6605402          D-24 )
32829       PARAMETER ( AMMUMU = 0.113428913        D+00 )
32830       PARAMETER ( AMPRMU = 1.007276470        D+00 )
32831       PARAMETER ( AMNEMU = 1.008664904        D+00 )
32832       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32833       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32834       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32835       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32836       PARAMETER ( PLABRC = 0.197327053        D+00 )
32837       PARAMETER ( AMELCT = 0.51099906         D-03 )
32838       PARAMETER ( AMUGEV = 0.93149432         D+00 )
32839       PARAMETER ( AMMUON = 0.105658389        D+00 )
32840       PARAMETER ( AMPRTN = 0.93827231         D+00 )
32841       PARAMETER ( AMNTRN = 0.93956563         D+00 )
32842       PARAMETER ( AMDEUT = 1.87561339         D+00 )
32843       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32844      &                   * 1.D-09 )
32845       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32846       PARAMETER ( BLTZMN = 8.617385           D-14 )
32847       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32848       PARAMETER ( GFOHB3 = 1.16639            D-05 )
32849       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32850       PARAMETER ( SIN2TW = 0.2319             D+00 )
32851       PARAMETER ( GEVMEV = 1.0                D+03 )
32852       PARAMETER ( EMVGEV = 1.0                D-03 )
32853       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
32854       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32855       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32856       LOGICAL LGBIAS, LGBANA
32857       COMMON /FKGLOB/ LGBIAS, LGBANA
32858 C     INCLUDE '(DIMPAR)'
32859 * DIMPAR.ADD
32860       PARAMETER ( MXXRGN = 5000 )
32861       PARAMETER ( MXXMDF = 82   )
32862       PARAMETER ( MXXMDE = 54   )
32863       PARAMETER ( MFSTCK = 1000 )
32864       PARAMETER ( MESTCK = 100  )
32865       PARAMETER ( NALLWP = 39   )
32866       PARAMETER ( NELEMX = 80   )
32867       PARAMETER ( MPDPDX = 8    )
32868       PARAMETER ( ICOMAX = 180  )
32869       PARAMETER ( NSTBIS = 304  )
32870       PARAMETER ( IDMAXP = 220  )
32871       PARAMETER ( IDMXDC = 640  )
32872       PARAMETER ( MKBMX1 = 1    )
32873       PARAMETER ( MKBMX2 = 1    )
32874 C     INCLUDE '(IOUNIT)'
32875 * IOUNIT.ADD
32876       PARAMETER ( LUNIN  =  5 )
32877       PARAMETER ( LUNOUT =  6 )
32878 **sr 19.5. set error output-unit from 15 to 6
32879       PARAMETER ( LUNERR = 6  )
32880       PARAMETER ( LUNBER = 14 )
32881       PARAMETER ( LUNECH =  8 )
32882       PARAMETER ( LUNFLU = 13 )
32883       PARAMETER ( LUNGEO = 16 )
32884       PARAMETER ( LUNPMF = 12 )
32885       PARAMETER ( LUNRAN =  2 )
32886       PARAMETER ( LUNXSC =  9 )
32887       PARAMETER ( LUNDET = 17 )
32888       PARAMETER ( LUNRAY = 10 )
32889       PARAMETER ( LUNRDB =  1 )
32890       PARAMETER ( LUNPGO =  7 )
32891       PARAMETER ( LUNPGS =  4 )
32892       PARAMETER ( LUNSCR =  3 )
32893 *
32894 *----------------------------------------------------------------------*
32895 *                                                                      *
32896 *     Created on 16 september 1991 by    Alfredo Ferrari & Paola Sala  *
32897 *                                                   Infn - Milan       *
32898 *                                                                      *
32899 *     Last change on 03-feb-94     by    Alfredo Ferrari               *
32900 *                                                                      *
32901 *                                                                      *
32902 *----------------------------------------------------------------------*
32903 *
32904 * (original name: CMPISG,CHPISG)
32905       PARAMETER ( TPPPI0 = 0.279656044337515D+00 )
32906       PARAMETER ( TNNPI0 = 0.279642680857450D+00 )
32907       PARAMETER ( TPPPIP = 0.292295207182790D+00 )
32908       PARAMETER ( TPPDEP = 0.287514778898469D+00 )
32909       PARAMETER ( TNNPIM = 0.286723140900975D+00 )
32910       PARAMETER ( TNNDEM = 0.281949292916434D+00 )
32911       PARAMETER ( TPNPI0 = 0.279456888147740D+00 )
32912       PARAMETER ( TPNDE0 = 0.274693916135245D+00 )
32913       PARAMETER ( TPNPIP = 0.292086756473890D+00 )
32914       PARAMETER ( TNPPI0 = 0.279842093144975D+00 )
32915       PARAMETER ( TNPDE0 = 0.275072555824202D+00 )
32916       PARAMETER ( TNPPIP = 0.292489370554958D+00 )
32917       PARAMETER ( PIRSMX = 1.2D+00 )
32918       PARAMETER ( NPIREA = 10 )
32919       PARAMETER ( NPIRTA = 68 )
32920       PARAMETER ( NPIRLN = 21 )
32921       PARAMETER ( NPIRLG = NPIRTA - NPIRLN )
32922       PARAMETER ( NPISIS = NPIRLN + 20 )
32923       PARAMETER ( NPISEX = NPIRLN + 21 )
32924       PARAMETER ( NPIIMN = 14 )
32925       PARAMETER ( NPIIRC =  6 )
32926       PARAMETER ( DELWLL = 0.035D+00 )
32927       CHARACTER CHPIRE*8
32928       LOGICAL LDLRES
32929       COMMON /FKCMPI/ PMNPIS, PMMPIS, PISPIS, PEXPIS, PMXPIS, DPPISG,
32930      &                RTPISG, AMNPIS, AMMPIS, AISPIS, AEXPIS, AMXPIS,
32931      &                ARPISG, BPISLO (NPIRLN:NPIRTA,NPIREA),
32932      &                CPISLO (NPIRLN:NPIRTA,NPIREA), PPITHR (NPIREA),
32933      &                SPISLO (NPIRLN:NPIRTA,NPIREA), APITHR (NPIREA),
32934      &                SGPIIN (NPIIMN:NPIRTA,NPIIRC), RHPICR (1:5)   ,
32935      &                SGPICU (0:20,NPIRTA,NPIREA)  , SGRTRS (NPIREA),
32936      &                SGPIDF (0:20,NPIRTA,NPIREA)  , BRREIN (NPIREA),
32937      &                SGPIIS (NPIRTA,NPIREA)       , BRREOU (NPIREA),
32938      &                BRD3OU (2,2,-1:2), BRDEOU (2,-1:2),
32939      &                SGABSR (2,2,4)   , PRRSDL,
32940      &                IPIREA (2,2,3:5) , IPIINE (2,3:5)    , NPIRVR ,
32941      &                KPIIRE (2,NPIREA), KPIORE (2,NPIREA) ,
32942      &                JSTOKP (5), KPTOJS (23), ITTRRS (3:5), LDLRES
32943       COMMON /FKCHPI/ CHPIRE (NPIREA)
32944       DIMENSION SG2BRS (2,2), SGABSW (2,2), SG3BRS (2,2,2)
32945       EQUIVALENCE ( SG2BRS   (1,1), SGABSR (1,1,1) )
32946       EQUIVALENCE ( SGABSW   (1,1), SGABSR (1,1,2) )
32947       EQUIVALENCE ( SG3BRS (1,1,1), SGABSR (1,1,3) )
32948 * (original name: FRBKCM)
32949       PARAMETER ( MXFFBK =     6 )
32950       PARAMETER ( MXZFBK =     9 )
32951       PARAMETER ( MXNFBK =    10 )
32952       PARAMETER ( MXAFBK =    16 )
32953       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
32954       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
32955       PARAMETER ( NXAFBK = MXAFBK + 1 )
32956       PARAMETER ( MXPSST =   300 )
32957       PARAMETER ( MXPSFB = 41000 )
32958       LOGICAL LFRMBK, LNCMSS
32959       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
32960      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
32961      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
32962      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
32963      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
32964      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
32965      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
32966      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
32967      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
32968 * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
32969       PARAMETER ( PI     = PIPIPI )
32970       PARAMETER ( PISQ   = PIPISQ )
32971       PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
32972       PARAMETER ( RZNUCL = 1.12        D+00 )
32973       PARAMETER ( RMSPRO = 0.8         D+00 )
32974       PARAMETER ( R0PROT = RMSPRO / SQRT12  )
32975       PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
32976      &          / R0PROT )
32977       PARAMETER ( RLLE04 = RZNUCL )
32978       PARAMETER ( RLLE16 = RZNUCL )
32979       PARAMETER ( RLGT16 = RZNUCL )
32980       PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
32981       PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
32982       PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
32983       PARAMETER ( SKLE04 = 1.4D+00 )
32984       PARAMETER ( SKLE16 = 1.9D+00 )
32985       PARAMETER ( SKGT16 = 2.4D+00 )
32986       PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
32987       PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
32988       PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
32989       PARAMETER ( ALPHA0 = 0.1D+00 )
32990       PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
32991       PARAMETER ( GAMSK0 = 0.9D+00 )
32992       PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
32993       PARAMETER ( POTME0 = 0.6666666666666667D+00 )
32994       PARAMETER ( POTBA0 = 1.D+00 )
32995       PARAMETER ( PNFRAT = 1.533D+00 )
32996       PARAMETER ( RADPIM = 0.035D+00 )
32997       PARAMETER ( RDPMHL = 14.D+00   )
32998       PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
32999       PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
33000       PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
33001       PARAMETER ( AP0PFS = 0.5D+00 )
33002       PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
33003       PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
33004       PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
33005       PARAMETER ( MXSCIN = 50     )
33006       LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
33007      &        LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
33008       COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
33009      &                RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
33010      &                SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
33011      &                CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
33012      &                PFRTAB (2:260)
33013       COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
33014      &                ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
33015      &                RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
33016      &                YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
33017      &                RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
33018      &                PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
33019      &                PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
33020      &                BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
33021      &                YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
33022      &                XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
33023      &                SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
33024      &                R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
33025      &                PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
33026      &                EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
33027      &                PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
33028      &                EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
33029      &                PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
33030      &                BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
33031       COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
33032      &                RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
33033      &                EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
33034      &                BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
33035      &                WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
33036      &                POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
33037      &                BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
33038      &                SIGPAB (3), SIGNAB (3), HHLP   (2), FORTOT (2),
33039      &                FPNBLC, DPNBLC, FFTFLG, IFTFLG,
33040      &                IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
33041      &                KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
33042      &                NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
33043      &                IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
33044      &                LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
33045       COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
33046       COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
33047      &                YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
33048      &                AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
33049      &                NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
33050      &                NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
33051      &                ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
33052      &                LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
33053      &                LNCDCY, LNUSCT
33054       DIMENSION AWSTAB (2:260), SIGMAB (3)
33055       EQUIVALENCE ( DEFPRO, DEFNUC (1) )
33056       EQUIVALENCE ( DEFNEU, DEFNUC (2) )
33057       EQUIVALENCE ( RHOIPP, RHONCP (1) )
33058       EQUIVALENCE ( RHOINP, RHONCP (2) )
33059       EQUIVALENCE ( RHOIP2, RHONC2 (1) )
33060       EQUIVALENCE ( RHOIN2, RHONC2 (2) )
33061       EQUIVALENCE ( RHOIP3, RHONC3 (1) )
33062       EQUIVALENCE ( RHOIN3, RHONC3 (2) )
33063       EQUIVALENCE ( RHOIPT, RHONCT (1) )
33064       EQUIVALENCE ( RHOINT, RHONCT (2) )
33065       EQUIVALENCE ( OMALHL, SK3PAR )
33066       EQUIVALENCE ( ALPHAL, HABPAR )
33067       EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
33068       EQUIVALENCE ( SIGMPE, SIGMPR (1) )
33069       EQUIVALENCE ( SIGMPC, SIGMPR (2) )
33070       EQUIVALENCE ( SIGMPI, SIGMPR (3) )
33071       EQUIVALENCE ( SIGMPA, SIGMPR (4) )
33072       EQUIVALENCE ( SIGMNE, SIGMNU (1) )
33073       EQUIVALENCE ( SIGMNC, SIGMNU (2) )
33074       EQUIVALENCE ( SIGMNI, SIGMNU (3) )
33075       EQUIVALENCE ( SIGMNA, SIGMNU (4) )
33076       EQUIVALENCE ( SIGMA2, SIGPAB (1) )
33077       EQUIVALENCE ( SIGMA3, SIGPAB (2) )
33078       EQUIVALENCE ( SIGMAS, SIGPAB (3) )
33079       EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
33080 * (original name: NUCLEV)
33081       LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
33082       COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
33083      &                DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
33084      &                CUMRAD (0:160,2), RUSNUC (2),
33085      &                ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
33086      &                NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
33087      &                NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
33088      &                JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
33089      &                MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
33090      &                NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
33091      &                LFLVSL, LRLVSL, LEQSBL
33092       DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
33093      &          MGSSPR (19) , MGSSNE (25)
33094       EQUIVALENCE ( RUSNUC (1), RUSPRO )
33095       EQUIVALENCE ( RUSNUC (2), RUSNEU )
33096       EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
33097       EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
33098       EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
33099       EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
33100       EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
33101       EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
33102       EQUIVALENCE ( NTANUC (1), NTAPRO )
33103       EQUIVALENCE ( NTANUC (2), NTANEU )
33104       EQUIVALENCE ( NAVNUC (1), NAVPRO )
33105       EQUIVALENCE ( NAVNUC (2), NAVNEU )
33106       EQUIVALENCE ( NLSNUC (1), NLSPRO )
33107       EQUIVALENCE ( NLSNUC (2), NLSNEU )
33108       EQUIVALENCE ( NCONUC (1), NCOPRO )
33109       EQUIVALENCE ( NCONUC (2), NCONEU )
33110       EQUIVALENCE ( NSKNUC (1), NSKPRO )
33111       EQUIVALENCE ( NSKNUC (2), NSKNEU )
33112       EQUIVALENCE ( NHANUC (1), NHAPRO )
33113       EQUIVALENCE ( NHANUC (2), NHANEU )
33114       EQUIVALENCE ( NUSNUC (1), NUSPRO )
33115       EQUIVALENCE ( NUSNUC (2), NUSNEU )
33116       EQUIVALENCE ( NACNUC (1), NACPRO )
33117       EQUIVALENCE ( NACNUC (2), NACNEU )
33118       EQUIVALENCE ( JMXNUC (1), JMXPRO )
33119       EQUIVALENCE ( JMXNUC (2), JMXNEU )
33120       EQUIVALENCE ( MAGNUC (1), MAGPRO )
33121       EQUIVALENCE ( MAGNUC (2), MAGNEU )
33122 * (original name: PARNUC)
33123       PARAMETER ( PIGRK  = PIPIPI )
33124       PARAMETER ( ALEVEL = 8.D-03 )
33125       PARAMETER ( RCNUCL = 1.12D+00 )
33126       PARAMETER ( R0SIG  = 1.3D+00 )
33127       PARAMETER ( R0SIGK = 1.5D+00 )
33128       PARAMETER ( RCOULB = 1.5D+00 )
33129       PARAMETER ( COULBH = 0.88235D-03 )
33130       PARAMETER ( RHONU0 = 0.75D+00 / PIGRK / RCNUCL / RCNUCL / RCNUCL )
33131       PARAMETER ( TAUFO0 = 10.0D+00 )
33132       PARAMETER ( EKEEXP = 0.03D+00 )
33133       PARAMETER ( EKREXP = 0.05D+00 )
33134       PARAMETER ( EKEMNM = 0.01D+00 )
33135       PARAMETER ( NCPMX = 120 )
33136       COMMON /FKPARN/ EKORI , PXORI , PYORI , PZORI , PTORI , TAUFOR,
33137      &                ENNUC  (NCPMX), PNUCL  (NCPMX), EKFNUC (NCPMX),
33138      &                XSTNUC (NCPMX), YSTNUC (NCPMX), ZSTNUC (NCPMX),
33139      &                PXNUCL (NCPMX), PYNUCL (NCPMX), PZNUCL (NCPMX),
33140      &                RSTNUC (NCPMX), FREEPA (NCPMX), CRRPAN (NCPMX),
33141      &                CRRPAP (NCPMX), BSTNUC (NCPMX), AGENUC (NCPMX),
33142      &                TAUFPA (NCPMX), RHNUCL(NCPMX,2), BNDGAV, DEFMIN,
33143      &                KPNUCL (NCPMX), KRFNUC (NCPMX), ILINUC (NCPMX),
33144      &                INUCTS (NCPMX), ISFNUC (NCPMX), KPORI , IBORI ,
33145      &                IBNUCL, NPNUC , NNUCTS
33146 *
33147       DATA LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH / 6*.FALSE. /
33148       DATA POTBAR / POTBA0 /, POTMES / POTME0 /, WLLRES / 0.D+00 /
33149       DATA JUSNUC / 320 * 0 /, INUCLV / 1 /, IEVPRE / 0 /
33150       DATA MAGNUM / 2, 8, 20, 28, 50, 82, 126, 160 /
33151       DATA LPREEQ / .FALSE. /
33152 * /cmpisg/
33153       DATA JSTOKP / 1, 8, 13, 14, 23 /
33154       DATA KPTOJS / 1, 6*0, 2, 4*0, 3, 4, 8*0, 5 /
33155       DATA CHPIRE / 'PI+PPI+P','PI-PPI-P','PI-PPI0N','PI0PPI0P',
33156      &              'PI0PPI+N','PI-NPI-N','PI+NPI+N','PI+NPI0P',
33157      &              'PI0NPI0N','PI0NPI-P' /
33158       DATA KPIIRE / 13, 1, 14, 1, 14, 1, 23, 1, 23, 1, 14, 8,
33159      &              13, 8, 13, 8, 23, 8, 23, 8 /
33160       DATA KPIORE / 13, 1, 14, 1, 23, 8, 23, 1, 13, 8, 14, 8,
33161      &              13, 8, 23, 1, 23, 8, 14, 1 /
33162       DATA IPIREA / 1, 0, 7, 8, 2, 3, 6, 0, 4, 5, 9, 10 /
33163       DATA IPIINE / 1, 2, 3, 4, 5, 6 /
33164 * /frbkcm/
33165       DATA LFRMBK / .FALSE. /
33166       DATA NBUFBK /   500  /
33167       DATA EXMXFB / 80.0 D+00 /
33168       DATA R0FRBK / 1.18 D+00 /
33169       DATA R0CFBK / 2.173D+00 /
33170       DATA C1CFBK / 6.103D-03 /
33171       DATA C2CFBK / 9.443D-03 /
33172 * /parnuc/
33173       DATA TAUFOR / TAUFO0 /
33174 *=== End of Block Data Bdpree =========================================*
33175       END
33176
33177 *$ CREATE DT_XHOINI.FOR
33178 *COPY DT_XHOINI
33179 *
33180 *====phoini============================================================*
33181 *
33182       SUBROUTINE DT_XHOINI
33183 C     SUBROUTINE DT_PHOINI
33184
33185       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33186       SAVE
33187       PARAMETER ( LINP = 10 ,
33188      &            LOUT = 6 ,
33189      &            LDAT = 9 )
33190
33191       RETURN
33192       END
33193
33194 *$ CREATE DT_XVENTB.FOR
33195 *COPY DT_XVENTB
33196 *
33197 *====eventb============================================================*
33198 *
33199       SUBROUTINE DT_XVENTB(NCSY,IREJ)
33200 C     SUBROUTINE DT_EVENTB(NCSY,IREJ)
33201
33202       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33203       SAVE
33204       PARAMETER ( LINP = 10 ,
33205      &            LOUT = 6 ,
33206      &            LDAT = 9 )
33207
33208       WRITE(LOUT,1000)
33209  1000 FORMAT(1X,'EVENTB:   PHOJET-package requested but not linked!')
33210       STOP
33211
33212       END
33213
33214 *$ CREATE DT_XVENT.FOR
33215 *COPY DT_XVENT
33216 *
33217 *===event==============================================================*
33218 *
33219       SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
33220 C     SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
33221
33222       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33223       SAVE
33224
33225       DIMENSION PP(4),PT(4)
33226
33227       RETURN
33228       END
33229
33230 *$ CREATE DT_XOHISX.FOR
33231 *COPY DT_XOHISX
33232 *
33233 *===pohisx=============================================================*
33234 *
33235       SUBROUTINE DT_XOHISX(I,X)
33236 C     SUBROUTINE POHISX(I,X)
33237
33238       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33239       SAVE
33240
33241       RETURN
33242       END
33243
33244 *$ CREATE PHO_LHIST.FOR
33245 *COPY PHO_LHIST
33246 *
33247 *===poluhi=============================================================*
33248 *
33249       SUBROUTINE PHO_LHIST(I,X)
33250 **
33251
33252       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33253       SAVE
33254
33255       RETURN
33256       END
33257
33258 *$ CREATE PDFSET.FOR
33259 *COPY PDFSET
33260 *
33261 C**********************************************************************
33262 C
33263 C   dummy subroutines, remove to link PDFLIB
33264 C
33265 C**********************************************************************
33266       SUBROUTINE PDFSET(PARAM,VALUE)
33267       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33268       DIMENSION PARAM(20),VALUE(20)
33269       CHARACTER*20 PARAM
33270       END
33271
33272 *$ CREATE STRUCTM.FOR
33273 *COPY STRUCTM
33274 *
33275       SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33276       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33277       END
33278
33279 *$ CREATE STRUCTP.FOR
33280 *COPY STRUCTP
33281 *
33282       SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33283       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33284       END
33285
33286 *$ CREATE DT_DIQBRK.FOR
33287 *COPY DT_DIQBRK
33288 *
33289 *===diqbrk=============================================================*
33290 *
33291       SUBROUTINE DT_XIQBRK
33292 C     SUBROUTINE DT_DIQBRK
33293
33294       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33295       SAVE
33296
33297       STOP 'diquark-breaking not implemeted !'
33298
33299       RETURN
33300       END
33301
33302 *$ CREATE DT_ELHAIN.FOR
33303 *COPY DT_ELHAIN
33304 *
33305 *===elhain=============================================================*
33306 *
33307       SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
33308
33309 ************************************************************************
33310 * Elastic hadron-hadron scattering.                                    *
33311 * This is a revised version of the original.                           *
33312 * This version dated 03.04.98 is written by S. Roesler                 *
33313 ************************************************************************
33314
33315       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33316       SAVE
33317       PARAMETER ( LINP = 10 ,
33318      &            LOUT = 6 ,
33319      &            LDAT = 9 )
33320       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33321      &           TINY10=1.0D-10)
33322
33323       PARAMETER (ENNTHR = 3.5D0)
33324       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
33325      &           BLOWB=0.05D0,BHIB=0.2D0,
33326      &           BLOWM=0.1D0, BHIM=2.0D0)
33327
33328 * particle properties (BAMJET index convention)
33329       CHARACTER*8  ANAME
33330       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33331      &                IICH(210),IIBAR(210),K1(210),K2(210)
33332 * final state from HADRIN interaction
33333       PARAMETER (MAXFIN=10)
33334       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33335      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33336
33337 C     DATA TSLOPE /10.0D0/
33338
33339       IREJ = 0
33340
33341     1 CONTINUE
33342
33343       PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
33344       EKIN = ELAB-AAM(IP)
33345 *   kinematical quantities in cms of the hadrons
33346       AMP2 = AAM(IP)**2
33347       AMT2 = AAM(IT)**2
33348       S    = AMP2+AMT2+TWO*ELAB*AAM(IT)
33349       ECM  = SQRT(S)
33350       ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
33351       PCM  = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
33352
33353 * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
33354       IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
33355      &     ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
33356 *   TSAMCS treats pp and np only, therefore change pn into np and
33357 *   nn into pp
33358          IF (IT.EQ.1) THEN
33359             KPROJ = IP
33360          ELSE
33361             KPROJ = 8
33362             IF (IP.EQ.8) KPROJ = 1
33363          ENDIF
33364          CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
33365          T = TWO*PCM**2*(CTCMS-ONE)
33366
33367 * very crude treatment otherwise: sample t from exponential dist.
33368       ELSE
33369 *   momentum transfer t
33370          TMAX = TWO*TWO*PCM**2
33371          RR = (PLAB-PLOWH)/(PHIH-PLOWH)
33372          IF (IIBAR(IP).NE.0) THEN
33373             TSLOPE = BLOWB+RR*(BHIB-BLOWB)
33374          ELSE
33375             TSLOPE = BLOWM+RR*(BHIM-BLOWM)
33376          ENDIF
33377          FMAX = EXP(-TSLOPE*TMAX)-ONE
33378          R = DT_RNDM(RR)
33379          T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
33380          IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
33381       ENDIF
33382
33383 *   target hadron in Lab after scattering
33384       ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
33385       PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
33386       IF (PLRH(2).LE.TINY10) THEN
33387 C        WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
33388          GOTO 1
33389       ENDIF
33390 *   projectile hadron in Lab after scattering
33391       ELRH(1) = ELAB+AAM(IT)-ELRH(2)
33392       PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
33393 *   scattering angle of projectile in Lab
33394       CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
33395       STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
33396       CALL DT_DSFECF(SPLABP,CPLABP)
33397 *   direction cosines of projectile in Lab
33398       CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
33399      &                          CXRH(1),CYRH(1),CZRH(1))
33400 *   scattering angle of target in Lab
33401       PLLABT = PLAB-CTLABP*PLRH(1)
33402       CTLABT = PLLABT/PLRH(2)
33403       STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
33404 *   direction cosines of target in Lab
33405       CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
33406      &                            CXRH(2),CYRH(2),CZRH(2))
33407 *   fill /HNFSPA/
33408       IRH = 2
33409       ITRH(1) = IP
33410       ITRH(2) = IT
33411
33412       RETURN
33413       END
33414
33415 *$ CREATE DT_TSAMCS.FOR
33416 *COPY DT_TSAMCS
33417 *
33418 *===tsamcs=============================================================*
33419 *
33420       SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
33421
33422 ************************************************************************
33423 * Sampling of cos(theta) for nucleon-proton scattering according to    *
33424 * hetkfa2/bertini parametrization.                                     *
33425 * This is a revised version of the original (HJM 24/10/88)             *
33426 * This version dated 28.10.95 is written by S. Roesler                 *
33427 ************************************************************************
33428
33429       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33430       SAVE
33431       PARAMETER ( LINP = 10 ,
33432      &            LOUT = 6 ,
33433      &            LDAT = 9 )
33434       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33435      &           TINY10=1.0D-10)
33436
33437       DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
33438       DIMENSION PDCI(60),PDCH(55)
33439
33440       DATA (DCLIN(I),I=1,80) /
33441      &     5.000D-01,  1.000D+00,  0.000D+00,  1.000D+00,  0.000D+00,
33442      &     4.993D-01,  9.881D-01,  5.963D-02,  9.851D-01,  5.945D-02,
33443      &     4.936D-01,  8.955D-01,  5.224D-01,  8.727D-01,  5.091D-01,
33444      &     4.889D-01,  8.228D-01,  8.859D-01,  7.871D-01,  8.518D-01,
33445      &     4.874D-01,  7.580D-01,  1.210D+00,  7.207D-01,  1.117D+00,
33446      &     4.912D-01,  6.969D-01,  1.516D+00,  6.728D-01,  1.309D+00,
33447      &     5.075D-01,  6.471D-01,  1.765D+00,  6.667D-01,  1.333D+00,
33448      &     5.383D-01,  6.054D-01,  1.973D+00,  7.059D-01,  1.176D+00,
33449      &     5.397D-01,  5.990D-01,  2.005D+00,  7.023D-01,  1.191D+00,
33450      &     5.336D-01,  6.083D-01,  1.958D+00,  6.959D-01,  1.216D+00,
33451      &     5.317D-01,  6.075D-01,  1.962D+00,  6.897D-01,  1.241D+00,
33452      &     5.300D-01,  6.016D-01,  1.992D+00,  6.786D-01,  1.286D+00,
33453      &     5.281D-01,  6.063D-01,  1.969D+00,  6.786D-01,  1.286D+00,
33454      &     5.280D-01,  5.960D-01,  2.020D+00,  6.667D-01,  1.333D+00,
33455      &     5.273D-01,  5.920D-01,  2.040D+00,  6.604D-01,  1.358D+00,
33456      &     5.273D-01,  5.862D-01,  2.069D+00,  6.538D-01,  1.385D+00/
33457       DATA (DCLIN(I),I=81,160) /
33458      &     5.223D-01,  5.980D-01,  2.814D+00,  6.538D-01,  1.385D+00,
33459      &     5.202D-01,  5.969D-01,  2.822D+00,  6.471D-01,  1.412D+00,
33460      &     5.183D-01,  5.881D-01,  2.883D+00,  6.327D-01,  1.469D+00,
33461      &     5.159D-01,  5.866D-01,  2.894D+00,  6.250D-01,  1.500D+00,
33462      &     5.133D-01,  5.850D-01,  2.905D+00,  6.170D-01,  1.532D+00,
33463      &     5.106D-01,  5.833D-01,  2.917D+00,  6.087D-01,  1.565D+00,
33464      &     5.084D-01,  5.801D-01,  2.939D+00,  6.000D-01,  1.600D+00,
33465      &     5.063D-01,  5.763D-01,  2.966D+00,  5.909D-01,  1.636D+00,
33466      &     5.036D-01,  5.730D-01,  2.989D+00,  5.814D-01,  1.674D+00,
33467      &     5.014D-01,  5.683D-01,  3.022D+00,  5.714D-01,  1.714D+00,
33468      &     4.986D-01,  5.641D-01,  3.051D+00,  5.610D-01,  1.756D+00,
33469      &     4.964D-01,  5.580D-01,  3.094D+00,  5.500D-01,  1.800D+00,
33470      &     4.936D-01,  5.573D-01,  3.099D+00,  5.431D-01,  1.827D+00,
33471      &     4.909D-01,  5.509D-01,  3.144D+00,  5.313D-01,  1.875D+00,
33472      &     4.885D-01,  5.512D-01,  3.142D+00,  5.263D-01,  1.895D+00,
33473      &     4.857D-01,  5.437D-01,  3.194D+00,  5.135D-01,  1.946D+00/
33474       DATA (DCLIN(I),I=161,195) /
33475      &     4.830D-01,  5.353D-01,  3.253D+00,  5.000D-01,  2.000D+00,
33476      &     4.801D-01,  5.323D-01,  3.274D+00,  4.915D-01,  2.034D+00,
33477      &     4.770D-01,  5.228D-01,  3.341D+00,  4.767D-01,  2.093D+00,
33478      &     4.738D-01,  5.156D-01,  3.391D+00,  4.643D-01,  2.143D+00,
33479      &     4.701D-01,  5.010D-01,  3.493D+00,  4.444D-01,  2.222D+00,
33480      &     4.672D-01,  4.990D-01,  3.507D+00,  4.375D-01,  2.250D+00,
33481      &     4.634D-01,  4.856D-01,  3.601D+00,  4.194D-01,  2.323D+00/
33482
33483       DATA PDCI /
33484      &     4.400D+02,  1.896D-01,  1.931D-01,  1.982D-01,  1.015D-01,
33485      &     1.029D-01,  4.180D-02,  4.228D-02,  4.282D-02,  4.350D-02,
33486      &     2.204D-02,  2.236D-02,  5.900D+02,  1.433D-01,  1.555D-01,
33487      &     1.774D-01,  1.000D-01,  1.128D-01,  5.132D-02,  5.600D-02,
33488      &     6.158D-02,  6.796D-02,  3.660D-02,  3.820D-02,  6.500D+02,
33489      &     1.192D-01,  1.334D-01,  1.620D-01,  9.527D-02,  1.141D-01,
33490      &     5.283D-02,  5.952D-02,  6.765D-02,  7.878D-02,  4.796D-02,
33491      &     6.957D-02,  8.000D+02,  4.872D-02,  6.694D-02,  1.152D-01,
33492      &     9.348D-02,  1.368D-01,  6.912D-02,  7.953D-02,  9.577D-02,
33493      &     1.222D-01,  7.755D-02,  9.525D-02,  1.000D+03,  3.997D-02,
33494      &     5.456D-02,  9.804D-02,  8.084D-02,  1.208D-01,  6.520D-02,
33495      &     8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,  1.093D-01/
33496
33497       DATA PDCH /
33498      &     1.000D+03,  9.453D-02,  9.804D-02,  8.084D-02,  1.208D-01,
33499      &     6.520D-02,  8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,
33500      &     1.093D-01,  1.400D+03,  1.072D-01,  7.450D-02,  6.645D-02,
33501      &     1.136D-01,  6.750D-02,  8.580D-02,  1.110D-01,  1.530D-01,
33502      &     1.010D-01,  1.350D-01,  2.170D+03,  4.004D-02,  3.013D-02,
33503      &     2.664D-02,  5.511D-02,  4.240D-02,  7.660D-02,  1.364D-01,
33504      &     2.300D-01,  1.670D-01,  2.010D-01,  2.900D+03,  1.870D-02,
33505      &     1.804D-02,  1.320D-02,  2.970D-02,  2.860D-02,  5.160D-02,
33506      &     1.020D-01,  2.400D-01,  2.250D-01,  3.370D-01,  4.400D+03,
33507      &     1.196D-03,  8.784D-03,  1.517D-02,  2.874D-02,  2.488D-02,
33508      &     4.464D-02,  8.330D-02,  2.008D-01,  2.360D-01,  3.567D-01/
33509
33510       DATA (DCHN(I),I=1,90) /
33511      &     4.770D-01,  4.750D-01,  4.715D-01,  4.685D-01,  4.650D-01,
33512      &     4.610D-01,  4.570D-01,  4.550D-01,  4.500D-01,  4.450D-01,
33513      &     4.405D-01,  4.350D-01,  4.300D-01,  4.250D-01,  4.200D-01,
33514      &     4.130D-01,  4.060D-01,  4.000D-01,  3.915D-01,  3.840D-01,
33515      &     3.760D-01,  3.675D-01,  3.580D-01,  3.500D-01,  3.400D-01,
33516      &     3.300D-01,  3.200D-01,  3.100D-01,  3.000D-01,  2.900D-01,
33517      &     2.800D-01,  2.700D-01,  2.600D-01,  2.500D-01,  2.400D-01,
33518      &     2.315D-01,  2.240D-01,  2.150D-01,  2.060D-01,  2.000D-01,
33519      &     1.915D-01,  1.850D-01,  1.780D-01,  1.720D-01,  1.660D-01,
33520      &     1.600D-01,  1.550D-01,  1.500D-01,  1.450D-01,  1.400D-01,
33521      &     1.360D-01,  1.320D-01,  1.280D-01,  1.250D-01,  1.210D-01,
33522      &     1.180D-01,  1.150D-01,  1.120D-01,  1.100D-01,  1.070D-01,
33523      &     1.050D-01,  1.030D-01,  1.010D-01,  9.900D-02,  9.700D-02,
33524      &     9.550D-02,  9.480D-02,  9.400D-02,  9.200D-02,  9.150D-02,
33525      &     9.100D-02,  9.000D-02,  8.990D-02,  8.900D-02,  8.850D-02,
33526      &     8.750D-02,  8.700D-02,  8.650D-02,  8.550D-02,  8.500D-02,
33527      &     8.499D-02,  8.450D-02,  8.350D-02,  8.300D-02,  8.250D-02,
33528      &     8.150D-02,  8.100D-02,  8.030D-02,  8.000D-02,  7.990D-02/
33529       DATA (DCHN(I),I=91,143) /
33530      &     7.980D-02,  7.950D-02,  7.900D-02,  7.860D-02,  7.800D-02,
33531      &     7.750D-02,  7.650D-02,  7.620D-02,  7.600D-02,  7.550D-02,
33532      &     7.530D-02,  7.500D-02,  7.499D-02,  7.498D-02,  7.480D-02,
33533      &     7.450D-02,  7.400D-02,  7.350D-02,  7.300D-02,  7.250D-02,
33534      &     7.230D-02,  7.200D-02,  7.100D-02,  7.050D-02,  7.020D-02,
33535      &     7.000D-02,  6.999D-02,  6.995D-02,  6.993D-02,  6.991D-02,
33536      &     6.990D-02,  6.870D-02,  6.850D-02,  6.800D-02,  6.780D-02,
33537      &     6.750D-02,  6.700D-02,  6.650D-02,  6.630D-02,  6.600D-02,
33538      &     6.550D-02,  6.525D-02,  6.510D-02,  6.500D-02,  6.499D-02,
33539      &     6.498D-02,  6.496D-02,  6.494D-02,  6.493D-02,  6.490D-02,
33540      &     6.488D-02,  6.485D-02,  6.480D-02/
33541
33542       DATA DCHNA /
33543      &     6.300D+02,  7.810D-02,  1.421D-01,  1.979D-01,  2.479D-01,
33544      &     3.360D-01,  5.400D-01,  7.236D-01,  1.000D+00,  1.540D+03,
33545      &     2.225D-01,  3.950D-01,  5.279D-01,  6.298D-01,  7.718D-01,
33546      &     9.405D-01,  9.835D-01,  1.000D+00,  2.560D+03,  2.625D-01,
33547      &     4.550D-01,  5.963D-01,  7.020D-01,  8.380D-01,  9.603D-01,
33548      &     9.903D-01,  1.000D+00,  3.520D+03,  4.250D-01,  6.875D-01,
33549      &     8.363D-01,  9.163D-01,  9.828D-01,  1.000D+00,  1.000D+00,
33550      &     1.000D+00/
33551
33552       DATA DCHNB /
33553      &     6.300D+02,  3.800D-02,  7.164D-02,  1.275D-01,  2.171D-01,
33554      &     3.227D-01,  4.091D-01,  5.051D-01,  6.061D-01,  7.074D-01,
33555      &     8.434D-01,  1.000D+00,  2.040D+03,  1.200D-01,  2.115D-01,
33556      &     3.395D-01,  5.295D-01,  7.251D-01,  8.511D-01,  9.487D-01,
33557      &     9.987D-01,  1.000D+00,  1.000D+00,  1.000D+00,  2.200D+03,
33558      &     1.344D-01,  2.324D-01,  3.754D-01,  5.674D-01,  7.624D-01,
33559      &     8.896D-01,  9.808D-01,  1.000D+00,  1.000D+00,  1.000D+00,
33560      &     1.000D+00,  2.850D+03,  2.330D-01,  4.130D-01,  6.610D-01,
33561      &     9.010D-01,  9.970D-01,  1.000D+00,  1.000D+00,  1.000D+00,
33562      &     1.000D+00,  1.000D+00,  1.000D+00,  3.500D+03,  3.300D-01,
33563      &     5.450D-01,  7.950D-01,  1.000D+00,  1.000D+00,  1.000D+00,
33564      &     1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00/
33565
33566       CST = ONE
33567       IF (EKIN.GT.3.5D0) RETURN
33568 C
33569       IF(KPROJ.EQ.8) GOTO 101
33570       IF(KPROJ.EQ.1) GOTO 102
33571 C*                                             INVALID REACTION
33572       WRITE(LOUT,'(A,I5/A)')
33573      &        ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
33574      &        ' COS(THETA) = 1D0 RETURNED'
33575       RETURN
33576 C-------------------------------- NP ELASTIC SCATTERING----------
33577 101   CONTINUE
33578       IF (EKIN.GT.0.740D0)GOTO 1000
33579       IF (EKIN.LT.0.300D0)THEN
33580 C                                 EKIN .LT. 300 MEV
33581          IDAT=1
33582       ELSE
33583 C                                 300 MEV < EKIN < 740 MEV
33584          IDAT=6
33585       END IF
33586 C
33587       ENER=EKIN
33588       IE=INT(ABS(ENER/0.020D0))
33589       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33590 C                                            FORWARD/BACKWARD DECISION
33591       K=IDAT+5*IE
33592       BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33593       IF (DT_RNDM(CST).LT.BWFW)THEN
33594          VALUE2=-1D0
33595          K=K+1
33596       ELSE
33597          VALUE2=1D0
33598          K=K+3
33599       END IF
33600 C
33601       COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33602       RND=DT_RNDM(COEF)
33603 C
33604       IF(RND.LT.COEF)THEN
33605          CST=DT_RNDM(RND)
33606          CST=CST*VALUE2
33607       ELSE
33608          R1=DT_RNDM(CST)
33609          R2=DT_RNDM(R1)
33610          R3=DT_RNDM(R2)
33611          R4=DT_RNDM(R3)
33612 C
33613          IF(VALUE2.GT.0.0)THEN
33614             CST=MAX(R1,R2,R3,R4)
33615             GOTO 1500
33616          ELSE
33617             R5=DT_RNDM(R4)
33618 C
33619             IF (IDAT.EQ.1)THEN
33620                CST=-MAX(R1,R2,R3,R4,R5)
33621             ELSE
33622                R6=DT_RNDM(R5)
33623                R7=DT_RNDM(R6)
33624                CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
33625             END IF
33626 C
33627          END IF
33628 C
33629       END IF
33630 C
33631       GOTO 1500
33632 C
33633 C********                                EKIN  .GT.  0.74 GEV
33634 C
33635 1000  ENER=EKIN - 0.66D0
33636 C     IE=ABS(ENER/0.02)
33637       IE=INT(ENER/0.02D0)
33638       EMEV=EKIN*1D3
33639 C
33640       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33641       K=IE
33642       BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
33643       RND=DT_RNDM(BWFW)
33644 C                                        FORWARD NEUTRON
33645       IF (RND.GE.BWFW)THEN
33646          DO 1200 K=10,36,9
33647            IF (DCHNA(K).GT.EMEV) THEN
33648               UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
33649               UNIV=DT_RNDM(UNIVE)
33650               DO 1100 I=1,8
33651                  II=K+I
33652                  P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
33653 C
33654                  IF (P.GT.UNIV)THEN
33655                     UNIV=DT_RNDM(UNIVE)
33656                     FLTI=DBLE(I)-UNIV
33657                     GOTO(290,290,290,290,330,340,350,360) I
33658                  END IF
33659  1100         CONTINUE
33660            END IF
33661  1200    CONTINUE
33662 C
33663       ELSE
33664 C                                        BACKWARD NEUTRON
33665          DO 1400 K=13,60,12
33666             IF (DCHNB(K).GT.EMEV) THEN
33667                UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
33668                UNIV=DT_RNDM(UNIVE)
33669                DO 1300 I=1,11
33670                  II=K+I
33671                  P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
33672 C
33673                  IF (P.GT.UNIV)THEN
33674                    UNIV=DT_RNDM(P)
33675                    FLTI=DBLE(I)-UNIV
33676                    GOTO(120,120,140,150,160,160,180,190,200,210,220) I
33677                  END IF
33678  1300          CONTINUE
33679             END IF
33680  1400    CONTINUE
33681       END IF
33682 C
33683 120   CST=1.0D-2*FLTI-1.0D0
33684       GOTO 1500
33685 140   CST=2.0D-2*UNIV-0.98D0
33686       GOTO 1500
33687 150   CST=4.0D-2*UNIV-0.96D0
33688       GOTO 1500
33689 160   CST=6.0D-2*FLTI-1.16D0
33690       GOTO 1500
33691 180   CST=8.0D-2*UNIV-0.80D0
33692       GOTO 1500
33693 190   CST=1.0D-1*UNIV-0.72D0
33694       GOTO 1500
33695 200   CST=1.2D-1*UNIV-0.62D0
33696       GOTO 1500
33697 210   CST=2.0D-1*UNIV-0.50D0
33698       GOTO 1500
33699 220   CST=3.0D-1*(UNIV-1.0D0)
33700       GOTO 1500
33701 C
33702 290   CST=1.0D0-2.5d-2*FLTI
33703       GOTO 1500
33704 330   CST=0.85D0+0.5D-1*UNIV
33705       GOTO 1500
33706 340   CST=0.70D0+1.5D-1*UNIV
33707       GOTO 1500
33708 350   CST=0.50D0+2.0D-1*UNIV
33709       GOTO 1500
33710 360   CST=0.50D0*UNIV
33711 C
33712 1500  RETURN
33713 C
33714 C-----------------------------------  PP ELASTIC SCATTERING -------
33715 C
33716  102  CONTINUE
33717       EMEV=EKIN*1D3
33718 C
33719       IF (EKIN.LE.0.500D0) THEN
33720          RND=DT_RNDM(EMEV)
33721          CST=2.0D0*RND-1.0D0
33722          RETURN
33723 C
33724       ELSEIF (EKIN.LT.1.0D0) THEN
33725          DO 2200 K=13,60,12
33726             IF (PDCI(K).GT.EMEV) THEN
33727                UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
33728                UNIV=DT_RNDM(UNIVE)
33729                SUM=0
33730                DO 2100 I=1,11
33731                  II=K+I
33732                  SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
33733 C
33734                  IF (UNIV.LT.SUM)THEN
33735                    UNIV=DT_RNDM(SUM)
33736                    FLTI=DBLE(I)-UNIV
33737                    GOTO(55,55,55,60,60,65,65,65,65,70,70) I
33738                  END IF
33739  2100          CONTINUE
33740             END IF
33741  2200    CONTINUE
33742       ELSE
33743          DO 2400 K=12,55,11
33744             IF (PDCH(K).GT.EMEV) THEN
33745               UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
33746               UNIV=DT_RNDM(UNIVE)
33747               SUM=0.0D0
33748               DO 2300 I=1,10
33749                 II=K+I
33750                 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
33751 C
33752                 IF (UNIV.LT.SUM)THEN
33753                   UNIV=DT_RNDM(SUM)
33754                   FLTI=UNIV+DBLE(I)
33755                   GOTO(50,55,60,60,65,65,65,65,70,70) I
33756                 END IF
33757  2300         CONTINUE
33758             END IF
33759  2400    CONTINUE
33760       END IF
33761 C
33762 50    CST=0.4D0*UNIV
33763       GOTO 2500
33764 55    CST=0.2D0*FLTI
33765       GOTO 2500
33766 60    CST=0.3D0+0.1D0*FLTI
33767       GOTO 2500
33768 65    CST=0.6D0+0.04D0*FLTI
33769       GOTO 2500
33770 70    CST=0.78D0+0.02D0*FLTI
33771 C
33772 2500  CONTINUE
33773       IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
33774 C
33775       RETURN
33776       END
33777
33778 *$ CREATE DT_DHADRI.FOR
33779 *COPY DT_DHADRI
33780 *
33781 *===dhadri=============================================================*
33782 *
33783       SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
33784
33785       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33786       SAVE
33787
33788       PARAMETER ( LINP = 10 ,
33789      &            LOUT = 6 ,
33790      &            LDAT = 9 )
33791 C
33792 C-----------------------------
33793 C*** INPUT VARIABLES LIST:
33794 C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
33795 C*** GEV/C LABORATORY MOMENTUM REGION
33796 C*** N    - PROJECTILE HADRON INDEX
33797 C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
33798 C*** ELAB - LABORATORY ENERGY OF N (GEV)
33799 C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
33800 C*** ITTA - TARGET NUCLEON INDEX
33801 C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
33802 C  IR COUNTS THE NUMBER OF PRODUCED PARTICLES
33803 C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
33804 C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
33805 C*** RESPECT., UNITS (GEV/C AND GEV)
33806 C----------------------------
33807
33808       COMMON /HNGAMR/ REDU,AMO,AMM(15)
33809       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33810       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33811      &                NRK(2,268),NURE(30,2)
33812 * particle properties (BAMJET index convention),
33813 * (dublicate of DTPART for HADRIN)
33814       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33815      &                K1H(110),K2H(110)
33816       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33817       COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
33818      &                ITS(149),IS
33819       COMMON /HNDRUN/ RUNTES,EFTES
33820 * particle properties (BAMJET index convention)
33821       CHARACTER*8  ANAME
33822       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33823      &                IICH(210),IIBAR(210),K1(210),K2(210)
33824 * final state from HADRIN interaction
33825       PARAMETER (MAXFIN=10)
33826       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33827      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33828
33829       DIMENSION ITPRF(110)
33830       DATA NNN/0/
33831       DATA UMODA/0./
33832       DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
33833       LOWP=0
33834       IF (N.LE.0.OR.N.GE.111)N=1
33835       IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
33836         GOTO 280
33837 *       WRITE (6,1000)
33838 *    +  ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
33839 *       STOP
33840 *1000   FORMAT (3(5H ****/),A,2I4,3(5H ****/))
33841 *    +  45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
33842       ENDIF
33843       IATMPT=0
33844       IF (ABS(PLAB-5.0D0).LT.4.99999D0)                        GO TO 20
33845 C     IF(IPRI.GE.1) WRITE (6,1010) PLAB
33846 C     STOP
33847  1010 FORMAT ( '  PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
33848      + ALLOWED REGION, PLAB=',1E15.5)
33849
33850    20 CONTINUE
33851       UMODAT=N*1.11111D0+ITTA*2.19291D0
33852       IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
33853       UMODA=UMODAT
33854    30 IATMPT=0
33855       LOWP=LOWP+1
33856    40 CONTINUE
33857       IMACH=0
33858       REDU=2.0D0
33859       IF (LOWP.GT.20) THEN
33860 C        WRITE(LOUT,*) ' jump 1'
33861          GO TO 280
33862       ENDIF
33863       NNN=N
33864       IF (NNN.EQ.N)                                             GO TO 50
33865       RUNTES=0.0D0
33866       EFTES=0.0D0
33867    50 CONTINUE
33868       IS=1
33869       IRH=0
33870       IST=1
33871       NSTAB=23
33872       IRE=NURE(N,1)
33873       IF(ITTA.GT.1) IRE=NURE(N,2)
33874 C
33875 C-----------------------------
33876 C*** IE,AMT,ECM,SI DETERMINATION
33877 C----------------------------
33878       CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
33879       IANTH=-1
33880 **sr
33881 C     IF (AMH(1).NE.0.93828D0) IANTH=1
33882       IF (AMH(1).NE.0.9383D0) IANTH=1
33883 **
33884       IF (IANTH.GE.0) SI=1.0D0
33885       ECMMH=ECM
33886 C
33887 C-----------------------------
33888 C    ENERGY INDEX
33889 C  IRE CHARACTERIZES THE REACTION
33890 C  IE IS THE ENERGY INDEX
33891 C----------------------------
33892       IF (SI.LT.1.D-6) THEN
33893 C        WRITE(LOUT,*) ' jump 2'
33894          GO TO 280
33895       ENDIF
33896       IF (N.LE.NSTAB)                                           GO TO 60
33897       RUNTES=RUNTES+1.0D0
33898       IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
33899  1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
33900       IF(IBARH(N).EQ.1) N=8
33901       IF(IBARH(N).EQ.-1)  N=9
33902    60 CONTINUE
33903       IMACH=IMACH+1
33904 **sr 19.2.97: loop for direct channel suppression
33905 C     IF (IMACH.GT.10) THEN
33906       IF (IMACH.GT.1000) THEN
33907 **
33908 C        WRITE(LOUT,*) ' jump 3'
33909          GO TO 280
33910       ENDIF
33911       ECM =ECMMH
33912       AMN2=AMN**2
33913       AMT2=AMT**2
33914       ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM    )
33915       IF(ECMN.LE.AMN) ECMN=AMN
33916       PCMN=SQRT(ECMN**2-AMN2)
33917       GAM=(ELAB+AMT)/ECM
33918       BGAM=PLAB/ECM
33919       IF (IANTH.GE.0) ECM=2.1D0
33920 C
33921 C-----------------------------
33922 C*** RANDOM CHOICE OF REACTION CHANNEL
33923 C----------------------------
33924       IST=0
33925       VV=DT_RNDM(AMN2)
33926       VV=VV-1.D-17
33927 C
33928 C-----------------------------
33929 C***  PLACE REDUCED VERSION
33930 C----------------------------
33931       IIEI=IEII(IRE)
33932       IDWK=IEII(IRE+1)-IIEI
33933       IIWK=IRII(IRE)
33934       IIKI=IKII(IRE)
33935 C
33936 C-----------------------------
33937 C***  SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
33938 C----------------------------
33939       HECM=ECM
33940       HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
33941       IF (HUMO.LT.ECM) ECM=HUMO
33942 C
33943 C-----------------------------
33944 C*** INTERPOLATION PREPARATION
33945 C----------------------------
33946       ECMO=UMO(IE)
33947       ECM1=UMO(IE-1)
33948       DECM=ECMO-ECM1
33949       DEC=ECMO-ECM
33950 C
33951 C-----------------------------
33952 C*** RANDOM LOOP
33953 C----------------------------
33954       IK=0
33955       WKK=0.0D0
33956       WICOR=0.0D0
33957    70 IK=IK+1
33958       IWK=IIWK+(IK-1)*IDWK+IE-IIEI
33959       WOK=WK(IWK)
33960       WDK=WOK-WK(IWK-1)
33961 C
33962 C-----------------------------
33963 C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
33964 C    GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
33965 C    CONTRIBUTE
33966 C----------------------------
33967       IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
33968       WICO=WOK*1.23459876D0+WDK*1.735218469D0
33969       IF (WICO.EQ.WICOR)                                        GO TO 70
33970       IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
33971       WICOR=WICO
33972 C
33973 C-----------------------------
33974 C*** INTERPOLATION IN CHANNEL WEIGHTS
33975 C----------------------------
33976       EKLIM=-THRESH(IIKI+IK)
33977       IELIM=IDT_IEFUND(EKLIM,IRE)
33978       DELIM=UMO(IELIM)+EKLIM
33979      *+1.D-16
33980       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
33981       IF (DELIM*DELIM-DETE*DETE) 90,90,80
33982    80 DECC=DELIM
33983                                                                GO TO 100
33984    90 DECC=DECM
33985   100 CONTINUE
33986       WKK=WOK-WDK*DEC/(DECC+1.D-9)
33987 C
33988 C-----------------------------
33989 C*** RANDOM CHOICE
33990 C----------------------------
33991 C
33992       IF (VV.GT.WKK)                                            GO TO 70
33993 C
33994 C***IK IS THE REACTION CHANNEL
33995 C----------------------------
33996       INRK=IKII(IRE)+IK
33997       ECM=HECM
33998       I1001 =0
33999 C
34000   110 CONTINUE
34001       IT1=NRK(1,INRK)
34002       AM1=DT_DAMG(IT1)
34003       IT2=NRK(2,INRK)
34004       AM2=DT_DAMG(IT2)
34005       AMS=AM1+AM2
34006       I1001=I1001+1
34007       IF (I1001.GT.50)                                          GO TO 60
34008 C
34009       IF (IT2*AMS.GT.IT2*ECM)                                  GO TO 110
34010       IT11=IT1
34011       IT22=IT2
34012       IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
34013       AM11=AM1
34014       AM22=AM2
34015       IF (IT2.GT.0)                                            GO TO 120
34016 **sr 19.2.97: supress direct channel for pp-collisions
34017       IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
34018          RR = DT_RNDM(AM11)
34019          IF (RR.LE.0.75D0) GOTO 60
34020       ENDIF
34021 **
34022 C
34023 C-----------------------------
34024 C  INCLUSION OF DIRECT RESONANCES
34025 C  RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE  IT1
34026 C------------------------
34027       KZ1=K1H(IT1)
34028       IST=IST+1
34029       IECO=0
34030       ECO=ECM
34031       GAM=(ELAB+AMT)/ECO
34032       BGAM=PLAB/ECO
34033       CXS(1)=CX
34034       CYS(1)=CY
34035       CZS(1)=CZ
34036                                                                GO TO 170
34037   120 CONTINUE
34038       WW=DT_RNDM(ECO)
34039       IF(WW.LT. 0.5D0)                                         GO TO 130
34040       IT1=IT22
34041       IT2=IT11
34042       AM1=AM22
34043       AM2=AM11
34044   130 CONTINUE
34045 C
34046 C-----------------------------
34047 C   THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
34048       IBN=IBARH(N)
34049       IB1=IBARH(IT1)
34050       IT11=IT1
34051       IT22=IT2
34052       AM11=AM1
34053       AM22=AM2
34054       IF(IB1.EQ.IBN)                                           GO TO 140
34055       IT1=IT22
34056       IT2=IT11
34057       AM1=AM22
34058       AM2=AM11
34059   140 CONTINUE
34060 C-----------------------------
34061 C***IT1,IT2 ARE THE CREATED PARTICLES
34062 C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
34063 C------------------------
34064       CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34065      *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
34066       IST=IST+1
34067       ITS(IST)=IT1
34068       AMM(IST)=AM1
34069 C
34070 C-----------------------------
34071 C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
34072 C----------------------------
34073       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
34074      &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34075       IST=IST+1
34076       ITS(IST)=IT2
34077       AMM(IST)=AM2
34078       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
34079      *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34080   150 CONTINUE
34081 C
34082 C-----------------------------
34083 C***TEST   STABLE OR UNSTABLE
34084 C----------------------------
34085       IF(ITS(IST).GT.NSTAB)                                    GO TO 160
34086       IRH=IRH+1
34087 C
34088 C-----------------------------
34089 C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
34090 C----------------------------
34091 C*    IF (REDU.LT.0.D0) GO TO 1009
34092       ITRH(IRH)=ITS(IST)
34093       PLRH(IRH)=PLS(IST)
34094       CXRH(IRH)=CXS(IST)
34095       CYRH(IRH)=CYS(IST)
34096       CZRH(IRH)=CZS(IST)
34097       ELRH(IRH)=ELS(IST)
34098       IST=IST-1
34099       IF(IST.GE.1)                                             GO TO 150
34100                                                                GO TO 260
34101   160 CONTINUE
34102 C
34103 C  RANDOM CHOICE OF DECAY CHANNELS
34104 C----------------------------
34105 C
34106       IT=ITS(IST)
34107       ECO=AMM(IST)
34108       GAM=ELS(IST)/ECO
34109       BGAM=PLS(IST)/ECO
34110       IECO=0
34111       KZ1=K1H(IT)
34112   170 CONTINUE
34113       IECO=IECO+1
34114       VV=DT_RNDM(GAM)
34115       VV=VV-1.D-17
34116       IIK=KZ1-1
34117   180 IIK=IIK+1
34118       IF (VV.GT.WTI(IIK))                                      GO TO 180
34119 C
34120 C  IIK IS THE DECAY CHANNEL
34121 C----------------------------
34122       IT1=NZKI(IIK,1)
34123       I310=0
34124   190 CONTINUE
34125       I310=I310+1
34126       AM1=DT_DAMG(IT1)
34127       IT2=NZKI(IIK,2)
34128       AM2=DT_DAMG(IT2)
34129       IF (IT2-1.LT.0)                                          GO TO 240
34130       IT3=NZKI(IIK,3)
34131       AM3=DT_DAMG(IT3)
34132       AMS=AM1+AM2+AM3
34133 C
34134 C  IF  IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
34135 C----------------------------
34136       IF (IECO.LE.10)                                          GO TO 200
34137       IATMPT=IATMPT+1
34138       IF(IATMPT.GT.3) THEN
34139 C        WRITE(LOUT,*) ' jump 4'
34140          GO TO 280
34141       ENDIF
34142                                                                 GO TO 40
34143   200 CONTINUE
34144       IF (I310.GT.50)                                          GO TO 170
34145       IF (AMS.GT.ECO)                                          GO TO 190
34146 C
34147 C  FOR THE DECAY CHANNEL
34148 C  IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM  IT
34149 C----------------------------
34150       IF (REDU.LT.0.D0)                                        GO TO 30
34151       ITWTHC=0
34152       REDU=2.0D0
34153       IF(IT3.EQ.0)                                             GO TO 220
34154   210 CONTINUE
34155       ITWTH=1
34156       CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
34157      *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
34158                                                                GO TO 230
34159   220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
34160      &COD2,COF2,SIF2,AM1,AM2)
34161       ITWTH=-1
34162       IT3=0
34163   230 CONTINUE
34164       ITWTHC=ITWTHC+1
34165       IF (REDU.GT.0.D0)                                        GO TO 240
34166       REDU=2.0D0
34167       IF (ITWTHC.GT.100)                                        GO TO 30
34168       IF (ITWTH) 220,220,210
34169   240 CONTINUE
34170       ITS(IST  )=IT1
34171       IF (IT2-1.LT.0)                                          GO TO 250
34172       ITS(IST+1)  =IT2
34173       ITS(IST+2)=IT3
34174       RX=CXS(IST)
34175       RY=CYS(IST)
34176       RZ=CZS(IST)
34177       AMM(IST)=AM1
34178       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
34179      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34180       IST=IST+1
34181       AMM(IST)=AM2
34182       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
34183      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34184       IF (IT3.LE.0)                                            GO TO 250
34185       IST=IST+1
34186       AMM(IST)=AM3
34187       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
34188      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34189   250 CONTINUE
34190                                                                GO TO 150
34191   260 CONTINUE
34192   270 CONTINUE
34193       RETURN
34194   280 CONTINUE
34195 C
34196 C----------------------------
34197 C
34198 C   ZERO CROSS SECTION CASE
34199 C----------------------------
34200 C
34201       IRH=1
34202       ITRH(1)=N
34203       CXRH(1)=CX
34204       CYRH(1)=CY
34205       CZRH(1)=CZ
34206       ELRH(1)=ELAB
34207       PLRH(1)=PLAB
34208       RETURN
34209       END
34210
34211 *$ CREATE DT_RUNTT.FOR
34212 *COPY DT_RUNTT
34213 *
34214 *===runtt==============================================================*
34215 *
34216       BLOCK DATA DT_RUNTT
34217
34218       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34219       SAVE
34220
34221       COMMON /HNDRUN/ RUNTES,EFTES
34222
34223       DATA RUNTES,EFTES /100.D0,100.D0/
34224
34225       END
34226
34227 *$ CREATE DT_NONAME.FOR
34228 *COPY DT_NONAME
34229 *
34230 *===noname=============================================================*
34231 *
34232       BLOCK DATA DT_NONAME
34233
34234       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34235       SAVE
34236
34237 * slope parameters for HADRIN interactions
34238       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34239       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34240
34241 C     DATAS     DATAS    DATAS      DATAS     DATAS
34242 C******          *********
34243       DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
34244      &           207, 224, 241, 252, 268 /
34245       DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
34246      &           220, 241, 262, 279, 296 /
34247       DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
34248      &           3364, 3507, 4011, 4368, 4725, 4912, 5184/
34249
34250 C
34251 C     MASSES FOR THE SLOPE B(M) IN GEV
34252 C     SLOPE B(M) FOR AN MESONIC SYSTEM
34253 C     SLOPE B(M) FOR A BARYONIC SYSTEM
34254
34255 *
34256       DATA SM,BBM,BBB/  0.8D0, 0.85D0,  0.9D0, 0.95D0, 1.D0,
34257      &     1.05D0,  1.1D0, 1.15D0,  1.2D0, 1.25D0,
34258      &      1.3D0,  1.35D0, 1.4D0,  1.45D0,  1.5D0,
34259      &     1.55D0,  1.6D0,  1.65D0, 1.7D0,   1.75D0,
34260      &      1.8D0,  1.85D0, 1.9D0,  1.95D0,  2.D0,
34261      &     15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
34262      &    12.35D0, 11.7D0, 10.85D0, 10.D0,  9.15D0,
34263      &      8.3D0,  7.8D0,  7.3D0,  7.25D0,  7.2D0,
34264      &     6.95D0,  6.7D0,  6.6D0,  6.5D0,   6.3D0,
34265      &      6.1D0,  5.85D0, 5.6D0,  5.35D0,  5.1D0,
34266      &      15.D0,   15.D0, 15.D0,  15.D0,   15.D0, 15.D0, 15.D0,
34267      &     14.2D0,  13.4D0, 12.6D0,
34268      &     11.8D0, 11.2D0, 10.6D0,  9.8D0,    9.D0,
34269      &     8.25D0,  7.5D0, 6.25D0,  5.D0,    4.5D0, 5*4.D0 /
34270 *
34271       END
34272
34273 *$ CREATE DT_DAMG.FOR
34274 *COPY DT_DAMG
34275 *
34276 *===damg===============================================================*
34277 *
34278       DOUBLE PRECISION FUNCTION DT_DAMG(IT)
34279
34280       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34281       SAVE
34282
34283 * particle properties (BAMJET index convention),
34284 * (dublicate of DTPART for HADRIN)
34285       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34286      &                K1H(110),K2H(110)
34287
34288       DIMENSION GASUNI(14)
34289       DATA GASUNI/
34290      *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
34291      *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
34292       DATA GAUNO/2.352D0/
34293       DATA GAUNON/2.4D0/
34294       DATA IO/14/
34295       DATA NSTAB/23/
34296
34297       I=1
34298       IF (IT.LE.0)                                              GO TO 30
34299       IF (IT.LE.NSTAB)                                          GO TO 20
34300       DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
34301       VV=DT_RNDM(DGAUNI)
34302       VV=VV*2.0D0-1.0D0+1.D-16
34303    10 CONTINUE
34304       VO=GASUNI(I)
34305       I=I+1
34306       V1=GASUNI(I)
34307       IF (VV.GT.V1)                                             GO TO 10
34308       UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
34309      &      (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
34310       DAM=GAH(IT)*UNIGA/GAUNO
34311       AAM=AMH(IT)+DAM
34312       DT_DAMG=AAM
34313       RETURN
34314    20 CONTINUE
34315       DT_DAMG=AMH(IT)
34316       RETURN
34317    30 CONTINUE
34318       DT_DAMG=0.0D0
34319       RETURN
34320       END
34321
34322 *$ CREATE DT_DCALUM.FOR
34323 *COPY DT_DCALUM
34324 *
34325 *===dcalum=============================================================*
34326 *
34327       SUBROUTINE DT_DCALUM(N,ITTA)
34328
34329       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34330       SAVE
34331
34332 C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
34333
34334 * particle properties (BAMJET index convention),
34335 * (dublicate of DTPART for HADRIN)
34336       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34337      &                K1H(110),K2H(110)
34338       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34339       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34340       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34341      &                NRK(2,268),NURE(30,2)
34342
34343       IRE=NURE(N,ITTA/8+1)
34344       IEO=IEII(IRE)+1
34345       IEE=IEII(IRE +1)
34346       AM1=AMH(N   )
34347       AM12=AM1**2
34348       AM2=AMH(ITTA)
34349       AM22=AM2**2
34350       DO 10 IE=IEO,IEE
34351         PLAB2=PLABF(IE)**2
34352         ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
34353         UMO(IE)=ELAB
34354    10 CONTINUE
34355       IKO=IKII(IRE)+1
34356       IKE=IKII(IRE +1)
34357       UMOO=UMO(IEO)
34358       DO 30 IK=IKO,IKE
34359         IF(NRK(2,IK).GT.0)                                      GO TO 30
34360         IKI=NRK(1,IK)
34361         AMSS=5.0D0
34362         K11=K1H(IKI)
34363         K22=K2H(IKI)
34364         DO 20 IK1=K11,K22
34365           IN=NZKI(IK1,1)
34366           AMS=AMH(IN)
34367           IN=NZKI(IK1,2)
34368           IF(IN.GT.0)AMS=AMS+AMH(IN)
34369           IN=NZKI(IK1,3)
34370           IF(IN.GT.0) AMS=AMS+AMH(IN)
34371           IF (AMS.LT.AMSS) AMSS=AMS
34372    20   CONTINUE
34373         IF(UMOO.LT.AMSS) UMOO=AMSS
34374         THRESH(IK)=UMOO
34375    30 CONTINUE
34376       RETURN
34377       END
34378
34379 *$ CREATE DT_DCHANH.FOR
34380 *COPY DT_DCHANH
34381 *
34382 *===dchanh=============================================================*
34383 *
34384       SUBROUTINE DT_DCHANH
34385
34386       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34387       SAVE
34388
34389       PARAMETER ( LINP = 10 ,
34390      &            LOUT = 6 ,
34391      &            LDAT = 9 )
34392 * particle properties (BAMJET index convention),
34393 * (dublicate of DTPART for HADRIN)
34394       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34395      &                K1H(110),K2H(110)
34396       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34397       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34398       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34399      &                NRK(2,268),NURE(30,2)
34400
34401       DIMENSION HWT(460),HWK(40),SI(5184)
34402       EQUIVALENCE (WK(1),SI(1))
34403 C--------------------
34404 C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
34405 C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
34406 C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
34407 C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
34408 C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
34409 C--------------------------
34410       IREG=16
34411       DO 90 IRE=1,IREG
34412         IWKO=IRII(IRE)
34413         IEE=IEII(IRE+1)-IEII(IRE)
34414         IKE=IKII(IRE+1)-IKII(IRE)
34415         IEO=IEII(IRE)+1
34416         IIKA=IKII(IRE)
34417 *   modifications to suppress elestic scattering  24/07/91
34418         DO 80 IE=1,IEE
34419           SIS=1.D-14
34420           SINORC=0.0D0
34421           DO 10 IK=1,IKE
34422             IWK=IWKO+IEE*(IK-1)+IE
34423             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34424             SIS=SIS+SI(IWK)*SINORC
34425    10     CONTINUE
34426           SIIN(IEO+IE-1)=SIS
34427           SIO=0.D0
34428           IF (SIS.GE.1.D-12)                                    GO TO 20
34429           SIS=1.D0
34430           SIO=1.D0
34431    20     CONTINUE
34432           SINORC=0.0D0
34433           DO 30 IK=1,IKE
34434             IWK=IWKO+IEE*(IK-1)+IE
34435             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34436             SIO=SIO+SI(IWK)*SINORC/SIS
34437             HWK(IK)=SIO
34438    30     CONTINUE
34439           DO 40 IK=1,IKE
34440             IWK=IWKO+IEE*(IK-1)+IE
34441    40     WK(IWK)=HWK(IK)
34442           IIKI=IKII(IRE)
34443           DO 70 IK=1,IKE
34444             AM111=0.D0
34445             INRK1=NRK(1,IIKI+IK)
34446             IF (INRK1.GT.0) AM111=AMH(INRK1)
34447             AM222=0.D0
34448             INRK2=NRK(2,IIKI+IK)
34449             IF (INRK2.GT.0) AM222=AMH(INRK2)
34450             THRESH(IIKI+IK)=AM111 +AM222
34451             IF (INRK2-1.GE.0)                                   GO TO 60
34452             INRKK=K1H(INRK1)
34453             AMSS=5.D0
34454             INRKO=K2H(INRK1)
34455             DO 50 INRK1=INRKK,INRKO
34456               INZK1=NZKI(INRK1,1)
34457               INZK2=NZKI(INRK1,2)
34458               INZK3=NZKI(INRK1,3)
34459               IF (INZK1.LE.0.OR.INZK1.GT.110)                   GO TO 50
34460               IF (INZK2.LE.0.OR.INZK2.GT.110)                   GO TO 50
34461               IF (INZK3.LE.0.OR.INZK3.GT.110)                   GO TO 50
34462 C     WRITE (6,310)INRK1,INZK1,INZK2,INZK3
34463  1000 FORMAT (4I10)
34464               AMS=AMH(INZK1)+AMH(INZK2)
34465               IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
34466               IF (AMSS.GT.AMS) AMSS=AMS
34467    50       CONTINUE
34468             AMS=AMSS
34469             IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
34470             THRESH(IIKI+IK)=AMS
34471    60       CONTINUE
34472    70     CONTINUE
34473    80   CONTINUE
34474    90 CONTINUE
34475       DO 100 J=1,460
34476   100 HWT(J)=0.D0
34477       DO 120 I=1,110
34478         IK1=K1H(I)
34479         IK2=K2H(I)
34480         HV=0.D0
34481         IF (IK2.GT.460)IK2=460
34482         IF (IK1.LE.0)IK1=1
34483         DO 110 J=IK1,IK2
34484           HV=HV+WTI(J)
34485           HWT(J)=HV
34486           JI=J
34487   110   CONTINUE
34488         IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
34489  1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
34490   120 CONTINUE
34491       DO 130 J=1,460
34492   130 WTI(J)=HWT(J)
34493       RETURN
34494       END
34495
34496 *$ CREATE DT_DHADDE.FOR
34497 *COPY DT_DHADDE
34498 *
34499 *===dhadde=============================================================*
34500 *
34501       SUBROUTINE DT_DHADDE
34502
34503       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34504       SAVE
34505
34506 * particle properties (BAMJET index convention)
34507       CHARACTER*8  ANAME
34508       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
34509      &                IICH(210),IIBAR(210),K1(210),K2(210)
34510 * HADRIN: decay channel information
34511       PARAMETER (IDMAX9=602)
34512       CHARACTER*8 ZKNAME
34513       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
34514 * particle properties (BAMJET index convention),
34515 * (dublicate of DTPART for HADRIN)
34516       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34517      &                K1H(110),K2H(110)
34518       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34519 * decay channel information for HADRIN
34520       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34521      &                K1Z(16),K2Z(16),WTZ(153),II22,
34522      &                NZK1(153),NZK2(153),NZK3(153)
34523
34524       DATA IRETUR/0/
34525
34526       IRETUR=IRETUR+1
34527       AMH(31)=0.48D0
34528       IF (IRETUR.GT.1) RETURN
34529       DO 10 I=1,94
34530         AMH(I)   = AAM(I)
34531         GAH(I)   = GA(I)
34532         TAUH(I)  = TAU(I)
34533         ICHH(I)  = IICH(I)
34534         IBARH(I) = IIBAR(I)
34535         K1H(I)   = K1(I)
34536         K2H(I)   = K2(I)
34537    10 CONTINUE
34538 **sr
34539 C     AMH(1)=0.93828D0
34540       AMH(1)=0.9383D0
34541 **
34542       AMH(2)=AMH(1)
34543       DO 20 I=26,30
34544         K1H(I)=452
34545         K2H(I)=452
34546    20 CONTINUE
34547       DO 30 I=1,307
34548         WTI(I)    = WT(I)
34549         NZKI(I,1) = NZK(I,1)
34550         NZKI(I,2) = NZK(I,2)
34551         NZKI(I,3) = NZK(I,3)
34552    30 CONTINUE
34553       DO 40 I=1,16
34554         L=I+94
34555         AMH(L)=AMZ(I)
34556         GAH( L)=GAZ(I)
34557         TAUH( L)=TAUZ(I)
34558         ICHH( L)=ICHZ(I)
34559         IBARH( L)=IBARZ(I)
34560         K1H( L)=K1Z(I)
34561         K2H( L)=K2Z(I)
34562    40 CONTINUE
34563       DO 50 I=1,153
34564         L=I+307
34565         WTI(L)    = WTZ(I)
34566         NZKI(L,3) = NZK3(I)
34567         NZKI(L,2) = NZK2(I)
34568         NZKI(L,1) = NZK1(I)
34569    50 CONTINUE
34570       RETURN
34571       END
34572
34573 *$ CREATE IDT_IEFUND.FOR
34574 *COPY IDT_IEFUND
34575 *
34576 *===iefund=============================================================*
34577 *
34578       INTEGER FUNCTION IDT_IEFUND(PL,IRE)
34579
34580       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34581       SAVE
34582
34583 C*****IEFUN CALCULATES A MOMENTUM INDEX
34584
34585       PARAMETER ( LINP = 10 ,
34586      &            LOUT = 6 ,
34587      &            LDAT = 9 )
34588       COMMON /HNDRUN/ RUNTES,EFTES
34589       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34590       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34591      &                NRK(2,268),NURE(30,2)
34592
34593       IPLA=IEII(IRE)+1
34594      *+1
34595       IPLE=IEII(IRE+1)
34596       IF (PL.LT.0.)                                             GO TO 30
34597       DO 10 I=IPLA,IPLE
34598         J=I-IPLA+1
34599         IF (PL.LE.PLABF(I))                                     GO TO 60
34600    10 CONTINUE
34601       I=IPLE
34602       IF ( EFTES.GT.40.D0)                                      GO TO 20
34603       EFTES=EFTES+1.0D0
34604       WRITE(LOUT,1000)PL,J
34605    20 CONTINUE
34606                                                                 GO TO 70
34607    30 CONTINUE
34608       DO 40 I=IPLA,IPLE
34609         J=I-IPLA+1
34610         IF (-PL.LE.UMO(I))                                      GO TO 60
34611    40 CONTINUE
34612       I=IPLE
34613       IF ( EFTES.GT.40.D0)                                      GO TO 50
34614       EFTES=EFTES+1.0D0
34615       WRITE(LOUT,1000)PL,I
34616    50 CONTINUE
34617    60 CONTINUE
34618    70 CONTINUE
34619       IDT_IEFUND=I
34620       RETURN
34621  1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
34622      +7H IEFUN=,I5)
34623       END
34624
34625 *$ CREATE DT_DSIGIN.FOR
34626 *COPY DT_DSIGIN
34627 *
34628 *===dsigin=============================================================*
34629 *
34630       SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
34631
34632       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34633       SAVE
34634
34635 * particle properties (BAMJET index convention),
34636 * (dublicate of DTPART for HADRIN)
34637       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34638      &                K1H(110),K2H(110)
34639       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34640       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34641      &                NRK(2,268),NURE(30,2)
34642
34643       IE=IDT_IEFUND(PLAB,IRE)
34644       IF (IE.LE.IEII(IRE)) IE=IE+1
34645       AMT=AMH(ITAR)
34646       AMN=AMH(N)
34647       AMN2=AMN*AMN
34648       AMT2=AMT*AMT
34649       ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
34650 C*** INTERPOLATION PREPARATION
34651       ECMO=UMO(IE)
34652       ECM1=UMO(IE-1)
34653       DECM=ECMO-ECM1
34654       DEC=ECMO-ECM
34655       IIKI=IKII(IRE)+1
34656       EKLIM=-THRESH(IIKI)
34657       WOK=SIIN(IE)
34658       WDK=WOK-SIIN(IE-1)
34659       IF (ECM.GT.ECMO) WDK=0.0D0
34660 C*** INTERPOLATION IN CHANNEL WEIGHTS
34661       IELIM=IDT_IEFUND(EKLIM,IRE)
34662       DELIM=UMO(IELIM)+EKLIM
34663      *+1.D-16
34664       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
34665       IF (DELIM*DELIM-DETE*DETE) 20,20,10
34666    10 DECC=DELIM
34667                                                                 GO TO 30
34668    20 DECC=DECM
34669    30 CONTINUE
34670       WKK=WOK-WDK*DEC/(DECC+1.D-9)
34671       IF (WKK.LT.0.0D0) WKK=0.0D0
34672       SI=WKK+1.D-12
34673       IF (-EKLIM.GT.ECM) SI=1.D-14
34674       RETURN
34675       END
34676
34677 *$ CREATE DT_DTCHOI.FOR
34678 *COPY DT_DTCHOI
34679 *
34680 *===dtchoi=============================================================*
34681 *
34682       SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
34683
34684       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34685       SAVE
34686
34687 C     ****************************
34688 C     TCHOIC CALCULATES A RANDOM VALUE
34689 C     FOR THE FOUR-MOMENTUM-TRANSFER T
34690 C     ****************************
34691
34692 * particle properties (BAMJET index convention),
34693 * (dublicate of DTPART for HADRIN)
34694       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34695      &                K1H(110),K2H(110)
34696 * slope parameters for HADRIN interactions
34697       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34698
34699       AMA=AM1
34700       AMB=AM2
34701       IF (I.GT.30.AND.II.GT.30)                                 GO TO 20
34702       III=II
34703       AM3=AM2
34704       IF (I.LE.30)                                              GO TO 10
34705       III=I
34706       AM3=AM1
34707    10 CONTINUE
34708                                                                 GO TO 30
34709    20 CONTINUE
34710       III=II
34711       AM3=AM2
34712       IF (AMA.LE.AMB)                                           GO TO 30
34713       III=I
34714       AM3=AM1
34715    30 CONTINUE
34716       IB=IBARH(III)
34717       AMA=AM3
34718       K=INT((AMA-0.75D0)/0.05D0)
34719       IF (K-2.LT.0) K=1
34720       IF (K-26.GE.0) K=25
34721       IF (IB)50,40,50
34722    40 BM=BBM(K)
34723                                                                 GO TO 60
34724    50 BM=BBB(K)
34725    60 CONTINUE
34726 C     NORMALIZATION
34727       TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1  **2
34728       TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1  **2
34729       VB=DT_RNDM(TMIN)
34730 **sr test
34731 C     IF (VB.LT.0.2D0) BM=BM*0.1
34732 C    **0.5
34733       BM = BM*5.05D0
34734 **
34735       TMI=BM*TMIN
34736       TMA=BM*TMAX
34737       ETMA=0.D0
34738       IF (ABS(TMA).GT.120.D0)                                   GO TO 70
34739       ETMA=EXP(TMA)
34740    70 CONTINUE
34741       AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
34742 C*** RANDOM CHOICE OF THE T - VALUE
34743       R=DT_RNDM(TMI)
34744       T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
34745       RETURN
34746       END
34747
34748 *$ CREATE DT_DTWOPA.FOR
34749 *COPY DT_DTWOPA
34750 *
34751 *===dtwopa=============================================================*
34752 *
34753       SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34754      &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
34755
34756       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34757       SAVE
34758
34759 C     ******************************************************
34760 C     QUASI TWO PARTICLE PRODUCTION
34761 C     TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
34762 C     FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
34763 C     IN THE CM - SYSTEM
34764 C     COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
34765 C     SPHERICAL COORDINATES
34766 C     ******************************************************
34767
34768 * particle properties (BAMJET index convention),
34769 * (dublicate of DTPART for HADRIN)
34770       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34771      &                K1H(110),K2H(110)
34772
34773       AMA=AM1
34774       AMB=AM2
34775       AMA2=AMA*AMA
34776       E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
34777       E2=UMOO - E1
34778       IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
34779       AMTE=(E1-AMA)*(E1+AMA)
34780       AMTE=AMTE+1.D-18
34781       P1=SQRT(AMTE)
34782       P2=P1
34783 C     / P2 / = / P1 /  BUT OPPOSITE DIRECTIONS
34784 C     DETERMINATION  OF  THE ANGLES
34785 C     COS(THETA1)=COD1      COS(THETA2)=COD2
34786 C     SIN(PHI1)=SIF1        SIN(PHI2)=SIF2
34787 C     COS(PHI1)=COF1        COS(PHI2)=COF2
34788 C     PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
34789       CALL DT_DSFECF(COF1,SIF1)
34790       COF2=-COF1
34791       SIF2=-SIF1
34792 C     CALCULATION OF THETA1
34793       CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
34794       COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
34795       IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
34796       COD2=-COD1
34797       RETURN
34798       END
34799
34800 *$ CREATE DT_ZK.FOR
34801 *COPY DT_ZK
34802 *
34803 *===zk=================================================================*
34804 *
34805       BLOCK DATA DT_ZK
34806
34807       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34808       SAVE
34809
34810 * decay channel information for HADRIN
34811       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34812      &                K1Z(16),K2Z(16),WTZ(153),II22,
34813      &                NZK1(153),NZK2(153),NZK3(153)
34814 * decay channel information for HADRIN
34815       CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
34816       COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
34817
34818 *     Particle masses in GeV                                           *
34819       DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
34820      &          2*1.7D0, 3*0.D0/
34821 *     Resonance width Gamma in GeV                                     *
34822       DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
34823 *     Mean life time in seconds                                        *
34824       DATA TAUZ / 16*0.D0 /
34825 *     Charge of particles and resonances                               *
34826       DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
34827 *     Baryonic charge                                                  *
34828       DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
34829 *     First number of decay channels used for resonances               *
34830 *     and decaying particles                                           *
34831       DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
34832      &          3*460/
34833 *     Last number of decay channels used for resonances                *
34834 *     and decaying particles                                           *
34835       DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
34836      &          3*460/
34837 *     Weight of decay channel                                          *
34838       DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
34839      & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
34840      & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
34841      & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
34842      & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
34843      & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
34844      & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
34845      & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
34846      & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
34847      & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
34848      & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
34849      & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
34850      & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
34851      & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
34852      & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
34853      & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
34854      & .05D0, .65D0, 9*1.D0 /
34855 *     Particle numbers in decay channel                                *
34856       DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
34857      & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
34858      & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
34859      & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
34860      & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
34861      & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
34862      & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
34863      & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
34864       DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
34865      & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
34866      & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
34867      & 4*33, 32, 3*35,  2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
34868      & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
34869      & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
34870      & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
34871      & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
34872      & 1, 8, 1, 8, 1, 9*0 /
34873       DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
34874      & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
34875      & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
34876      & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
34877      & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
34878      & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
34879 *     Particle  names                                                  *
34880       DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS  ',' PAP  ',' PAN  ',
34881      & 'APN', 'DEO   ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
34882      & 3*'BLANK' /
34883 *     Name of decay channel                                            *
34884       DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
34885      & 'ANNPI0','APPPI0','ANPPI-'/
34886       DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K-  ','K0AK0 ',
34887      & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET  ','&0R0  ','P-R+  ',
34888      & 'P+R-  ','POOM  ',' ETET ','ETSP0 ','R0ET  ',' R0R0 ','R+R-  ',
34889      & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
34890      & 'P+R-R0','R0OM  ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
34891      & 'P+R-OM','OMOM  ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
34892      & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
34893      & 'OMOMOM',
34894      & ' P+PO ','P+POPO','P+P+P-','P+ET  ','P0R+  ','P+R0  ','ETSP+ ',
34895      & 'R+ET  ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
34896      & 'P+R-R+','R+OM  ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
34897      & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
34898      & 'P-PO  ','P-POPO','P-P-P+','P-ET  ','POR-  ','P-R0  ','ETSP- ',
34899      & 'R-ET  ','R-R0  ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
34900       DATA ZKNAM6/'P+R-R-','R-OM  ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
34901      & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
34902      & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO  ','LPI+  ',
34903      & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
34904      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
34905      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
34906      & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
34907      & 9*'BLANK'/
34908 *=                                               end*block.zk      *
34909       END
34910
34911 *$ CREATE DT_BLKD43.FOR
34912 *COPY DT_BLKD43
34913 *
34914 *===blkd43=============================================================*
34915 *
34916       BLOCK DATA DT_BLKD43
34917
34918       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34919       SAVE
34920
34921 *
34922 *=== reac =============================================================*
34923 *
34924 *----------------------------------------------------------------------*
34925 *                                                                      *
34926 *     Created on 10 december 1991  by    Alfredo Ferrari & Paola Sala  *
34927 *                                                   Infn - Milan       *
34928 *                                                                      *
34929 *     Last change on 10-dec-91     by    Alfredo Ferrari               *
34930 *                                                                      *
34931 *     This is the original common reac of Hadrin                       *
34932 *                                                                      *
34933 *----------------------------------------------------------------------*
34934 *
34935       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34936      &                NRK(2,268),NURE(30,2)
34937
34938       DIMENSION
34939      & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
34940      & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
34941      & SPIKP1(315), SPIKPU(278), SPIKPV(372),
34942      & SPIKPW(278), SPIKPX(372), SPIKP4(315),
34943      & SPIKP5(187), SPIKP6(289),
34944      & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
34945      & SPIKP9(143), SPIKP0(169), SPKPV(143),
34946      & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
34947      & SANPEL(84) , SPIKPF(273),
34948      & SPKP15(187), SPKP16(272),
34949      & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
34950      & NURELN(60)
34951 *
34952        DIMENSION NRKLIN(532)
34953        EQUIVALENCE (NRK(1,1), NRKLIN(1))
34954        EQUIVALENCE (   UMO(  1),  UMOPI(1)), (   UMO( 93),  UMOKC(1))
34955        EQUIVALENCE (   UMO(161),   UMOP(1)), (   UMO(200),   UMON(1))
34956        EQUIVALENCE (   UMO(263),  UMOK0(1))
34957        EQUIVALENCE ( PLABF(  1),  PLAPI(1)), ( PLABF( 93),  PLAKC(1))
34958        EQUIVALENCE ( PLABF(161),   PLAP(1)), ( PLABF(200),   PLAN(1))
34959        EQUIVALENCE ( PLABF(263),  PLAK0(1))
34960        EQUIVALENCE (   WK(   1), SPIKP1(1)), (   WK( 316), SPIKPU(1))
34961        EQUIVALENCE (   WK( 594), SPIKPV(1)), (   WK( 966), SPIKPW(1))
34962        EQUIVALENCE (   WK(1244), SPIKPX(1)), (   WK(1616), SPIKP4(1))
34963        EQUIVALENCE (   WK(1931), SPIKP5(1)), (   WK(2118), SPIKP6(1))
34964        EQUIVALENCE (   WK(2407), SKMPEL(1)), (   WK(2509), SPIKP7(1))
34965        EQUIVALENCE (   WK(2798), SKMNEL(1)), (   WK(2866), SPIKP8(1))
34966        EQUIVALENCE (   WK(3053), SPIKP9(1)), (   WK(3196), SPIKP0(1))
34967        EQUIVALENCE (   WK(3365),  SPKPV(1)), (   WK(3508), SAPPEL(1))
34968        EQUIVALENCE (   WK(3613), SPIKPE(1)), (   WK(4012), SAPNEL(1))
34969        EQUIVALENCE (   WK(4096), SPIKPZ(1)), (   WK(4369), SANPEL(1))
34970        EQUIVALENCE (   WK(4453), SPIKPF(1)), (   WK(4726), SPKP15(1))
34971        EQUIVALENCE (   WK(4913), SPKP16(1))
34972        EQUIVALENCE (NRK(1,1), NRKLIN(1))
34973        EQUIVALENCE (NRKLIN(   1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
34974        EQUIVALENCE (NRKLIN( 297),  NRKP(1)), (NRKLIN( 367),  NRKN(1))
34975        EQUIVALENCE (NRKLIN( 483), NRKK0(1))
34976        EQUIVALENCE (NURE(1,1), NURELN(1))
34977 *
34978 **** pi- p data                                                        *
34979 **** pi+ n data                                                        *
34980       DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
34981      & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
34982      & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
34983      & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
34984      & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
34985      & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
34986      & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
34987      & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
34988      & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
34989      & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
34990       DATA PLAKC /
34991      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34992      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34993      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
34994      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34995      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34996      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
34997      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34998      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34999      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35000      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35001      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35002      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
35003       DATA PLAK0 /
35004      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35005      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35006      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35007      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35008      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35009      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
35010 *                 pp   pn   np   nn                                    *
35011       DATA PLAP /
35012      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35013      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35014      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35015      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35016      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35017      & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
35018 *    app   apn   anp   ann                                             *
35019       DATA PLAN /
35020      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
35021      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35022      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35023      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
35024      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35025      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35026      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
35027      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35028      & 3.43D0, 3.75D0, 4.07D0, 4.43D0  /
35029       DATA SIIN / 296*0.D0 /
35030       DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35031      & 1.557D0,1.615D0,1.6435D0,
35032      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35033      & 2.286D0,2.366D0,2.482D0,2.56D0,
35034      & 2.735D0,2.90D0,
35035      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35036      & 1.496D0,1.527D0,1.557D0,
35037      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35038      & 2.071D0,2.159D0,2.286D0,2.366D0,
35039      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35040      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35041      & 1.496D0,1.527D0,1.557D0,
35042      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35043      & 2.071D0,2.159D0,2.286D0,2.366D0,
35044      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35045      &                   1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35046      & 1.557D0,1.615D0,1.6435D0,
35047      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35048      & 2.286D0,2.366D0,2.482D0,2.56D0,
35049      &  2.735D0, 2.90D0/
35050       DATA UMOKC/ 1.44D0,
35051      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35052      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35053      & 3.1D0,1.44D0,
35054      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35055      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35056      & 3.1D0,1.44D0,
35057      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35058      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35059      & 3.1D0,1.44D0,
35060      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35061      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35062      &  3.1D0/
35063       DATA UMOK0/ 1.44D0,
35064      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35065      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35066      & 3.1D0,1.44D0,
35067      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35068      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35069      &  3.1D0/
35070 *                 pp   pn   np   nn                                    *
35071       DATA UMOP/
35072      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35073      & 3.D0,3.1D0,3.2D0,
35074      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35075      & 3.D0,3.1D0,3.2D0,
35076      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35077      & 3.D0,3.1D0,3.2D0/
35078 *    app   apn   anp   ann                                             *
35079       DATA UMON /
35080      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35081      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35082      & 3.D0,3.1D0,3.2D0,
35083      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35084      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35085      & 3.D0,3.1D0,3.2D0,
35086      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35087      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35088      &  3.D0,3.1D0,3.2D0/
35089 **** reaction channel state particles                                  *
35090       DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
35091      & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
35092      & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
35093      & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
35094      & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
35095      & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
35096      & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
35097      & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
35098      & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
35099      & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
35100       DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
35101      & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
35102      & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
35103      & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
35104      & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
35105      & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
35106      & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
35107      & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
35108 *                                                                      *
35109 *   k0 p   k0 n   ak0 p   ak/ n                                        *
35110 *                                                                      *
35111       DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
35112      & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13,   22, 13, 21, 23,
35113      & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
35114      & 53, 47, 1, 103, 0, 93, 0/
35115 *   pp  pn   np   nn                                                   *
35116       DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
35117      & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
35118      & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
35119      & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
35120 *     app   apn   anp   ann                                            *
35121       DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
35122      & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
35123      & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
35124      & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
35125      & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
35126      & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
35127      & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
35128 **** channel cross section                                             *
35129       DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
35130      & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
35131      & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
35132      & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
35133      & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
35134      &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
35135      & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
35136      & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
35137      &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
35138      & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
35139      & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
35140      & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
35141      & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
35142      & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
35143      & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
35144      & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
35145      & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
35146      & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
35147      & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
35148      & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
35149 **** pi+ n data                                                        *
35150       DATA SPIKPU/   0.D0, 25.D0, 13.D0,  11.D0, 10.5D0, 14.D0,  20.D0,
35151      & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35152      & 10.D0, 10.D0, 9.5D0,  9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35153      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0,   5.5D0,  4.8D0,
35154      & 4.2D0, 7.5D0, 3.4D0,  2.5D0, 2.5D0, 2.1D0, 1.4D0,   1.D0,   .8D0,
35155      &  .6D0, .46D0,  .3D0, .2D0, .15D0, .13D0, 11*0.D0,  .95D0,  .65D0,
35156      & .48D0, .35D0,  .2D0, .18D0, .17D0, .16D0,  .15D0,   .1D0,  .09D0,
35157      & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0,  .2D0,   .1D0,
35158      & .08D0, .06D0, .045D0,   .03D0, .02D0, .01D0,      .005D0, .003D0,
35159      & 12*0.D0, .3D0, .24D0,   .18D0, .15D0, .13D0,  .12D0, .11D0, .1D0,
35160      & .09D0,  .08D0, .05D0,   .04D0, .03D0,  0.D0, 0.16D0, .7D0, 1.3D0,
35161      & 3.1D0,  4.5D0,  2.D0, 18*0.D0, 3*.0D0,  0.D0, 0.D0, 4.0D0, 11.D0,
35162      & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0,  1.5D0, .9D0, .55D0,
35163      &  .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0,   2.25D0, 3.3D0,
35164      & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
35165      & .64D0,  1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0,  4.4D0,   3.D0, 1.8D0,
35166      &  .9D0, .53D0, .28D0,      10*0.D0, 2*0.D0,  .25D0,  .82D0,
35167      & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0,  5.7D0, 3.9D0, 2.35D0, 1.15D0,
35168      & .69D0, .37D0, 10*0.D0,     7*0.D0,   .0D0, .34D0,  1.5D0, 3.47D0,
35169      & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0,  .3D0,  .15D0, 6*0.D0/
35170 *
35171       DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35172      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
35173      & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
35174      & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
35175      & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
35176      & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
35177      & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
35178      & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
35179      & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
35180      & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
35181      & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
35182      & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
35183      & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
35184      & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
35185      & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
35186      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35187      & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
35188      & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
35189      & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
35190      & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
35191 **** pi- p data                                                        *
35192       DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
35193      & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35194      & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35195      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
35196      & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
35197      & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
35198      & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
35199      & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
35200      & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
35201      & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
35202      & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
35203      & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
35204      & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
35205      & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
35206      & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
35207      & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
35208      & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
35209      & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
35210      & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
35211 *
35212       DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35213      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
35214      & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
35215      & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
35216      & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
35217      & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
35218      & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
35219      & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
35220      & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
35221      & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
35222      & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
35223      & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
35224      & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
35225      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35226      & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
35227      & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
35228      & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
35229      & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
35230      & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
35231      & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
35232 **** pi- n data                                                        *
35233       DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
35234      & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
35235      & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
35236      & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
35237      & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
35238      & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
35239      & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
35240      & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
35241      & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
35242      & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
35243      & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
35244      & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
35245      & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
35246      & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
35247      & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
35248      & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
35249      & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
35250      & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
35251      & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
35252      & 3.3D0, 5.4D0, 7.D0 /
35253 **** k+  p data                                                        *
35254       DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
35255      & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35256      & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
35257      & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
35258      & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35259      & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35260      & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
35261      & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
35262      & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
35263      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35264      & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
35265      & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
35266      & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
35267 **** k+  n data                                                        *
35268       DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
35269      & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
35270      & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
35271      & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
35272      & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35273      & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
35274      & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
35275      & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
35276      & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
35277      & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
35278      & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
35279      & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
35280      & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
35281      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35282      & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
35283      & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
35284      & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
35285      & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
35286      & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
35287 **** k-  p data                                                        *
35288       DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
35289      &     7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
35290      &    0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
35291      &    .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
35292      &    0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
35293      &    .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
35294      &    0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
35295      &    .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
35296      &    0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
35297      &    .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
35298      &    0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
35299      &    .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
35300       DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
35301      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35302      & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
35303      & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
35304      & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,  3*0.D0, 1.0D0, 3.03D0,
35305      & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
35306      & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
35307      & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
35308      & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35309      & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
35310      & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
35311      & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
35312      & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35313      & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
35314      & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
35315      & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
35316      & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
35317      & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
35318      & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
35319      & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
35320      & 10*0.D0/
35321 ***** k- n data                                                        *
35322       DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35323      &        3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
35324      &        0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
35325      &        1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
35326      &        0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
35327      &        .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
35328      &        0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
35329      &       .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
35330       DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35331      &  14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35332      &  1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
35333      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35334      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35335      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35336      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35337      &  7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
35338      &  .39D0, .22D0, .07D0, 0.D0,
35339      &  6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35340      &  4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
35341      &  10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
35342      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35343      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35344      &  9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
35345      &  5.10D0, 5.44D0, 5.3D0,
35346      &  4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
35347 *****  p p data                                                        *
35348       DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35349      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35350      &              0.D0, 3.6D0, 1.7D0, 10*0.D0,
35351      &              .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
35352      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35353      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35354      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35355      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35356      &              16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
35357      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
35358      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
35359      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35360      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35361      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35362      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35363 *****  p n data                                                        *
35364       DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35365      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35366      &              0.D0, 1.8D0, .2D0,  12*0.D0,
35367      &              3.2D0, 6.05D0, 9.9D0, 5.1D0,
35368      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35369      &              2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
35370      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35371      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35372      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35373      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35374      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35375      &              10*0.D0, .7D0, 5.1D0, 8.D0,
35376      &              10*0.D0, .7D0, 5.1D0, 8.D0,
35377      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
35378      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
35379      &              7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
35380      &              7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
35381      &              5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
35382 *   nn - data                                                          *
35383 *                                                                      *
35384       DATA SPKPV/  0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35385      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35386      &              0.D0, 3.6D0, 1.7D0, 12*0.D0,
35387      &              8.7D0, 17.7D0, 18.8D0, 15.9D0,
35388      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35389      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35390      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35391      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
35392      &              11.D0, 5.5D0, 3.5D0,
35393      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
35394      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
35395      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35396      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35397      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35398      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35399 ****************   ap - p - data                                       *
35400       DATA SAPPEL/ 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
35401      &  50.D0,  50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35402      &  25.D0,  22.D0, 21.D0, 20.D0, 18.D0, 17.D0,  11*0.D0,
35403      &  .05D0,  .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
35404      &  0.D0,  1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
35405      &  .1D0,  .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35406      &  0.D0,  55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
35407      &  10.D0,  7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
35408      &  1.55D0,  1.3D0, .95D0, .75D0,
35409      &  0.D0,  3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
35410      &  .25D0,  .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35411      & .01D0,  .008D0, .006D0, .005D0/
35412       DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35413      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35414      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
35415      & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
35416      & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
35417      & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
35418      & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
35419      & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
35420      & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
35421      & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
35422      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35423      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35424      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35425      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
35426      & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
35427      & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
35428      & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
35429      & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
35430      & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
35431      & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
35432 ****************   ap - n - data                                       *
35433       DATA SAPNEL/
35434      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0,  68.D0, 65.D0,
35435      & 50.D0, 50.D0,  43.D0,  42.D0,  40.5D0, 35.D0, 30.D0,  28.D0,
35436      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0,  17.D0, 11*0.D0,
35437      & .05D0, .15D0, .18D0,  .2D0,    .2D0,  .3D0,  .4D0,   .6D0,  .7D0,
35438      & .85D0,  0.D0,  1.D0,  .9D0,    .46D0, .3D0,  .23D0, .18D0, .16D0,
35439      & .14D0,  .1D0, .08D0, .05D0,    .02D0, .015D0, 4*.011D0, 3*.005D0,
35440      & 0.D0,  3.3D0,  3.D0, 1.5D0,     1.D0, .7D0,  .4D0,  .35D0, .4D0,
35441      & .25D0, .18D0, .08D0, .04D0,    .03D0, .023D0, .016D0, .014D0,
35442      & .01D0, .008D0, .006D0, .005D0 /
35443        DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35444      &  84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35445      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35446      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35447      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35448      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35449      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35450      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35451      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35452      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35453      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35454      & 4.9D0, 8.5D0,  15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35455      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35456      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35457 *                                                                      *
35458 *                                                                      *
35459 ****************   an - p - data                                       *
35460 *                                                                      *
35461       DATA SANPEL/
35462      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
35463      & 50.D0, 43.D0,  42.D0,  40.5D0, 35.D0, 30.D0, 28.D0,
35464      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0, 17.D0, 11*0.D0, .05D0,
35465      & .15D0, .18D0,   .2D0,   .2D0,   .3D0,  .4D0, .6D0,   .7D0, .85D0,
35466      & 0.D0,   1.D0,   .9D0,  .46D0,  .3D0,  .23D0, .18D0, .16D0, .14D0,
35467      & .1D0,  .08D0,  .05D0,  .02D0, .015D0, 4*.011D0, 3*.005D0,
35468      & 0.D0,  3.3D0,  3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
35469      & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35470      & .01D0, .008D0, .006D0, .005D0 /
35471       DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35472      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35473      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35474      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35475      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35476      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35477      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35478      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35479      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35480      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35481      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35482      & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35483      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35484      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35485 ****  ko - n - data                                                    *
35486       DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
35487      &      6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35488      &      0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
35489      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35490      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35491      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35492      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35493      &    4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
35494      &     1.4D0, 1.2D0, 1.05D0, .9D0, .66D0,  .5D0,
35495      &    7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
35496      &   11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
35497      &    4.85D0, 4.9D0,
35498      &   10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
35499      &    6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
35500      &    2.85D0, 2.35D0, 2.01D0, 1.8D0,
35501      &   12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
35502      &   12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0  /
35503 **** ako - p - data                                                    *
35504       DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35505      & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
35506      & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
35507      & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
35508      & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
35509      & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
35510      & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
35511      & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35512      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
35513      & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
35514      & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
35515      & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
35516      & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
35517      & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35518      & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
35519      & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
35520      & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
35521      & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
35522      & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
35523      & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
35524      & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
35525       DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
35526      & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
35527 *=                                               end*block.blkdt3      *
35528       END
35529
35530 *$ CREATE DT_QEL_POL.FOR
35531 *COPY DT_QEL_POL
35532 *
35533 *===qel_pol============================================================*
35534 *
35535       SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
35536
35537       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35538       SAVE
35539
35540       CALL DT_MASS_INI
35541       CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35542
35543       RETURN
35544       END
35545
35546 *$ CREATE DT_GEN_QEL.FOR
35547 *COPY DT_GEN_QEL
35548 C==================================================================
35549 C   Generation of  a Quasi-Elastic neutrino scattering
35550 C==================================================================
35551 *
35552 *===gen_qel============================================================*
35553 *
35554       SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35555
35556 C...Generate a quasi-elastic   neutrino/antineutrino
35557 C.  Interaction on a nuclear target
35558 C.  INPUT  : LTYP = neutrino type (1,...,6)
35559 C.           ENU (GeV) = neutrino energy
35560 C----------------------------------------------------
35561
35562       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35563       SAVE
35564
35565       PARAMETER ( LINP = 10 ,
35566      &            LOUT = 6 ,
35567      &            LDAT = 9 )
35568       PARAMETER (MAXLND=4000)
35569       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35570 * nuclear potential
35571       LOGICAL LFERMI
35572       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
35573      &                EBINDP(2),EBINDN(2),EPOT(2,210),
35574      &                ETACOU(2),ICOUL,LFERMI
35575 * steering flags for qel neutrino scattering modules
35576       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
35577 **sr - removed (not needed)
35578 C     COMMON /CBAD/  LBAD, NBAD
35579 C     COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
35580 **
35581
35582       DIMENSION PI(3),PO(3)
35583 CJR+
35584       DATA ININU/0/
35585 CJR-
35586 C     REAL*8 DBETA(3)
35587 C     REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
35588       DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
35589       DATA AMN  /0.93827231D0, 0.93956563D0/
35590       DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
35591       DATA INIPRI/0/
35592
35593 C     DATA PFERMI/0.22D0/
35594 CGB+...Binding Energy
35595       DATA EBIND/0.008D0/
35596 CGB-...
35597
35598       ININU=ININU+1
35599       IF(ININU.EQ.1)NDSIG=0
35600       LBAD = 0
35601       enu0=enu
35602 c      write(*,*) enu0
35603 C...Lepton mass
35604       AML = AML0(LTYP)       !  massa leptoni
35605       AML2 = AML**2          !  massa leptoni **2
35606 C...Particle labels (LUND)
35607       N = 5
35608       K(1,1) = 21
35609       K(2,1) = 21
35610       K(3,1) = 21
35611       K(3,3) = 1
35612       K(4,1) = 1
35613       K(4,3) = 1
35614       K(5,1) = 1
35615       K(5,3) = 2
35616       K0 = (LTYP-1)/2          !  2
35617       K1 = LTYP/2              !  2
35618       KA = 12 + 2*K0           !  16
35619       IS = -1 + 2*LTYP - 4*K1  !  -1 +10 -8 = 1
35620       K(1,2) = IS*KA
35621       K(4,2) = IS*(KA-1)
35622       K(3,2) = IS*24
35623       LNU = 2 - LTYP + 2*K1    !  2 - 5 + 2 = - 1
35624       IF (LNU .EQ. 2)  THEN
35625         K(2,2) = 2212
35626         K(5,2) = 2112
35627         AMI = AMN(1)
35628         AMF = AMN(2)
35629 CJR+
35630         PFERMI=PFERMN(2)
35631 CJR-
35632       ELSE
35633         K(2,2) = 2112
35634         K(5,2) = 2212
35635         AMI = AMN(2)
35636         AMF = AMN(1)
35637 CJR+
35638         PFERMI=PFERMP(2)
35639 CJR-
35640       ENDIF
35641       AMI2 = AMI**2
35642       AMF2 = AMF**2
35643
35644       DO IGB=1,5
35645         P(3,IGB) = 0.
35646         P(4,IGB) = 0.
35647         P(5,IGB) = 0.
35648       END DO
35649
35650       NTRY = 0
35651 CGB+...
35652       EFMAX  = SQRT(PFERMI**2 + AMI2) -AMI             ! max. Fermi Energy
35653       ENWELL = EFMAX + EBIND ! depth of nuclear potential well
35654 CGB-...
35655
35656   100 CONTINUE
35657
35658 C...4-momentum initial lepton
35659       P(1,5) = 0.     ! massa
35660       P(1,4) = ENU0    ! energia
35661       P(1,1) = 0.     ! px
35662       P(1,2) = 0.     ! py
35663       P(1,3) = ENU0    ! pz
35664
35665 C     PF = PFERMI*PYR(0)**(1./3.)
35666 c       write(23,*) PYR(0)
35667 c      write(*,*) 'Pfermi=',PF
35668 c      PF = 0.
35669       NTRY=NTRY+1
35670 C     IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
35671       IF (NTRY .GT. 500)  THEN
35672         LBAD = 1
35673         WRITE (LOUT,1001)  NBAD, ENU
35674         RETURN
35675       ENDIF
35676 C     CT = -1. + 2.*PYR(0)
35677 c      CT = -1.
35678 C     ST =  SQRT(1.-CT*CT)
35679 C     F = 2.*3.1415926*PYR(0)
35680 c      F = 0.
35681
35682 C     P(2,4) = SQRT(PF*PF + MI2) - EBIND  ! energia
35683 C     P(2,1) = PF*ST*COS(F)               ! px
35684 C     P(2,2) = PF*ST*SIN(F)               ! py
35685 C     P(2,3) = PF*CT                      ! pz
35686 C     P(2,5) = SQRT(P(2,4)**2-PF*PF)      ! massa
35687        P(2,1) = P21
35688        P(2,2) = P22
35689        P(2,3) = P23
35690        P(2,4) = P24
35691        P(2,5) = P25
35692       beta1=-p(2,1)/p(2,4)
35693       beta2=-p(2,2)/p(2,4)
35694       beta3=-p(2,3)/p(2,4)
35695       N=2
35696 C      WRITE(6,*)' before transforming into target rest frame'
35697       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35698 C      print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35699       N=5
35700
35701       phi11=atan(p(1,2)/p(1,3))
35702       pi(1)=p(1,1)
35703       pi(2)=p(1,2)
35704       pi(3)=p(1,3)
35705
35706       CALL DT_TESTROT(PI,Po,PHI11,1)
35707       DO ll=1,3
35708         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35709       END DO
35710 c        WRITE(*,*) po
35711       p(1,1)=po(1)
35712       p(1,2)=po(2)
35713       p(1,3)=po(3)
35714       phi12=atan(p(1,1)/p(1,3))
35715
35716       pi(1)=p(1,1)
35717       pi(2)=p(1,2)
35718       pi(3)=p(1,3)
35719       CALL DT_TESTROT(Pi,Po,PHI12,2)
35720       DO ll=1,3
35721         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35722       END DO
35723 c        WRITE(*,*) po
35724       p(1,1)=po(1)
35725       p(1,2)=po(2)
35726       p(1,3)=po(3)
35727
35728       enu=p(1,4)
35729
35730 C...Kinematical limits in Q**2
35731 c      S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) !            ????
35732       S = P(2,5)**2 + 2.*ENU*P(2,5)
35733       SQS = SQRT(S)                          ! E centro massa
35734       IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
35735       ELF = (S-AMF2+AML2)/(2.*SQS)           ! energia leptone finale p
35736       PSTAR = (S-P(2,5)**2)/(2.*SQS)       ! p* neutrino nel c.m.
35737       PLF = SQRT(ELF**2-AML2)               ! 3-momento leptone finale
35738       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)    ! + o -
35739       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)    ! according con cos(theta)
35740       IF (Q2MIN .LT. 0.)   Q2MIN = 0.      ! ??? non fisico
35741
35742 C...Generate Q**2
35743       DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
35744   200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35745       DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
35746       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
35747       CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
35748       NDSIG=NDSIG+1
35749 C     WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
35750 C    &Q2,Q2min,Q2MAX,DSIGEV
35751
35752 C...c.m. frame. Neutrino along z axis
35753       DETOT = (P(1,4)) + (P(2,4)) ! e totale
35754       DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
35755       DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
35756       DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
35757 c      WRITE(*,*)
35758 c      WRITE(*,*)
35759 C      WRITE(*,*) 'Input values laboratory frame'
35760       N=2
35761
35762       CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
35763
35764       N=5
35765 c      STHETA = ULANGL(P(1,3),P(1,1))
35766 c      write(*,*) 'stheta' ,stheta
35767 c      stheta=0.
35768 c      CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
35769 c      WRITE(*,*)
35770 c      WRITE(*,*)
35771 C      WRITE(*,*) 'Output values cm frame'
35772 C...Kinematic in c.m. frame
35773       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
35774       STSTAR = SQRT(1.-CTSTAR**2)
35775       PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
35776       P(4,5) = AML                  ! massa leptone
35777       P(4,4) = ELF                 ! e leptone
35778       P(4,3) = PLF*CTSTAR          ! px
35779       P(4,1) = PLF*STSTAR*COS(PHI) ! py
35780       P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
35781
35782       P(5,5) = AMF                  ! barione
35783       P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
35784       P(5,3) = -P(4,3)             ! px
35785       P(5,1) = -P(4,1)             ! py
35786       P(5,2) = -P(4,2)             ! pz
35787
35788       P(3,5) = -Q2
35789       P(3,1) = P(1,1)-P(4,1)
35790       P(3,2) = P(1,2)-P(4,2)
35791       P(3,3) = P(1,3)-P(4,3)
35792       P(3,4) = P(1,4)-P(4,4)
35793
35794 C...Transform back to laboratory  frame
35795 C      WRITE(*,*) 'before going back to nucl rest frame'
35796 c      CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
35797       N=5
35798
35799       CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
35800
35801 C      WRITE(*,*) 'Now back in nucl rest frame'
35802       IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
35803
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,PHI12,3)
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 c********************************************
35819
35820       DO kw=1,5
35821         pi(1)=p(kw,1)
35822         pi(2)=p(kw,2)
35823         pi(3)=p(kw,3)
35824         CALL DT_TESTROT(Pi,Po,PHI11,4)
35825         DO ll=1,3
35826           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35827         END DO
35828         p(kw,1)=po(1)
35829         p(kw,2)=po(2)
35830         p(kw,3)=po(3)
35831       END DO
35832
35833 c********************************************
35834
35835 C      WRITE(*,*) 'Now back in lab frame'
35836
35837       CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35838
35839 CGB+...
35840 C...test (on final momentum of nucleon) if Fermi-blocking
35841 C...is operating
35842       ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
35843      &  - P(5,5)
35844       IF (ENUCL.LT. EFMAX) THEN
35845         IF(INIPRI.LT.10)THEN
35846           INIPRI=INIPRI+1
35847 C         WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
35848 C...the interaction is not possible due to Pauli-Blocking and
35849 C...it must be resampled
35850         ENDIF
35851         GOTO 100
35852       ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
35853         IF(INIPRI.LT.10)THEN
35854           INIPRI=INIPRI+1
35855 C     WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
35856         ENDIF
35857 C                      Reject (J:R) here all these events
35858 C                      are otherwise rejected in dpmjet
35859         GOTO 100
35860 C...the interaction is possible, but the nucleon remains inside
35861 C...the nucleus. The nucleus is therefore left excited.
35862 C...We treat this case as a nucleon with 0 kinetic energy.
35863 C       P(5,5) = AMF
35864 C       P(5,4) = AMF
35865 C       P(5,1) = 0.
35866 C       P(5,2) = 0.
35867 C       P(5,3) = 0.
35868       ELSE IF (ENUCL.GE.ENWELL) THEN
35869 C     WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
35870 C...the interaction is possible, the nucleon can exit the nucleus
35871 C...but the nuclear well depth must be subtracted. The nucleus could be
35872 C...left in an excited state.
35873         Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
35874 C       P(5,4) = ENUCL-ENWELL + AMF
35875         Pnucl = SQRT(P(5,4)**2-AMF**2)
35876 C...The 3-momentum is scaled assuming that the direction remains
35877 C...unaffected
35878         P(5,1) = P(5,1) * Pnucl/Pstart
35879         P(5,2) = P(5,2) * Pnucl/Pstart
35880         P(5,3) = P(5,3) * Pnucl/Pstart
35881 C     WRITE(6,*)' qel new P(5,4) ',P(5,4)
35882       ENDIF
35883 CGB-...
35884       DSIGSU=DSIGSU+DSIGEV
35885
35886          GA=P(4,4)/P(4,5)
35887          BGX=P(4,1)/P(4,5)
35888          BGY=P(4,2)/P(4,5)
35889          BGZ=P(4,3)/P(4,5)
35890 *
35891          DBETB(1)=BGX/GA
35892          DBETB(2)=BGY/GA
35893          DBETB(3)=BGZ/GA
35894          IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
35895
35896             CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
35897
35898          ENDIF
35899 c
35900 C      PRINT*,' FINE   EVENTO '
35901       enu=enu0
35902       RETURN
35903
35904  1001 FORMAT(2X, 'DT_GEN_QEL   : event rejected ', I5,  G10.3)
35905       END
35906
35907 *$ CREATE DT_MASS_INI.FOR
35908 *COPY DT_MASS_INI
35909 C====================================================================
35910 C.  Masses
35911 C====================================================================
35912 *
35913 *===mass_ini===========================================================*
35914 *
35915       SUBROUTINE DT_MASS_INI
35916 C...Initialize  the kinematics for the quasi-elastic cross section
35917
35918       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35919       SAVE
35920
35921 * particle masses used in qel neutrino scattering modules
35922       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
35923      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
35924      &                EMPROTSQ,EMNEUTSQ,EMNSQ
35925
35926       EML(1) = 0.51100D-03   ! e-
35927       EML(2) = EML(1)        ! e+
35928       EML(3) = 0.105659D0      ! mu-
35929       EML(4) = EML(3)        ! mu+
35930       EML(5) = 1.7777D0        ! tau-
35931       EML(6) = EML(5)        ! tau+
35932       EMPROT = 0.93827231D0    ! p
35933       EMNEUT = 0.93956563D0    ! n
35934       EMPROTSQ = EMPROT**2
35935       EMNEUTSQ = EMNEUT**2
35936       EMN = (EMPROT + EMNEUT)/2.
35937       EMNSQ = EMN**2
35938       DO J=1,3
35939         J0 = 2*(J-1)
35940         EMN1(J0+1) = EMNEUT
35941         EMN1(J0+2) = EMPROT
35942         EMN2(J0+1) = EMPROT
35943         EMN2(J0+2) = EMNEUT
35944       ENDDO
35945       DO J=1,6
35946         EMLSQ(J) = EML(J)**2
35947         ETQE(J)  = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
35948       ENDDO
35949       RETURN
35950       END
35951
35952 *$ CREATE DT_DSQEL_Q2.FOR
35953 *COPY DT_DSQEL_Q2
35954 *
35955 *===dsqel_q2===========================================================*
35956 *
35957       DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
35958
35959 C...differential cross section for  Quasi-Elastic scattering
35960 C.       nu + N -> l + N'
35961 C.  From Llewellin Smith  Phys.Rep.  3C, 261, (1971).
35962 C.
35963 C.  INPUT :  JTYP = 1,...,6    nu_e, ...., nubar_tau
35964 C.           ENU (GeV) =  Neutrino energy
35965 C.           Q2  (GeV**2) =  (Transfer momentum)**2
35966 C.
35967 C.  OUTPUT : DSQEL_Q2  = differential  cross section :
35968 C.                       dsigma/dq**2  (10**-38 cm+2/GeV**2)
35969 C------------------------------------------------------------------
35970
35971       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35972       SAVE
35973
35974 * particle masses used in qel neutrino scattering modules
35975       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
35976      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
35977      &                EMPROTSQ,EMNEUTSQ,EMNSQ
35978 **sr - removed (not needed)
35979 C     COMMON /CAXIAL/ FA0, AXIAL2
35980 **
35981
35982       DIMENSION SS(6)
35983       DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
35984       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
35985       DATA AXIAL2 /1.03D0/  ! to be checked
35986
35987       FA0=-1.253D0
35988       CSI = 3.71D0                   !  ???
35989       GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2   ! G_e(q**2)
35990       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
35991       X = Q2/(EMN*EMN)     ! emn=massa barione
35992       XA = X/4.D0
35993       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
35994       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
35995       FA = FA0/(1.D0 + Q2/AXIAL2)**2
35996       FFA = FA*FA
35997       FFV1 = FV1*FV1
35998       FFV2 = FV2*FV2
35999       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
36000       A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
36001       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
36002       AA = (XA+0.25D0*RM)*(A1 + A2)
36003       BB = -X*FA*(FV1 + FV2)
36004       CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
36005       SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
36006       DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU)  !
36007       IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
36008
36009       RETURN
36010       END
36011
36012 *$ CREATE DT_PREPOLA.FOR
36013 *COPY DT_PREPOLA
36014 *
36015 *===prepola============================================================*
36016 *
36017       SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
36018
36019       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36020       SAVE
36021 c
36022 c By G. Battistoni and E. Scapparone (sept. 1997)
36023 c According to:
36024 c     Albright & Jarlskog, Nucl Phys B84 (1975) 467
36025 c
36026 c
36027       PARAMETER (MAXLND=4000)
36028       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36029       COMMON /QNPOL/ POLARX(4),PMODUL
36030 * particle masses used in qel neutrino scattering modules
36031       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
36032      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
36033      &                EMPROTSQ,EMNEUTSQ,EMNSQ
36034 * steering flags for qel neutrino scattering modules
36035       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
36036 **sr - removed (not needed)
36037 C     COMMON /CAXIAL/ FA0, AXIAL2
36038 C     COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
36039 C    &        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
36040 **
36041       REAL*8 POL(4,4),BB2(3)
36042       DIMENSION SS(6)
36043 C     DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
36044       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
36045 **sr uncommented since common block CAXIAL is now commented
36046       DATA AXIAL2 /1.03D0/  ! to be checked
36047 **
36048
36049       RML=P(4,5)
36050       RMM=0.93960D+00
36051       FM2 = RMM**2
36052       MPI = 0.135D+00
36053       OLDQ2=Q2
36054       FA0=-1.253D+00
36055       CSI = 3.71D+00                      !
36056       GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2   ! G_e(q**2)
36057       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
36058       X = Q2/(EMN*EMN)     ! emn=massa barione
36059       XA = X/4.D0
36060       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
36061       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
36062       FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
36063       FFA = FA*FA
36064       FFV1 = FV1*FV1
36065       FFV2 = FV2*FV2
36066       FP=2.D0*FA*RMM/(MPI**2 + Q2)
36067       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
36068       A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
36069       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
36070       AA = (XA+0.25D+00*RM)*(A1 + A2)
36071       BB = -X*FA*(FV1 + FV2)
36072       CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
36073       SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
36074
36075       OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2   )  ! articolo di ll...-smith
36076       OMEGA2=4.D+00*CC
36077       OMEGA3=2.D+00*FA*(FV1+FV2)
36078       OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
36079      1     (Q2/FM2))*FP**2)
36080       OMEGA5=OMEGA2
36081       OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
36082       WW1=2.D+00*OMEGA1*EMN**2
36083       WW2=2.D+00*OMEGA2*EMN**2
36084       WW3=2.D+00*OMEGA3*EMN**2
36085       WW4=2.D+00*OMEGA4*EMN**2
36086       WW5=2.D+00*OMEGA5*EMN**2
36087
36088       DO I=1,3
36089         BB2(I)=-P(4,I)/P(4,4)
36090       END DO
36091 c      WRITE(*,*)
36092 c      WRITE(*,*)
36093 c      WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
36094       N=5
36095       CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
36096 * NOW PARTICLES ARE IN THE SCATTERED LEPTON  REST FRAME
36097 c      WRITE(*,*)
36098 c      WRITE(*,*)
36099 c      WRITE(*,*) 'Prepola: now in lepton rest frame'
36100       EE=ENU
36101       QM2=Q2+RML**2
36102       U=Q2/(2.*RMM)
36103       FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
36104      +     (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
36105      +     ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
36106
36107       FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
36108      +     - ((RML**2)/FM2)*WW4                        !<=FM2 inv di RMM!!
36109
36110       FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
36111
36112       DO I=1,3
36113         POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
36114         POLARX(I)=POL(4,I)
36115       END DO
36116
36117       PMODUL=0.D0
36118       DO I=1,3
36119         PMODUL=PMODUL+POL(4,I)**2
36120       END DO
36121
36122       IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
36123          IF(NEUDEC.EQ.1) THEN
36124             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
36125      +        ETL,PXL,PYL,PZL,
36126      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36127 c
36128 c     Tau has decayed in muon
36129 c
36130          ENDIF
36131          IF(NEUDEC.EQ.2) THEN
36132             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
36133      +        ETL,PXL,PYL,PZL,
36134      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36135 c
36136 c     Tau has decayed in electron
36137 c
36138          ENDIF
36139          K(4,1)=15
36140          K(4,4) = 6
36141          K(4,5) = 8
36142          N=N+3
36143 c
36144 c     fill common for muon(electron)
36145 c
36146          P(6,1)=PXL
36147          P(6,2)=PYL
36148          P(6,3)=PZL
36149          P(6,4)=ETL
36150          K(6,1)=1
36151          IF(JTYP.EQ.5) THEN
36152             IF(NEUDEC.EQ.1) THEN
36153                P(6,5)=EML(JTYP-2)
36154                K(6,2)=13
36155             ELSEIF(NEUDEC.EQ.2) THEN
36156                P(6,5)=EML(JTYP-4)
36157                K(6,2)=11
36158             ENDIF
36159          ELSEIF(JTYP.EQ.6) THEN
36160             IF(NEUDEC.EQ.1) THEN
36161                K(6,2)=-13
36162             ELSEIF(NEUDEC.EQ.2) THEN
36163                K(6,2)=-11
36164             ENDIF
36165          END IF
36166          K(6,3)=4
36167          K(6,4)=0
36168          K(6,5)=0
36169 c
36170 c     fill common for tau_(anti)neutrino
36171 c
36172          P(7,1)=PXB
36173          P(7,2)=PYB
36174          P(7,3)=PZB
36175          P(7,4)=ETB
36176          P(7,5)=0.
36177          K(7,1)=1
36178          IF(JTYP.EQ.5) THEN
36179             K(7,2)=16
36180          ELSEIF(JTYP.EQ.6) THEN
36181             K(7,2)=-16
36182          END IF
36183          K(7,3)=4
36184          K(7,4)=0
36185          K(7,5)=0
36186 c
36187 c     Fill common for muon(electron)_(anti)neutrino
36188 c
36189          P(8,1)=PXN
36190          P(8,2)=PYN
36191          P(8,3)=PZN
36192          P(8,4)=ETN
36193          P(8,5)=0.
36194          K(8,1)=1
36195          IF(JTYP.EQ.5) THEN
36196             IF(NEUDEC.EQ.1) THEN
36197                K(8,2)=-14
36198             ELSEIF(NEUDEC.EQ.2) THEN
36199                K(8,2)=-12
36200             ENDIF
36201          ELSEIF(JTYP.EQ.6) THEN
36202             IF(NEUDEC.EQ.1) THEN
36203                K(8,2)=14
36204             ELSEIF(NEUDEC.EQ.2) THEN
36205                K(8,2)=12
36206             ENDIF
36207          END IF
36208          K(8,3)=4
36209          K(8,4)=0
36210          K(8,5)=0
36211       ENDIF
36212 c      WRITE(*,*)
36213 c      WRITE(*,*)
36214
36215 c      IF(PMODUL.GE.1.D+00) THEN
36216 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36217 c        write(*,*) pmodul
36218 c        DO I=1,3
36219 c          POL(4,I)=POL(4,I)/PMODUL
36220 c          POLARX(I)=POL(4,I)
36221 c        END DO
36222 c        PMODUL=0.
36223 c        DO I=1,3
36224 c          PMODUL=PMODUL+POL(4,I)**2
36225 c        END DO
36226 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36227 c
36228 c      ENDIF
36229
36230 c      WRITE(*,*) 'PMODUL = ',PMODUL
36231
36232 c      WRITE(*,*)
36233 c      WRITE(*,*)
36234 c      WRITE(*,*) 'prepola: Now back to nucl rest frame'
36235       CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
36236
36237       XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
36238       YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
36239       ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
36240       DO NDC =6,8
36241          V(NDC,1) = XDC
36242          V(NDC,2) = YDC
36243          V(NDC,3) = ZDC
36244       END DO
36245
36246       RETURN
36247       END
36248
36249 *$ CREATE DT_TESTROT.FOR
36250 *COPY DT_TESTROT
36251 *
36252 *===testrot============================================================*
36253 *
36254       SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
36255
36256       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36257       SAVE
36258
36259       DIMENSION ROT(3,3),PI(3),PO(3)
36260
36261       IF (MODE.EQ.1) THEN
36262          ROT(1,1) = 1.D0
36263          ROT(1,2) = 0.D0
36264          ROT(1,3) = 0.D0
36265          ROT(2,1) = 0.D0
36266          ROT(2,2) = COS(PHI)
36267          ROT(2,3) = -SIN(PHI)
36268          ROT(3,1) = 0.D0
36269          ROT(3,2) = SIN(PHI)
36270          ROT(3,3) = COS(PHI)
36271       ELSEIF (MODE.EQ.2) THEN
36272          ROT(1,1) = 0.D0
36273          ROT(1,2) = 1.D0
36274          ROT(1,3) = 0.D0
36275          ROT(2,1) = COS(PHI)
36276          ROT(2,2) = 0.D0
36277          ROT(2,3) = -SIN(PHI)
36278          ROT(3,1) = SIN(PHI)
36279          ROT(3,2) = 0.D0
36280          ROT(3,3) = COS(PHI)
36281       ELSEIF (MODE.EQ.3) THEN
36282          ROT(1,1) = 0.D0
36283          ROT(2,1) = 1.D0
36284          ROT(3,1) = 0.D0
36285          ROT(1,2) = COS(PHI)
36286          ROT(2,2) = 0.D0
36287          ROT(3,2) = -SIN(PHI)
36288          ROT(1,3) = SIN(PHI)
36289          ROT(2,3) = 0.D0
36290          ROT(3,3) = COS(PHI)
36291       ELSEIF (MODE.EQ.4) THEN
36292          ROT(1,1) = 1.D0
36293          ROT(2,1) = 0.D0
36294          ROT(3,1) = 0.D0
36295          ROT(1,2) = 0.D0
36296          ROT(2,2) = COS(PHI)
36297          ROT(3,2) = -SIN(PHI)
36298          ROT(1,3) = 0.D0
36299          ROT(2,3) = SIN(PHI)
36300          ROT(3,3) = COS(PHI)
36301       ELSE
36302          STOP ' TESTROT: mode not supported!'
36303       ENDIF
36304       DO 1 J=1,3
36305         PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
36306     1 CONTINUE
36307
36308       RETURN
36309       END
36310
36311 *$ CREATE DT_LEPDCYP.FOR
36312 *COPY DT_LEPDCYP
36313 *
36314 *===lepdcyp============================================================*
36315 *
36316       SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
36317      &                      ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36318 C
36319 C-----------------------------------------------------------------
36320 C
36321 C   Author   :- G. Battistoni         10-NOV-1995
36322 C
36323 C=================================================================
36324 C
36325 C   Purpose   : performs decay of polarized lepton in
36326 C               its rest frame: a => b + l + anti-nu
36327 C               (Example: mu- => nu-mu + e- + anti-nu-e)
36328 C               Polarization is assumed along Z-axis
36329 C               WARNING:
36330 C               1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
36331 C                  OF NEGLIGIBLE MASS
36332 C               2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
36333 C                  IN THIS VERSION
36334 C
36335 C   Method    : modifies phase space distribution obtained
36336 C               by routine EXPLOD using a rejection against the
36337 C               matrix element for unpolarized lepton decay
36338 C
36339 C   Inputs    : Mass of a :  AMA
36340 C               Mass of l :  AML
36341 C               Polar. of a: POL
36342 C               (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
36343 C                                                 POL = -1)
36344 C
36345 C   Outputs   : kinematic variables in the rest frame of decaying lepton
36346 C               ETL,PXL,PYL,PZL 4-moment of l
36347 C               ETB,PXB,PYB,PZB 4-moment of b
36348 C               ETN,PXN,PYN,PZN 4-moment of anti-nu
36349 C
36350 C============================================================
36351 C +
36352 C Declarations.
36353 C -
36354       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36355       SAVE
36356
36357       PARAMETER ( LINP = 10 ,
36358      &            LOUT = 6 ,
36359      &            LDAT = 9 )
36360       PARAMETER ( KALGNM = 2 )
36361       PARAMETER ( ANGLGB = 5.0D-16 )
36362       PARAMETER ( ANGLSQ = 2.5D-31 )
36363       PARAMETER ( AXCSSV = 0.2D+16 )
36364       PARAMETER ( ANDRFL = 1.0D-38 )
36365       PARAMETER ( AVRFLW = 1.0D+38 )
36366       PARAMETER ( AINFNT = 1.0D+30 )
36367       PARAMETER ( AZRZRZ = 1.0D-30 )
36368       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
36369       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
36370       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
36371       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
36372       PARAMETER ( CSNNRM = 2.0D-15 )
36373       PARAMETER ( DMXTRN = 1.0D+08 )
36374       PARAMETER ( ZERZER = 0.D+00 )
36375       PARAMETER ( ONEONE = 1.D+00 )
36376       PARAMETER ( TWOTWO = 2.D+00 )
36377       PARAMETER ( THRTHR = 3.D+00 )
36378       PARAMETER ( FOUFOU = 4.D+00 )
36379       PARAMETER ( FIVFIV = 5.D+00 )
36380       PARAMETER ( SIXSIX = 6.D+00 )
36381       PARAMETER ( SEVSEV = 7.D+00 )
36382       PARAMETER ( EIGEIG = 8.D+00 )
36383       PARAMETER ( ANINEN = 9.D+00 )
36384       PARAMETER ( TENTEN = 10.D+00 )
36385       PARAMETER ( HLFHLF = 0.5D+00 )
36386       PARAMETER ( ONETHI = ONEONE / THRTHR )
36387       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
36388       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
36389       PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
36390       PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
36391       PARAMETER ( CLIGHT = 2.99792458         D+10 )
36392       PARAMETER ( AVOGAD = 6.0221367          D+23 )
36393       PARAMETER ( AMELGR = 9.1093897          D-28 )
36394       PARAMETER ( PLCKBR = 1.05457266         D-27 )
36395       PARAMETER ( ELCCGS = 4.8032068          D-10 )
36396       PARAMETER ( ELCMKS = 1.60217733         D-19 )
36397       PARAMETER ( AMUGRM = 1.6605402          D-24 )
36398       PARAMETER ( AMMUMU = 0.113428913        D+00 )
36399       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
36400       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
36401       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
36402       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
36403       PARAMETER ( PLABRC = 0.197327053        D+00 )
36404       PARAMETER ( AMELCT = 0.51099906         D-03 )
36405       PARAMETER ( AMUGEV = 0.93149432         D+00 )
36406       PARAMETER ( AMMUON = 0.105658389        D+00 )
36407       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
36408       PARAMETER ( GEVMEV = 1.0                D+03 )
36409       PARAMETER ( EMVGEV = 1.0                D-03 )
36410       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
36411       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
36412       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
36413 C +
36414 C    variables for EXPLOD
36415 C -
36416       PARAMETER ( KPMX = 10 )
36417       DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
36418      &          PZEXPL (KPMX), ETEXPL (KPMX)
36419 C +
36420 C      test variables
36421 C -
36422 **sr - removed (not needed)
36423 C     COMMON /GBATNU/ ELERAT,NTRY
36424 **
36425 C +
36426 C     Initializes test variables
36427 C -
36428       NTRY = 0
36429       ELERAT = 0.D+00
36430 C +
36431 C     Maximum value for matrix element
36432 C -
36433       ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
36434      &  SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
36435 C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
36436 C     Inputs for EXPLOD
36437 C part. no. 1 is l       (e- in mu- decay)
36438 C part. no. 2 is b       (nu-mu in mu- decay)
36439 C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
36440 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
36441       NPEXPL = 3
36442       ETOTEX = AMA
36443       AMEXPL(1) = AML
36444       AMEXPL(2) = 0.D+00
36445       AMEXPL(3) = 0.D+00
36446 C +
36447 C     phase space distribution
36448 C -
36449   100 CONTINUE
36450       NTRY = NTRY + 1
36451
36452       CALL DT_EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
36453      &                 PYEXPL, PZEXPL )
36454
36455 C +
36456 C  Calculates matrix element:
36457 C  64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
36458 C  Here CTH is the cosine of the angle between anti-nu and Z axis
36459 C -
36460       CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
36461      &  PZEXPL(3)**2 )
36462       PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
36463       PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
36464      &     PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
36465       ELEMAT = 16.D+00 * PROD1 * PROD2
36466       IF(ELEMAT.GT.ELEMAX) THEN
36467         WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
36468         STOP
36469       ENDIF
36470 C +
36471 C     Here performs the rejection
36472 C -
36473       TEST = DT_RNDM(ETOTEX) * ELEMAX
36474       IF ( TEST .GT. ELEMAT ) GO TO 100
36475 C +
36476 C     final assignment of variables
36477 C -
36478       ELERAT = ELEMAT/ELEMAX
36479       ETL = ETEXPL(1)
36480       PXL = PXEXPL(1)
36481       PYL = PYEXPL(1)
36482       PZL = PZEXPL(1)
36483       ETB = ETEXPL(2)
36484       PXB = PXEXPL(2)
36485       PYB = PYEXPL(2)
36486       PZB = PZEXPL(2)
36487       ETN = ETEXPL(3)
36488       PXN = PXEXPL(3)
36489       PYN = PYEXPL(3)
36490       PZN = PZEXPL(3)
36491   999 RETURN
36492       END
36493
36494 *$ CREATE DT_GEN_DELTA.FOR
36495 *COPY DT_GEN_DELTA
36496 C==================================================================
36497 C.  Generation of  Delta resonance events
36498 C==================================================================
36499 *
36500 *===gen_delta==========================================================*
36501 *
36502       SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
36503
36504       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36505       SAVE
36506
36507       PARAMETER ( LINP = 10 ,
36508      &            LOUT = 6 ,
36509      &            LDAT = 9 )
36510 C...Generate a Delta-production neutrino/antineutrino
36511 C.  CC-interaction on a nucleon
36512 C
36513 C.  INPUT  ENU (GeV) = Neutrino Energy
36514 C.         LLEP = neutrino type
36515 C.         LTARG = nucleon target type 1=p, 2=n.
36516 C.         JINT = 1:CC, 2::NC
36517 C.
36518 C.  OUTPUT PPL(4)  4-monentum of final lepton
36519 C----------------------------------------------------
36520       PARAMETER (MAXLND=4000)
36521       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36522 **sr - removed (not needed)
36523 C     COMMON /CBAD/  LBAD, NBAD
36524 **
36525
36526       DIMENSION PI(3),PO(3)
36527 C     REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
36528       DIMENSION AML0(6),AMN(2)
36529       DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
36530       DATA AMN  /0.93827231, 0.93956563/
36531       DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
36532
36533 c     WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
36534       LBAD = 0
36535 C...Final lepton mass
36536       IF (JINT.EQ.1) THEN
36537         AML = AML0(LLEP)
36538       ELSE
36539         AML = 0.
36540       ENDIF
36541       AML2 = AML**2
36542
36543 C...Particle labels (LUND)
36544       N = 5
36545       K(1,1) = 21
36546       K(2,1) = 21
36547       K(3,1) = 21
36548       K(4,1) = 1
36549       K(3,3) = 1
36550       K(4,3) = 1
36551       IF (LTARG .EQ. 1)  THEN
36552          K(2,2) = 2212
36553       ELSE
36554          K(2,2) = 2112
36555       ENDIF
36556       K0 = (LLEP-1)/2
36557       K1 = LLEP/2
36558       KA = 12 + 2*K0
36559       IS = -1 + 2*LLEP - 4*K1
36560       LNU = 2 - LLEP + 2*K1
36561       K(1,2) = IS*KA
36562       K(5,1) = 1
36563       K(5,3) = 2
36564       IF (JINT .EQ. 1)  THEN                    ! CC interactions
36565          K(3,2) = IS*24
36566          K(4,2) = IS*(KA-1)
36567         IF(LNU.EQ.1) THEN
36568           IF (LTARG .EQ. 1)  THEN
36569               K(5,2) = 2224
36570           ELSE
36571               K(5,2) = 2214
36572           ENDIF
36573         ELSE
36574           IF (LTARG .EQ. 1)  THEN
36575               K(5,2) = 2114
36576           ELSE
36577               K(5,2) = 1114
36578           ENDIF
36579         ENDIF
36580       ELSE
36581          K(3,2) = 23                           ! NC (Z0) interactions
36582          K(4,2) = K(1,2)
36583 **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
36584 *                                Delta0 for neutron (LTARG=2)
36585 C        IF (LTARG .EQ. 1)  THEN
36586 C           K(5,2) = 2114
36587 C        ELSE
36588 C           K(5,2) = 2214
36589 C        ENDIF
36590          IF (LTARG .EQ. 1)  THEN
36591             K(5,2) = 2214
36592          ELSE
36593             K(5,2) = 2114
36594          ENDIF
36595 **
36596       ENDIF
36597
36598 C...4-momentum initial lepton
36599       P(1,5) = 0.
36600       P(1,4) = ENU
36601       P(1,1) = 0.
36602       P(1,2) = 0.
36603       P(1,3) = ENU
36604 C...4-momentum initial nucleon
36605       P(2,5) = AMN(LTARG)
36606 C     P(2,4) = P(2,5)
36607 C     P(2,1) = 0.
36608 C     P(2,2) = 0.
36609 C     P(2,3) = 0.
36610        P(2,1) = P21
36611        P(2,2) = P22
36612        P(2,3) = P23
36613        P(2,4) = P24
36614        P(2,5) = P25
36615       N=2
36616       beta1=-p(2,1)/p(2,4)
36617       beta2=-p(2,2)/p(2,4)
36618       beta3=-p(2,3)/p(2,4)
36619       N=2
36620
36621       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
36622
36623 C     print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
36624
36625       phi11=atan(p(1,2)/p(1,3))
36626       pi(1)=p(1,1)
36627       pi(2)=p(1,2)
36628       pi(3)=p(1,3)
36629
36630       CALL DT_TESTROT(PI,Po,PHI11,1)
36631       DO ll=1,3
36632        IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36633       END DO
36634       p(1,1)=po(1)
36635       p(1,2)=po(2)
36636       p(1,3)=po(3)
36637       phi12=atan(p(1,1)/p(1,3))
36638
36639       pi(1)=p(1,1)
36640       pi(2)=p(1,2)
36641       pi(3)=p(1,3)
36642       CALL DT_TESTROT(Pi,Po,PHI12,2)
36643       DO ll=1,3
36644         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36645       END DO
36646       p(1,1)=po(1)
36647       p(1,2)=po(2)
36648       p(1,3)=po(3)
36649
36650       ENUU=P(1,4)
36651
36652 C...Generate the Mass of the Delta
36653       NTRY = 0
36654 100   R = PYR(0)
36655       AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
36656       NTRY = NTRY + 1
36657       IF (NTRY .GT. 1000)  THEN
36658          LBAD = 1
36659          WRITE (LOUT,1001)  NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
36660          RETURN
36661       ENDIF
36662       IF (AMD .LT. AMDMIN)  GOTO 100
36663       ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
36664       IF (ENUU .LT. ET) GOTO 100
36665
36666 C...Kinematical  limits in Q**2
36667       S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
36668       SQS = SQRT(S)
36669       PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
36670       ELF = (S - AMD**2 + AML2)/(2.*SQS)
36671       PLF = SQRT(ELF**2 - AML2)
36672       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
36673       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
36674       IF (Q2MIN .LT. 0.)   Q2MIN = 0.
36675
36676       DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
36677 200   Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
36678       DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
36679       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
36680
36681 C...Generate the kinematics of the final particles
36682       EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
36683       GAM = EISTAR/AMN(LTARG)
36684       BET = PSTAR/EISTAR
36685       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
36686       EL  = GAM*(ELF + BET*PLF*CTSTAR)
36687       PLZ = GAM*(PLF*CTSTAR + BET*ELF)
36688       PL  = SQRT(EL**2 - AML2)
36689       PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
36690       PHI = 6.28319*PYR(0)
36691       P(4,1) = PLT*COS(PHI)
36692       P(4,2) = PLT*SIN(PHI)
36693       P(4,3) = PLZ
36694       P(4,4) = EL
36695       P(4,5) = AML
36696
36697 C...4-momentum of Delta
36698       P(5,1) = -P(4,1)
36699       P(5,2) = -P(4,2)
36700       P(5,3) = ENUU-P(4,3)
36701       P(5,4) = ENUU+AMN(LTARG)-P(4,4)
36702       P(5,5) = AMD
36703
36704 C...4-momentum  of intermediate boson
36705       P(3,5) = -Q2
36706       P(3,4) = P(1,4)-P(4,4)
36707       P(3,1) = P(1,1)-P(4,1)
36708       P(3,2) = P(1,2)-P(4,2)
36709       P(3,3) = P(1,3)-P(4,3)
36710       N=5
36711
36712       DO kw=1,5
36713         pi(1)=p(kw,1)
36714         pi(2)=p(kw,2)
36715         pi(3)=p(kw,3)
36716         CALL DT_TESTROT(Pi,Po,PHI12,3)
36717         DO ll=1,3
36718           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36719         END DO
36720         p(kw,1)=po(1)
36721         p(kw,2)=po(2)
36722         p(kw,3)=po(3)
36723       END DO
36724
36725 c********************************************
36726
36727         DO kw=1,5
36728           pi(1)=p(kw,1)
36729           pi(2)=p(kw,2)
36730           pi(3)=p(kw,3)
36731           CALL DT_TESTROT(Pi,Po,PHI11,4)
36732           DO ll=1,3
36733             IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36734           END DO
36735           p(kw,1)=po(1)
36736           p(kw,2)=po(2)
36737           p(kw,3)=po(3)
36738        END DO
36739 c********************************************
36740 C         transform back into Lab.
36741
36742       CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
36743
36744 C     WRITE(6,*)' Lab fram ( fermi incl.) '
36745       N=5
36746       CALL PYEXEC
36747
36748       RETURN
36749 1001  FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5,  6G10.3)
36750       END
36751
36752 *$ CREATE DT_DSIGMA_DELTA.FOR
36753 *COPY DT_DSIGMA_DELTA
36754 *
36755 *===dsigma_delta=======================================================*
36756 *
36757       DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
36758
36759       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36760       SAVE
36761
36762 C...Reaction nu + N -> lepton + Delta
36763 C.  returns the  cross section
36764 C.  dsigma/dt
36765 C.  INPUT  LNU = 1, 2  (neutrino-antineutrino)
36766 C.         QQ = t (always negative)  GeV**2
36767 C.         S  = (c.m energy)**2      GeV**2
36768 C.  OUTPUT =  10**-38 cm+2/GeV**2
36769 C-----------------------------------------------------
36770       REAL*8 MN, MN2, MN4, MD,MD2, MD4
36771       DATA MN /0.938/
36772       DATA PI /3.1415926/
36773
36774       GF = (1.1664 * 1.97)
36775       GF2 = GF*GF
36776       MN2 = MN*MN
36777       MN4 = MN2*MN2
36778       MD2 = MD*MD
36779       MD4 = MD2*MD2
36780       AML2 = AML*AML
36781       AML4 = AML2*AML2
36782       VQ  = (MN2 - MD2 - QQ)/2.
36783       VPI = (MN2 + MD2 - QQ)/2.
36784       VK  = (S + QQ - MN2 - AML2)/2.
36785       PIK = (S - MN2)/2.
36786       QK = (AML2 - QQ)/2.
36787       PIQ = (QQ + MN2 - MD2)/2.
36788       Q = SQRT(-QQ)
36789       C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
36790       C3 = SQRT(3.)*C3V/MN
36791       C4 = -C3/MD             ! attenzione al segno
36792       C5A = 1.18/(1.-QQ/0.4225)**2
36793       C32 = C3**2
36794       C42 = C4**2
36795       C5A2 = C5A**2
36796
36797       IF (LNU .EQ. 1)  THEN
36798       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36799      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36800      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36801      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36802       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36803      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36804      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36805      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36806      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36807      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
36808      . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36809      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36810      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36811      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36812      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
36813      . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
36814      . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
36815      . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
36816      . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
36817      . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36818      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36819      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36820      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36821       ELSE
36822       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36823      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36824      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36825      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36826       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36827      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36828      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36829      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36830      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36831      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
36832      . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36833      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36834      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36835      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36836      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
36837      . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
36838      . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
36839      . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
36840      . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
36841      . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36842      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36843      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36844      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36845       ENDIF
36846       ANS1=32.*ANS2
36847       ANS=ANS1/(3.*MD2)
36848       P1CM = (S-MN2)/(2.*SQRT(S))
36849       DT_DSIGMA_DELTA  = GF2/2. * ANS/(64.*PI*S*P1CM**2)
36850
36851       RETURN
36852       END
36853
36854 *$ CREATE DT_QGAUS.FOR
36855 *COPY DT_QGAUS
36856 *
36857 *===qgaus==============================================================*
36858 *
36859       SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
36860
36861       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36862       SAVE
36863
36864       DIMENSION X(5),W(5)
36865       DATA X/.1488743389D0,.4333953941D0,
36866      & .6794095682D0,.8650633666D0,.9739065285D0
36867      */
36868       DATA W/.2955242247D0,.2692667193D0,
36869      & .2190863625D0,.1494513491D0,.0666713443D0
36870      */
36871       XM=0.5D0*(B+A)
36872       XR=0.5D0*(B-A)
36873       SS=0
36874       DO 11 J=1,5
36875         DX=XR*X(J)
36876         SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
36877      *  DT_DSQEL_Q2(LTYP,ENU,XM-DX))
36878 11    CONTINUE
36879       SS=XR*SS
36880
36881       RETURN
36882       END
36883
36884 *$ CREATE DT_DIQBRK.FOR
36885 *COPY DT_DIQBRK
36886 *
36887 *===diqbrk=============================================================*
36888 *
36889       SUBROUTINE DT_DIQBRK
36890
36891       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36892       SAVE
36893
36894 * event history
36895       PARAMETER (NMXHKK=200000)
36896       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36897      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36898      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36899 * extended event history
36900       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36901      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36902      &                IHIST(2,NMXHKK)
36903 * event flag
36904       COMMON /DTEVNO/ NEVENT,ICASCA
36905
36906 C     IF(DT_RNDM(VV).LE.0.5D0)THEN
36907 C       CALL GSQBS1(NHKK)
36908 C       CALL GSQBS2(NHKK)
36909 C       CALL USQBS1(NHKK)
36910 C       CALL USQBS2(NHKK)
36911 C       CALL GSABS1(NHKK)
36912 C       CALL GSABS2(NHKK)
36913 C       CALL USABS1(NHKK)
36914 C       CALL USABS2(NHKK)
36915 C     ELSE
36916 C       CALL GSQBS2(NHKK)
36917 C       CALL GSQBS1(NHKK)
36918 C       CALL USQBS2(NHKK)
36919 C       CALL USQBS1(NHKK)
36920 C       CALL GSABS2(NHKK)
36921 C       CALL GSABS1(NHKK)
36922 C       CALL USABS2(NHKK)
36923 C       CALL USABS1(NHKK)
36924 C     ENDIF
36925
36926       IF(DT_RNDM(VV).LE.0.5D0) THEN
36927         CALL DT_DBREAK(1)
36928         CALL DT_DBREAK(2)
36929         CALL DT_DBREAK(3)
36930         CALL DT_DBREAK(4)
36931         CALL DT_DBREAK(5)
36932         CALL DT_DBREAK(6)
36933         CALL DT_DBREAK(7)
36934         CALL DT_DBREAK(8)
36935       ELSE
36936         CALL DT_DBREAK(2)
36937         CALL DT_DBREAK(1)
36938         CALL DT_DBREAK(4)
36939         CALL DT_DBREAK(3)
36940         CALL DT_DBREAK(6)
36941         CALL DT_DBREAK(5)
36942         CALL DT_DBREAK(8)
36943         CALL DT_DBREAK(7)
36944       ENDIF
36945
36946       RETURN
36947       END
36948
36949 *$ CREATE MUSQBS2.FOR
36950 *COPY MUSQBS2
36951 C
36952 C
36953 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36954       SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36955      *              IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
36956 C
36957 C                  USQBS-2 diagram (split target diquark)
36958 C
36959       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36960       SAVE
36961
36962       PARAMETER ( LINP = 10 ,
36963      &            LOUT = 6 ,
36964      &            LDAT = 9 )
36965 * event history
36966       PARAMETER (NMXHKK=200000)
36967       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36968      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36969      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36970 * extended event history
36971       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36972      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36973      &                IHIST(2,NMXHKK)
36974 * Lorentz-parameters of the current interaction
36975       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
36976      &                UMO,PPCM,EPROJ,PPROJ
36977 * diquark-breaking mechanism
36978       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36979
36980 C
36981       PARAMETER (NTMHKK= 300)
36982       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36983      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36984      +(4,NTMHKK)
36985 *KEEP,XSEADI.
36986       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
36987      +SSMIMQ,VVMTHR
36988 *KEEP,DPRIN.
36989       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
36990       COMMON /EVFLAG/ NUMEV
36991 C
36992 C                  USQBS-2 diagram (split target diquark)
36993 C
36994 C
36995 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
36996 C     Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
36997 C
36998 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
36999 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37000 C
37001 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37002 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37003 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37004 C
37005 C
37006 C       Put new chains into COMMON /HKKTMP/
37007 C
37008       IIGLU1=NC1T-NC1P-1
37009       IIGLU2=NC2T-NC2P-1
37010       IGCOUN=0
37011 C     WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37012       CVQ=1.D0
37013       IREJ=0
37014       IF(IPIP.EQ.2)THEN
37015 C     IF(NUMEV.EQ.-324)THEN
37016 C     WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37017 C    *             'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
37018 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37019 C    *              IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
37020       ENDIF
37021 C
37022 C
37023 C
37024 C     determine x-values of NC1T diquark
37025       XDIQT=PHKK(4,NC1T)*2.D0/UMO
37026       XVQP=PHKK(4,NC1P)*2.D0/UMO
37027 C
37028 C     determine x-values of sea quark pair
37029 C
37030       IPCO=1
37031       ICOU=0
37032  2234 CONTINUE
37033       ICOU=ICOU+1
37034       IF(ICOU.GE.500)THEN
37035         IREJ=1
37036         IF(ISQ.EQ.3)IREJ=3
37037         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
37038         IPCO=0
37039         RETURN
37040       ENDIF
37041       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
37042      * UMO, XDIQT,XVQP
37043       XSQ=0.D0
37044       XSAQ=0.D0
37045 **NEW
37046 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37047       IF (IPIP.EQ.1) THEN
37048          XQMAX  = XDIQT/2.0D0
37049          XAQMAX = 2.D0*XVQP/3.0D0
37050       ELSE
37051          XQMAX  = 2.D0*XVQP/3.0D0
37052          XAQMAX = XDIQT/2.0D0
37053       ENDIF
37054       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37055       ISAQ = 6+ISQ
37056 C     write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37057 **
37058         IF(IPCO.GE.3)
37059      &     WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37060       IF(IREJ.GE.1)THEN
37061         IF(IPCO.GE.3)
37062      &     WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37063         IPCO=0
37064         RETURN
37065       ENDIF
37066       IF(IPIP.EQ.1)THEN
37067         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37068       ELSEIF(IPIP.EQ.2)THEN
37069         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37070       ENDIF
37071       IF(IPCO.GE.3)THEN
37072         WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37073      *  XDIQT,XVQP,XSQ,XSAQ
37074       ENDIF
37075 C
37076 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
37077 C
37078 C     XSQ=0.D0
37079       IF(IPIP.EQ.1)THEN
37080         XDIQT=XDIQT-XSQ
37081         XVQP =XVQP -XSAQ
37082       ELSEIF(IPIP.EQ.2)THEN
37083         XDIQT=XDIQT-XSAQ
37084         XVQP =XVQP -XSQ
37085       ENDIF
37086       IF(IPCO.GE.3)
37087      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37088 C
37089 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37090 C
37091       XVTHRO=CVQ/UMO
37092       IVTHR=0
37093  3466 CONTINUE
37094       IF(IVTHR.EQ.10)THEN
37095         IREJ=1
37096         IF(ISQ.EQ.3)IREJ=3
37097         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
37098       IPCO=0
37099         RETURN
37100       ENDIF
37101       IVTHR=IVTHR+1
37102       XVTHR=XVTHRO/(201-IVTHR)
37103       UNOPRV=UNON
37104  380  CONTINUE
37105       IF(XVTHR.GT.0.66D0*XDIQT)THEN
37106         IREJ=1
37107         IF(ISQ.EQ.3)IREJ=3
37108         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR  large ',
37109      *  XVTHR
37110       IPCO=0
37111         RETURN
37112       ENDIF
37113       IF(DT_RNDM(V).LT.0.5D0)THEN
37114         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37115         XVTQII=XDIQT-XVTQI
37116       ELSE
37117         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37118         XVTQI=XDIQT-XVTQII
37119       ENDIF
37120       IF(IPCO.GE.3)THEN
37121         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37122       ENDIF
37123 C
37124 C     Prepare 4 momenta of new chains and chain ends
37125 C
37126 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37127 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37128 C    +(4,NTMHKK)
37129 C
37130 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37131 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37132 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37133 C
37134 C     SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37135 C    *              IP1,IP21,IP22,IPP1,IPP2)
37136 C
37137       IF(IPIP.EQ.1)THEN
37138         XSQ1=XSQ
37139         XSAQ1=XSAQ
37140         ISQ1=ISQ
37141         ISAQ1=ISAQ
37142       ELSEIF(IPIP.EQ.2)THEN
37143         XSQ1=XSAQ
37144         XSAQ1=XSQ
37145         ISQ1=ISAQ
37146         ISAQ1=ISQ
37147       ENDIF
37148       IDHKT(1)   =IPP1
37149       ISTHKT(1)  =951
37150       JMOHKT(1,1)=NC2P
37151       JMOHKT(2,1)=0
37152       JDAHKT(1,1)=3+IIGLU1
37153       JDAHKT(2,1)=0
37154 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37155       PHKT(1,1)  =PHKK(1,NC2P)
37156       PHKT(2,1)  =PHKK(2,NC2P)
37157       PHKT(3,1)  =PHKK(3,NC2P)
37158       PHKT(4,1)  =PHKK(4,NC2P)
37159 C     PHKT(5,1)  =PHKK(5,NC2P)
37160       XMIST  =(PHKT(4,1)**2-
37161      * PHKT(3,1)**2-PHKT(2,1)**2-
37162      *PHKT(1,1)**2)
37163       IF(XMIST.GT.0.D0)THEN
37164       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37165      *PHKT(1,1)**2)
37166       ELSE
37167 C     WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
37168       PHKT(5,1)=0.D0
37169       ENDIF
37170       VHKT(1,1)  =VHKK(1,NC2P)
37171       VHKT(2,1)  =VHKK(2,NC2P)
37172       VHKT(3,1)  =VHKK(3,NC2P)
37173       VHKT(4,1)  =VHKK(4,NC2P)
37174       WHKT(1,1)  =WHKK(1,NC2P)
37175       WHKT(2,1)  =WHKK(2,NC2P)
37176       WHKT(3,1)  =WHKK(3,NC2P)
37177       WHKT(4,1)  =WHKK(4,NC2P)
37178 C     Add here IIGLU1 gluons to this chaina
37179       PG1=0.D0
37180       PG2=0.D0
37181       PG3=0.D0
37182       PG4=0.D0
37183       IF(IIGLU1.GE.1)THEN
37184       JJG=NC1P
37185       DO 61 IIG=2,2+IIGLU1-1
37186         KKG=JJG+IIG-1
37187         IDHKT(IIG)   =IDHKK(KKG)
37188         ISTHKT(IIG)  =921
37189         JMOHKT(1,IIG)=KKG
37190         JMOHKT(2,IIG)=0
37191         JDAHKT(1,IIG)=3+IIGLU1
37192         JDAHKT(2,IIG)=0
37193         PHKT(1,IIG)=PHKK(1,KKG)
37194         PG1=PG1+ PHKT(1,IIG)
37195         PHKT(2,IIG)=PHKK(2,KKG)
37196         PG2=PG2+ PHKT(2,IIG)
37197         PHKT(3,IIG)=PHKK(3,KKG)
37198         PG3=PG3+ PHKT(3,IIG)
37199         PHKT(4,IIG)=PHKK(4,KKG)
37200         PG4=PG4+ PHKT(4,IIG)
37201         PHKT(5,IIG)=PHKK(5,KKG)
37202         VHKT(1,IIG)  =VHKK(1,KKG)
37203         VHKT(2,IIG)  =VHKK(2,KKG)
37204         VHKT(3,IIG)  =VHKK(3,KKG)
37205         VHKT(4,IIG)  =VHKK(4,KKG)
37206         WHKT(1,IIG) =WHKK(1,KKG)
37207         WHKT(2,IIG) =WHKK(2,KKG)
37208         WHKT(3,IIG) =WHKK(3,KKG)
37209         WHKT(4,IIG) =WHKK(4,KKG)
37210    61 CONTINUE
37211       ENDIF
37212       IDHKT(2+IIGLU1)   =IP21
37213       ISTHKT(2+IIGLU1)  =952
37214       JMOHKT(1,2+IIGLU1)=NC1T
37215       JMOHKT(2,2+IIGLU1)=0
37216       JDAHKT(1,2+IIGLU1)=3+IIGLU1
37217       JDAHKT(2,2+IIGLU1)=0
37218       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
37219       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
37220       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
37221       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
37222 C     PHKT(5,2)  =PHKK(5,NC1T)
37223       XMIST  =(PHKT(4,2+IIGLU1)**2-
37224      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37225      *PHKT(1,2+IIGLU1)**2)
37226       IF(XMIST.GT.0.D0)THEN
37227       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
37228      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37229      *PHKT(1,2+IIGLU1)**2)
37230       ELSE
37231 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37232         PHKT(5,5+IIGLU1)=0.D0
37233       ENDIF
37234       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
37235       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
37236       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
37237       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
37238       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
37239       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
37240       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
37241       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
37242       IDHKT(3+IIGLU1)   =88888
37243       ISTHKT(3+IIGLU1)  =95
37244       JMOHKT(1,3+IIGLU1)=1
37245       JMOHKT(2,3+IIGLU1)=2+IIGLU1
37246       JDAHKT(1,3+IIGLU1)=0
37247       JDAHKT(2,3+IIGLU1)=0
37248       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37249       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37250       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37251       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37252       XMIST
37253      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37254      *            -PHKT(3,3+IIGLU1)**2)
37255       IF(XMIST.GT.0.D0)THEN
37256       PHKT(5,3+IIGLU1)
37257      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37258      *            -PHKT(3,3+IIGLU1)**2)
37259       ELSE
37260 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37261         PHKT(5,5+IIGLU1)=0.D0
37262       ENDIF
37263       IF(IPIP.GE.2)THEN
37264 C     IF(NUMEV.EQ.-324)THEN
37265 C     WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
37266 C    * JDAHKT(1,1),
37267 C    *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37268       DO 71 IIG=2,2+IIGLU1-1
37269 C     WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37270 C    &             JMOHKT(1,IIG),JMOHKT(2,IIG),
37271 C    * JDAHKT(1,IIG),
37272 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37273    71 CONTINUE
37274 C     WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37275 C    * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37276 C    *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37277 C     WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37278 C    * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37279 C    *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37280       ENDIF
37281       CHAMAL=CHAM1
37282       IF(IPIP.EQ.1)THEN
37283         IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
37284       ELSEIF(IPIP.EQ.2)THEN
37285         IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
37286       ENDIF
37287       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37288 C       IREJ=1
37289         IPCO=0
37290 C       RETURN
37291 C       WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
37292         GO TO 3466
37293       ENDIF
37294       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
37295       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
37296       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
37297       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
37298       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
37299       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
37300       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
37301       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
37302       IF(IPIP.EQ.1)THEN
37303         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
37304       ELSEIF(IPIP.EQ.2)THEN
37305         IDHKT(4+IIGLU1)   =ISAQ1
37306       ENDIF
37307       ISTHKT(4+IIGLU1)  =951
37308       JMOHKT(1,4+IIGLU1)=NC1P
37309       JMOHKT(2,4+IIGLU1)=0
37310       JDAHKT(1,4+IIGLU1)=6+IIGLU1
37311       JDAHKT(2,4+IIGLU1)=0
37312 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37313       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37314       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37315       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37316       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37317 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
37318       XMIST  =(PHKT(4,4+IIGLU1)**2-
37319      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37320      *PHKT(1,4+IIGLU1)**2)
37321       IF(XMIST.GT.0.D0)THEN
37322       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
37323      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37324      *PHKT(1,4+IIGLU1)**2)
37325       ELSE
37326 C     WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
37327       PHKT(5,4+IIGLU1)=0.D0
37328       ENDIF
37329       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
37330       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
37331       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
37332       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
37333       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
37334       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
37335       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
37336       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
37337       IDHKT(5+IIGLU1)   =IP22
37338       ISTHKT(5+IIGLU1)  =952
37339       JMOHKT(1,5+IIGLU1)=NC1T
37340       JMOHKT(2,5+IIGLU1)=0
37341       JDAHKT(1,5+IIGLU1)=6+IIGLU1
37342       JDAHKT(2,5+IIGLU1)=0
37343       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37344       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37345       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37346       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37347 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
37348       XMIST  =(PHKT(4,5+IIGLU1)**2-
37349      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37350      *PHKT(1,5+IIGLU1)**2)
37351       IF(XMIST.GT.0.D0)THEN
37352       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
37353      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37354      *PHKT(1,5+IIGLU1)**2)
37355       ELSE
37356 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37357         PHKT(5,5+IIGLU1)=0.D0
37358       ENDIF
37359       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
37360       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
37361       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
37362       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
37363       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
37364       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
37365       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
37366       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
37367       IDHKT(6+IIGLU1)   =88888
37368       ISTHKT(6+IIGLU1)  =95
37369       JMOHKT(1,6+IIGLU1)=4+IIGLU1
37370       JMOHKT(2,6+IIGLU1)=5+IIGLU1
37371       JDAHKT(1,6+IIGLU1)=0
37372       JDAHKT(2,6+IIGLU1)=0
37373       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37374       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37375       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37376       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37377       XMIST
37378      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37379      *            -PHKT(3,6+IIGLU1)**2)
37380       IF(XMIST.GT.0.D0)THEN
37381       PHKT(5,6+IIGLU1)
37382      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37383      *            -PHKT(3,6+IIGLU1)**2)
37384       ELSE
37385 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37386         PHKT(5,5+IIGLU1)=0.D0
37387       ENDIF
37388 C     IF(IPIP.GE.2)THEN
37389 C     IF(NUMEV.EQ.-324)THEN
37390 C     WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37391 C    * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37392 C    *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37393 C     WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37394 C    * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37395 C    *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37396 C     WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37397 C    * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37398 C    *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37399 C     ENDIF
37400       CHAMAL=CHAM1
37401       IF(IPIP.EQ.1)THEN
37402         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37403       ELSEIF(IPIP.EQ.2)THEN
37404         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37405       ENDIF
37406       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37407 C       IREJ=1
37408         IPCO=0
37409 C       RETURN
37410 C       WRITE(6,*)' MUSQBS1 jump back from chain 6',
37411 C    *  CHAMAL,PHKT(5,6+IIGLU1)
37412         GO TO 3466
37413       ENDIF
37414       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
37415       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
37416       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
37417       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
37418       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
37419       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
37420       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
37421       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
37422 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
37423       IDHKT(7+IIGLU1)   =IP1
37424       ISTHKT(7+IIGLU1)  =951
37425       JMOHKT(1,7+IIGLU1)=NC1P
37426       JMOHKT(2,7+IIGLU1)=0
37427 **NEW
37428 C     JDAHKT(1,7+IIGLU1)=9+IIGLU1
37429       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37430 **
37431       JDAHKT(2,7+IIGLU1)=0
37432       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
37433       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
37434       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
37435       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
37436 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
37437       XMIST  =(PHKT(4,7+IIGLU1)**2-
37438      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37439      *PHKT(1,7+IIGLU1)**2)
37440       IF(XMIST.GT.0.D0)THEN
37441       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
37442      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37443      *PHKT(1,7+IIGLU1)**2)
37444       ELSE
37445 C     WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
37446       PHKT(5,7+IIGLU1)=0.D0
37447       ENDIF
37448       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
37449       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
37450       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
37451       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
37452       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
37453       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
37454       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
37455       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
37456 C     Insert here the IIGLU2 gluons
37457       PG1=0.D0
37458       PG2=0.D0
37459       PG3=0.D0
37460       PG4=0.D0
37461       IF(IIGLU2.GE.1)THEN
37462       JJG=NC2P
37463       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37464         KKG=JJG+IIG-7-IIGLU1
37465         IDHKT(IIG)   =IDHKK(KKG)
37466         ISTHKT(IIG)  =921
37467         JMOHKT(1,IIG)=KKG
37468         JMOHKT(2,IIG)=0
37469         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37470         JDAHKT(2,IIG)=0
37471         PHKT(1,IIG)=PHKK(1,KKG)
37472         PG1=PG1+ PHKT(1,IIG)
37473         PHKT(2,IIG)=PHKK(2,KKG)
37474         PG2=PG2+ PHKT(2,IIG)
37475         PHKT(3,IIG)=PHKK(3,KKG)
37476         PG3=PG3+ PHKT(3,IIG)
37477         PHKT(4,IIG)=PHKK(4,KKG)
37478         PG4=PG4+ PHKT(4,IIG)
37479         PHKT(5,IIG)=PHKK(5,KKG)
37480         VHKT(1,IIG)  =VHKK(1,KKG)
37481         VHKT(2,IIG)  =VHKK(2,KKG)
37482         VHKT(3,IIG)  =VHKK(3,KKG)
37483         VHKT(4,IIG)  =VHKK(4,KKG)
37484         WHKT(1,IIG)  =WHKK(1,KKG)
37485         WHKT(2,IIG) =WHKK(2,KKG)
37486         WHKT(3,IIG) =WHKK(3,KKG)
37487         WHKT(4,IIG) =WHKK(4,KKG)
37488    81 CONTINUE
37489       ENDIF
37490       IF(IPIP.EQ.1)THEN
37491         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
37492         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
37493         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
37494         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
37495       ELSEIF(IPIP.EQ.2)THEN
37496         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
37497         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
37498         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
37499         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
37500       ENDIF
37501       ISTHKT(8+IIGLU1+IIGLU2)  =952
37502       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
37503       JMOHKT(2,8+IIGLU1+IIGLU2)=0
37504       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37505       JDAHKT(2,8+IIGLU1+IIGLU2)=0
37506       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC2T)+
37507      * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
37508       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC2T)+
37509      * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
37510       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC2T)+
37511      * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
37512       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC2T)+
37513      * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
37514 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
37515 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
37516       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
37517 C       IREJ=1
37518 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
37519 C    *  ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
37520         IPCO=0
37521 C       RETURN
37522         GO TO 3466
37523       ENDIF
37524 C     PHKT(5,8)  =PHKK(5,NC2T)
37525       XMIST  =(PHKT(4,8+IIGLU1+IIGLU2)**2-
37526      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37527      *PHKT(1,8+IIGLU1+IIGLU2)**2)
37528       IF(XMIST.GT.0.D0)THEN
37529       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37530      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37531      *PHKT(1,8+IIGLU1+IIGLU2)**2)
37532       ELSE
37533 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37534         PHKT(5,5+IIGLU1)=0.D0
37535       ENDIF
37536       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
37537       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
37538       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
37539       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
37540       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
37541       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
37542       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
37543       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
37544       IDHKT(9+IIGLU1+IIGLU2)   =88888
37545       ISTHKT(9+IIGLU1+IIGLU2)  =95
37546       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37547       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37548       JDAHKT(1,9+IIGLU1+IIGLU2)=0
37549       JDAHKT(2,9+IIGLU1+IIGLU2)=0
37550 **NEW
37551 C     PHKT(1,9+IIGLU1+IIGLU2)
37552 C    * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37553 C     PHKT(2,9+IIGLU1+IIGLU2)
37554 C    * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37555 C     PHKT(3,9+IIGLU1+IIGLU2)
37556 C    * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37557 C     PHKT(4,9+IIGLU1+IIGLU2)
37558 C    * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37559       PHKT(1,9+IIGLU1+IIGLU2)
37560      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37561       PHKT(2,9+IIGLU1+IIGLU2)
37562      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37563       PHKT(3,9+IIGLU1+IIGLU2)
37564      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37565       PHKT(4,9+IIGLU1+IIGLU2)
37566      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37567 **
37568       XMIST
37569      * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37570      * -PHKT(2,9+IIGLU1+IIGLU2)**2
37571      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
37572       IF(XMIST.GT.0.D0)THEN
37573       PHKT(5,9+IIGLU1+IIGLU2)
37574      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37575      * -PHKT(2,9+IIGLU1+IIGLU2)**2
37576      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
37577       ELSE
37578 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37579         PHKT(5,5+IIGLU1)=0.D0
37580       ENDIF
37581       IF(IPIP.GE.2)THEN
37582 C     IF(NUMEV.EQ.-324)THEN
37583 C     WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37584 C    * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37585 C    *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37586 C     DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37587 C     WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
37588 C    * JDAHKT(1,IIG),
37589 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37590 C  91 CONTINUE
37591 C     WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
37592 C    * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
37593 C    *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
37594 C    *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37595 C     WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37596 C    * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37597 C    *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37598 C    *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37599       ENDIF
37600       CHAMAL=CHAB1
37601       IF(IPIP.EQ.1)THEN
37602         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37603       ELSEIF(IPIP.EQ.2)THEN
37604         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37605       ENDIF
37606       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37607 C       IREJ=1
37608         IPCO=0
37609 C       RETURN
37610 C       WRITE(6,*)' MUSQBS1 jump back from chain 9',
37611 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37612         GO TO 3466
37613       ENDIF
37614       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
37615       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
37616       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
37617       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
37618       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
37619       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
37620       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
37621       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
37622 C
37623       IPCO=0
37624       IGCOUN=9+IIGLU1+IIGLU2
37625        RETURN
37626        END
37627
37628 *$ CREATE MGSQBS2.FOR
37629 *COPY MGSQBS2
37630 C
37631 C
37632 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37633       SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37634      *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
37635 C
37636 C                  GSQBS-2 diagram (split target diquark)
37637 C
37638       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37639       SAVE
37640
37641       PARAMETER ( LINP = 10 ,
37642      &            LOUT = 6 ,
37643      &            LDAT = 9 )
37644 * event history
37645       PARAMETER (NMXHKK=200000)
37646       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37647      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37648      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37649 * extended event history
37650       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37651      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37652      &                IHIST(2,NMXHKK)
37653 * Lorentz-parameters of the current interaction
37654       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37655      &                UMO,PPCM,EPROJ,PPROJ
37656 * diquark-breaking mechanism
37657       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37658
37659 C
37660       PARAMETER (NTMHKK= 300)
37661       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37662      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37663      +(4,NTMHKK)
37664
37665 *KEEP,XSEADI.
37666       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37667      +SSMIMQ,VVMTHR
37668 *KEEP,DPRIN.
37669       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37670 C
37671 C                  GSQBS-2 diagram (split target diquark)
37672 C
37673 C
37674 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
37675 C     Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
37676 C
37677 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
37678 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37679 C
37680 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37681 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37682 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37683 C
37684 C
37685 C
37686 C       Put new chains into COMMON /HKKTMP/
37687 C
37688       IIGLU1=NC1T-NC1P-1
37689       IIGLU2=NC2T-NC2P-1
37690       IGCOUN=0
37691 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37692       CVQ=1.D0
37693       IREJ=0
37694 C     IF(IPIP.EQ.2)THEN
37695 C     WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37696 C    *             'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
37697 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37698 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
37699 C     ENDIF
37700 C
37701 C
37702 C
37703 C     determine x-values of NC1T diquark
37704       XDIQT=PHKK(4,NC1T)*2.D0/UMO
37705       XVQP=PHKK(4,NC1P)*2.D0/UMO
37706 C
37707 C     determine x-values of sea quark pair
37708 C
37709       IPCO=1
37710       ICOU=0
37711  2234 CONTINUE
37712       ICOU=ICOU+1
37713       IF(ICOU.GE.500)THEN
37714         IREJ=1
37715         IF(ISQ.EQ.3)IREJ=3
37716         IF(IPCO.GE.3)
37717      &     WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
37718         IPCO=0
37719         RETURN
37720       ENDIF
37721       IF(IPCO.GE.3)
37722      &     WRITE(LOUT,*)'MGSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
37723      * UMO, XDIQT,XVQP
37724       XSQ=0.D0
37725       XSAQ=0.D0
37726 **NEW
37727 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37728       IF (IPIP.EQ.1) THEN
37729          XQMAX  = XDIQT/2.0D0
37730          XAQMAX = 2.D0*XVQP/3.0D0
37731       ELSE
37732          XQMAX  = 2.D0*XVQP/3.0D0
37733          XAQMAX = XDIQT/2.0D0
37734       ENDIF
37735       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37736       ISAQ = 6+ISQ
37737 C     write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37738 **
37739         IF(IPCO.GE.3)
37740      &     WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37741       IF(IREJ.GE.1)THEN
37742         IF(IPCO.GE.3)
37743      &     WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37744         IPCO=0
37745         RETURN
37746       ENDIF
37747       IF(IPIP.EQ.1)THEN
37748         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37749       ELSEIF(IPIP.EQ.2)THEN
37750         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37751       ENDIF
37752       IF(IPCO.GE.3)THEN
37753         WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37754      *  XDIQT,XVQP,XSQ,XSAQ
37755       ENDIF
37756 C
37757 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
37758 C
37759 C     XSQ=0.D0
37760       IF(IPIP.EQ.1)THEN
37761         XDIQT=XDIQT-XSQ
37762         XVQP =XVQP -XSAQ
37763       ELSEIF(IPIP.EQ.2)THEN
37764         XDIQT=XDIQT-XSAQ
37765         XVQP =XVQP -XSQ
37766       ENDIF
37767       IF(IPCO.GE.3)
37768      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37769 C
37770 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37771 C
37772       XVTHRO=CVQ/UMO
37773       IVTHR=0
37774  3466 CONTINUE
37775       IF(IVTHR.EQ.10)THEN
37776         IREJ=1
37777         IF(ISQ.EQ.3)IREJ=3
37778         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
37779         IPCO=0
37780         RETURN
37781       ENDIF
37782       IVTHR=IVTHR+1
37783       XVTHR=XVTHRO/(201-IVTHR)
37784       UNOPRV=UNON
37785  380  CONTINUE
37786       IF(XVTHR.GT.0.66D0*XDIQT)THEN
37787         IREJ=1
37788         IF(ISQ.EQ.3)IREJ=3
37789         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR  large ',
37790      *  XVTHR
37791         IPCO=0
37792         RETURN
37793       ENDIF
37794       IF(DT_RNDM(V).LT.0.5D0)THEN
37795         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37796         XVTQII=XDIQT-XVTQI
37797       ELSE
37798         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37799         XVTQI=XDIQT-XVTQII
37800       ENDIF
37801       IF(IPCO.GE.3)THEN
37802         WRITE(LOUT,'(A,2E12.4)')'  MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37803       ENDIF
37804 C
37805 C     Prepare 4 momenta of new chains and chain ends
37806 C
37807 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37808 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37809 C    +(4,NTMHKK)
37810 C
37811 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37812 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37813 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37814 C
37815 C     SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37816 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
37817 C
37818       IF(IPIP.EQ.1)THEN
37819         XSQ1=XSQ
37820         XSAQ1=XSAQ
37821         ISQ1=ISQ
37822         ISAQ1=ISAQ
37823       ELSEIF(IPIP.EQ.2)THEN
37824         XSQ1=XSAQ
37825         XSAQ1=XSQ
37826         ISQ1=ISAQ
37827         ISAQ1=ISQ
37828       ENDIF
37829       KK11=IP21
37830 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
37831       KK21=IPP11
37832       KK22=IPP12
37833       XGIVE=0.D0
37834       IF(IPIP.EQ.1)THEN
37835         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
37836       ELSEIF(IPIP.EQ.2)THEN
37837         IDHKT(4+IIGLU1)   =ISAQ1
37838       ENDIF
37839       ISTHKT(4+IIGLU1)  =961
37840       JMOHKT(1,4+IIGLU1)=NC1P
37841       JMOHKT(2,4+IIGLU1)=0
37842       JDAHKT(1,4+IIGLU1)=6+IIGLU1
37843       JDAHKT(2,4+IIGLU1)=0
37844 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37845       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37846       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37847       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37848       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37849 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
37850       XXMIST=(PHKT(4,4+IIGLU1)**2-
37851      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37852      *PHKT(1,4+IIGLU1)**2)
37853       IF(XXMIST.GT.0.D0)THEN
37854         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
37855       ELSE
37856         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
37857         XXMIST=ABS(XXMIST)
37858         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
37859       ENDIF
37860       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
37861       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
37862       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
37863       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
37864       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
37865       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
37866       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
37867       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
37868       IDHKT(5+IIGLU1)   =IP22
37869       ISTHKT(5+IIGLU1)  =962
37870       JMOHKT(1,5+IIGLU1)=NC1T
37871       JMOHKT(2,5+IIGLU1)=0
37872       JDAHKT(1,5+IIGLU1)=6+IIGLU1
37873       JDAHKT(2,5+IIGLU1)=0
37874       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37875       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37876       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37877       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37878 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
37879       XXMIST=(PHKT(4,5+IIGLU1)**2-
37880      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37881      *PHKT(1,5+IIGLU1)**2)
37882       IF(XXMIST.GT.0.D0)THEN
37883         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
37884       ELSE
37885         WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
37886         XXMIST=ABS(XXMIST)
37887         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
37888       ENDIF
37889       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
37890       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
37891       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
37892       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
37893       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
37894       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
37895       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
37896       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
37897       IDHKT(6+IIGLU1)   =88888
37898       ISTHKT(6+IIGLU1)  =96
37899       JMOHKT(1,6+IIGLU1)=4+IIGLU1
37900       JMOHKT(2,6+IIGLU1)=5+IIGLU1
37901       JDAHKT(1,6+IIGLU1)=0
37902       JDAHKT(2,6+IIGLU1)=0
37903       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37904       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37905       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37906       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37907       PHKT(5,6+IIGLU1)
37908      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37909      *            -PHKT(3,6+IIGLU1)**2)
37910       CHAMAL=CHAM1
37911       IF(IPIP.EQ.1)THEN
37912         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37913       ELSEIF(IPIP.EQ.2)THEN
37914         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37915       ENDIF
37916 C---------------------------------------------------
37917       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37918         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37919 C                    we drop chain 6 and give the energy to chain 3
37920           IDHKT(6+IIGLU1)=22888
37921           XGIVE=1.D0
37922 C         WRITE(6,*)' drop chain 6 xgive=1'
37923           GO TO 7788
37924         ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
37925 C                    we drop chain 6 and give the energy to chain 3
37926 C                    and change KK11 to IDHKT(5)
37927           IDHKT(6+IIGLU1)=22888
37928           XGIVE=1.D0
37929 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
37930           KK11=IDHKT(5+IIGLU1)
37931           GO TO 7788
37932         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
37933 C                    we drop chain 6 and give the energy to chain 3
37934 C                    and change KK21 to IDHKT(5+IIGLU1)
37935 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
37936           IDHKT(6+IIGLU1)=22888
37937           XGIVE=1.D0
37938 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
37939           KK21=IDHKT(5+IIGLU1)
37940           GO TO 7788
37941         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
37942 C                    we drop chain 6 and give the energy to chain 3
37943 C                    and change KK22 to IDHKT(5)
37944 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
37945           IDHKT(6+IIGLU1)=22888
37946           XGIVE=1.D0
37947 C         WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
37948           KK22=IDHKT(5+IIGLU1)
37949           GO TO 7788
37950         ENDIF
37951 C       IREJ=1
37952         IPCO=0
37953 C       RETURN
37954         GO TO 3466
37955       ENDIF
37956  7788 CONTINUE
37957 C---------------------------------------------------
37958       IF(IPIP.GE.3)THEN
37959       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37960      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37961      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37962       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37963      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37964      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37965       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37966      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37967      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37968       ENDIF
37969       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
37970       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
37971       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
37972       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
37973       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
37974       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
37975       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
37976       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
37977 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
37978       IF(IPIP.EQ.1)THEN
37979         IDHKT(1)   =1000*KK21+100*KK22+3
37980         IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
37981         IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
37982         IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
37983       ELSEIF(IPIP.EQ.2)THEN
37984         IDHKT(1)   =1000*KK21+100*KK22-3
37985         IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
37986         IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
37987         IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
37988       ENDIF
37989       ISTHKT(1)  =961
37990       JMOHKT(1,1)=NC2P
37991       JMOHKT(2,1)=0
37992       JDAHKT(1,1)=3+IIGLU1
37993       JDAHKT(2,1)=0
37994 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37995       PHKT(1,1)  =PHKK(1,NC2P)
37996      *+XGIVE*PHKT(1,4+IIGLU1)
37997       PHKT(2,1)  =PHKK(2,NC2P)
37998      *+XGIVE*PHKT(2,4+IIGLU1)
37999       PHKT(3,1)  =PHKK(3,NC2P)
38000      *+XGIVE*PHKT(3,4+IIGLU1)
38001       PHKT(4,1)  =PHKK(4,NC2P)
38002      *+XGIVE*PHKT(4,4+IIGLU1)
38003 C     PHKT(5,1)  =PHKK(5,NC2P)
38004       XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38005      *PHKT(1,1)**2
38006       IF(XXMIST.GT.0.D0)THEN
38007         PHKT(5,1)  =SQRT(XXMIST)
38008       ELSE
38009         WRITE(LOUT,*)'MGSQBS2',XXMIST
38010         XXMIST=ABS(XXMIST)
38011         PHKT(5,1)  =SQRT(XXMIST)
38012       ENDIF
38013       VHKT(1,1)  =VHKK(1,NC2P)
38014       VHKT(2,1)  =VHKK(2,NC2P)
38015       VHKT(3,1)  =VHKK(3,NC2P)
38016       VHKT(4,1)  =VHKK(4,NC2P)
38017       WHKT(1,1)  =WHKK(1,NC2P)
38018       WHKT(2,1)  =WHKK(2,NC2P)
38019       WHKT(3,1)  =WHKK(3,NC2P)
38020       WHKT(4,1)  =WHKK(4,NC2P)
38021 C     Add here IIGLU1 gluons to this chaina
38022       PG1=0.D0
38023       PG2=0.D0
38024       PG3=0.D0
38025       PG4=0.D0
38026       IF(IIGLU1.GE.1)THEN
38027       JJG=NC1P
38028       DO 61 IIG=2,2+IIGLU1-1
38029         KKG=JJG+IIG-1
38030         IDHKT(IIG)   =IDHKK(KKG)
38031         ISTHKT(IIG)  =921
38032         JMOHKT(1,IIG)=KKG
38033         JMOHKT(2,IIG)=0
38034         JDAHKT(1,IIG)=3+IIGLU1
38035         JDAHKT(2,IIG)=0
38036         PHKT(1,IIG)=PHKK(1,KKG)
38037         PG1=PG1+ PHKT(1,IIG)
38038         PHKT(2,IIG)=PHKK(2,KKG)
38039         PG2=PG2+ PHKT(2,IIG)
38040         PHKT(3,IIG)=PHKK(3,KKG)
38041         PG3=PG3+ PHKT(3,IIG)
38042         PHKT(4,IIG)=PHKK(4,KKG)
38043         PG4=PG4+ PHKT(4,IIG)
38044         PHKT(5,IIG)=PHKK(5,KKG)
38045         VHKT(1,IIG)  =VHKK(1,KKG)
38046         VHKT(2,IIG)  =VHKK(2,KKG)
38047         VHKT(3,IIG)  =VHKK(3,KKG)
38048         VHKT(4,IIG)  =VHKK(4,KKG)
38049         WHKT(1,IIG)  =WHKK(1,KKG)
38050         WHKT(2,IIG)  =WHKK(2,KKG)
38051         WHKT(3,IIG)  =WHKK(3,KKG)
38052         WHKT(4,IIG)  =WHKK(4,KKG)
38053    61 CONTINUE
38054       ENDIF
38055 C     IDHKT(2)   =IP21
38056       IDHKT(2+IIGLU1)   =KK11
38057       ISTHKT(2+IIGLU1)  =962
38058       JMOHKT(1,2+IIGLU1)=NC1T
38059       JMOHKT(2,2+IIGLU1)=0
38060       JDAHKT(1,2+IIGLU1)=3+IIGLU1
38061       JDAHKT(2,2+IIGLU1)=0
38062       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
38063 C    * +0.5D0*PHKK(1,NC2T)
38064      *+XGIVE*PHKT(1,5+IIGLU1)
38065       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
38066 C    *+0.5D0*PHKK(2,NC2T)
38067      *+XGIVE*PHKT(2,5+IIGLU1)
38068       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
38069 C    *+0.5D0*PHKK(3,NC2T)
38070      *+XGIVE*PHKT(3,5+IIGLU1)
38071       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
38072 C    *+0.5D0*PHKK(4,NC2T)
38073      *+XGIVE*PHKT(4,5+IIGLU1)
38074 C     PHKT(5,2)  =PHKK(5,NC1T)
38075       XXMIST=(PHKT(4,2+IIGLU1)**2-
38076      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38077      *PHKT(1,2+IIGLU1)**2)
38078       IF(XXMIST.GT.0.D0)THEN
38079         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
38080       ELSE
38081         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
38082         XXMIST=ABS(XXMIST)
38083         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
38084       ENDIF
38085       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
38086       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
38087       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
38088       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
38089       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
38090       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
38091       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
38092       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
38093       IDHKT(3+IIGLU1)   =88888
38094       ISTHKT(3+IIGLU1)  =96
38095       JMOHKT(1,3+IIGLU1)=1
38096       JMOHKT(2,3+IIGLU1)=2+IIGLU1
38097       JDAHKT(1,3+IIGLU1)=0
38098       JDAHKT(2,3+IIGLU1)=0
38099       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38100       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38101       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38102       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38103       PHKT(5,3+IIGLU1)
38104      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38105      *            -PHKT(3,3+IIGLU1)**2)
38106       IF(IPIP.EQ.3)THEN
38107       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38108      * JDAHKT(1,1),
38109      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38110       DO 71 IIG=2,2+IIGLU1-1
38111       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38112      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38113      * JDAHKT(1,IIG),
38114      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38115    71 CONTINUE
38116       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38117      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38118      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38119       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38120      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38121      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38122       ENDIF
38123       CHAMAL=CHAB1
38124       IF(IPIP.EQ.1)THEN
38125         IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
38126       ELSEIF(IPIP.EQ.2)THEN
38127         IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
38128       ENDIF
38129       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38130 C       IREJ=1
38131         IPCO=0
38132 C       RETURN
38133         GO TO 3466
38134       ENDIF
38135       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
38136       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
38137       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
38138       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
38139       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
38140       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
38141       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
38142       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
38143 C     IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+1
38144       IDHKT(7+IIGLU1)   =IP1
38145       ISTHKT(7+IIGLU1)  =961
38146       JMOHKT(1,7+IIGLU1)=NC1P
38147       JMOHKT(2,7+IIGLU1)=0
38148       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38149       JDAHKT(2,7+IIGLU1)=0
38150       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
38151       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
38152       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
38153       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
38154 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
38155       XXMIST=(PHKT(4,7+IIGLU1)**2-
38156      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38157      *PHKT(1,7+IIGLU1)**2)
38158       IF(XXMIST.GT.0.D0)THEN
38159         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
38160       ELSE
38161         WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
38162         XXMIST=ABS(XXMIST)
38163         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
38164       ENDIF
38165       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
38166       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
38167       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
38168       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
38169       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
38170       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
38171       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
38172       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
38173 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
38174 C     Insert here the IIGLU2 gluons
38175       PG1=0.D0
38176       PG2=0.D0
38177       PG3=0.D0
38178       PG4=0.D0
38179       IF(IIGLU2.GE.1)THEN
38180       JJG=NC2P
38181       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38182         KKG=JJG+IIG-7-IIGLU1
38183         IDHKT(IIG)   =IDHKK(KKG)
38184         ISTHKT(IIG)  =921
38185         JMOHKT(1,IIG)=KKG
38186         JMOHKT(2,IIG)=0
38187         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38188         JDAHKT(2,IIG)=0
38189         PHKT(1,IIG)=PHKK(1,KKG)
38190         PG1=PG1+ PHKT(1,IIG)
38191         PHKT(2,IIG)=PHKK(2,KKG)
38192         PG2=PG2+ PHKT(2,IIG)
38193         PHKT(3,IIG)=PHKK(3,KKG)
38194         PG3=PG3+ PHKT(3,IIG)
38195         PHKT(4,IIG)=PHKK(4,KKG)
38196         PG4=PG4+ PHKT(4,IIG)
38197         PHKT(5,IIG)=PHKK(5,KKG)
38198         VHKT(1,IIG)  =VHKK(1,KKG)
38199         VHKT(2,IIG)  =VHKK(2,KKG)
38200         VHKT(3,IIG)  =VHKK(3,KKG)
38201         VHKT(4,IIG)  =VHKK(4,KKG)
38202         WHKT(1,IIG)  =WHKK(1,KKG)
38203         WHKT(2,IIG)  =WHKK(2,KKG)
38204         WHKT(3,IIG)  =WHKK(3,KKG)
38205         WHKT(4,IIG)  =WHKK(4,KKG)
38206    81 CONTINUE
38207       ENDIF
38208       IF(IPIP.EQ.1)THEN
38209         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
38210         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
38211         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
38212         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
38213       ELSEIF(IPIP.EQ.2)THEN
38214 **NEW
38215 C       IDHKT(8)   =1000*IPP2+100*(-ISQ1+6)-3
38216         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
38217 **
38218         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
38219         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
38220         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
38221       ENDIF
38222       ISTHKT(8+IIGLU1+IIGLU2)  =962
38223       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
38224       JMOHKT(2,8+IIGLU1+IIGLU2)=0
38225       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38226       JDAHKT(2,8+IIGLU1+IIGLU2)=0
38227 C     PHKT(1,8)  =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
38228 C     PHKT(2,8)  =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
38229 C     PHKT(3,8)  =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
38230 C     PHKT(4,8)  =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
38231       PHKT(1,8+IIGLU1+IIGLU2)  =
38232      * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
38233       PHKT(2,8+IIGLU1+IIGLU2)  =
38234      * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
38235       PHKT(3,8+IIGLU1+IIGLU2)  =
38236      * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
38237       PHKT(4,8+IIGLU1+IIGLU2)  =
38238      * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
38239 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
38240 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
38241       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
38242 C       IREJ=1
38243 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
38244         IPCO=0
38245 C       RETURN
38246         GO TO 3466
38247       ENDIF
38248 C     PHKT(5,8)  =PHKK(5,NC2T)
38249       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38250      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38251      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38252       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
38253       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
38254       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
38255       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
38256       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
38257       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
38258       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
38259       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
38260       IDHKT(9+IIGLU1+IIGLU2)   =88888
38261       ISTHKT(9+IIGLU1+IIGLU2)  =96
38262       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38263       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38264       JDAHKT(1,9+IIGLU1+IIGLU2)=0
38265       JDAHKT(2,9+IIGLU1+IIGLU2)=0
38266       PHKT(1,9+IIGLU1+IIGLU2)
38267      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38268       PHKT(2,9+IIGLU1+IIGLU2)
38269      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38270       PHKT(3,9+IIGLU1+IIGLU2)
38271      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38272       PHKT(4,9+IIGLU1+IIGLU2)
38273      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38274       PHKT(5,9+IIGLU1+IIGLU2)
38275      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38276      * PHKT(2,9+IIGLU1+IIGLU2)**2
38277      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38278       IF(IPIP.GE.3)THEN
38279       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38280      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38281      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38282       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38283       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38284      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38285      * JDAHKT(1,IIG),
38286      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38287    91 CONTINUE
38288       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38289      * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
38290      *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
38291      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38292       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38293      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38294      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38295      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38296       ENDIF
38297       CHAMAL=CHAB1
38298       IF(IPIP.EQ.1)THEN
38299         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38300       ELSEIF(IPIP.EQ.2)THEN
38301         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38302       ENDIF
38303       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38304 C       IREJ=1
38305         IPCO=0
38306 C       RETURN
38307         GO TO 3466
38308       ENDIF
38309       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
38310       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
38311       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
38312       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
38313       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
38314       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
38315       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
38316       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
38317 C
38318       IPCO=0
38319       IGCOUN=9+IIGLU1+IIGLU2
38320        RETURN
38321        END
38322
38323 *$ CREATE MUSQBS1.FOR
38324 *COPY MUSQBS1
38325 C
38326 C
38327 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38328       SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38329      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
38330 C
38331 C                  USQBS-1 diagram (split projectile diquark)
38332 C
38333       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38334       SAVE
38335
38336       PARAMETER ( LINP = 10 ,
38337      &            LOUT = 6 ,
38338      &            LDAT = 9 )
38339 * event history
38340       PARAMETER (NMXHKK=200000)
38341       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38342      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38343      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38344 * extended event history
38345       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38346      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38347      &                IHIST(2,NMXHKK)
38348 * Lorentz-parameters of the current interaction
38349       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38350      &                UMO,PPCM,EPROJ,PPROJ
38351 * diquark-breaking mechanism
38352       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38353
38354 C
38355       PARAMETER (NTMHKK= 300)
38356       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38357      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38358      +(4,NTMHKK)
38359 *KEEP,XSEADI.
38360       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
38361      +SSMIMQ,VVMTHR
38362 *KEEP,DPRIN.
38363       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
38364       COMMON /EVFLAG/ NUMEV
38365 C
38366 C                  USQBS-1 diagram (split projectile diquark)
38367 C
38368 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
38369 C     Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
38370 C
38371 C     Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
38372 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38373 C
38374 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38375 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38376 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38377 C
38378 C       Put new chains into COMMON /HKKTMP/
38379 C
38380       IIGLU1=NC1T-NC1P-1
38381       IIGLU2=NC2T-NC2P-1
38382       IGCOUN=0
38383 C     WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
38384       CVQ=1.D0
38385       IREJ=0
38386       IF(IPIP.EQ.3)THEN
38387 C     IF(NUMEV.EQ.-324)THEN
38388       WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
38389      *             ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
38390      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38391      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
38392       ENDIF
38393 C
38394 C
38395 C
38396 C     determine x-values of NC1P diquark
38397       XDIQP=PHKK(4,NC1P)*2.D0/UMO
38398       XVQT=PHKK(4,NC1T)*2.D0/UMO
38399 C
38400 C     determine x-values of sea quark pair
38401 C
38402       IPCO=1
38403       ICOU=0
38404  2234 CONTINUE
38405       ICOU=ICOU+1
38406       IF(ICOU.GE.500)THEN
38407         IREJ=1
38408         IF(ISQ.EQ.3)IREJ=3
38409         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
38410         IPCO=0
38411         RETURN
38412       ENDIF
38413       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
38414      * UMO, XDIQP,XVQT
38415       XSQ=0.D0
38416       XSAQ=0.D0
38417 **NEW
38418 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
38419       IF (IPIP.EQ.1) THEN
38420          XQMAX  = XDIQP/2.0D0
38421          XAQMAX = 2.D0*XVQT/3.0D0
38422       ELSE
38423          XQMAX  = 2.D0*XVQT/3.0D0
38424          XAQMAX = XDIQP/2.0D0
38425       ENDIF
38426       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
38427       ISAQ = 6+ISQ
38428 C     write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
38429 **
38430       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38431       IF(IREJ.GE.1)THEN
38432         IF(IPCO.GE.3)
38433      &     WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38434         IPCO=0
38435         RETURN
38436       ENDIF
38437       IF(IPIP.EQ.1)THEN
38438         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38439       ELSEIF(IPIP.EQ.2)THEN
38440         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38441       ENDIF
38442       IF(IPCO.GE.3)THEN
38443         WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
38444      *  XDIQP,XVQT,XSQ,XSAQ
38445       ENDIF
38446 C
38447 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
38448 C
38449 C     XSQ=0.D0
38450       IF(IPIP.EQ.1)THEN
38451         XDIQP=XDIQP-XSQ
38452         XVQT =XVQT -XSAQ
38453       ELSEIF(IPIP.EQ.2)THEN
38454         XDIQP=XDIQP-XSAQ
38455         XVQT =XVQT -XSQ
38456       ENDIF
38457       IF(IPCO.GE.3)
38458      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
38459 C
38460 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38461 C
38462       XVTHRO=CVQ/UMO
38463       IVTHR=0
38464  3466 CONTINUE
38465       IF(IVTHR.EQ.10)THEN
38466         IREJ=1
38467         IF(ISQ.EQ.3)IREJ=3
38468         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
38469         IPCO=0
38470         RETURN
38471       ENDIF
38472       IVTHR=IVTHR+1
38473       XVTHR=XVTHRO/(201-IVTHR)
38474       UNOPRV=UNON
38475  380  CONTINUE
38476       IF(XVTHR.GT.0.66D0*XDIQP)THEN
38477         IREJ=1
38478         IF(ISQ.EQ.3)IREJ=3
38479         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR  large ',
38480      *  XVTHR
38481         IPCO=0
38482         RETURN
38483       ENDIF
38484       IF(DT_RNDM(V).LT.0.5D0)THEN
38485         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38486         XVPQII=XDIQP-XVPQI
38487       ELSE
38488         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38489         XVPQI=XDIQP-XVPQII
38490       ENDIF
38491       IF(IPCO.GE.3)THEN
38492         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
38493       ENDIF
38494 C
38495 C     Prepare 4 momenta of new chains and chain ends
38496 C
38497 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38498 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38499 C    +(4,NTMHKK)
38500 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38501 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38502 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38503       IF(IPIP.EQ.1)THEN
38504         XSQ1=XSQ
38505         XSAQ1=XSAQ
38506         ISQ1=ISQ
38507         ISAQ1=ISAQ
38508       ELSEIF(IPIP.EQ.2)THEN
38509         XSQ1=XSAQ
38510         XSAQ1=XSQ
38511         ISQ1=ISAQ
38512         ISAQ1=ISQ
38513       ENDIF
38514       IDHKT(1)   =IP11
38515       ISTHKT(1)  =931
38516       JMOHKT(1,1)=NC1P
38517       JMOHKT(2,1)=0
38518       JDAHKT(1,1)=3+IIGLU1
38519       JDAHKT(2,1)=0
38520 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38521       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38522       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38523       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38524       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38525 C     PHKT(5,1)  =PHKK(5,NC1P)
38526       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38527      *PHKT(1,1)**2)
38528       IF(XMIST.GE.0.D0)THEN
38529       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38530      *PHKT(1,1)**2)
38531       ELSE
38532 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38533        PHKT(5,1)=0.D0
38534       ENDIF
38535       VHKT(1,1)  =VHKK(1,NC1P)
38536       VHKT(2,1)  =VHKK(2,NC1P)
38537       VHKT(3,1)  =VHKK(3,NC1P)
38538       VHKT(4,1)  =VHKK(4,NC1P)
38539       WHKT(1,1)  =WHKK(1,NC1P)
38540       WHKT(2,1)  =WHKK(2,NC1P)
38541       WHKT(3,1)  =WHKK(3,NC1P)
38542       WHKT(4,1)  =WHKK(4,NC1P)
38543 C     Add here IIGLU1 gluons to this chaina
38544       PG1=0.D0
38545       PG2=0.D0
38546       PG3=0.D0
38547       PG4=0.D0
38548       IF(IIGLU1.GE.1)THEN
38549       JJG=NC1P
38550       DO 61 IIG=2,2+IIGLU1-1
38551         KKG=JJG+IIG-1
38552         IDHKT(IIG)   =IDHKK(KKG)
38553         ISTHKT(IIG)  =921
38554         JMOHKT(1,IIG)=KKG
38555         JMOHKT(2,IIG)=0
38556         JDAHKT(1,IIG)=3+IIGLU1
38557         JDAHKT(2,IIG)=0
38558         PHKT(1,IIG)=PHKK(1,KKG)
38559         PG1=PG1+ PHKT(1,IIG)
38560         PHKT(2,IIG)=PHKK(2,KKG)
38561         PG2=PG2+ PHKT(2,IIG)
38562         PHKT(3,IIG)=PHKK(3,KKG)
38563         PG3=PG3+ PHKT(3,IIG)
38564         PHKT(4,IIG)=PHKK(4,KKG)
38565         PG4=PG4+ PHKT(4,IIG)
38566         PHKT(5,IIG)=PHKK(5,KKG)
38567         VHKT(1,IIG)  =VHKK(1,KKG)
38568         VHKT(2,IIG)  =VHKK(2,KKG)
38569         VHKT(3,IIG)  =VHKK(3,KKG)
38570         VHKT(4,IIG)  =VHKK(4,KKG)
38571         WHKT(1,IIG) =WHKK(1,KKG)
38572         WHKT(2,IIG) =WHKK(2,KKG)
38573         WHKT(3,IIG) =WHKK(3,KKG)
38574         WHKT(4,IIG) =WHKK(4,KKG)
38575    61 CONTINUE
38576       ENDIF
38577       IDHKT(2+IIGLU1)   =IPP2
38578       ISTHKT(2+IIGLU1)  =932
38579       JMOHKT(1,2+IIGLU1)=NC2T
38580       JMOHKT(2,2+IIGLU1)=0
38581       JDAHKT(1,2+IIGLU1)=3+IIGLU1
38582       JDAHKT(2,2+IIGLU1)=0
38583       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
38584       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
38585       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
38586       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
38587 C     PHKT(5,2+IIGLU1)  =PHKK(5,NC2T)
38588       XMIST=(PHKT(4,2+IIGLU1)**2-
38589      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38590      *PHKT(1,2+IIGLU1)**2)
38591       IF(XMIST.GT.0.D0)THEN
38592       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
38593      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38594      *PHKT(1,2+IIGLU1)**2)
38595       ELSE
38596 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38597         PHKT(5,2+IIGLU1)=0.D0
38598       ENDIF
38599       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
38600       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
38601       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
38602       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
38603       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
38604       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
38605       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
38606       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
38607       IDHKT(3+IIGLU1)   =88888
38608       ISTHKT(3+IIGLU1)  =94
38609       JMOHKT(1,3+IIGLU1)=1
38610       JMOHKT(2,3+IIGLU1)=2+IIGLU1
38611       JDAHKT(1,3+IIGLU1)=0
38612       JDAHKT(2,3+IIGLU1)=0
38613       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38614       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38615       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38616       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38617       XMIST
38618      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38619      *            -PHKT(3,3+IIGLU1)**2)
38620       IF(XMIST.GE.0.D0)THEN
38621       PHKT(5,3+IIGLU1)
38622      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38623      *            -PHKT(3,3+IIGLU1)**2)
38624       ELSE
38625 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38626        PHKT(5,1)=0.D0
38627       ENDIF
38628       IF(IPIP.GE.3)THEN
38629 C     IF(NUMEV.EQ.-324)THEN
38630       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
38631      * JMOHKT(2,1),JDAHKT(1,1),
38632      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38633       DO 71 IIG=2,2+IIGLU1-1
38634       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38635      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38636      * JDAHKT(1,IIG),
38637      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38638    71 CONTINUE
38639       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38640      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38641      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38642       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38643      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38644      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38645       ENDIF
38646       CHAMAL=CHAM1
38647       IF(IPIP.EQ.1)THEN
38648         IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
38649       ELSEIF(IPIP.EQ.2)THEN
38650         IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
38651       ENDIF
38652       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38653 C       IREJ=1
38654         IPCO=0
38655 C       RETURN
38656 C       WRITE(6,*)' MUSQBS1 jump back from chain 3'
38657         GO TO 3466
38658       ENDIF
38659       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
38660       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
38661       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
38662       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
38663       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
38664       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
38665       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
38666       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
38667       IDHKT(4+IIGLU1)   =IP12
38668       ISTHKT(4+IIGLU1)  =931
38669       JMOHKT(1,4+IIGLU1)=NC1P
38670       JMOHKT(2,4+IIGLU1)=0
38671       JDAHKT(1,4+IIGLU1)=6+IIGLU1
38672       JDAHKT(2,4+IIGLU1)=0
38673 C   create  chain   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38674       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
38675       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
38676       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
38677       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
38678 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
38679       XMIST  =(PHKT(4,4+IIGLU1)**2-
38680      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38681      *PHKT(1,4+IIGLU1)**2)
38682       IF(XMIST.GT.0.D0)THEN
38683       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
38684      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38685      *PHKT(1,4+IIGLU1)**2)
38686       ELSE
38687 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38688         PHKT(5,4+IIGLU1)=0.D0
38689       ENDIF
38690       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
38691       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
38692       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
38693       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
38694       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
38695       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
38696       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
38697       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
38698       IF(IPIP.EQ.1)THEN
38699         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
38700       ELSEIF(IPIP.EQ.2)THEN
38701         IDHKT(5+IIGLU1)   =ISAQ1
38702       ENDIF
38703       ISTHKT(5+IIGLU1)  =932
38704       JMOHKT(1,5+IIGLU1)=NC1T
38705       JMOHKT(2,5+IIGLU1)=0
38706       JDAHKT(1,5+IIGLU1)=6+IIGLU1
38707       JDAHKT(2,5+IIGLU1)=0
38708       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
38709       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
38710       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
38711       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
38712 C     IF( PHKT(4,5).EQ.0.D0)THEN
38713 C       IREJ=1
38714 CIPCO=0
38715 CRETURN
38716 C     ENDIF
38717 C     PHKT(5,5)  =PHKK(5,NC1T)
38718       XMIST=(PHKT(4,5+IIGLU1)**2-
38719      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38720      *PHKT(1,5+IIGLU1)**2)
38721       IF(XMIST.GT.0.D0)THEN
38722       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
38723      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38724      *PHKT(1,5+IIGLU1)**2)
38725       ELSE
38726 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38727         PHKT(5,5+IIGLU1)=0.D0
38728       ENDIF
38729       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
38730       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
38731       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
38732       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
38733       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
38734       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
38735       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
38736       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
38737       IDHKT(6+IIGLU1)   =88888
38738       ISTHKT(6+IIGLU1)  =94
38739       JMOHKT(1,6+IIGLU1)=4+IIGLU1
38740       JMOHKT(2,6+IIGLU1)=5+IIGLU1
38741       JDAHKT(1,6+IIGLU1)=0
38742       JDAHKT(2,6+IIGLU1)=0
38743       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
38744       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
38745       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
38746       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
38747       XMIST
38748      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38749      *            -PHKT(3,6+IIGLU1)**2)
38750       IF(XMIST.GE.0.D0)THEN
38751       PHKT(5,6+IIGLU1)
38752      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38753      *            -PHKT(3,6+IIGLU1)**2)
38754       ELSE
38755 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38756        PHKT(5,1)=0.D0
38757       ENDIF
38758 C     IF(IPIP.EQ.3)THEN
38759       CHAMAL=CHAM1
38760       IF(IPIP.EQ.1)THEN
38761         IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
38762       ELSEIF(IPIP.EQ.2)THEN
38763         IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
38764       ENDIF
38765       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
38766 C       IREJ=1
38767         IPCO=0
38768 C       RETURN
38769 C       WRITE(6,*)' MGSQBS1 jump back from chain 6',
38770 C    *  CHAMAL,PHKT(5,6+IIGLU1)
38771         GO TO 3466
38772       ENDIF
38773       IF(IPIP.GE.3)THEN
38774 C     IF(NUMEV.EQ.-324)THEN
38775       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38776      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38777      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38778       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38779      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38780      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38781       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38782      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38783      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38784       ENDIF
38785       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
38786       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
38787       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
38788       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
38789       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
38790       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
38791       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
38792       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
38793       IF(IPIP.EQ.1)THEN
38794         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+3
38795         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
38796         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
38797         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
38798       ELSEIF(IPIP.EQ.2)THEN
38799         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
38800         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38801         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38802         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38803 C       WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
38804       ENDIF
38805       ISTHKT(7+IIGLU1)  =931
38806       JMOHKT(1,7+IIGLU1)=NC2P
38807       JMOHKT(2,7+IIGLU1)=0
38808       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38809       JDAHKT(2,7+IIGLU1)=0
38810 C    create chain     9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38811       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38812       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38813       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38814       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38815 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38816 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38817       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38818 C       IREJ=1
38819 C       WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
38820         IPCO=0
38821 C       RETURN
38822         GO TO 3466
38823       ENDIF
38824 C     PHKT(5,7)  =PHKK(5,NC2P)
38825       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
38826      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38827      *PHKT(1,7+IIGLU1)**2)
38828       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
38829       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
38830       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
38831       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
38832       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
38833       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
38834       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
38835       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
38836 C     Insert here the IIGLU2 gluons
38837       PG1=0.D0
38838       PG2=0.D0
38839       PG3=0.D0
38840       PG4=0.D0
38841       IF(IIGLU2.GE.1)THEN
38842       JJG=NC2P
38843       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38844         KKG=JJG+IIG-7-IIGLU1
38845         IDHKT(IIG)   =IDHKK(KKG)
38846         ISTHKT(IIG)  =921
38847         JMOHKT(1,IIG)=KKG
38848         JMOHKT(2,IIG)=0
38849         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38850         JDAHKT(2,IIG)=0
38851         PHKT(1,IIG)=PHKK(1,KKG)
38852         PG1=PG1+ PHKT(1,IIG)
38853         PHKT(2,IIG)=PHKK(2,KKG)
38854         PG2=PG2+ PHKT(2,IIG)
38855         PHKT(3,IIG)=PHKK(3,KKG)
38856         PG3=PG3+ PHKT(3,IIG)
38857         PHKT(4,IIG)=PHKK(4,KKG)
38858         PG4=PG4+ PHKT(4,IIG)
38859         PHKT(5,IIG)=PHKK(5,KKG)
38860         VHKT(1,IIG)  =VHKK(1,KKG)
38861         VHKT(2,IIG)  =VHKK(2,KKG)
38862         VHKT(3,IIG)  =VHKK(3,KKG)
38863         VHKT(4,IIG)  =VHKK(4,KKG)
38864         WHKT(1,IIG)  =WHKK(1,KKG)
38865         WHKT(2,IIG) =WHKK(2,KKG)
38866         WHKT(3,IIG) =WHKK(3,KKG)
38867         WHKT(4,IIG) =WHKK(4,KKG)
38868    81 CONTINUE
38869       ENDIF
38870       IDHKT(8+IIGLU1+IIGLU2)   =IP2
38871       ISTHKT(8+IIGLU1+IIGLU2)  =932
38872       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38873       JMOHKT(2,8+IIGLU1+IIGLU2)=0
38874       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38875       JDAHKT(2,8+IIGLU1+IIGLU2)=0
38876       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38877       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38878       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38879       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38880 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
38881       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38882      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38883      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38884       IF(XMIST.GT.0.D0)THEN
38885       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38886      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38887      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38888       ELSE
38889 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38890         PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38891       ENDIF
38892       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
38893       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
38894       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
38895       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
38896       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
38897       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
38898       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
38899       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
38900       IDHKT(9+IIGLU1+IIGLU2)   =88888
38901       ISTHKT(9+IIGLU1+IIGLU2)  =94
38902       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38903       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38904       JDAHKT(1,9+IIGLU1+IIGLU2)=0
38905       JDAHKT(2,9+IIGLU1+IIGLU2)=0
38906       PHKT(1,9+IIGLU1+IIGLU2)
38907      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38908       PHKT(2,9+IIGLU1+IIGLU2)
38909      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38910       PHKT(3,9+IIGLU1+IIGLU2)
38911      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38912       PHKT(4,9+IIGLU1+IIGLU2)
38913      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38914       XMIST
38915      *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38916      * -PHKT(2,9+IIGLU1+IIGLU2)**2
38917      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38918       IF(XMIST.GE.0.D0)THEN
38919       PHKT(5,9+IIGLU1+IIGLU2)
38920      *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38921      * -PHKT(2,9+IIGLU1+IIGLU2)**2
38922      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38923       ELSE
38924 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38925        PHKT(5,1)=0.D0
38926       ENDIF
38927       IF(IPIP.GE.3)THEN
38928 C     IF(NUMEV.EQ.-324)THEN
38929       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38930      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38931      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38932       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38933       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38934      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38935      * JDAHKT(1,IIG),
38936      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38937    91 CONTINUE
38938       WRITE(LOUT,*)8+IIGLU1+IIGLU2,
38939      * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
38940      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38941      *JDAHKT(1,8+IIGLU1+IIGLU2),
38942      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38943       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38944      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38945      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38946      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38947       ENDIF
38948       CHAMAL=CHAB1
38949       IF(IPIP.EQ.1)THEN
38950         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38951       ELSEIF(IPIP.EQ.2)THEN
38952         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38953       ENDIF
38954       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38955 C       IREJ=1
38956         IPCO=0
38957 C       RETURN
38958 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
38959 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
38960         GO TO 3466
38961       ENDIF
38962       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
38963       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
38964       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
38965       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
38966       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
38967       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
38968       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
38969       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
38970 C
38971       IPCO=0
38972       IGCOUN=9+IIGLU1+IIGLU2
38973        RETURN
38974        END
38975
38976 *$ CREATE MGSQBS1.FOR
38977 *COPY MGSQBS1
38978 C
38979 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38980       SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38981      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
38982 C
38983 C                  GSQBS-1 diagram (split projectile diquark)
38984 C
38985       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38986       SAVE
38987
38988       PARAMETER ( LINP = 10 ,
38989      &            LOUT = 6 ,
38990      &            LDAT = 9 )
38991 * event history
38992       PARAMETER (NMXHKK=200000)
38993       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38994      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38995      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38996 * extended event history
38997       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38998      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38999      &                IHIST(2,NMXHKK)
39000 * Lorentz-parameters of the current interaction
39001       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
39002      &                UMO,PPCM,EPROJ,PPROJ
39003 * diquark-breaking mechanism
39004       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
39005
39006 C
39007       PARAMETER (NTMHKK= 300)
39008       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39009      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39010      +(4,NTMHKK)
39011 *KEEP,XSEADI.
39012       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
39013      +SSMIMQ,VVMTHR
39014 *KEEP,DPRIN.
39015       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
39016 C
39017 C                  GSQBS-1 diagram (split projectile diquark)
39018 C
39019 C
39020 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
39021 C     Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
39022 C
39023 C     Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
39024 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39025 C
39026 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39027 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39028 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39029 C
39030 C       Put new chains into COMMON /HKKTMP/
39031 C
39032       IIGLU1=NC1T-NC1P-1
39033       IIGLU2=NC2T-NC2P-1
39034       IGCOUN=0
39035 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
39036       CVQ=1.D0
39037       NNNC1=IDHKK(NC1)/1000
39038       MMMC1=IDHKK(NC1)-NNNC1*1000
39039       KKKC1=ISTHKK(NC1)
39040       NNNC2=IDHKK(NC2)/1000
39041       MMMC2=IDHKK(NC2)-NNNC2*1000
39042       KKKC2=ISTHKK(NC2)
39043       IREJ=0
39044       IF(IPIP.EQ.3)THEN
39045       WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
39046      *             ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
39047      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
39048      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
39049       ENDIF
39050 C
39051 C
39052 C
39053 C     determine x-values of NC1P diquark
39054       XDIQP=PHKK(4,NC1P)*2.D0/UMO
39055       XVQT=PHKK(4,NC1T)*2.D0/UMO
39056 C
39057 C     determine x-values of sea quark pair
39058 C
39059       IPCO=1
39060       ICOU=0
39061  2234 CONTINUE
39062       ICOU=ICOU+1
39063       IF(ICOU.GE.500)THEN
39064         IREJ=1
39065         IF(ISQ.EQ.3)IREJ=3
39066         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
39067       IPCO=0
39068         RETURN
39069       ENDIF
39070       IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
39071      * UMO, XDIQP,XVQT
39072       XSQ=0.D0
39073       XSAQ=0.D0
39074 **NEW
39075 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
39076       IF (IPIP.EQ.1) THEN
39077          XQMAX  = XDIQP/2.0D0
39078          XAQMAX = 2.D0*XVQT/3.0D0
39079       ELSE
39080          XQMAX  = 2.D0*XVQT/3.0D0
39081          XAQMAX = XDIQP/2.0D0
39082       ENDIF
39083       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
39084       ISAQ = 6+ISQ
39085 C     write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
39086 **
39087         IF(IPCO.GE.3)
39088      &     WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39089       IF(IREJ.GE.1)THEN
39090         IF(IPCO.GE.3)
39091      &     WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39092       IPCO=0
39093         RETURN
39094       ENDIF
39095       IF(IPIP.EQ.1)THEN
39096         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39097       ELSEIF(IPIP.EQ.2)THEN
39098         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39099       ENDIF
39100       IF(IPCO.GE.3)THEN
39101         WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
39102      *  XDIQP,XVQT,XSQ,XSAQ
39103       ENDIF
39104 C
39105 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
39106 C
39107 C     XSQ=0.D0
39108       IF(IPIP.EQ.1)THEN
39109         XDIQP=XDIQP-XSQ
39110 **NEW
39111 C       IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
39112 **
39113         XVQT =XVQT -XSAQ
39114       ELSEIF(IPIP.EQ.2)THEN
39115         XDIQP=XDIQP-XSAQ
39116         XVQT =XVQT -XSQ
39117       ENDIF
39118       IF(IPCO.GE.3)
39119      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
39120 C
39121 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39122 C
39123       XVTHRO=CVQ/UMO
39124       IVTHR=0
39125  3466 CONTINUE
39126       IF(IVTHR.EQ.10)THEN
39127         IREJ=1
39128         IF(ISQ.EQ.3)IREJ=3
39129         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
39130       IPCO=0
39131         RETURN
39132       ENDIF
39133       IVTHR=IVTHR+1
39134       XVTHR=XVTHRO/(201-IVTHR)
39135       UNOPRV=UNON
39136  380  CONTINUE
39137       IF(XVTHR.GT.0.66D0*XDIQP)THEN
39138         IREJ=1
39139         IF(ISQ.EQ.3)IREJ=3
39140         IF(IPCO.GE.3)
39141      &     WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR  large ',
39142      *  XVTHR
39143       IPCO=0
39144         RETURN
39145       ENDIF
39146       IF(DT_RNDM(V).LT.0.5D0)THEN
39147         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39148         XVPQII=XDIQP-XVPQI
39149       ELSE
39150         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39151         XVPQI=XDIQP-XVPQII
39152       ENDIF
39153       IF(IPCO.GE.3)THEN
39154         WRITE(LOUT,'(A,4E12.4)')'  MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
39155      *  XVTHR,XDIQP,XVPQI,XVPQII
39156       ENDIF
39157 C
39158 C     Prepare 4 momenta of new chains and chain ends
39159 C
39160 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39161 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39162 C    +(4,NTMHKK)
39163 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39164 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39165 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39166       IF(IPIP.EQ.1)THEN
39167         XSQ1=XSQ
39168         XSAQ1=XSAQ
39169         ISQ1=ISQ
39170         ISAQ1=ISAQ
39171       ELSEIF(IPIP.EQ.2)THEN
39172         XSQ1=XSAQ
39173         XSAQ1=XSQ
39174         ISQ1=ISAQ
39175         ISAQ1=ISQ
39176       ENDIF
39177       KK11=IP11
39178 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39179       KK21= IPP21
39180       KK22= IPP22
39181       XGIVE=0.D0
39182       IDHKT(4+IIGLU1)   =IP12
39183       ISTHKT(4+IIGLU1)  =921
39184       JMOHKT(1,4+IIGLU1)=NC1P
39185       JMOHKT(2,4+IIGLU1)=0
39186       JDAHKT(1,4+IIGLU1)=6+IIGLU1
39187       JDAHKT(2,4+IIGLU1)=0
39188 **NEW
39189       IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
39190      &    (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
39191 **
39192       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
39193       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
39194       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
39195       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
39196 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
39197       XXMIST=(PHKT(4,4+IIGLU1)**2-
39198      *              PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
39199      *              PHKT(1,4+IIGLU1)**2)
39200       IF(XXMIST.GT.0.D0)THEN
39201         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
39202       ELSE
39203         WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
39204         XXMIST=ABS(XXMIST)
39205         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
39206       ENDIF
39207       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
39208       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
39209       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
39210       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
39211       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
39212       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
39213       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
39214       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
39215       IF(IPIP.EQ.1)THEN
39216         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
39217       ELSEIF(IPIP.EQ.2)THEN
39218         IDHKT(5+IIGLU1)   =ISAQ1
39219       ENDIF
39220       ISTHKT(5+IIGLU1)  =922
39221       JMOHKT(1,5+IIGLU1)=NC1T
39222       JMOHKT(2,5+IIGLU1)=0
39223       JDAHKT(1,5+IIGLU1)=6+IIGLU1
39224       JDAHKT(2,5+IIGLU1)=0
39225 **NEW
39226       IF ((XSAQ1.LT.0.0D0).OR.(XVQT  .LT.0.0D0))
39227      &    WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
39228 **
39229       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
39230       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
39231       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
39232       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
39233 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
39234       XMIST=(PHKT(4,5+IIGLU1)**2-
39235      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39236      *PHKT(1,5+IIGLU1)**2)
39237       IF(XMIST.GT.0.D0)THEN
39238       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
39239      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39240      *PHKT(1,5+IIGLU1)**2)
39241       ELSE
39242 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
39243         PHKT(5,5+IIGLU1)=0.D0
39244       ENDIF
39245       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
39246       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
39247       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
39248       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
39249       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
39250       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
39251       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
39252       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
39253       IDHKT(6+IIGLU1)   =88888
39254 C     IDHKT(6)   =1000*NNNC1+MMMC1
39255       ISTHKT(6+IIGLU1)  =93
39256 C     ISTHKT(6)  =KKKC1
39257       JMOHKT(1,6+IIGLU1)=4+IIGLU1
39258       JMOHKT(2,6+IIGLU1)=5+IIGLU1
39259       JDAHKT(1,6+IIGLU1)=0
39260       JDAHKT(2,6+IIGLU1)=0
39261       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
39262       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
39263       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
39264       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
39265       PHKT(5,6+IIGLU1)
39266      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
39267      *            -PHKT(3,6+IIGLU1)**2)
39268       CHAMAL=CHAM1
39269       IF(IPIP.EQ.1)THEN
39270         IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
39271       ELSEIF(IPIP.EQ.2)THEN
39272         IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
39273       ENDIF
39274       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
39275         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
39276 C                    we drop chain 6 and give the energy to chain 3
39277           IDHKT(6+IIGLU1)=33888
39278           XGIVE=1.D0
39279 C         WRITE(6,*)' drop chain 6 xgive=1'
39280           GO TO 7788
39281         ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
39282 C                    we drop chain 6 and give the energy to chain 3
39283 C                    and change KK11 to IDHKT(4)
39284           IDHKT(6+IIGLU1)=33888
39285           XGIVE=1.D0
39286 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
39287           KK11=IDHKT(4+IIGLU1)
39288           GO TO 7788
39289         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
39290 C                    we drop chain 6 and give the energy to chain 3
39291 C                    and change KK21 to IDHKT(4)
39292 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39293           IDHKT(6+IIGLU1)=33888
39294           XGIVE=1.D0
39295 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
39296           KK21=IDHKT(4+IIGLU1)
39297           GO TO 7788
39298         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
39299 C                    we drop chain 6 and give the energy to chain 3
39300 C                    and change KK22 to IDHKT(4)
39301 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39302           IDHKT(6+IIGLU1)=33888
39303           XGIVE=1.D0
39304 C         WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
39305           KK22=IDHKT(4+IIGLU1)
39306           GO TO 7788
39307         ENDIF
39308 C       IREJ=1
39309         IPCO=0
39310 C       RETURN
39311 C       WRITE(6,*)' MGSQBS1 jump back from chain 6'
39312         GO TO 3466
39313       ENDIF
39314  7788 CONTINUE
39315       IF(IPIP.GE.3)THEN
39316       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
39317      * JMOHKT(1,4+IIGLU1),
39318      * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
39319      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
39320       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
39321      * JMOHKT(1,5+IIGLU1),
39322      * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
39323      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
39324       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
39325      * JMOHKT(1,6+IIGLU1),
39326      * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
39327      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
39328       ENDIF
39329       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
39330       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
39331       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
39332       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
39333       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
39334       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
39335       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
39336       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
39337 C     IDHKT(1)   =IP11
39338       IDHKT(1)   =KK11
39339       ISTHKT(1)  =921
39340       JMOHKT(1,1)=NC1P
39341       JMOHKT(2,1)=0
39342       JDAHKT(1,1)=3+IIGLU1
39343       JDAHKT(2,1)=0
39344       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
39345 C    * +0.5D0*PHKK(1,NC2P)
39346      *+XGIVE*PHKT(1,4+IIGLU1)
39347       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
39348 C    * +0.5D0*PHKK(2,NC2P)
39349      *+XGIVE*PHKT(2,4+IIGLU1)
39350       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
39351 C    * +0.5D0*PHKK(3,NC2P)
39352      *+XGIVE*PHKT(3,4+IIGLU1)
39353       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
39354 C    * +0.5D0*PHKK(4,NC2P)
39355      *+XGIVE*PHKT(4,4+IIGLU1)
39356 C     PHKT(5,1)  =PHKK(5,NC1P)
39357       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39358      *PHKT(1,1)**2)
39359       IF(XMIST.GE.0.D0)THEN
39360       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39361      *PHKT(1,1)**2)
39362       ELSE
39363 C      WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
39364        PHKT(5,1)=0.D0
39365       ENDIF
39366       VHKT(1,1)  =VHKK(1,NC1P)
39367       VHKT(2,1)  =VHKK(2,NC1P)
39368       VHKT(3,1)  =VHKK(3,NC1P)
39369       VHKT(4,1)  =VHKK(4,NC1P)
39370       WHKT(1,1)  =WHKK(1,NC1P)
39371       WHKT(2,1)  =WHKK(2,NC1P)
39372       WHKT(3,1)  =WHKK(3,NC1P)
39373       WHKT(4,1)  =WHKK(4,NC1P)
39374 C     Add here IIGLU1 gluons to this chaina
39375       PG1=0.D0
39376       PG2=0.D0
39377       PG3=0.D0
39378       PG4=0.D0
39379       IF(IIGLU1.GE.1)THEN
39380       JJG=NC1P
39381       DO 61 IIG=2,2+IIGLU1-1
39382         KKG=JJG+IIG-1
39383         IDHKT(IIG)   =IDHKK(KKG)
39384         ISTHKT(IIG)  =921
39385         JMOHKT(1,IIG)=KKG
39386         JMOHKT(2,IIG)=0
39387         JDAHKT(1,IIG)=3+IIGLU1
39388         JDAHKT(2,IIG)=0
39389         PHKT(1,IIG)=PHKK(1,KKG)
39390         PG1=PG1+ PHKT(1,IIG)
39391         PHKT(2,IIG)=PHKK(2,KKG)
39392         PG2=PG2+ PHKT(2,IIG)
39393         PHKT(3,IIG)=PHKK(3,KKG)
39394         PG3=PG3+ PHKT(3,IIG)
39395         PHKT(4,IIG)=PHKK(4,KKG)
39396         PG4=PG4+ PHKT(4,IIG)
39397         PHKT(5,IIG)=PHKK(5,KKG)
39398         VHKT(1,IIG)  =VHKK(1,KKG)
39399         VHKT(2,IIG)  =VHKK(2,KKG)
39400         VHKT(3,IIG)  =VHKK(3,KKG)
39401         VHKT(4,IIG)  =VHKK(4,KKG)
39402         WHKT(1,IIG)  =WHKK(1,KKG)
39403         WHKT(2,IIG)  =WHKK(2,KKG)
39404         WHKT(3,IIG)  =WHKK(3,KKG)
39405         WHKT(4,IIG)  =WHKK(4,KKG)
39406    61 CONTINUE
39407       ENDIF
39408 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39409       IF(IPIP.EQ.1)THEN
39410         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22+3
39411         IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
39412         IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
39413         IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
39414       ELSEIF(IPIP.EQ.2)THEN
39415         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22-3
39416         IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
39417         IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
39418         IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
39419       ENDIF
39420       ISTHKT(2+IIGLU1)  =922
39421       JMOHKT(1,2+IIGLU1)=NC2T
39422       JMOHKT(2,2+IIGLU1)=0
39423       JDAHKT(1,2+IIGLU1)=3+IIGLU1
39424       JDAHKT(2,2+IIGLU1)=0
39425       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
39426      *+XGIVE*PHKT(1,5+IIGLU1)
39427       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
39428      *+XGIVE*PHKT(2,5+IIGLU1)
39429       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
39430      *+XGIVE*PHKT(3,5+IIGLU1)
39431       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
39432      *+XGIVE*PHKT(4,5+IIGLU1)
39433 C     PHKT(5,2)  =PHKK(5,NC2T)
39434       XMIST=(PHKT(4,2+IIGLU1)**2-
39435      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39436      *PHKT(1,2+IIGLU1)**2)
39437       IF(XMIST.GT.0.D0)THEN
39438       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
39439      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39440      *PHKT(1,2+IIGLU1)**2)
39441       ELSE
39442 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39443       PHKT(5,2+IIGLU1)=0.D0
39444       ENDIF
39445       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
39446       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
39447       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
39448       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
39449       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
39450       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
39451       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
39452       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
39453       IDHKT(3+IIGLU1)   =88888
39454 C     IDHKT(3)   =1000*NNNC1+MMMC1+10
39455       ISTHKT(3+IIGLU1)  =93
39456 C     ISTHKT(3)  =KKKC1
39457       JMOHKT(1,3+IIGLU1)=1
39458       JMOHKT(2,3+IIGLU1)=2+IIGLU1
39459       JDAHKT(1,3+IIGLU1)=0
39460       JDAHKT(2,3+IIGLU1)=0
39461       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
39462       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
39463       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
39464       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
39465       PHKT(5,3+IIGLU1)
39466      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
39467      *            -PHKT(3,3+IIGLU1)**2)
39468       IF(IPIP.GE.3)THEN
39469       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
39470      * JDAHKT(1,1),
39471      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
39472       DO 71 IIG=2,2+IIGLU1-1
39473       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39474      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
39475      * JDAHKT(1,IIG),
39476      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39477    71 CONTINUE
39478       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
39479      &             IDHKT(2),JMOHKT(1,2+IIGLU1),
39480      * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
39481      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
39482       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
39483      * JMOHKT(1,3+IIGLU1),
39484      * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
39485      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
39486       ENDIF
39487       CHAMAL=CHAB1
39488 **NEW
39489 C     IF(IPIP.EQ.1)THEN
39490 C       IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
39491 C     ELSEIF(IPIP.EQ.2)THEN
39492 C       IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
39493 C     ENDIF
39494       IF(IPIP.EQ.1)THEN
39495         IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
39496       ELSEIF(IPIP.EQ.2)THEN
39497         IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
39498       ENDIF
39499 **
39500       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
39501 C       IREJ=1
39502         IPCO=0
39503 C       RETURN
39504 C       WRITE(6,*)' MGSQBS1 jump back from chain 3'
39505         GO TO 3466
39506       ENDIF
39507       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
39508       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
39509       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
39510       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
39511       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
39512       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
39513       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
39514       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
39515       IF(IPIP.EQ.1)THEN
39516         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ1+3
39517         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
39518         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
39519         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
39520       ELSEIF(IPIP.EQ.2)THEN
39521         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
39522         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
39523         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
39524         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
39525 C       WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
39526       ENDIF
39527       ISTHKT(7+IIGLU1)  =921
39528       JMOHKT(1,7+IIGLU1)=NC2P
39529       JMOHKT(2,7+IIGLU1)=0
39530       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
39531       JDAHKT(2,7+IIGLU1)=0
39532 C     PHKT(1,7)  =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
39533 C     PHKT(2,7)  =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
39534 C     PHKT(3,7)  =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
39535 C     PHKT(4,7+IIGLU1)  =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
39536 **NEW
39537       IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
39538      &    WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
39539 **
39540       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
39541       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
39542       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
39543       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
39544 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
39545 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
39546       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
39547 C       IREJ=1
39548 C       WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
39549         IPCO=0
39550 C       RETURN
39551         GO TO 3466
39552       ENDIF
39553 C     PHKT(5,7)  =PHKK(5,NC2P)
39554       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
39555      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
39556      *PHKT(1,7+IIGLU1)**2)
39557       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
39558       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
39559       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
39560       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
39561       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
39562       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
39563       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
39564       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
39565 C     Insert here the IIGLU2 gluons
39566       PG1=0.D0
39567       PG2=0.D0
39568       PG3=0.D0
39569       PG4=0.D0
39570       IF(IIGLU2.GE.1)THEN
39571       JJG=NC2P
39572       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39573         KKG=JJG+IIG-7-IIGLU1
39574         IDHKT(IIG)   =IDHKK(KKG)
39575         ISTHKT(IIG)  =921
39576         JMOHKT(1,IIG)=KKG
39577         JMOHKT(2,IIG)=0
39578         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
39579         JDAHKT(2,IIG)=0
39580         PHKT(1,IIG)=PHKK(1,KKG)
39581         PG1=PG1+ PHKT(1,IIG)
39582         PHKT(2,IIG)=PHKK(2,KKG)
39583         PG2=PG2+ PHKT(2,IIG)
39584         PHKT(3,IIG)=PHKK(3,KKG)
39585         PG3=PG3+ PHKT(3,IIG)
39586         PHKT(4,IIG)=PHKK(4,KKG)
39587         PG4=PG4+ PHKT(4,IIG)
39588         PHKT(5,IIG)=PHKK(5,KKG)
39589         VHKT(1,IIG)  =VHKK(1,KKG)
39590         VHKT(2,IIG)  =VHKK(2,KKG)
39591         VHKT(3,IIG)  =VHKK(3,KKG)
39592         VHKT(4,IIG)  =VHKK(4,KKG)
39593         WHKT(1,IIG)  =WHKK(1,KKG)
39594         WHKT(2,IIG)  =WHKK(2,KKG)
39595         WHKT(3,IIG)  =WHKK(3,KKG)
39596         WHKT(4,IIG)  =WHKK(4,KKG)
39597    81 CONTINUE
39598       ENDIF
39599       IDHKT(8+IIGLU1+IIGLU2)   =IP2
39600       ISTHKT(8+IIGLU1+IIGLU2)  =922
39601       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
39602       JMOHKT(2,8+IIGLU1+IIGLU2)=0
39603       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
39604       JDAHKT(2,8+IIGLU1+IIGLU2)=0
39605 **NEW
39606       IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
39607      &    WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
39608 **
39609       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
39610       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
39611       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
39612       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
39613 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
39614       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
39615      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39616      *PHKT(1,8+IIGLU1+IIGLU2)**2)
39617       IF(XMIST.GT.0.D0)THEN
39618       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
39619      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39620      *PHKT(1,8+IIGLU1+IIGLU2)**2)
39621       ELSE
39622 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39623       PHKT(5,8+IIGLU1+IIGLU2)=0.D0
39624       ENDIF
39625       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
39626       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
39627       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
39628       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
39629       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
39630       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
39631       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
39632       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
39633       IDHKT(9+IIGLU1+IIGLU2)   =88888
39634 C     IDHKT(9)   =1000*NNNC2+MMMC2+10
39635       ISTHKT(9+IIGLU1+IIGLU2)  =93
39636 C     ISTHKT(9)  =KKKC2
39637       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
39638       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
39639       JDAHKT(1,9+IIGLU1+IIGLU2)=0
39640       JDAHKT(2,9+IIGLU1+IIGLU2)=0
39641       PHKT(1,9+IIGLU1+IIGLU2)  =PHKT(1,7+IIGLU1)
39642      * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
39643       PHKT(2,9+IIGLU1+IIGLU2)  =PHKT(2,7+IIGLU1)
39644      * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
39645       PHKT(3,9+IIGLU1+IIGLU2)  =PHKT(3,7+IIGLU1)
39646      * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
39647       PHKT(4,9+IIGLU1+IIGLU2)  =PHKT(4,7+IIGLU1)
39648      * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
39649       PHKT(5,9+IIGLU1+IIGLU2)
39650      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
39651      * PHKT(2,9+IIGLU1+IIGLU2)**2
39652      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
39653       IF(IPIP.GE.3)THEN
39654       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
39655      * JMOHKT(1,7+IIGLU1),
39656      * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
39657      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
39658       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39659       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39660      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
39661      * JDAHKT(1,IIG),
39662      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39663    91 CONTINUE
39664       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
39665      * IDHKT(8+IIGLU1+IIGLU2),
39666      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
39667      * JDAHKT(1,8+IIGLU1+IIGLU2),
39668      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
39669       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
39670      * IDHKT(9+IIGLU1+IIGLU2),
39671      * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
39672      * JDAHKT(1,9+IIGLU1+IIGLU2),
39673      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
39674       ENDIF
39675       CHAMAL=CHAB1
39676       IF(IPIP.EQ.1)THEN
39677         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
39678       ELSEIF(IPIP.EQ.2)THEN
39679         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
39680       ENDIF
39681       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
39682 C       IREJ=1
39683         IPCO=0
39684 C       RETURN
39685 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
39686 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
39687         GO TO 3466
39688       ENDIF
39689       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
39690       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
39691       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
39692       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
39693       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
39694       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
39695       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
39696       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
39697 C
39698       IGCOUN=9+IIGLU1+IIGLU2
39699       IPCO=0
39700        RETURN
39701        END
39702
39703 *$ CREATE HKKHKT.FOR
39704 *COPY HKKHKT
39705 C
39706 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
39707 C
39708       SUBROUTINE HKKHKT(I,J)
39709       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39710       SAVE
39711
39712 * event history
39713       PARAMETER (NMXHKK=200000)
39714       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39715      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39716      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39717 * extended event history
39718       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39719      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39720      &                IHIST(2,NMXHKK)
39721
39722       PARAMETER (NTMHKK= 300)
39723       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39724      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39725      +(4,NTMHKK)
39726 C
39727       ISTHKK(I)  =ISTHKT(J)
39728       IDHKK(I)   =IDHKT(J)
39729 C     IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
39730       IF(IDHKK(I).EQ.88888)THEN
39731 C       JMOHKK(1,I)=I-2
39732 C       JMOHKK(2,I)=I-1
39733         JMOHKK(1,I)=I-(J-JMOHKT(1,J))
39734         JMOHKK(2,I)=I-(J-JMOHKT(2,J))
39735       ELSE
39736         JMOHKK(1,I)=JMOHKT(1,J)
39737         JMOHKK(2,I)=JMOHKT(2,J)
39738       ENDIF
39739       JDAHKK(1,I)=JDAHKT(1,J)
39740       JDAHKK(2,I)=JDAHKT(2,J)
39741 C       IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
39742 C       JDAHKK(1,I)=I+2
39743 C     ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
39744 C       JDAHKK(1,I)=I+1
39745 C     ENDIF
39746       IF(JDAHKT(1,J).GT.0)THEN
39747         JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
39748       ENDIF
39749       PHKK(1,I)  =PHKT(1,J)
39750       PHKK(2,I)  =PHKT(2,J)
39751       PHKK(3,I)  =PHKT(3,J)
39752       PHKK(4,I)  =PHKT(4,J)
39753       PHKK(5,I)  =PHKT(5,J)
39754       VHKK(1,I)  =VHKT(1,J)
39755       VHKK(2,I)  =VHKT(2,J)
39756       VHKK(3,I)  =VHKT(3,J)
39757       VHKK(4,I)  =VHKT(4,J)
39758       WHKK(1,I)  =WHKT(1,J)
39759       WHKK(2,I)  =WHKT(2,J)
39760       WHKK(3,I)  =WHKT(3,J)
39761       WHKK(4,I)  =WHKT(4,J)
39762       RETURN
39763       END
39764
39765 *$ CREATE DT_DBREAK.FOR
39766 *COPY DT_DBREAK
39767 *
39768 *===dbreak=============================================================*
39769 *
39770       SUBROUTINE DT_DBREAK(MODE)
39771
39772 ************************************************************************
39773 * This is the steering subroutine for the different diquark breaking   *
39774 * mechanisms.                                                          *
39775 *                                                                      *
39776 * MODE = 1  breaking of projectile diquark in qq-q chain using         *
39777 *           a sea quark (q-qq chain) of the same projectile            *
39778 *      = 2  breaking of target     diquark in q-qq chain using         *
39779 *           a sea quark (qq-q chain) of the same target                *
39780 *      = 3  breaking of projectile diquark in qq-q chain using         *
39781 *           a sea quark (q-aq chain) of the same projectile            *
39782 *      = 4  breaking of target     diquark in q-qq chain using         *
39783 *           a sea quark (aq-q chain) of the same target                *
39784 *      = 5  breaking of projectile anti-diquark in aqaq-aq chain using *
39785 *           a sea anti-quark (aq-aqaq chain) of the same projectile    *
39786 *      = 6  breaking of target     anti-diquark in aq-aqaq chain using *
39787 *           a sea anti-quark (aqaq-aq chain) of the same target        *
39788 *      = 7  breaking of projectile anti-diquark in aqaq-aq chain using *
39789 *           a sea anti-quark (aq-q chain) of the same projectile       *
39790 *      = 8  breaking of target     anti-diquark in aq-aqaq chain using *
39791 *           a sea anti-quark (q-aq chain) of the same target           *
39792 *                                                                      *
39793 * Original version by J. Ranft.                                        *
39794 * This version dated 17.5.00  is written by S. Roesler.                *
39795 ************************************************************************
39796
39797       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39798       SAVE
39799       PARAMETER ( LINP = 10 ,
39800      &            LOUT = 6 ,
39801      &            LDAT = 9 )
39802
39803 * event history
39804       PARAMETER (NMXHKK=200000)
39805       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39806      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39807      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39808 * extended event history
39809       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39810      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39811      &                IHIST(2,NMXHKK)
39812 * flags for input different options
39813       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
39814       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
39815      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
39816 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
39817       PARAMETER (MAXCHN=10000)
39818       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
39819 * diquark-breaking mechanism
39820       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
39821 * flags for particle decays
39822       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
39823      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
39824      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
39825
39826 *
39827 * chain identifiers
39828 * ( 1 = q-aq,   2 = aq-q,   3 = q-qq,   4 = qq-q,
39829 *   5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
39830       DIMENSION IDCHN1(8),IDCHN2(8)
39831       DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
39832       DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
39833 *
39834 * parton identifiers
39835 * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
39836 *   +-51/52 = unitarity-sea, +-61/62 = gluons )
39837       DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
39838       DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
39839      &             31, 31, 31, 31, 31, 31, 31, 31,
39840      &             41, 41, 41, 41, 51, 51, 51, 51/
39841       DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
39842      &             32, 32, 32, 32, 32, 32, 32, 32,
39843      &             42, 42, 42, 42, 52, 52, 52, 52/
39844       DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
39845      &             51, 31, 41, 41, 31, 31, 31, 31,
39846      &              0, 41, 51, 51, 51, 51, 51, 51/
39847       DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
39848      &             32, 52, 42, 42, 32, 32, 32, 32,
39849      &             42,  0, 52, 52, 52, 52, 52, 52/
39850
39851       IF (NCHAIN.LE.0) RETURN
39852       DO 1 I=1,NCHAIN
39853          IDX1 = IDXCHN(1,I)
39854          IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
39855          IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
39856          IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
39857      &       .AND.
39858      &        ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
39859      &                                    (IS1P.EQ.ISP1P(MODE,3)))
39860      &       .AND.
39861      &        ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
39862      &                                    (IS1T.EQ.ISP1T(MODE,3)))
39863      &      ) THEN
39864             DO 2 J=1,NCHAIN
39865                IDX2 = IDXCHN(1,J)
39866                IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
39867                IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
39868                IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
39869      &             .AND.
39870      &              ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
39871      &                                      .OR.(IS2P.EQ.ISP2P(MODE,3)))
39872      &             .AND.
39873      &              ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
39874      &                                      .OR.(IS2T.EQ.ISP2T(MODE,3)))
39875      &            ) THEN
39876 *   find mother nucleons of the diquark to be splitted and of the
39877 *   sea-quark and reject this combination if it is not the same
39878                   IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
39879      &                (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
39880                      IANCES = 1
39881                   ELSE
39882                      IANCES = 2
39883                   ENDIF
39884                   IDXMO1 = JMOHKK(IANCES,IDX1)
39885     4             CONTINUE
39886                   IF ((JMOHKK(1,IDXMO1).NE.0).AND.
39887      &                (JMOHKK(2,IDXMO1).NE.0)) THEN
39888                      IANC = IANCES
39889                   ELSE
39890                      IANC = 1
39891                   ENDIF
39892                   IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
39893                      IDXMO1 = JMOHKK(IANC,IDXMO1)
39894                      GOTO 4
39895                   ENDIF
39896                   IDXMO2 = JMOHKK(IANCES,IDX2)
39897     5             CONTINUE
39898                   IF ((JMOHKK(1,IDXMO2).NE.0).AND.
39899      &                (JMOHKK(2,IDXMO2).NE.0)) THEN
39900                      IANC = IANCES
39901                   ELSE
39902                      IANC = 1
39903                   ENDIF
39904                   IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
39905                      IDXMO2 = JMOHKK(IANC,IDXMO2)
39906                      GOTO 5
39907                   ENDIF
39908                   IF (IDXMO1.NE.IDXMO2) GOTO 2
39909 *   quark content of projectile parton
39910                   IP1   = IDHKK(JMOHKK(1,IDX1))
39911                   IP11  = IP1/1000
39912                   IP12  = (IP1-1000*IP11)/100
39913                   IP2   = IDHKK(JMOHKK(2,IDX1))
39914                   IP21  = IP2/1000
39915                   IP22  = (IP2-1000*IP21)/100
39916 *   quark content of target parton
39917                   IT1  = IDHKK(JMOHKK(1,IDX2))
39918                   IT11 = IT1/1000
39919                   IT12 = (IT1-1000*IT11)/100
39920                   IT2  = IDHKK(JMOHKK(2,IDX2))
39921                   IT21 = IT2/1000
39922                   IT22 = (IT2-1000*IT21)/100
39923 *   split diquark and form new chains
39924                   IF (MODE.EQ.1) THEN
39925                      IF (IT1.EQ.4) GOTO 2
39926                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39927      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39928      &                         IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
39929                   ELSEIF (MODE.EQ.2) THEN
39930                      IF (IT2.EQ.4) GOTO 2
39931                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39932      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39933      &                         IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
39934                   ELSEIF (MODE.EQ.3) THEN
39935                      IF (IT1.EQ.4) GOTO 2
39936                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39937      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39938      &                         IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
39939                   ELSEIF (MODE.EQ.4) THEN
39940                      IF (IT2.EQ.4) GOTO 2
39941                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39942      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39943      &                         IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
39944                   ELSEIF (MODE.EQ.5) THEN
39945                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39946      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39947      &                         IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
39948                   ELSEIF (MODE.EQ.6) THEN
39949                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39950      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39951      &                         IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
39952                   ELSEIF (MODE.EQ.7) THEN
39953                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39954      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39955      &                         IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
39956                   ELSEIF (MODE.EQ.8) THEN
39957                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39958      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39959      &                         IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
39960                   ENDIF
39961                   IF (IREJ.GE.1) THEN
39962                      if ((ipq.lt.0).or.(ipq.ge.4))
39963      &                  write(LOUT,*) 'ipq !!!',ipq,mode
39964                      DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
39965 *   accept or reject new chains corresponding to PDBSEA
39966                   ELSE
39967                      IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
39968                         ACC   = DBRKA(1,MODE)+DBRKA(2,MODE)
39969                         REJ   = DBRKR(1,MODE)+DBRKR(2,MODE)
39970                      ELSEIF (IPQ.EQ.3) THEN
39971                         ACC   = DBRKA(3,MODE)
39972                         REJ   = DBRKR(3,MODE)
39973                      ELSE
39974                         WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
39975                         STOP
39976                      ENDIF
39977                      IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
39978                         DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
39979                         IACC = 1
39980                      ELSE
39981                         DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
39982                         IACC = 0
39983                      ENDIF
39984 *   new chains have been accepted and are now copied into HKKEVT
39985                      IF (IACC.EQ.1) THEN
39986                         IF (LEMCCK) THEN
39987                            CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
39988      &                                    PHKK(3,IDX1),PHKK(4,IDX1),
39989      &                                    1,IDUM1,IDUM2)
39990                            CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
39991      &                                    PHKK(3,IDX2),PHKK(4,IDX2),
39992      &                                    2,IDUM1,IDUM2)
39993                         ENDIF
39994                         IDHKK(IDX1) = 99888
39995                         IDHKK(IDX2) = 99888
39996                         IDXCHN(2,I) = -1
39997                         IDXCHN(2,J) = -1
39998                         DO 3 K=1,IGCOUN
39999                            NHKK = NHKK+1
40000                            CALL HKKHKT(NHKK,K)
40001                            IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
40002                               PX = -PHKK(1,NHKK)
40003                               PY = -PHKK(2,NHKK)
40004                               PZ = -PHKK(3,NHKK)
40005                               PE = -PHKK(4,NHKK)
40006                               CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
40007                            ENDIF
40008     3                   CONTINUE
40009                         IF (LEMCCK) THEN
40010                            CHKLEV = 0.1D0
40011                            CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
40012      &                                                             IREJ)
40013                            IF (IREJ.NE.0) CALL DT_EVTOUT(4)
40014                         ENDIF
40015                         GOTO 1
40016                      ENDIF
40017                   ENDIF
40018                ENDIF
40019     2       CONTINUE
40020          ENDIF
40021     1 CONTINUE
40022       RETURN
40023       END
40024
40025 *$ CREATE DT_CQPAIR.FOR
40026 *COPY DT_CQPAIR
40027 *
40028 *===cqpair=============================================================*
40029 *
40030       SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
40031
40032 ************************************************************************
40033 * This subroutine Creates a Quark-antiquark PAIR from the sea.         *
40034 *                                                                      *
40035 *   XQMAX   maxium energy fraction of quark (input)                    *
40036 *   XAQMAX  maxium energy fraction of antiquark (input)                *
40037 *   XQ      energy fraction of quark (output)                          *
40038 *   XAQ     energy fraction of antiquark (output)                      *
40039 *   IFLV    quark flavour (- antiquark flavor) (output)                *
40040 *                                                                      *
40041 * This version dated 14.5.00  is written by S. Roesler.                *
40042 ************************************************************************
40043
40044       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
40045       SAVE
40046       PARAMETER ( LINP = 10 ,
40047      &            LOUT = 6 ,
40048      &            LDAT = 9 )
40049
40050 * Lorentz-parameters of the current interaction
40051       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
40052      &                UMO,PPCM,EPROJ,PPROJ
40053
40054 *
40055       IREJ = 0
40056       XQ   = 0.0D0
40057       XAQ  = 0.0D0
40058 *
40059 * sample quark flavour
40060 *
40061 *  set seasq here (the one from DTCHAI should be used in the future)
40062       SEASQ = 0.5D0
40063       IFLV  = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
40064 *
40065 * sample energy fractions of sea pair
40066 * we first sample the energy fraction of a gluon and then split the gluon
40067 *
40068 *  maximum energy fraction of the gluon forced via input
40069       XGMAXI = XQMAX+XAQMAX
40070 *  minimum energy fraction of the gluon
40071       XTHR1 = 4.0D0 /UMO**2
40072       XTHR2 = 0.54D0/UMO**1.5D0
40073       XGMIN = MAX(XTHR1,XTHR2)
40074 *  maximum energy fraction of the gluon
40075       XGMAX = 0.3D0
40076       XGMAX = MIN(XGMAXI,XGMAX)
40077       IF (XGMIN.GE.XGMAX) THEN
40078          IREJ = 1
40079          RETURN
40080       ENDIF
40081 *
40082 *  sample energy fraction of the gluon
40083       NLOOP = 0
40084     1 CONTINUE
40085       NLOOP = NLOOP+1
40086       IF (NLOOP.GE.50) THEN
40087          IREJ = 1
40088          RETURN
40089       ENDIF
40090       XGLUON = DT_SAMSQX(XGMIN,XGMAX)
40091       EGLUON = XGLUON*UMO/2.0D0
40092 *
40093 *  split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
40094       ZMIN = MIN(0.1D0,0.5D0/EGLUON)
40095       ZMAX = 1.0D0-ZMIN
40096       RZ   = DT_RNDM(ZMAX)
40097       XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
40098       RQ   = DT_RNDM(ZMAX)
40099       IF (RQ.LT.0.5D0) THEN
40100          XQ  = XGLUON*XHLP
40101          XAQ = XGLUON-XQ
40102       ELSE
40103          XAQ = XGLUON*XHLP
40104          XQ  = XGLUON-XAQ
40105       ENDIF
40106       IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1
40107
40108       RETURN
40109       END