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. (IT.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
2170       PARAMETER (NMXHEP=4000)
2171       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2172      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
2173      &                VHEP(4,NMXHEP), NSD1, NSD2, NDD
2174
2175       PARAMETER (NMXHKK=200000)
2176       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2177      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2178      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2179 * extended event history
2180       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2181      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2182      &                IHIST(2,NMXHKK)
2183 * particle properties (BAMJET index convention)
2184       CHARACTER*8  ANAME
2185       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2186      &                IICH(210),IIBAR(210),K1(210),K2(210)
2187 * properties of interacting particles
2188       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2189 * Lorentz-parameters of the current interaction
2190       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
2191      &                UMO,PPCM,EPROJ,PPROJ
2192 * flags for input different options
2193       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2194       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2195      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2196 * flags for particle decays
2197       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2198      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2199      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2200 * cuts for variable energy runs
2201       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2202 * Glauber formalism: flags and parameters for statistics
2203       LOGICAL LPROD
2204       CHARACTER*8 CGLB
2205       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2206
2207       DIMENSION WHAT(6)
2208
2209       IREJ  = 0
2210       ILOOP = 0
2211       NSD1  = 0
2212       NSD2  = 0
2213       NDD   = 0
2214   100 CONTINUE
2215       IF (ILOOP.EQ.4) THEN
2216          WRITE(LOUT,1000) NEVHKK
2217  1000    FORMAT(1X,'KKINC: event ',I8,' rejected!')
2218          GOTO 9999
2219       ENDIF
2220       ILOOP = ILOOP+1
2221
2222 * variable energy-runs, recalculate parameters for LT's
2223       IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN
2224          PDUM = ZERO
2225          CDUM = ZERO
2226          CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1)
2227       ENDIF
2228       IF (EPN.GT.EPROJ) THEN
2229          WRITE(LOUT,'(A,E9.3,2A,E9.3,A)')
2230      &      ' Requested energy (',EPN,'GeV) exceeds',
2231      &      ' initialization energy (',EPROJ,'GeV) !'
2232          STOP
2233       ENDIF
2234
2235 * re-initialize /DTPRTA/
2236       IP  = NPMASS
2237       IPZ = NPCHAR
2238       IT  = NTMASS
2239       ITZ = NTCHAR
2240       IJPROJ = IDP
2241       IBPROJ = IIBAR(IJPROJ)
2242
2243 * calculate nuclear potentials (common /DTNPOT/)
2244       CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
2245
2246 * initialize treatment for residual nuclei
2247       CALL DT_RESNCL(EPN,NLOOP,1)
2248
2249 * sample hadron/nucleus-nucleus interaction
2250       CALL DT_KKEVNT(KKMAT,IREJ1)
2251       IF (IREJ1.GT.0) THEN
2252          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC'
2253          GOTO 9999
2254       ENDIF
2255
2256       IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN
2257
2258 * intranuclear cascade of final state particles for KTAUGE generations
2259 * of secondaries
2260          CALL DT_FOZOCA(LFZC,IREJ1)
2261          IF (IREJ1.GT.0) THEN
2262             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC'
2263             GOTO 9999
2264          ENDIF
2265
2266 * baryons unable to escape the nuclear potential are treated as
2267 * excited nucleons (ISTHKK=15,16)
2268          CALL DT_SCN4BA
2269
2270 * decay of resonances produced in intranuclear cascade processes
2271 **sr 15-11-95 should be obsolete
2272 C        IF (LFZC) CALL DT_DECAY1
2273
2274   101    CONTINUE
2275 * treatment of residual nuclei
2276          CALL DT_RESNCL(EPN,NLOOP,2)
2277
2278 * evaporation / fission / fragmentation
2279 * (if intranuclear cascade was sampled only)
2280          IF (LFZC) THEN
2281             CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1)
2282             IF (IREJ1.GT.1) GOTO 101
2283             IF (IREJ1.EQ.1) GOTO 100
2284          ENDIF
2285
2286       ENDIF
2287
2288 * rejection of unphysical configurations
2289       CALL DT_REJUCO(1,IREJ1)
2290       IF (IREJ1.GT.0) THEN
2291          IF (IOULEV(1).GT.0)
2292      &      WRITE(LOUT,*) 'rejected 3 in KKINC: too large x'
2293          GOTO 100
2294       ENDIF
2295
2296 * transform finale state into Lab.
2297       IFLAG = 2
2298       CALL DT_BEAMPR(WHAT,DUM,IFLAG)
2299       IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB
2300
2301       IF (IPI0.EQ.1) CALL DT_DECPI0
2302
2303 C     IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4)
2304       RETURN
2305  9999 CONTINUE
2306       IREJ = 1
2307
2308       RETURN
2309       END
2310
2311 *$ CREATE DT_DEFAUL.FOR
2312 *COPY DT_DEFAUL
2313 *
2314 *===defaul=============================================================*
2315 *
2316       SUBROUTINE DT_DEFAUL(EPN,PPN)
2317
2318 ************************************************************************
2319 * Variables are set to default values.                                 *
2320 * This version dated 8.5.95 is written by S. Roesler.                  *
2321 ************************************************************************
2322
2323       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2324       SAVE
2325       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
2326       PARAMETER (TWOPI  = 6.283185307179586454D+00)
2327
2328 * particle properties (BAMJET index convention)
2329       CHARACTER*8  ANAME
2330       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2331      &                IICH(210),IIBAR(210),K1(210),K2(210)
2332 * nuclear potential
2333       LOGICAL LFERMI
2334       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
2335      &                EBINDP(2),EBINDN(2),EPOT(2,210),
2336      &                ETACOU(2),ICOUL,LFERMI
2337 * interface HADRIN-DPM
2338       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
2339 * central particle production, impact parameter biasing
2340       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
2341 * properties of interacting particles
2342       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2343 * properties of photon/lepton projectiles
2344       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2345       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2346 * emulsion treatment
2347       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2348      &                NCOMPO,IEMUL
2349 * parameter for intranuclear cascade
2350       LOGICAL LPAULI
2351       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
2352 * various options for treatment of partons (DTUNUC 1.x)
2353 * (chain recombination, Cronin,..)
2354       LOGICAL LCO2CR,LINTPT
2355       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
2356      &                LCO2CR,LINTPT
2357 * threshold values for x-sampling (DTUNUC 1.x)
2358       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
2359      &                SSMIMQ,VVMTHR
2360 * flags for input different options
2361       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2362       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2363      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2364 * n-n cross section fluctuations
2365       PARAMETER (NBINS = 1000)
2366       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
2367 * flags for particle decays
2368       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2369      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2370      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2371 * diquark-breaking mechanism
2372       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
2373 * nucleon-nucleon event-generator
2374       CHARACTER*8 CMODEL
2375       LOGICAL LPHOIN
2376       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2377 * flags for diffractive interactions (DTUNUC 1.x)
2378       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
2379 * VDM parameter for photon-nucleus interactions
2380       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
2381 * Glauber formalism: flags and parameters for statistics
2382       LOGICAL LPROD
2383       CHARACTER*8 CGLB
2384       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2385 * kinematical cuts for lepton-nucleus interactions
2386       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2387      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2388 * flags for activated histograms
2389       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2390 * cuts for variable energy runs
2391       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2392 * parameters for hA-diffraction
2393       COMMON /DTDIHA/ DIBETA,DIALPH
2394 * LEPTO
2395       REAL RPPN
2396       COMMON /LEPTOI/ RPPN,LEPIN,INTER
2397 * steering flags for qel neutrino scattering modules
2398       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
2399 * event flag
2400       COMMON /DTEVNO/ NEVENT,ICASCA
2401
2402       DATA POTMES /0.002D0/
2403
2404 * common /DTNPOT/
2405       DO 10 I=1,2
2406          PFERMP(I) = ZERO
2407          PFERMN(I) = ZERO
2408          EBINDP(I) = ZERO
2409          EBINDN(I) = ZERO
2410          DO 11 J=1,210
2411             EPOT(I,J) = ZERO
2412    11    CONTINUE
2413 * nucleus independent meson potential
2414          EPOT(I,13) = POTMES
2415          EPOT(I,14) = POTMES
2416          EPOT(I,15) = POTMES
2417          EPOT(I,16) = POTMES
2418          EPOT(I,23) = POTMES
2419          EPOT(I,24) = POTMES
2420          EPOT(I,25) = POTMES
2421    10 CONTINUE
2422       FERMOD    = 0.55D0
2423       ETACOU(1) = ZERO
2424       ETACOU(2) = ZERO
2425       ICOUL     = 1
2426       LFERMI    = .TRUE.
2427
2428 * common /HNTHRE/
2429       EHADTH = -99.0D0
2430       EHADLO = 4.06D0
2431       EHADHI = 6.0D0
2432       INTHAD = 1
2433       IDXTA  = 2
2434
2435 * common /DTIMPA/
2436       ICENTR = 0
2437       BIMIN  = ZERO
2438       BIMAX  = 1.0D10
2439       XSFRAC = 1.0D0
2440
2441 * common /DTPRTA/
2442       IP  = 1
2443       IPZ = 1
2444       IT  = 1
2445       ITZ = 1
2446       IJPROJ = 1
2447       IBPROJ = 1
2448       IJTARG = 1
2449       IBTARG = 1
2450 * common /DTGPRO/
2451       VIRT = ZERO
2452       DO 14 I=1,4
2453          PGAMM(I)  = ZERO
2454          PLEPT0(I) = ZERO
2455          PLEPT1(I) = ZERO
2456          PNUCL(I)  = ZERO
2457    14 CONTINUE
2458       IDIREC   = 0
2459
2460 * common /DTFOTI/
2461 **sr 7.4.98: changed after corrected B-sampling
2462 C     TAUFOR = 4.4D0
2463       TAUFOR = 3.5D0
2464       KTAUGE = 25
2465       ITAUVE = 1
2466       INCMOD = 1
2467       LPAULI = .TRUE.
2468
2469 * common /DTCHAI/
2470       SEASQ  = ONE
2471       MKCRON = 1
2472       CRONCO = 0.64D0
2473       ISICHA = 0
2474       CUTOF  = 100.0D0
2475       LCO2CR = .FALSE.
2476       IRECOM = 1
2477       LINTPT = .TRUE.
2478
2479 * common /DTXCUT/
2480 *  definition of soft quark distributions
2481       XSEACU = 0.05D0
2482       UNON   = 2.0D0
2483       UNOM   = 1.5D0
2484       UNOSEA = 5.0D0
2485 *  cutoff parameters for x-sampling
2486       CVQ    = 1.0D0
2487       CDQ    = 2.0D0
2488 C     CSEA   = 0.3D0
2489       CSEA   = 0.1D0
2490       SSMIMA = 1.2D0
2491       SSMIMQ = SSMIMA**2
2492       VVMTHR = 2.0D0
2493
2494 * common /DTXSFL/
2495       IFLUCT = 0
2496
2497 * common /DTFRPA/
2498       PDB = 0.15D0
2499       PDBSEA(1) = 0.0D0
2500       PDBSEA(2) = 0.0D0
2501       PDBSEA(3) = 0.0D0
2502       ISIG0 = 0
2503       IPI0  = 0
2504       NMSTU = 0
2505       NPARU = 0
2506       NMSTJ = 0
2507       NPARJ = 0
2508
2509 * common /DTDIQB/
2510       DO 15 I=1,8
2511          DBRKR(1,I) = 5.0D0
2512          DBRKR(2,I) = 5.0D0
2513          DBRKR(3,I) = 10.0D0
2514          DBRKA(1,I) = ZERO
2515          DBRKA(2,I) = ZERO
2516          DBRKA(3,I) = ZERO
2517    15 CONTINUE
2518       CHAM1 = 0.2D0
2519       CHAM3 = 0.5D0
2520       CHAB1 = 0.7D0
2521       CHAB3 = 1.0D0
2522
2523 * common /DTFLG3/
2524       ISINGD = 0
2525       IDOUBD = 0
2526       IFLAGD = 0
2527       IDIFF  = 0
2528
2529 * common /DTMODL/
2530       MCGENE    = 2
2531       CMODEL(1) = 'DTUNUC  '
2532       CMODEL(2) = 'PHOJET  '
2533       CMODEL(3) = 'LEPTO   '
2534       CMODEL(4) = 'QNEUTRIN'
2535       LPHOIN    = .TRUE.
2536       ELOJET    = 5.0D0
2537
2538 * common /DTLCUT/
2539       ECMIN  = 3.5D0
2540       ECMAX  = 1.0D10
2541       XBJMIN = ZERO
2542       ELMIN = ZERO
2543       EGMIN = ZERO
2544       EGMAX = 1.0D10
2545       YMIN  = TINY10
2546       YMAX  = 0.999D0
2547       Q2MIN = TINY10
2548       Q2MAX = 10.0D0
2549       THMIN = ZERO
2550       THMAX = TWOPI
2551       Q2LI  = ZERO
2552       Q2HI  = 1.0D10
2553       ECMLI = ZERO
2554       ECMHI = 1.0D10
2555
2556 * common /DTVDMP/
2557       RL2       = 2.0D0
2558       INTRGE(1) = 1
2559       INTRGE(2) = 3
2560       IDPDF     = 2212
2561       MODEGA    = 4
2562       ISHAD(1)  = 1
2563       ISHAD(2)  = 1
2564       ISHAD(3)  = 1
2565       EPSPOL    = ZERO
2566
2567 * common /DTGLGP/
2568       JSTATB = 1000
2569       JBINSB = 49
2570       CGLB   = '        '
2571       IF (ITRSPT.EQ.1) THEN
2572          IOGLB  = 100
2573       ELSE
2574          IOGLB  = 0
2575       ENDIF
2576       LPROD  = .TRUE.
2577
2578 * common /DTHIS3/
2579       DO 16 I=1,50
2580          IHISPP(I) = 0
2581          IHISXS(I) = 0
2582    16 CONTINUE
2583       IXSTBL = 0
2584
2585 * common /DTVARE/
2586       VARELO = ZERO
2587       VAREHI = ZERO
2588       VARCLO = ZERO
2589       VARCHI = ZERO
2590
2591 * common /DTDIHA/
2592       DIBETA = -1.0D0
2593       DIALPH = ZERO
2594
2595 * common /LEPTOI/
2596       RPPN  = 0.0
2597       LEPIN = 0
2598       INTER = 0
2599
2600 * common /QNEUTO/
2601       NEUTYP = 1
2602       NEUDEC = 0
2603
2604 * common /DTEVNO/
2605       NEVENT = 1
2606       IF (ITRSPT.EQ.1) THEN
2607          ICASCA = 1
2608       ELSE
2609          ICASCA = 0
2610       ENDIF
2611
2612 * default Lab.-energy
2613       EPN = 200.0D0
2614       PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ)))
2615
2616       RETURN
2617       END
2618
2619 *$ CREATE DT_AAEVT.FOR
2620 *COPY DT_AAEVT
2621 *
2622 *===aaevt==============================================================*
2623 *
2624       SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2625      &                                             IDP,IGLAU)
2626
2627 ************************************************************************
2628 * This version dated 22.03.96 is written by S. Roesler.                *
2629 ************************************************************************
2630
2631       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2632       SAVE
2633       PARAMETER ( LINP = 10 ,
2634      &            LOUT = 6 ,
2635      &            LDAT = 9 )
2636
2637       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2638 * emulsion treatment
2639       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2640      &                NCOMPO,IEMUL
2641 * event flag
2642       COMMON /DTEVNO/ NEVENT,ICASCA
2643       CHARACTER*8 DATE,HHMMSS
2644       DIMENSION IDMNYR(3)
2645       NSD1 = 0
2646       NSD2 = 0
2647       NDD  = 0
2648       KKMAT  = 1
2649       NMSG   = MAX(NEVTS/100,1)
2650
2651 * initialization of run-statistics and histograms
2652       CALL DT_STATIS(1)
2653       CALL PHO_PHIST(1000,DUM)
2654
2655 * initialization of Glauber-formalism
2656       IF (NCOMPO.LE.0) THEN
2657          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2658       ELSE
2659          DO 1 I=1,NCOMPO
2660             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2661     1    CONTINUE
2662       ENDIF
2663       CALL DT_SIGEMU
2664
2665       CALL IDATE(IDMNYR)
2666       WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2667      &   IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2668       CALL ITIME(IDMNYR)
2669       WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2670      &   IDMNYR(1),IDMNYR(2),IDMNYR(3)
2671       WRITE(LOUT,1001) DATE,HHMMSS
2672  1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8,
2673      &       '   Time: ',A8,' )')
2674
2675 * generate NEVTS events
2676       DO 2 IEVT=1,NEVTS
2677
2678 *  print run-status message
2679          IF (MOD(IEVT,NMSG).EQ.0) THEN
2680             CALL IDATE(IDMNYR)
2681             WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2682      &         IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2683             CALL ITIME(IDMNYR)
2684             WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2685      &         IDMNYR(1),IDMNYR(2),IDMNYR(3)
2686             WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS
2687  1000       FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A,
2688      &             '   Time: ',A,' )',/)
2689 C           WRITE(LOUT,1000) IEVT-1
2690 C1000       FORMAT(1X,I8,' events sampled')
2691          ENDIF
2692          NEVENT = IEVT
2693 *  treat nuclear emulsions
2694          IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
2695 *  composite targets only
2696          KKMAT = -KKMAT
2697 *  sample this event
2698          CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ)
2699
2700          CALL PHO_PHIST(2000,DUM)
2701
2702          write(6,*) "Diffractive collisions", NSD1, NSD2, NDD
2703
2704     2 CONTINUE
2705
2706 * print run-statistics and histograms to output-unit 6
2707       CALL PHO_PHIST(3000,DUM)
2708       CALL DT_STATIS(2)
2709       RETURN
2710       END
2711
2712 *$ CREATE DT_LAEVT.FOR
2713 *COPY DT_LAEVT
2714 *
2715 *===laevt==============================================================*
2716 *
2717       SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2718      &                                             IDP,IGLAU)
2719
2720 ************************************************************************
2721 * Interface to run DPMJET for lepton-nucleus interactions.             *
2722 * Kinematics is sampled using the equivalent photon approximation      *
2723 * Based on GPHERA-routine by R. Engel.                                 *
2724 * This version dated 23.03.96 is written by S. Roesler.                *
2725 ************************************************************************
2726
2727       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2728       SAVE
2729       PARAMETER ( LINP = 10 ,
2730      &            LOUT = 6 ,
2731      &            LDAT = 9 )
2732       PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,
2733      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
2734       PARAMETER (TWOPI  = 6.283185307179586454D+00,
2735      &           PI     = TWOPI/TWO,
2736      &           ALPHEM = ONE/137.0D0)
2737
2738 C     CHARACTER*72 HEADER
2739
2740 * particle properties (BAMJET index convention)
2741       CHARACTER*8  ANAME
2742       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2743      &                IICH(210),IIBAR(210),K1(210),K2(210)
2744 * event history
2745       PARAMETER (NMXHKK=200000)
2746       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2747      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2748      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2749 * extended event history
2750       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2751      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2752      &                IHIST(2,NMXHKK)
2753 * kinematical cuts for lepton-nucleus interactions
2754       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2755      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2756 * properties of interacting particles
2757       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2758 * properties of photon/lepton projectiles
2759       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2760 * kinematics at lepton-gamma vertex
2761       COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4)
2762 * flags for activated histograms
2763       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2764       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2765 * emulsion treatment
2766       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2767      &                NCOMPO,IEMUL
2768 * Glauber formalism: cross sections
2769       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
2770      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
2771      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
2772      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
2773      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
2774      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
2775      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
2776      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
2777      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
2778      &                BSLOPE,NEBINI,NQBINI
2779 * nucleon-nucleon event-generator
2780       CHARACTER*8 CMODEL
2781       LOGICAL LPHOIN
2782       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2783 * flags for input different options
2784       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2785       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2786      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2787 * event flag
2788       COMMON /DTEVNO/ NEVENT,ICASCA
2789
2790       DIMENSION XDUMB(40),BGTA(4)
2791
2792 * LEPTO
2793       IF (MCGENE.EQ.3) THEN
2794          STOP ' This version does not contain LEPTO !'
2795       ENDIF
2796
2797       KKMAT  = 1
2798       NMSG   = MAX(NEVTS/10,1)
2799
2800 * mass of incident lepton
2801       AMLPT  = AAM(IDP)
2802       AMLPT2 = AMLPT**2
2803       IDPPDG = IDT_IPDGHA(IDP)
2804
2805 * consistency of kinematical limits
2806       Q2MIN  = MAX(Q2MIN,TINY10)
2807       Q2MAX  = MAX(Q2MAX,TINY10)
2808       YMIN   = MIN(MAX(YMIN,TINY10),0.999D0)
2809       YMAX   = MIN(MAX(YMAX,TINY10),0.999D0)
2810
2811 * total energy of the lepton-nucleon system
2812       PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2
2813      &                                      +(PLEPT0(3)+PNUCL(3))**2 )
2814       ETOTLN = PLEPT0(4)+PNUCL(4)
2815       ECMLN  = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN))
2816       ECMAX  = MIN(ECMAX,ECMLN)
2817       WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN,
2818      &                 THMIN,THMAX,ELMIN
2819  1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X,
2820      &       '------------------',/,9X,'W (min)   =',
2821      &       F7.1,' GeV    (max) =',F7.1,' GeV',/,9X,'y (min)   =',
2822      &       F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1,
2823      &       ' GeV^2  (max) =',F7.1,' GeV^2',/,' (Lab)   E_g (min) ='
2824      &       ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =',
2825      &       F7.4,'   for E_lpt >',F7.1,' GeV',/)
2826
2827 * Lorentz-parameter for transf. into Lab
2828       BGTA(1) = PNUCL(1)/AAM(1)
2829       BGTA(2) = PNUCL(2)/AAM(1)
2830       BGTA(3) = PNUCL(3)/AAM(1)
2831       BGTA(4) = PNUCL(4)/AAM(1)
2832 * LT of incident lepton into Lab and dump it in DTEVT1
2833       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2834      &            PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4),
2835      &            PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4))
2836       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2837      &            PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4),
2838      &            PLTOT,PPA(1),PPA(2),PPA(3),PPA(4))
2839 * maximum energy of photon nucleon system
2840       PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2
2841      &                                      +(YMAX*PPL0(3)+PPA(3))**2)
2842       ETOTGN = YMAX*PPL0(4)+PPA(4)
2843       EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2844       EGNMAX = MIN(EGNMAX,ECMAX)
2845 * minimum energy of photon nucleon system
2846       PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2
2847      &                                      +(YMIN*PPL0(3)+PPA(3))**2)
2848       ETOTGN = YMIN*PPL0(4)+PPA(4)
2849       EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2850       EGNMIN = MAX(EGNMIN,ECMIN)
2851
2852 * limits for Glauber-initialization
2853       Q2LI  = Q2MIN
2854       Q2HI  = MAX(Q2LI,MIN(Q2HI,Q2MAX))
2855       ECMLI = MAX(EGNMIN,THREE)
2856       ECMHI = EGNMAX
2857       WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI
2858  1004 FORMAT(1X,'resulting limits:',/,9X,'W (min)   =',F7.1,
2859      &       ' GeV    (max) =',F7.1,' GeV',/,/,' limits for ',
2860      &       'Glauber-initialization:',/,9X,'W (min)   =',F7.1,
2861      &       ' GeV    (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1,
2862      &       ' GeV^2  (max) =',F7.1,' GeV^2',/)
2863 * initialization of Glauber-formalism
2864       IF (NCOMPO.LE.0) THEN
2865          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2866       ELSE
2867          DO 9 I=1,NCOMPO
2868             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2869     9    CONTINUE
2870       ENDIF
2871       CALL DT_SIGEMU
2872
2873 * initialization of run-statistics and histograms
2874       CALL DT_STATIS(1)
2875       CALL PHO_PHIST(1000,DUM)
2876
2877 * maximum photon-nucleus cross section
2878       I1  = 1
2879       I2  = 1
2880       RAT = ONE
2881       IF (EGNMAX.GE.ECMNN(NEBINI)) THEN
2882          I1  = NEBINI
2883          I2  = NEBINI
2884          RAT = ONE
2885       ELSEIF (EGNMAX.GT.ECMNN(1)) THEN
2886          DO 5 I=2,NEBINI
2887             IF (EGNMAX.LT.ECMNN(I)) THEN
2888                I1  = I-1
2889                I2  = I
2890                RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2891                GOTO 6
2892             ENDIF
2893     5    CONTINUE
2894     6    CONTINUE
2895       ENDIF
2896       SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2897       EGNXX  = EGNMAX
2898       I1  = 1
2899       I2  = 1
2900       RAT = ONE
2901       IF (EGNMIN.GE.ECMNN(NEBINI)) THEN
2902          I1  = NEBINI
2903          I2  = NEBINI
2904          RAT = ONE
2905       ELSEIF (EGNMIN.GT.ECMNN(1)) THEN
2906          DO 7 I=2,NEBINI
2907             IF (EGNMIN.LT.ECMNN(I)) THEN
2908                I1  = I-1
2909                I2  = I
2910                RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2911                GOTO 8
2912             ENDIF
2913     7    CONTINUE
2914     8    CONTINUE
2915       ENDIF
2916       SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2917       IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN
2918       SIGMAX = MAX(SIGMAX,SIGXX)
2919       WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb'
2920
2921 * plot photon flux table
2922       AYMIN = LOG(YMIN)
2923       AYMAX = LOG(YMAX)
2924       AYRGE = AYMAX-AYMIN
2925       MAXTAB = 50
2926       ADY    = LOG(YMAX/YMIN)/DBLE(MAXTAB-1)
2927 C     WRITE(LOUT,'(/,1X,A)') 'LAEVT:   photon flux '
2928       DO 1 I=1,MAXTAB
2929          Y     = EXP(AYMIN+ADY*DBLE(I-1))
2930          Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y))
2931          FF1   = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2932      &                           -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX))
2933          FF2   = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2934      &                           -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX))
2935 C        WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2
2936     1 CONTINUE
2937
2938 * maximum residual weight for flux sampling (dy/y)
2939       YY     = YMIN
2940       Q2LOW  = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2941       WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW)
2942      &         -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2943
2944       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0)
2945       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1)
2946       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2)
2947       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0)
2948       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1)
2949       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2)
2950       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0)
2951       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1)
2952       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2)
2953       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0)
2954       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1)
2955       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2)
2956       XBLOW = 0.001D0
2957       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0)
2958       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1)
2959       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2)
2960
2961       ITRY = 0
2962       ITRW = 0
2963       NC0  = 0
2964       NC1  = 0
2965
2966 * generate events
2967       DO 2 IEVT=1,NEVTS
2968          IF (MOD(IEVT,NMSG).EQ.0) THEN
2969 C           OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out',
2970 C    &                                         STATUS='UNKNOWN')
2971             WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled'
2972 C           CLOSE(LDAT)
2973          ENDIF
2974          NEVENT = IEVT
2975
2976   100    CONTINUE
2977          ITRY = ITRY+1
2978
2979 *  sample y
2980   101    CONTINUE
2981          ITRW  = ITRW+1
2982          YY    = EXP(AYRGE*DT_RNDM(RAT)+AYMIN)
2983          Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2984          Q2LOG = LOG(Q2MAX/Q2LOW)
2985          WGH   = (ONE+(ONE-YY)**2)*Q2LOG
2986      &           -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2987          IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH
2988  1000    FORMAT(1X,'LAEVT:   weight error!',3E12.5)
2989          IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101
2990
2991 *  sample Q2
2992          YEFF = ONE+(ONE-YY)**2
2993   102    CONTINUE
2994          Q2  = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
2995          WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF
2996          IF (WGH.LT.DT_RNDM(Q2)) GOTO 102
2997
2998 c        NC0 = NC0+1
2999 c        CALL DT_FILHGR(YY,ONE,IHFLY0,NC0)
3000 c        CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0)
3001
3002 *  kinematics at lepton-photon vertex
3003 *   scattered electron
3004          YQ2 = SQRT((ONE-YY)*Q2)
3005          Q2E = Q2/(4.0D0*PLEPT0(4))
3006          E1Y = (ONE-YY)*PLEPT0(4)
3007          CALL DT_DSFECF(SIF,COF)
3008          PLEPT1(1) = YQ2*COF
3009          PLEPT1(2) = YQ2*SIF
3010          PLEPT1(3) = E1Y-Q2E
3011          PLEPT1(4) = E1Y+Q2E
3012 C        THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) )
3013 *   radiated photon
3014          PGAMM(1) = -PLEPT1(1)
3015          PGAMM(2) = -PLEPT1(2)
3016          PGAMM(3) = PLEPT0(3)-PLEPT1(3)
3017          PGAMM(4) = PLEPT0(4)-PLEPT1(4)
3018 *   E_cm cut
3019          PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2
3020      &                                        +(PGAMM(3)+PNUCL(3))**2 )
3021          ETOTGN = PGAMM(4)+PNUCL(4)
3022          ECMGN  = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)
3023          IF (ECMGN.LT.0.1D0) GOTO 101
3024          ECMGN  = SQRT(ECMGN)
3025          IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101
3026
3027 *  Lorentz-transformation into nucleon-rest system
3028          CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3029      &               PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4),
3030      &               PGTOT,PPG(1),PPG(2),PPG(3),PPG(4))
3031          CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3032      &               PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4),
3033      &               PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4))
3034 *  temporary checks..
3035          Q2TMP = ABS(PPG(4)**2-PGTOT**2)
3036          IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP
3037  1001    FORMAT(1X,'LAEVT:    inconsistent kinematics (Q2,Q2TMP) ',
3038      &          2F10.4)
3039          ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT))
3040          IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP
3041  1002    FORMAT(1X,'LAEVT:    inconsistent kinematics (ECMGN,ECMTMP) ',
3042      &          2F10.2)
3043          YYTMP = PPG(4)/PPL0(4)
3044          IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP
3045  1005    FORMAT(1X,'LAEVT:    inconsistent kinematics (YY,YYTMP) ',
3046      &          2F10.4)
3047
3048 *  lepton tagger (Lab)
3049          THETA = ACOS( PPL1(3)/PLTOT )
3050          IF (PPL1(4).GT.ELMIN) THEN
3051             IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101
3052          ENDIF
3053 *  photon energy-cut (Lab)
3054          IF (PPG(4).LT.EGMIN) GOTO 101
3055          IF (PPG(4).GT.EGMAX) GOTO 101
3056 *   x_Bj cut
3057          XBJ = ABS(Q2/(1.876D0*PPG(4)))
3058          IF (XBJ.LT.XBJMIN) GOTO 101
3059
3060          NC0 = NC0+1
3061          CALL DT_FILHGR(    Q2,ONE,IHFLQ0,NC0)
3062          CALL DT_FILHGR(    YY,ONE,IHFLY0,NC0)
3063          CALL DT_FILHGR(   XBJ,ONE,IHFLX0,NC0)
3064          CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0)
3065          CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0)
3066
3067 *  rotation angles against z-axis
3068          COD = PPG(3)/PGTOT
3069 C        SID = SQRT((ONE-COD)*(ONE+COD))
3070          PPT = SQRT(PPG(1)**2+PPG(2)**2)
3071          SID = PPT/PGTOT
3072          COF = ONE
3073          SIF = ZERO
3074          IF (PGTOT*SID.GT.TINY10) THEN
3075             COF   = PPG(1)/(SID*PGTOT)
3076             SIF   = PPG(2)/(SID*PGTOT)
3077             ANORF = SQRT(COF*COF+SIF*SIF)
3078             COF   = COF/ANORF
3079             SIF   = SIF/ANORF
3080          ENDIF
3081
3082          IF (IXSTBL.EQ.0) THEN
3083 *  change to photon projectile
3084             IJPROJ = 7
3085 *  set virtuality
3086             VIRT = Q2
3087 *  re-initialize LTs with new kinematics
3088 *  !!PGAMM ist set in cms (ECMGN) along z
3089             EPN = ZERO
3090             PPN = ZERO
3091             CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0)
3092 *  force Lab-system
3093             IFRAME = 1
3094 *  get emulsion component if requested
3095             IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
3096 *  convolute with cross section
3097             CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT)
3098             CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT)
3099             IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)')
3100      &         'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX,
3101      &                                        Q2,ECMGN,STOT
3102             IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100
3103             NC1 = NC1+1
3104             CALL DT_FILHGR(    Q2,ONE,IHFLQ1,NC1)
3105             CALL DT_FILHGR(    YY,ONE,IHFLY1,NC1)
3106             CALL DT_FILHGR(   XBJ,ONE,IHFLX1,NC1)
3107             CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1)
3108             CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1)
3109 *  composite targets only
3110             KKMAT = -KKMAT
3111 *  sample this event
3112             CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT,
3113      &                                                            IREJ)
3114 *  rotate momenta of final state particles back in photon-nucleon syst.
3115             DO 4 I=NPOINT(4),NHKK
3116                IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3117      &                                      (ISTHKK(I).EQ.1001)) THEN
3118                   PX = PHKK(1,I)
3119                   PY = PHKK(2,I)
3120                   PZ = PHKK(3,I)
3121                   CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF,
3122      &                        PHKK(1,I),PHKK(2,I),PHKK(3,I))
3123                ENDIF
3124     4       CONTINUE
3125          ENDIF
3126
3127          CALL DT_FILHGR(    Q2,ONE,IHFLQ2,NC1)
3128          CALL DT_FILHGR(    YY,ONE,IHFLY2,NC1)
3129          CALL DT_FILHGR(   XBJ,ONE,IHFLX2,NC1)
3130          CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1)
3131          CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1)
3132
3133 *  dump this event to histograms
3134          CALL PHO_PHIST(2000,DUM)
3135
3136     2 CONTINUE
3137
3138       WGY    = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW)
3139       WGY    = WGY*LOG(YMAX/YMIN)
3140       WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY)
3141
3142 C     HEADER = ' LAEVT:  Q^2 distribution 0'
3143 C     CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3144 C     HEADER = ' LAEVT:  Q^2 distribution 1'
3145 C     CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3146 C     HEADER = ' LAEVT:  Q^2 distribution 2'
3147 C     CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3148 C     HEADER = ' LAEVT:  y   distribution 0'
3149 C     CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3150 C     HEADER = ' LAEVT:  y   distribution 1'
3151 C     CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3152 C     HEADER = ' LAEVT:  y   distribution 2'
3153 C     CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3154 C     HEADER = ' LAEVT:  x   distribution 0'
3155 C     CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3156 C     HEADER = ' LAEVT:  x   distribution 1'
3157 C     CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3158 C     HEADER = ' LAEVT:  x   distribution 2'
3159 C     CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3160 C     HEADER = ' LAEVT:  E_g distribution 0'
3161 C     CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3162 C     HEADER = ' LAEVT:  E_g distribution 1'
3163 C     CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3164 C     HEADER = ' LAEVT:  E_g distribution 2'
3165 C     CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3166 C     HEADER = ' LAEVT:  E_c distribution 0'
3167 C     CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3168 C     HEADER = ' LAEVT:  E_c distribution 1'
3169 C     CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3170 C     HEADER = ' LAEVT:  E_c distribution 2'
3171 C     CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3172
3173 * print run-statistics and histograms to output-unit 6
3174       CALL PHO_PHIST(3000,DUM)
3175       IF (IXSTBL.EQ.0) CALL DT_STATIS(2)
3176
3177       RETURN
3178       END
3179
3180 *$ CREATE DT_DTUINI.FOR
3181 *COPY DT_DTUINI
3182 *
3183 *===dtuini=============================================================*
3184 *
3185       SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
3186      &                                               IDP,IEMU)
3187
3188       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3189       SAVE
3190
3191       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
3192 * emulsion treatment
3193       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
3194      &                NCOMPO,IEMUL
3195 * Glauber formalism: flags and parameters for statistics
3196       LOGICAL LPROD
3197       CHARACTER*8 CGLB
3198       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
3199
3200       CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU)
3201       CALL DT_STATIS(1)
3202       CALL PHO_PHIST(1000,DUM)
3203       IF (NCOMPO.LE.0) THEN
3204          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
3205       ELSE
3206          DO 1 I=1,NCOMPO
3207             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
3208     1    CONTINUE
3209       ENDIF
3210       IF (IOGLB.NE.100) CALL DT_SIGEMU
3211       IEMU = IEMUL
3212
3213       RETURN
3214       END
3215
3216 *$ CREATE DT_DTUOUT.FOR
3217 *COPY DT_DTUOUT
3218 *
3219 *===dtuout=============================================================*
3220 *
3221       SUBROUTINE DT_DTUOUT
3222
3223       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3224       SAVE
3225
3226       CALL PHO_PHIST(3000,DUM)
3227       CALL DT_STATIS(2)
3228
3229       RETURN
3230       END
3231
3232 *$ CREATE DT_BEAMPR.FOR
3233 *COPY DT_BEAMPR
3234 *
3235 *===beampr=============================================================*
3236 *
3237       SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE)
3238
3239 ************************************************************************
3240 * Initialization of event generation                                   *
3241 * This version dated  7.4.98  is written by S. Roesler.                *
3242 ************************************************************************
3243
3244       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3245       SAVE
3246
3247       PARAMETER ( LINP = 10 ,
3248      &            LOUT = 6 ,
3249      &            LDAT = 9 )
3250       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3251       PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3252
3253       LOGICAL LBEAM
3254
3255 * event history
3256       PARAMETER (NMXHKK=200000)
3257       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3258      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3259      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3260 * extended event history
3261       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3262      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3263      &                IHIST(2,NMXHKK)
3264 * properties of interacting particles
3265       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3266 * particle properties (BAMJET index convention)
3267       CHARACTER*8  ANAME
3268       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3269      &                IICH(210),IIBAR(210),K1(210),K2(210)
3270 * beam momenta
3271       COMMON /DTBEAM/ P1(4),P2(4)
3272
3273 C     DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4)
3274       DIMENSION WHAT(6),P1CMS(4),P2CMS(4)
3275
3276       DATA LBEAM /.FALSE./
3277
3278       GOTO (1,2) MODE
3279
3280     1 CONTINUE
3281
3282       E1  = WHAT(1)
3283       IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1))
3284       E2  = WHAT(2)
3285       IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2))
3286       PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) )
3287       PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) )
3288       TH  = 1.D-6*WHAT(3)/2.D0
3289       PH  = WHAT(4)*BOG
3290       P1(1) = PP1*SIN(TH)*COS(PH)
3291       P1(2) = PP1*SIN(TH)*SIN(PH)
3292       P1(3) = PP1*COS(TH)
3293       P1(4) = E1
3294       P2(1) = PP2*SIN(TH)*COS(PH)
3295       P2(2) = PP2*SIN(TH)*SIN(PH)
3296       P2(3) = -PP2*COS(TH)
3297       P2(4) = E2
3298       ECM  = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
3299      &                                              -(P1(3)+P2(3))**2 )
3300       ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG))
3301       PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) )
3302       BGX  = (P1(1)+P2(1))/ECM
3303       BGY  = (P1(2)+P2(2))/ECM
3304       BGZ  = (P1(3)+P2(3))/ECM
3305       BGE  = (P1(4)+P2(4))/ECM
3306       CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4),
3307      &            P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4))
3308       CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4),
3309      &            P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4))
3310       COD = P1CMS(3)/P1TOT
3311 C     SID = SQRT((ONE-COD)*(ONE+COD))
3312       PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2)
3313       SID = PPT/P1TOT
3314       COF = ONE
3315       SIF = ZERO
3316       IF (P1TOT*SID.GT.TINY10) THEN
3317          COF   = P1CMS(1)/(SID*P1TOT)
3318          SIF   = P1CMS(2)/(SID*P1TOT)
3319          ANORF = SQRT(COF*COF+SIF*SIF)
3320          COF   = COF/ANORF
3321          SIF   = SIF/ANORF
3322       ENDIF
3323 **check
3324 C     WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3325 C     WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3326 C     WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT
3327 C     WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT
3328 C     PAX = ZERO
3329 C     PAY = ZERO
3330 C     PAZ = P1TOT
3331 C     PAE = SQRT(AAM(IJPROJ)**2+PAZ**2)
3332 C     PBX = ZERO
3333 C     PBY = ZERO
3334 C     PBZ = -P2TOT
3335 C     PBE = SQRT(AAM(IJTARG)**2+PBZ**2)
3336 C     WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE
3337 C     WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE
3338 C     CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF,
3339 C    &            P1CMS(1),P1CMS(2),P1CMS(3))
3340 C     CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF,
3341 C    &            P2CMS(1),P2CMS(2),P2CMS(3))
3342 C     WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)
3343 C     WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)
3344 C     CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),
3345 C    &            P1TOT,P1(1),P1(2),P1(3),P1(4))
3346 C     CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),
3347 C    &            P2TOT,P2(1),P2(2),P2(3),P2(4))
3348 C     WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3349 C     WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3350 C     STOP
3351 **
3352
3353       LBEAM = .TRUE.
3354
3355       RETURN
3356
3357     2 CONTINUE
3358
3359       IF (LBEAM) THEN
3360          IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3361          DO 20 I=NPOINT(4),NHKK
3362             IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3363      &                                   (ISTHKK(I).EQ.1001)) THEN
3364                CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
3365      &                     COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
3366                PECMS = PHKK(4,I)
3367                CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
3368      &                     PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
3369             ENDIF
3370    20    CONTINUE
3371       ELSE
3372          MODE = -1
3373       ENDIF
3374
3375       RETURN
3376       END
3377
3378 *$ CREATE DT_REJUCO.FOR
3379 *COPY DT_REJUCO
3380 *
3381 *===rejuco=============================================================*
3382 *
3383       SUBROUTINE DT_REJUCO(MODE,IREJ)
3384
3385 ************************************************************************
3386 * REJection of Unphysical COnfigurations                               *
3387 *     MODE = 1  rejection of particles with unphysically large energy  *
3388 *                                                                      *
3389 * This version dated 27.12.2006 is written by S. Roesler.              *
3390 ************************************************************************
3391
3392       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3393       SAVE
3394
3395       PARAMETER ( LINP = 10 ,
3396      &            LOUT = 6 ,
3397      &            LDAT = 9 )
3398       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3399       PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3400
3401 * maximum x_cms of final state particle
3402       PARAMETER (XCMSMX = 1.4D0)
3403
3404 * event history
3405       PARAMETER (NMXHKK=200000)
3406       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3407      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3408      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3409 * extended event history
3410       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3411      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3412      &                IHIST(2,NMXHKK)
3413 * Lorentz-parameters of the current interaction
3414       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
3415      &                UMO,PPCM,EPROJ,PPROJ
3416
3417       IREJ = 0
3418
3419       IF (MODE.EQ.1) THEN
3420          IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3421          ECMHLF = UMO/2.0D0
3422          DO 10 I=NPOINT(4),NHKK
3423             IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN
3424                XCMS = ABS(PHKK(4,I))/ECMHLF
3425                IF (XCMS.GT.XCMSMX) GOTO 9999
3426             ENDIF
3427    10    CONTINUE
3428       ENDIF
3429
3430       RETURN
3431  9999 CONTINUE
3432       IREJ = 1
3433       RETURN
3434       END
3435
3436 *$ CREATE DT_EVENTB.FOR
3437 *COPY DT_EVENTB
3438 *
3439 *===eventb=============================================================*
3440 *
3441       SUBROUTINE DT_EVENTB(NCSY,IREJ)
3442
3443 ************************************************************************
3444 * Treatment of nucleon-nucleon interactions with full two-component    *
3445 * Dual Parton Model.                                                   *
3446 *          NCSY     number of nucleon-nucleon interactions             *
3447 *          IREJ     rejection flag                                     *
3448 * This version dated 14.01.2000 is written by S. Roesler               *
3449 ************************************************************************
3450
3451       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3452       SAVE
3453       PARAMETER ( LINP = 10 ,
3454      &            LOUT = 6 ,
3455      &            LDAT = 9 )
3456       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
3457
3458 * event history
3459       PARAMETER (NMXHKK=200000)
3460       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3461      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3462      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3463 * extended event history
3464       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3465      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3466      &                IHIST(2,NMXHKK)
3467 *! uncomment this line for internal phojet-fragmentation
3468 C #include "dtu_dtevtp.inc"
3469 * particle properties (BAMJET index convention)
3470       CHARACTER*8  ANAME
3471       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3472      &                IICH(210),IIBAR(210),K1(210),K2(210)
3473 * flags for input different options
3474       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
3475       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3476      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3477 * rejection counter
3478       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
3479      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
3480      &                IREXCI(3),IRDIFF(2),IRINC
3481 * properties of interacting particles
3482       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3483 * properties of photon/lepton projectiles
3484       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
3485 * various options for treatment of partons (DTUNUC 1.x)
3486 * (chain recombination, Cronin,..)
3487       LOGICAL LCO2CR,LINTPT
3488       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
3489      &                LCO2CR,LINTPT
3490 * statistics
3491       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
3492      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
3493      &                ICEVTG(8,0:30)
3494 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
3495       COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
3496 * Glauber formalism: collision properties
3497       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
3498      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
3499 * flags for diffractive interactions (DTUNUC 1.x)
3500       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
3501 * statistics: double-Pomeron exchange
3502       COMMON /DTFLG2/ INTFLG,IPOPO
3503 * flags for particle decays
3504       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
3505      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
3506      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
3507 * nucleon-nucleon event-generator
3508       CHARACTER*8 CMODEL
3509       LOGICAL LPHOIN
3510       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
3511 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
3512       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3513       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3514       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3515      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3516 C  model switches and parameters
3517       CHARACTER*8 MDLNA
3518       INTEGER ISWMDL,IPAMDL
3519       DOUBLE PRECISION PARMDL
3520       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3521 C  initial state parton radiation (internal part)
3522       INTEGER MXISR3,MXISR4
3523       PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
3524       INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
3525       DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
3526       COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
3527      &                ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
3528      &                IFL1(2,MXISR3),IFL2(2,MXISR3),
3529      &                IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
3530 C  event debugging information
3531       INTEGER NMAXD
3532       PARAMETER (NMAXD=100)
3533       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3534      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3535       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3536      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3537 C  general process information
3538       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3539       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3540
3541       DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
3542      &          PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
3543      &          PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
3544      &          KPRON(15),ISINGL(2000)
3545
3546 * initial values for max. number of phojet scatterings and dtunuc chains
3547 * to be fragmented with one pyexec call
3548       DATA MXPHFR,MXDTFR /10,100/
3549
3550       IREJ      = 0
3551 * pointer to first parton of the first chain in dtevt common
3552       NPOINT(3) = NHKK+1
3553 * special flag for double-Pomeron statistics
3554       IPOPO = 1
3555 * counter for low-mass (DTUNUC) interactions
3556       NDTUSC = 0
3557 * counter for interactions treated by PHOJET
3558       NPHOSC = 0
3559
3560 * scan interactions for single nucleon-nucleon interactions
3561 * (this has to be checked here because Cronin modifies parton momenta)
3562       NC = NPOINT(2)
3563       IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
3564       DO 8 I=1,NCSY
3565          ISINGL(I) = 0
3566          MOP = JMOHKK(1,NC)
3567          MOT = JMOHKK(1,NC+1)
3568          DIFF1 = ABS(PHKK(4,MOP)-PHKK(4,  NC)-PHKK(4,NC+2))
3569          DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
3570          IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
3571          NC = NC+4
3572     8 CONTINUE
3573
3574 * multiple scattering of chain ends
3575       IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
3576       IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
3577
3578 * switch to PHOJET-settings for JETSET parameter
3579       CALL DT_INITJS(1)
3580
3581 * loop over nucleon-nucleon interaction
3582       NC = NPOINT(2)
3583       DO 2 I=1,NCSY
3584 *
3585 *   pick up one nucleon-nucleon interaction from DTEVT1
3586 *     ppnn  / ptnn   - momenta of the interacting nucleons (cms)
3587 *     ptotnn         - total momentum of the interacting nucleons (cms)
3588 *     pp1,2 / pt1,2  - momenta of the four partons
3589 *     pp    / pt     - total momenta of the proj / targ partons
3590 *     ptot           - total momentum of the four partons
3591          MOP = JMOHKK(1,NC)
3592          MOT = JMOHKK(1,NC+1)
3593          DO 3 K=1,4
3594             PPNN(K)   = PHKK(K,MOP)
3595             PTNN(K)   = PHKK(K,MOT)
3596             PTOTNN(K) = PPNN(K)+PTNN(K)
3597             PP1(K)    = PHKK(K,NC)
3598             PT1(K)    = PHKK(K,NC+1)
3599             PP2(K)    = PHKK(K,NC+2)
3600             PT2(K)    = PHKK(K,NC+3)
3601             PP(K)     = PP1(K)+PP2(K)
3602             PT(K)     = PT1(K)+PT2(K)
3603             PTOT(K)   = PP(K)+PT(K)
3604     3    CONTINUE
3605 *
3606 *-----------------------------------------------------------------------
3607 *   this is a complete nucleon-nucleon interaction
3608 *
3609          IF (ISINGL(I).EQ.1) THEN
3610 *
3611 *     initialize PHOJET-variables for remnant/valence-partons
3612             IHFLD(1,1) = 0
3613             IHFLD(1,2) = 0
3614             IHFLD(2,1) = 0
3615             IHFLD(2,2) = 0
3616             IHFLS(1) = 1
3617             IHFLS(2) = 1
3618 *     save current settings of PHOJET process and min. bias flags
3619             DO 9 K=1,11
3620                KPRON(K) = IPRON(K,1)
3621     9       CONTINUE
3622             ISWSAV   = ISWMDL(2)
3623 *
3624 *     check if forced sampling of diffractive interaction requested
3625             IF (ISINGD.LT.-1) THEN
3626                DO 90 K=1,11
3627                   IPRON(K,1) = 0
3628    90          CONTINUE
3629                IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
3630                IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
3631                IF (ISINGD.EQ.-5) IPRON(4,1) = 1
3632             ENDIF
3633 *
3634 *     for photons: a direct/anomalous interaction is not sampled
3635 *     in PHOJET but already in Glauber-formalism. Here we check if such
3636 *     an interaction is requested
3637             IF (IJPROJ.EQ.7) THEN
3638 *       first switch off direct interactions
3639                IPRON(8,1) = 0
3640 *       this is a direct interactions
3641                IF (IDIREC.EQ.1) THEN
3642                   DO 12 K=1,11
3643                      IPRON(K,1) = 0
3644    12             CONTINUE
3645                   IPRON(8,1) = 1
3646 *       this is an anomalous interactions
3647 *         (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
3648                ELSEIF (IDIREC.EQ.2) THEN
3649                   ISWMDL(2) = 0
3650                ENDIF
3651             ELSE
3652                IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
3653             ENDIF
3654 *
3655 *     make sure that total momenta of partons, pp and pt, are on mass
3656 *     shell (Cronin may have srewed this up..)
3657             CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
3658             IF (IR1.NE.0) THEN
3659                IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
3660      &              'EVENTB:  mass shell correction rejected'
3661                GOTO 9999
3662             ENDIF
3663 *
3664 *     initialize the incoming particles in PHOJET
3665             IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3666                CALL PHO_SETPAR(1,22,0,VIRT)
3667             ELSE
3668                CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
3669             ENDIF
3670             CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
3671 *
3672 *     initialize rejection loop counter for anomalous processes
3673             IRJANO = 0
3674   800       CONTINUE
3675             IRJANO = IRJANO+1
3676 *
3677 *     temporary fix for ifano problem
3678             IFANO(1) = 0
3679             IFANO(2) = 0
3680 *
3681 *     generate complete hadron/nucleon/photon-nucleon event with PHOJET
3682             CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
3683 *
3684 *     for photons: special consistency check for anomalous interactions
3685             IF (IJPROJ.EQ.7) THEN
3686                IF (IRJANO.LT.30) THEN
3687                   IF (IFANO(1).NE.0) THEN
3688 *       here, an anomalous interaction was generated. Check if it
3689 *       was also requested. Otherwise reject this event.
3690                      IF (IDIREC.EQ.0) GOTO 800
3691                   ELSE
3692 *       here, an anomalous interaction was not generated. Check if it
3693 *       was requested in which case we need to reject this event.
3694                      IF (IDIREC.EQ.2) GOTO 800
3695                   ENDIF
3696                ELSE
3697                   WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
3698      &                          IRJANO,IDIREC,NEVHKK
3699                ENDIF
3700             ENDIF
3701 *
3702 *     copy back original settings of PHOJET process and min. bias flags
3703             DO 10 K=1,11
3704                IPRON(K,1) = KPRON(K)
3705    10       CONTINUE
3706             ISWMDL(2) = ISWSAV
3707 *
3708 *     check if PHOJET has rejected this event
3709             IF (IREJ1.NE.0) THEN
3710 C              IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3711                WRITE(LOUT,'(1X,A,I4)')
3712      &            'EVENTB:  chain system rejected',IDIREC
3713                CALL PHO_PREVNT(0)
3714                GOTO 9999
3715             ENDIF
3716 *
3717 *     copy partons and strings from PHOJET common back into DTEVT for
3718 *     external fragmentation
3719             MO1 = NC
3720             MO2 = NC+3
3721 *!      uncomment this line for internal phojet-fragmentation
3722 C           CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
3723             NPHOSC = NPHOSC+1
3724             CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
3725             IF (IREJ1.NE.0) THEN
3726                IF (IOULEV(1).GT.0)
3727      &         WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
3728                GOTO 9999
3729             ENDIF
3730 *
3731 *     update statistics counter
3732             ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
3733 *
3734 *-----------------------------------------------------------------------
3735 *   this interaction involves "remnants"
3736 *
3737          ELSE
3738 *
3739 *     total mass of this system
3740             PPTOT  = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
3741             AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
3742             IF (AMTOT2.LT.ZERO) THEN
3743                AMTOT = ZERO
3744             ELSE
3745                AMTOT = SQRT(AMTOT2)
3746             ENDIF
3747 *
3748 *     systems with masses larger than elojet are treated with PHOJET
3749             IF (AMTOT.GT.ELOJET) THEN
3750 *
3751 *     initialize PHOJET-variables for remnant/valence-partons
3752 *       projectile parton flavors and valence flag
3753                IHFLD(1,1) = IDHKK(NC)
3754                IHFLD(1,2) = IDHKK(NC+2)
3755                IHFLS(1)   = 0
3756                IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
3757      &                            .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
3758 *       target parton flavors and valence flag
3759                IHFLD(2,1) = IDHKK(NC+1)
3760                IHFLD(2,2) = IDHKK(NC+3)
3761                IHFLS(2)   = 0
3762                IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
3763      &                            .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
3764 *       flag signalizing PHOJET how to treat the remnant:
3765 *         iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
3766 *         iremn > -1 valence remnant: PHOJET assumes flavors according
3767 *                    to mother particle
3768                IREMN1 = IHFLS(1)-1
3769                IREMN2 = IHFLS(2)-1
3770 *
3771 *     initialize the incoming particles in PHOJET
3772                IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3773                   CALL PHO_SETPAR(1,22,IREMN1,VIRT)
3774                ELSE
3775                   CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
3776                ENDIF
3777                CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
3778 *
3779 *     calculate Lorentz parameter of the nucleon-nucleon cm-system
3780                PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
3781                AMNN   = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
3782                BGX    = PTOTNN(1)/AMNN
3783                BGY    = PTOTNN(2)/AMNN
3784                BGZ    = PTOTNN(3)/AMNN
3785                GAM    = PTOTNN(4)/AMNN
3786 *     transform interacting nucleons into nucleon-nucleon cm-system
3787                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3788      &                     PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
3789      &                     PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
3790                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3791      &                     PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
3792      &                     PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
3793 *     transform (total) momenta of the proj and targ partons into
3794 *     nucleon-nucleon cm-system
3795                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3796      &                     PP(1),PP(2),PP(3),PP(4),
3797      &                     PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
3798                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3799      &                     PT(1),PT(2),PT(3),PT(4),
3800      &                     PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
3801 *     energy fractions of the proj and targ partons
3802                XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
3803                XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
3804 ***
3805 * testprint
3806 c              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3807 c    &                        (PPTCMS(2)+PTTCMS(2))**2 +
3808 c    &                        (PPTCMS(3)+PTTCMS(3))**2 )
3809 c              EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3810 c    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3811 c              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3812 c    &                        (PPSUB(2)+PTSUB(2))**2 +
3813 c    &                        (PPSUB(3)+PTSUB(3))**2 )
3814 c              EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3815 c    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
3816 ***
3817 *
3818 *     save current settings of PHOJET process and min. bias flags
3819                DO 7 K=1,11
3820                   KPRON(K) = IPRON(K,1)
3821     7          CONTINUE
3822 *     disallow direct photon int. (does not make sense here anyway)
3823                IPRON(8,1) = 0
3824 *     disallow double pomeron processes (due to technical problems
3825 *     in PHOJET, needs to be solved sometime)
3826                IPRON(4,1) = 0
3827 *     disallow diffraction for sea-diquarks
3828                IF ((IABS(IHFLD(1,1)).GT.1100).AND.
3829      &             (IABS(IHFLD(1,2)).GT.1100)) THEN
3830                   IPRON(3,1) = 0
3831                   IPRON(6,1) = 0
3832                ENDIF
3833                IF ((IABS(IHFLD(2,1)).GT.1100).AND.
3834      &             (IABS(IHFLD(2,2)).GT.1100)) THEN
3835                   IPRON(3,1) = 0
3836                   IPRON(5,1) = 0
3837                ENDIF
3838 *
3839 *     we need massless partons: transform them on mass shell
3840                XMP = ZERO
3841                XMT = ZERO
3842                DO 6 K=1,4
3843                   PPTMP(K) = PPSUB(K)
3844                   PTTMP(K) = PTSUB(K)
3845     6          CONTINUE
3846                CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
3847                PPSUTO  = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
3848                PTSUTO  = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
3849                PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
3850      &                  (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
3851 *     total energy of the subsysten after mass transformation
3852 *      (should be the same as before..)
3853                SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
3854      &                      (PPSUB(4)+PTSUB(4)+PSUTOT) )
3855 *
3856 *     after mass shell transformation the x_sub - relation has to be
3857 *     corrected. We therefore create "pseudo-momenta" of mother-nucleons.
3858 *
3859 *     The old version was to scale based on the original x_sub and the
3860 *     4-momenta of the subsystem. At very high energy this could lead to
3861 *     "pseudo-cm energies" of the parent system considerably exceeding
3862 *     the true cm energy. Now we keep the true cm energy and calculate
3863 *     new x_sub instead.
3864 C old version  PPTCMS(4) = PPSUB(4)/XPSUB
3865                PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
3866                XPSUB = PPSUB(4)/PPTCMS(4)
3867                IF (IJPROJ.EQ.7) THEN
3868                   AMP2  = PHKK(5,MOT)**2
3869                   PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
3870                ELSE
3871 *???????
3872                   PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
3873      &                        *(PPTCMS(4)+PHKK(5,MOP)))
3874 C                 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
3875 C    &                        *(PPTCMS(4)+PHKK(5,MOT)))
3876                ENDIF
3877 C old version  PTTCMS(4) = PTSUB(4)/XTSUB
3878                PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
3879                XTSUB = PTSUB(4)/PTTCMS(4)
3880                PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
3881      &                     *(PTTCMS(4)+PHKK(5,MOT)))
3882                DO 4 K=1,3
3883                   PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
3884                   PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
3885     4          CONTINUE
3886 ***
3887 * testprint
3888 *
3889 *     ppnn  / ptnn   - momenta of the int. nucleons (cms, negl. Fermi)
3890 *     ptotnn         - total momentum of the int. nucleons (cms, negl. Fermi)
3891 *     pptcms/ pttcms - momenta of the interacting nucleons (cms)
3892 *     pp1,2 / pt1,2  - momenta of the four partons
3893 *
3894 *     pp    / pt     - total momenta of the pr/ta partons (cms, negl. Fermi)
3895 *     ptot           - total momentum of the four partons (cms, negl. Fermi)
3896 *     ppsub / ptsub  - total momenta of the proj / targ partons (cms)
3897 *
3898 c              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3899 c    &                        (PPTCMS(2)+PTTCMS(2))**2 +
3900 c    &                        (PPTCMS(3)+PTTCMS(3))**2 )
3901 c              ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3902 c    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3903 c              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3904 c    &                        (PPSUB(2)+PTSUB(2))**2 +
3905 c    &                        (PPSUB(3)+PTSUB(3))**2 )
3906 c              ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3907 c    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
3908 c              IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
3909 c                 WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
3910 c                 WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
3911 c                 WRITE(*,*) ' XPSUB,  XTSUB  : ',XPSUB,XTSUB
3912 c              ENDIF
3913 c              BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
3914 c              BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
3915 c              BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
3916 c              BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
3917 *     transform interacting nucleons into nucleon-nucleon cm-system
3918 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3919 c    &                    PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
3920 c    &                     PPNEW1,PPNEW2,PPNEW3,PPNEW4)
3921 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3922 c    &                    PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
3923 c    &                     PTNEW1,PTNEW2,PTNEW3,PTNEW4)
3924 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3925 c    &                     PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
3926 c    &                     PPSUB1,PPSUB2,PPSUB3,PPSUB4)
3927 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3928 c    &                     PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
3929 c    &                     PTSUB1,PTSUB2,PTSUB3,PTSUB4)
3930 c              PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
3931 c    &                        (PPNEW2+PTNEW2)**2 +
3932 c    &                        (PPNEW3+PTNEW3)**2 )
3933 c              ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
3934 c    &                        (PPNEW4+PTNEW4+PTSTCM) )
3935 c              PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
3936 c    &                        (PPSUB2+PTSUB2)**2 +
3937 c    &                        (PPSUB3+PTSUB3)**2 )
3938 c              ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
3939 c    &                        (PPSUB4+PTSUB4+PTSTSU) )
3940 C              WRITE(*,*) ' mother cmE :'
3941 C              WRITE(*,*) ETSTCM,ENEWCM
3942 C              WRITE(*,*) ' subsystem cmE :'
3943 C              WRITE(*,*) ETSTSU,ENEWSU
3944 C              WRITE(*,*) ' projectile mother :'
3945 C              WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
3946 C              WRITE(*,*) ' target mother :'
3947 C              WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
3948 C              WRITE(*,*) ' projectile subsystem:'
3949 C              WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
3950 C              WRITE(*,*) ' target subsystem:'
3951 C              WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
3952 C              WRITE(*,*) ' projectile subsystem should be:'
3953 C              WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
3954 C    &                    XPSUB*ETSTCM/2.0D0
3955 C              WRITE(*,*) ' target subsystem should be:'
3956 C              WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
3957 C    &                    XTSUB*ETSTCM/2.0D0
3958 C              WRITE(*,*) ' subsystem cmE should be: '
3959 C              WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
3960 ***
3961 *
3962 *     generate complete remnant - nucleon/remnant event with PHOJET
3963                CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
3964 *
3965 *     copy back original settings of PHOJET process flags
3966                DO 11 K=1,11
3967                   IPRON(K,1) = KPRON(K)
3968    11          CONTINUE
3969 *
3970 *     check if PHOJET has rejected this event
3971                IF (IREJ1.NE.0) THEN
3972                   IF (IOULEV(1).GT.0)
3973      &            WRITE(LOUT,'(1X,A)') 'EVENTB:  chain system rejected'
3974                   WRITE(LOUT,*)
3975      &                 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
3976                   CALL PHO_PREVNT(0)
3977                   GOTO 9999
3978                ENDIF
3979 *
3980 *     copy partons and strings from PHOJET common back into DTEVT for
3981 *     external fragmentation
3982                MO1 = NC
3983                MO2 = NC+3
3984 *!      uncomment this line for internal phojet-fragmentation
3985 C              CALL DT_GETFSP(MO1,MO2,PP,PT,1)
3986                NPHOSC = NPHOSC+1
3987                CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
3988                IF (IREJ1.NE.0) THEN
3989                   IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3990      &               'EVENTB: chain system rejected 2'
3991                   GOTO 9999
3992                ENDIF
3993 *
3994 *     update statistics counter
3995                ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
3996 *
3997 *-----------------------------------------------------------------------
3998 * two-chain approx. for smaller systems
3999 *
4000             ELSE
4001 *
4002                NDTUSC = NDTUSC+1
4003 *   special flag for double-Pomeron statistics
4004                IPOPO = 0
4005 *
4006 *   pick up flavors at the ends of the two chains
4007                IFP1 = IDHKK(NC)
4008                IFT1 = IDHKK(NC+1)
4009                IFP2 = IDHKK(NC+2)
4010                IFT2 = IDHKK(NC+3)
4011 *   ..and the indices of the mothers
4012                MOP1 = NC
4013                MOT1 = NC+1
4014                MOP2 = NC+2
4015                MOT2 = NC+3
4016                CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
4017      &                     IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
4018 *
4019 *   check if this chain system was rejected
4020                IF (IREJ1.GT.0) THEN
4021                   IF (IOULEV(1).GT.0) THEN
4022                      WRITE(LOUT,*) 'rejected 1 in EVENTB'
4023                      WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
4024      &                  IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
4025                   ENDIF
4026                   IRHHA = IRHHA+1
4027                   GOTO 9999
4028                ENDIF
4029 *   the following lines are for sea-sea chains rejected in GETCSY
4030                IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
4031                ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
4032             ENDIF
4033 *
4034          ENDIF
4035 *
4036 *     update statistics counter
4037          ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
4038 *
4039          NC = NC+4
4040 *
4041     2 CONTINUE
4042 *
4043 *-----------------------------------------------------------------------
4044 * treatment of low-mass chains (if there are any)
4045 *
4046       IF (NDTUSC.GT.0) THEN
4047 *
4048 *   correct chains of very low masses for possible resonances
4049          IF (IRESCO.EQ.1) THEN
4050             CALL DT_EVTRES(IREJ1)
4051             IF (IREJ1.GT.0) THEN
4052                IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
4053                IRRES(1) = IRRES(1)+1
4054                GOTO 9999
4055             ENDIF
4056          ENDIF
4057 *   fragmentation of low-mass chains
4058 *!  uncomment this line for internal phojet-fragmentation
4059 *   (of course it will still be fragmented by DPMJET-routines but it
4060 *    has to be done here instead of further below)
4061 C        CALL DT_EVTFRA(IREJ1)
4062 C        IF (IREJ1.GT.0) THEN
4063 C           IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
4064 C           IRFRAG = IRFRAG+1
4065 C           GOTO 9999
4066 C        ENDIF
4067       ELSE
4068 *! uncomment this line for internal phojet-fragmentation
4069 C        NPOINT(4) = NHKK+1
4070          IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
4071       ENDIF
4072 *
4073 *-----------------------------------------------------------------------
4074 * new di-quark breaking mechanisms
4075 *
4076       MXLEFT = 2
4077       CALL DT_CHASTA(0)
4078       IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
4079      &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
4080          CALL DT_DIQBRK
4081          MXLEFT = 4
4082       ENDIF
4083 *
4084 *-----------------------------------------------------------------------
4085 * hadronize this event
4086 *
4087 *   hadronize PHOJET chain systems
4088       NPYMAX = 0
4089       NPJE   = NPHOSC/MXPHFR
4090       IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
4091       IF (NPJE.GT.1) THEN
4092          NLEFT = NPHOSC-NPJE*MXPHFR
4093          DO 20 JFRG=1,NPJE
4094             NFRG = JFRG*MXPHFR
4095             IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
4096                CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4097                IF (IREJ1.GT.0) GOTO 22
4098                NLEFT = 0
4099             ELSE
4100                CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
4101                IF (IREJ1.GT.0) GOTO 22
4102             ENDIF
4103             IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4104    20    CONTINUE
4105          IF (NLEFT.GT.0) THEN
4106             CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4107             IF (IREJ1.GT.0) GOTO 22
4108             IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4109          ENDIF
4110       ELSE
4111          CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4112          IF (IREJ1.GT.0) GOTO 22
4113          IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4114       ENDIF
4115 *
4116 *   check max. filling level of jetset common and
4117 *   reduce mxphfr if necessary
4118       IF (NPYMAX.GT.3000) THEN
4119          IF (NPYMAX.GT.3500) THEN
4120             MXPHFR = MAX(1,MXPHFR-2)
4121          ELSE
4122             MXPHFR = MAX(1,MXPHFR-1)
4123          ENDIF
4124 C        WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
4125       ENDIF
4126 *
4127 *   hadronize DTUNUC chain systems
4128    23 CONTINUE
4129       IBACK = MXDTFR
4130       CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
4131       IF (IREJ2.GT.0) GOTO 22
4132 *
4133 *   check max. filling level of jetset common and
4134 *   reduce mxdtfr if necessary
4135       IF (NPYMEM.GT.3000) THEN
4136          IF (NPYMEM.GT.3500) THEN
4137             MXDTFR = MAX(1,MXDTFR-20)
4138          ELSE
4139             MXDTFR = MAX(1,MXDTFR-10)
4140          ENDIF
4141 C        WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
4142       ENDIF
4143 *
4144       IF (IBACK.EQ.-1) GOTO 23
4145 *
4146    22 CONTINUE
4147 C     CALL DT_EVTFRG(1,IREJ1)
4148 C     CALL DT_EVTFRG(2,IREJ2)
4149       IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
4150          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
4151          IRFRAG = IRFRAG+1
4152          GOTO 9999
4153       ENDIF
4154 *
4155 * get final state particles from /DTEVTP/
4156 *! uncomment this line for internal phojet-fragmentation
4157 C     CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
4158
4159       IF (IJPROJ.NE.7)
4160      &   CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
4161 C     IF (IREJ3.NE.0) GOTO 9999
4162
4163       RETURN
4164
4165  9999 CONTINUE
4166       IREVT = IREVT+1
4167       IREJ  = 1
4168       RETURN
4169       END
4170
4171 *$ CREATE DT_GETPJE.FOR
4172 *COPY DT_GETPJE
4173 *
4174 *===getpje=============================================================*
4175 *
4176       SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
4177
4178 ************************************************************************
4179 * This subroutine copies PHOJET partons and strings from POEVT1 into   *
4180 * DTEVT1.                                                              *
4181 *      MO1,MO2   indices of first and last mother-parton in DTEVT1     *
4182 *      PP,PT     4-momenta of projectile/target being handled by       *
4183 *                PHOJET                                                *
4184 * This version dated 11.12.99 is written by S. Roesler                 *
4185 ************************************************************************
4186
4187       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4188       SAVE
4189       PARAMETER ( LINP = 10 ,
4190      &            LOUT = 6 ,
4191      &            LDAT = 9 )
4192       PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
4193      &           ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
4194
4195       LOGICAL LFLIP
4196
4197 * event history
4198       PARAMETER (NMXHKK=200000)
4199       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4200      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4201      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4202 * extended event history
4203       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4204      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4205      &                IHIST(2,NMXHKK)
4206 * Lorentz-parameters of the current interaction
4207       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4208      &                UMO,PPCM,EPROJ,PPROJ
4209 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
4210       COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
4211 * flags for input different options
4212       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4213       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4214      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4215 * statistics: double-Pomeron exchange
4216       COMMON /DTFLG2/ INTFLG,IPOPO
4217 * statistics
4218       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
4219      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
4220      &                ICEVTG(8,0:30)
4221 * rejection counter
4222       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
4223      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
4224      &                IREXCI(3),IRDIFF(2),IRINC
4225 C  standard particle data interface
4226       INTEGER NMXHEP
4227       PARAMETER (NMXHEP=4000)
4228       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
4229       DOUBLE PRECISION PHEP,VHEP
4230       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
4231      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
4232      &                VHEP(4,NMXHEP), NSD1, NSD2, NDD
4233 C  extension to standard particle data interface (PHOJET specific)
4234       INTEGER IMPART,IPHIST,ICOLOR
4235       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
4236 C  color string configurations including collapsed strings and hadrons
4237       INTEGER MSTR
4238       PARAMETER (MSTR=500)
4239       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
4240       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
4241      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
4242      &                NNCH(MSTR),IBHAD(MSTR),ISTR
4243 C  general process information
4244       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4245       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4246 C  model switches and parameters
4247       CHARACTER*8 MDLNA
4248       INTEGER ISWMDL,IPAMDL
4249       DOUBLE PRECISION PARMDL
4250       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4251 C  event debugging information
4252       INTEGER NMAXD
4253       PARAMETER (NMAXD=100)
4254       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4255      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4256       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4257      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4258
4259       DIMENSION PP(4),PT(4)
4260       DATA MAXLOP /10000/
4261
4262       INHKK = NHKK
4263       LFLIP = .TRUE.
4264     1 CONTINUE
4265       NPVAL = 0
4266       NTVAL = 0
4267       IREJ  = 0
4268
4269 *   store initial momenta for energy-momentum conservation check
4270       IF (LEMCCK) THEN
4271          CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
4272          CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
4273       ENDIF
4274 * copy partons and strings from POEVT1 into DTEVT1
4275       DO 11 I=1,ISTR
4276 C        IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
4277          IF (NCODE(I).EQ.-99) THEN
4278             IDXSTG = NPOS(1,I)
4279             IDSTG  = IDHEP(IDXSTG)
4280             PX = PHEP(1,IDXSTG)
4281             PY = PHEP(2,IDXSTG)
4282             PZ = PHEP(3,IDXSTG)
4283             PE = PHEP(4,IDXSTG)
4284             IF (MODE.LT.0) THEN
4285                ISTAT = 70000+IPJE
4286                CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
4287      &                        11,IDSTG,0)
4288                IF (LEMCCK) THEN
4289                   PX = -PX
4290                   PY = -PY
4291                   PZ = -PZ
4292                   PE = -PE
4293                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4294                ENDIF
4295             ELSE
4296                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4297      &                        PPX,PPY,PPZ,PPE)
4298                ISTAT = 70000+IPJE
4299                CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
4300      &                        11,IDSTG,0)
4301                IF (LEMCCK) THEN
4302                   PX = -PPX
4303                   PY = -PPY
4304                   PZ = -PPZ
4305                   PE = -PPE
4306                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4307                ENDIF
4308             ENDIF
4309             NOBAM(NHKK)   = 0
4310             IHIST(1,NHKK) = IPHIST(1,IDXSTG)
4311             IHIST(2,NHKK) = 0
4312          ELSEIF (NCODE(I).GE.0) THEN
4313 *   indices of partons and string in POEVT1
4314             IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
4315             IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
4316             IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
4317                WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
4318      &         ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
4319                STOP ' GETPJE 1'
4320             ENDIF
4321             IDXSTG = NPOS(1,I)
4322 *   find "mother" string of the string
4323             IDXMS1 = ABS(JMOHEP(1,IDX1))
4324             IDXMS2 = ABS(JMOHEP(1,IDX2))
4325             IF (IDXMS1.NE.IDXMS2) THEN
4326                IDXMS1 = IDXSTG
4327                IDXMS2 = IDXSTG
4328 C              STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
4329             ENDIF
4330 *   search POEVT1 for the original hadron of the parton
4331             ILOOP = 0
4332             IPOM1 = 0
4333    14       CONTINUE
4334             ILOOP = ILOOP+1
4335             IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
4336             IDXMS1 = ABS(JMOHEP(1,IDXMS1))
4337             IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
4338      &          (ILOOP.LT.MAXLOP)) GOTO 14
4339             IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
4340             IPOM2 = 0
4341             ILOOP = 0
4342    15       CONTINUE
4343             ILOOP = ILOOP+1
4344             IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
4345             IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
4346                IDXMS2 = ABS(JMOHEP(2,IDXMS2))
4347             ELSE
4348                IDXMS2 = ABS(JMOHEP(1,IDXMS2))
4349             ENDIF
4350             IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
4351      &          (ILOOP.LT.MAXLOP)) GOTO 15
4352             IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
4353 *   parton 1
4354             IF (IDXMS1.EQ.1) THEN
4355                ISPTN1 = ISTHKK(MO1)
4356                M1PTN1 = MO1
4357                M2PTN1 = MO1+2
4358             ELSE
4359                ISPTN1 = ISTHKK(MO2)
4360                M1PTN1 = MO2-2
4361                M2PTN1 = MO2
4362             ENDIF
4363 *   parton 2
4364             IF (IDXMS2.EQ.1) THEN
4365                ISPTN2 = ISTHKK(MO1)
4366                M1PTN2 = MO1
4367                M2PTN2 = MO1+2
4368             ELSE
4369                ISPTN2 = ISTHKK(MO2)
4370                M1PTN2 = MO2-2
4371                M2PTN2 = MO2
4372             ENDIF
4373 *   check for mis-identified mothers and switch mother indices if necessary
4374             IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
4375      &          .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
4376      &          (LFLIP)) THEN
4377                IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
4378                   ISPTN1 = ISTHKK(MO1)
4379                   M1PTN1 = MO1
4380                   M2PTN1 = MO1+2
4381                   ISPTN2 = ISTHKK(MO2)
4382                   M1PTN2 = MO2-2
4383                   M2PTN2 = MO2
4384                ELSE
4385                   ISPTN1 = ISTHKK(MO2)
4386                   M1PTN1 = MO2-2
4387                   M2PTN1 = MO2
4388                   ISPTN2 = ISTHKK(MO1)
4389                   M1PTN2 = MO1
4390                   M2PTN2 = MO1+2
4391                ENDIF
4392             ENDIF
4393 *   register partons in temporary common
4394 *     parton at chain end
4395             PX = PHEP(1,IDX1)
4396             PY = PHEP(2,IDX1)
4397             PZ = PHEP(3,IDX1)
4398             PE = PHEP(4,IDX1)
4399 * flag only partons coming from Pomeron with 41/42
4400 C           IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4401             IF (IPOM1.NE.0) THEN
4402                ISTX = ABS(ISPTN1)/10
4403                IMO  = ABS(ISPTN1)-10*ISTX
4404                ISPTN1 = -(40+IMO)
4405             ELSE
4406                IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
4407                   ISTX = ABS(ISPTN1)/10
4408                   IMO  = ABS(ISPTN1)-10*ISTX
4409                   IF ((IDHEP(IDX1).EQ.21).OR.
4410      &                (ABS(IPHIST(1,IDX1)).GE.100)) THEN
4411                      ISPTN1 = -(60+IMO)
4412                   ELSE
4413                      ISPTN1 = -(50+IMO)
4414                   ENDIF
4415                ENDIF
4416             ENDIF
4417             IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
4418             IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
4419             IF (MODE.LT.0) THEN
4420                CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
4421      &                        PZ,PE,0,0,0)
4422             ELSE
4423                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4424      &                        PPX,PPY,PPZ,PPE)
4425                CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
4426      &                        PPZ,PPE,0,0,0)
4427             ENDIF
4428             IHIST(1,NHKK) = IPHIST(1,IDX1)
4429             IHIST(2,NHKK) = 0
4430             DO 19 KK=1,4
4431                VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
4432                WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
4433    19       CONTINUE
4434             VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
4435             WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
4436             M1STRG = NHKK
4437 *     gluon kinks
4438             NGLUON = IDX2-IDX1-1
4439             IF (NGLUON.GT.0) THEN
4440                DO 17 IGLUON=1,NGLUON
4441                   IDX   = IDX1+IGLUON
4442                   IDXMS = ABS(JMOHEP(1,IDX))
4443                   IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
4444                      ILOOP = 0
4445    16                CONTINUE
4446                      ILOOP = ILOOP+1
4447                      IDXMS = ABS(JMOHEP(1,IDXMS))
4448                      IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
4449      &                   (ILOOP.LT.MAXLOP)) GOTO 16
4450                      IF (ILOOP.EQ.MAXLOP)
4451      &                  WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
4452                   ENDIF
4453                   IF (IDXMS.EQ.1) THEN
4454                      ISPTN = ISTHKK(MO1)
4455                      M1PTN = MO1
4456                      M2PTN = MO1+2
4457                   ELSE
4458                      ISPTN = ISTHKK(MO2)
4459                      M1PTN = MO2-2
4460                      M2PTN = MO2
4461                   ENDIF
4462                   PX = PHEP(1,IDX)
4463                   PY = PHEP(2,IDX)
4464                   PZ = PHEP(3,IDX)
4465                   PE = PHEP(4,IDX)
4466                   IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
4467                      ISTX = ABS(ISPTN)/10
4468                      IMO  = ABS(ISPTN)-10*ISTX
4469                      IF ((IDHEP(IDX).EQ.21).OR.
4470      &                   (ABS(IPHIST(1,IDX)).GE.100)) THEN
4471                         ISPTN = -(60+IMO)
4472                      ELSE
4473                         ISPTN = -(50+IMO)
4474                      ENDIF
4475                   ENDIF
4476                   IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
4477                   IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
4478                   IF (MODE.LT.0) THEN
4479                      CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4480      &                              PX,PY,PZ,PE,0,0,0)
4481                   ELSE
4482                      CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4483      &                              PPX,PPY,PPZ,PPE)
4484                      CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4485      &                              PPX,PPY,PPZ,PPE,0,0,0)
4486                   ENDIF
4487                   IHIST(1,NHKK) = IPHIST(1,IDX)
4488                   IHIST(2,NHKK) = 0
4489                   DO 20 KK=1,4
4490                      VHKK(KK,NHKK) = VHKK(KK,M2PTN)
4491                      WHKK(KK,NHKK) = WHKK(KK,M1PTN)
4492    20             CONTINUE
4493                   VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
4494                   WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
4495    17          CONTINUE
4496             ENDIF
4497 *     parton at chain end
4498             PX = PHEP(1,IDX2)
4499             PY = PHEP(2,IDX2)
4500             PZ = PHEP(3,IDX2)
4501             PE = PHEP(4,IDX2)
4502 * flag only partons coming from Pomeron with 41/42
4503 C           IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4504             IF (IPOM2.NE.0) THEN
4505                ISTX = ABS(ISPTN2)/10
4506                IMO  = ABS(ISPTN2)-10*ISTX
4507                ISPTN2 = -(40+IMO)
4508             ELSE
4509                IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
4510                   ISTX = ABS(ISPTN2)/10
4511                   IMO  = ABS(ISPTN2)-10*ISTX
4512                   IF ((IDHEP(IDX2).EQ.21).OR.
4513      &                (ABS(IPHIST(1,IDX2)).GE.100)) THEN
4514                      ISPTN2 = -(60+IMO)
4515                   ELSE
4516                      ISPTN2 = -(50+IMO)
4517                   ENDIF
4518                ENDIF
4519             ENDIF
4520             IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
4521             IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
4522             IF (MODE.LT.0) THEN
4523                CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4524      &                        PX,PY,PZ,PE,0,0,0)
4525             ELSE
4526                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4527      &                        PPX,PPY,PPZ,PPE)
4528                CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4529      &                        PPX,PPY,PPZ,PPE,0,0,0)
4530             ENDIF
4531             IHIST(1,NHKK) = IPHIST(1,IDX2)
4532             IHIST(2,NHKK) = 0
4533             DO 21 KK=1,4
4534                VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
4535                WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
4536    21       CONTINUE
4537             VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
4538             WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
4539             M2STRG = NHKK
4540 *   register string
4541             JSTRG = 100*IPROCE+NCODE(I)
4542             PX = PHEP(1,IDXSTG)
4543             PY = PHEP(2,IDXSTG)
4544             PZ = PHEP(3,IDXSTG)
4545             PE = PHEP(4,IDXSTG)
4546             IF (MODE.LT.0) THEN
4547                ISTAT = 70000+IPJE
4548                CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4549      &                        PX,PY,PZ,PE,0,0,0)
4550                IF (LEMCCK) THEN
4551                   PX = -PX
4552                   PY = -PY
4553                   PZ = -PZ
4554                   PE = -PE
4555                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4556                ENDIF
4557             ELSE
4558                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4559      &                        PPX,PPY,PPZ,PPE)
4560                ISTAT = 70000+IPJE
4561                CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4562      &                        PPX,PPY,PPZ,PPE,0,0,0)
4563                IF (LEMCCK) THEN
4564                   PX = -PPX
4565                   PY = -PPY
4566                   PZ = -PPZ
4567                   PE = -PPE
4568                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4569                ENDIF
4570             ENDIF
4571             NOBAM(NHKK)   = 0
4572             IHIST(1,NHKK) = 0
4573             IHIST(2,NHKK) = 0
4574             DO 18 KK=1,4
4575                VHKK(KK,NHKK) = VHKK(KK,MO2)
4576                WHKK(KK,NHKK) = WHKK(KK,MO1)
4577    18       CONTINUE
4578             VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
4579             WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
4580          ENDIF
4581    11 CONTINUE
4582
4583       IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
4584          NHKK  = INHKK
4585          LFLIP = .FALSE.
4586          GOTO 1
4587       ENDIF
4588
4589       IF (LEMCCK) THEN
4590          IF (UMO.GT.1.0D5) THEN
4591             CHKLEV = 1.0D0
4592          ELSE
4593             CHKLEV = TINY1
4594          ENDIF
4595          CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
4596          IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
4597       ENDIF
4598
4599 * internal statistics
4600 *   dble-Po statistics.
4601       IF (IPROCE.NE.4) IPOPO = 0
4602
4603       INTFLG = IPROCE
4604       IDCHSY = IDCH(MO1)
4605       IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
4606          ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
4607       ELSE
4608          WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
4609  1000    FORMAT(1X,'GETFSP:   warning! incons. process id. (',I2,
4610      &          ') at evt(chain) ',I6,'(',I2,')')
4611       ENDIF
4612       IF (IPROCE.EQ.5) THEN
4613          IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
4614             ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
4615          ELSE
4616 C           WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4617  1001       FORMAT(1X,'GETFSP:   warning! incons. diffrac. id. ',
4618      &             '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
4619          ENDIF
4620       ELSEIF (IPROCE.EQ.6) THEN
4621          IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4622             ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
4623          ELSE
4624 C           WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4625          ENDIF
4626       ELSEIF (IPROCE.EQ.7) THEN
4627          IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
4628      &       (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4629             IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
4630      &         ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
4631             IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
4632      &         ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
4633             IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
4634      &         ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
4635             IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
4636      &         ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
4637          ELSE
4638             WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4639          ENDIF
4640       ENDIF
4641       IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
4642      &                                                       THEN
4643          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4644          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4645          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4646       ENDIF
4647       ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
4648       ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
4649       ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
4650       ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
4651       ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
4652
4653       RETURN
4654
4655  9999 CONTINUE
4656       IREJ = 1
4657       RETURN
4658       END
4659
4660 *$ CREATE DT_PHOINI.FOR
4661 *COPY DT_PHOINI
4662 *
4663 *===phoini=============================================================*
4664 *
4665       SUBROUTINE DT_PHOINI
4666
4667 ************************************************************************
4668 * Initialization PHOJET-event generator for nucleon-nucleon interact.  *
4669 * This version dated 16.11.95 is written by S. Roesler                 *
4670 *                                                                      *
4671 * Last change 27.12.2006 by S. Roesler.                                *
4672 ************************************************************************
4673
4674       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4675       SAVE
4676       PARAMETER ( LINP = 10 ,
4677      &            LOUT = 6 ,
4678      &            LDAT = 9 )
4679       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
4680
4681 * nucleon-nucleon event-generator
4682       CHARACTER*8 CMODEL
4683       LOGICAL LPHOIN
4684       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
4685 * particle properties (BAMJET index convention)
4686       CHARACTER*8  ANAME
4687       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
4688      &                IICH(210),IIBAR(210),K1(210),K2(210)
4689 * Lorentz-parameters of the current interaction
4690       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4691      &                UMO,PPCM,EPROJ,PPROJ
4692 * properties of interacting particles
4693       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4694 * properties of photon/lepton projectiles
4695       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
4696       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
4697 * emulsion treatment
4698       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
4699      &                NCOMPO,IEMUL
4700 * VDM parameter for photon-nucleus interactions
4701       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
4702 * nuclear potential
4703       LOGICAL LFERMI
4704       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4705      &                EBINDP(2),EBINDN(2),EPOT(2,210),
4706      &                ETACOU(2),ICOUL,LFERMI
4707 * Glauber formalism: flags and parameters for statistics
4708       LOGICAL LPROD
4709       CHARACTER*8 CGLB
4710       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
4711 *
4712 * parameters for cascade calculations:
4713 * maximum mumber of PDF's which can be defined in phojet (limited
4714 * by the dimension of ipdfs in pho_setpdf)
4715       PARAMETER (MAXPDF = 20)
4716 * PDF parametrization and number of set for the first 30 hadrons in
4717 * the bamjet-code list
4718 *   negative numbers mean that the PDF is set in phojet,
4719 *   zero stands for "not a hadron"
4720       DIMENSION IPARPD(30),ISETPD(30)
4721 * PDF parametrization
4722       DATA IPARPD /
4723      &  -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
4724      &   5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
4725 * number of set
4726       DATA ISETPD /
4727      &  -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
4728      &   6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
4729
4730 **PHOJET105a
4731 C     COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4732 C     PARAMETER ( MAXPRO = 16 )
4733 C     PARAMETER ( MAXTAB = 20 )
4734 C     COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
4735 C    &                MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
4736 C     CHARACTER*8 MDLNA
4737 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
4738 C     COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
4739 **PHOJET110
4740 C  global event kinematics and particle IDs
4741       INTEGER IFPAP,IFPAB
4742       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
4743       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4744 C  hard cross sections and MC selection weights
4745       INTEGER Max_pro_2
4746       PARAMETER ( Max_pro_2 = 16 )
4747       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
4748      &  MH_acc_1,MH_acc_2
4749       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
4750       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
4751      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
4752      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
4753      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
4754      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
4755 C  model switches and parameters
4756       CHARACTER*8 MDLNA
4757       INTEGER ISWMDL,IPAMDL
4758       DOUBLE PRECISION PARMDL
4759       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4760 C  general process information
4761       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4762       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4763 **
4764       DIMENSION PP(4),PT(4)
4765
4766       LOGICAL LSTART
4767       DATA LSTART /.TRUE./
4768
4769       IJP = IJPROJ
4770       IJT = IJTARG
4771       Q2  = VIRT
4772 * lepton-projectiles: initialize real photon instead
4773       IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
4774          IJP = 7
4775          Q2  = ZERO
4776       ENDIF
4777       IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM)
4778 * switch Reggeon off
4779 C     IPAMDL(3)= 0
4780       IF (IP.EQ.1) THEN
4781          IFPAP(1) = IDT_IPDGHA(IJP)
4782          IFPAB(1) = IJP
4783       ELSE
4784          IFPAP(1) = 2212
4785          IFPAB(1) = IDT_ICIHAD(IFPAP(1))
4786       ENDIF
4787       PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
4788       PVIRT(1) = PMASS(1)**2
4789       IF (IT.EQ.1) THEN
4790          IFPAP(2) = IDT_IPDGHA(IJT)
4791          IFPAB(2) = IJT
4792       ELSE
4793          IFPAP(2) = 2212
4794          IFPAB(2) = IDT_ICIHAD(IFPAP(2))
4795       ENDIF
4796       PMASS(2) = AAM(IFPAB(2))
4797       PVIRT(2) = ZERO
4798       DO 1 K=1,4
4799          PP(K) = ZERO
4800          PT(K) = ZERO
4801     1 CONTINUE
4802 * get max. possible momenta of incoming particles to be used for PHOJET ini.
4803       PPF = ZERO
4804       PTF = ZERO
4805       SCPF= 1.5D0
4806       IF (UMO.GE.1.E5) THEN
4807          SCPF= 5.0D0
4808       ENDIF
4809       IF (NCOMPO.GT.0) THEN
4810          DO 2 I=1,NCOMPO
4811             IF (IT.GT.1) THEN
4812                CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
4813             ELSE
4814                CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
4815             ENDIF
4816             PPFTMP = MAX(PFERMP(1),PFERMN(1))
4817             PTFTMP = MAX(PFERMP(2),PFERMN(2))
4818             IF (PPFTMP.GT.PPF) PPF = PPFTMP
4819             IF (PTFTMP.GT.PTF) PTF = PTFTMP
4820     2    CONTINUE
4821       ELSE
4822          CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
4823          PPF = MAX(PFERMP(1),PFERMN(1))
4824          PTF = MAX(PFERMP(2),PFERMN(2))
4825       ENDIF
4826       PTF = -PTF
4827       PPF = SCPF*PPF
4828       PTF = SCPF*PTF
4829       IF (IJP.EQ.7) THEN
4830          AMP2  = SIGN(PMASS(1)**2,PMASS(1))
4831          PP(3) = PPCM
4832          PP(4) = SQRT(AMP2+PP(3)**2)
4833       ELSE
4834          EPF = SQRT(PPF**2+PMASS(1)**2)
4835          CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
4836       ENDIF
4837       ETF = SQRT(PTF**2+PMASS(2)**2)
4838       CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
4839       ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
4840      &              (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
4841       IF (LSTART) THEN
4842          WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
4843  1001    FORMAT(
4844      &      ' DT_PHOINI:    PHOJET initialized for projectile A,Z = ',
4845      &      I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
4846          IF (NCOMPO.GT.0) THEN
4847             WRITE(LOUT,1002) SCPF,PTF,PT
4848          ELSE
4849             WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
4850          ENDIF
4851  1002    FORMAT(
4852      &      ' DT_PHOINI:    PHOJET initialized for target emulsion  ',
4853      &          /,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
4854  1003    FORMAT(
4855      &      ' DT_PHOINI:    PHOJET initialized for target     A,Z = ',
4856      &      I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
4857          WRITE(LOUT,1004) ECMINI
4858  1004    FORMAT(' E_cm = ',E10.3)
4859          IF (IJP.EQ.8) WRITE(LOUT,1005)
4860  1005    FORMAT(
4861      &      ' DT_PHOINI: warning! proton parameters used for neutron',
4862      &          ' projectile')
4863          LSTART = .FALSE.
4864       ENDIF
4865 * switch off new diffractive cross sections at low energies for nuclei
4866 * (temporary solution)
4867       IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
4868          WRITE(LOUT,'(1X,A)')
4869      &      ' DT_PHOINI: model-switch 30 for nuclei re-set !'
4870          CALL PHO_SETMDL(30,0,1)
4871       ENDIF
4872 *
4873 C     IF (IJP.EQ.7) THEN
4874 C        AMP2  = SIGN(PMASS(1)**2,PMASS(1))
4875 C        PP(3) = PPCM
4876 C        PP(4) = SQRT(AMP2+PP(3)**2)
4877 C     ELSE
4878 C        PFERMX = ZERO
4879 C        IF (IP.GT.1) PFERMX = 0.5D0
4880 C        EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
4881 C        CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
4882 C     ENDIF
4883 C     PFERMX = ZERO
4884 C     IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
4885 C     EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
4886 C     CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
4887 **sr 26.10.96
4888       ISAV = IPAMDL(13)
4889       IF ((ISHAD(2).EQ.1).AND.
4890      &   ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
4891      &    (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
4892 **
4893       CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
4894 **sr 26.10.96
4895       IPAMDL(13) = ISAV
4896 **
4897 *
4898 * patch for cascade calculations:
4899 * define parton distribution functions for other hadrons, i.e. other
4900 * then defined already in phojet
4901       IF (IOGLB.EQ.100) THEN
4902          WRITE(LOUT,1006)
4903  1006    FORMAT(/,1X,'PHOINI: additional parton distribution functions',
4904      &          ' assiged (ID,IPAR,ISET)',/)
4905          NPDF = 0
4906          DO 3 I=1,30
4907             IF (IPARPD(I).NE.0) THEN
4908                NPDF = NPDF+1
4909                IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
4910                IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
4911                   IDPDG = IDT_IPDGHA(I)
4912                   IPAR  = IPARPD(I)
4913                   ISET  = ISETPD(I)
4914                   WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
4915                   CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
4916                ENDIF
4917             ENDIF
4918     3    CONTINUE
4919       ENDIF
4920
4921 C     CALL PHO_PHIST(-1,SIGMAX)
4922       IF (IREJ1.NE.0) THEN
4923          WRITE(LOUT,1000)
4924  1000    FORMAT(1X,'PHOINI:   PHOJET event-initialization failed!')
4925          STOP
4926       ENDIF
4927
4928       RETURN
4929       END
4930
4931 *$ CREATE DT_EVENTD.FOR
4932 *COPY DT_EVENTD
4933 *
4934 *===eventd=============================================================*
4935 *
4936       SUBROUTINE DT_EVENTD(IREJ)
4937
4938 ************************************************************************
4939 * Quasi-elastic neutrino nucleus scattering.                           *
4940 * This version dated 29.04.00 is written by S. Roesler.                *
4941 ************************************************************************
4942
4943       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4944       SAVE
4945       PARAMETER ( LINP = 10 ,
4946      &            LOUT = 6 ,
4947      &            LDAT = 9 )
4948       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
4949       PARAMETER (SQTINF=1.0D+15)
4950
4951       LOGICAL LFIRST
4952
4953 * event history
4954       PARAMETER (NMXHKK=200000)
4955       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4956      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4957      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4958 * extended event history
4959       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4960      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4961      &                IHIST(2,NMXHKK)
4962 * flags for input different options
4963       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4964       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4965      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4966       PARAMETER (MAXLND=4000)
4967       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
4968 * properties of interacting particles
4969       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4970 * Lorentz-parameters of the current interaction
4971       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4972      &                UMO,PPCM,EPROJ,PPROJ
4973 * nuclear potential
4974       LOGICAL LFERMI
4975       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4976      &                EBINDP(2),EBINDN(2),EPOT(2,210),
4977      &                ETACOU(2),ICOUL,LFERMI
4978 * steering flags for qel neutrino scattering modules
4979       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
4980       COMMON /QNPOL/ POLARX(4),PMODUL
4981       INTEGER PYK
4982
4983       DATA LFIRST /.TRUE./
4984
4985       IREJ = 0
4986
4987       IF (LFIRST) THEN
4988          LFIRST = .FALSE.
4989          CALL DT_MASS_INI
4990       ENDIF
4991
4992 * JETSET parameter
4993       CALL DT_INITJS(0)
4994
4995 * interacting target nucleon
4996       LTYP = NEUTYP
4997       IF (NEUDEC.LE.9) THEN
4998          IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
4999             NUCTYP = 2112
5000             NUCTOP = 2
5001          ELSE
5002             NUCTYP = 2212
5003             NUCTOP = 1
5004          ENDIF
5005       ELSE
5006          RTYP  = DT_RNDM(RTYP)
5007          ZFRAC = DBLE(ITZ)/DBLE(IT)
5008          IF (RTYP.LE.ZFRAC) THEN
5009             NUCTYP = 2212
5010             NUCTOP = 1
5011          ELSE
5012             NUCTYP = 2112
5013             NUCTOP = 2
5014          ENDIF
5015       ENDIF
5016
5017 * select first nucleon in list with matching id and reset all other
5018 * nucleons which have been marked as "wounded" by ININUC
5019       IFOUND = 0
5020       DO 1 I=1,NHKK
5021          IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
5022             ISTHKK(I) = 12
5023             IFOUND    = 1
5024             IDX = I
5025          ELSE
5026             IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
5027          ENDIF
5028     1 CONTINUE
5029       IF (IFOUND.EQ.0)
5030      &   STOP ' EVENTD: interacting target nucleon not found! '
5031
5032 * correct position of proj. lepton: assume position of target nucleon
5033       DO 3 I=1,4
5034          VHKK(I,1) = VHKK(I,IDX)
5035          WHKK(I,1) = WHKK(I,IDX)
5036     3 CONTINUE
5037
5038 * load initial momenta for conservation check
5039       IF (LEMCCK) THEN
5040          CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
5041          CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
5042      &                                                      2,IDUM,IDUM)
5043       ENDIF
5044
5045 * quasi-elastic scattering
5046       IF (NEUDEC.LT.9) THEN
5047          CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
5048      &                                          PHKK(4,IDX),PHKK(5,IDX))
5049 *  CC event on p or n
5050       ELSEIF (NEUDEC.EQ.10) THEN
5051          CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
5052      &                     PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5053 *  NC event on p or n
5054       ELSEIF (NEUDEC.EQ.11) THEN
5055          CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
5056      &                     PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5057       ENDIF
5058
5059 * get final state particles from Lund-common and write them into HKKEVT
5060       NPOINT(1) = NHKK+1
5061       NPOINT(4) = NHKK+1
5062       NLINES = PYK(0,1)
5063       NHKK0  = NHKK+1
5064       DO 4 I=4,NLINES
5065          IF (K(I,1).EQ.1) THEN
5066             ID = K(I,2)
5067             PX = P(I,1)
5068             PY = P(I,2)
5069             PZ = P(I,3)
5070             PE = P(I,4)
5071             CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
5072             IDBJ = IDT_ICIHAD(ID)
5073             EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
5074             IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
5075                IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
5076             ENDIF
5077             VHKK(1,NHKK) = VHKK(1,IDX)
5078             VHKK(2,NHKK) = VHKK(2,IDX)
5079             VHKK(3,NHKK) = VHKK(3,IDX)
5080             VHKK(4,NHKK) = VHKK(4,IDX)
5081 C           IF (I.EQ.4) THEN
5082 C              WHKK(1,NHKK) = POLARX(1)
5083 C              WHKK(2,NHKK) = POLARX(2)
5084 C              WHKK(3,NHKK) = POLARX(3)
5085 C              WHKK(4,NHKK) = POLARX(4)
5086 C           ELSE
5087                WHKK(1,NHKK) = WHKK(1,IDX)
5088                WHKK(2,NHKK) = WHKK(2,IDX)
5089                WHKK(3,NHKK) = WHKK(3,IDX)
5090                WHKK(4,NHKK) = WHKK(4,IDX)
5091 C           ENDIF
5092             IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
5093          ENDIF
5094     4 CONTINUE
5095
5096       IF (LEMCCK) THEN
5097          CHKLEV = TINY5
5098          CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
5099          IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
5100       ENDIF
5101
5102 * transform momenta into cms (as required for inc etc.)
5103       DO 5 I=NHKK0,NHKK
5104          IF (ISTHKK(I).EQ.1) THEN
5105             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
5106             PHKK(3,I) = PZ
5107             PHKK(4,I) = PE
5108          ENDIF
5109     5 CONTINUE
5110
5111       RETURN
5112       END
5113
5114 *$ CREATE DT_KKEVNT.FOR
5115 *COPY DT_KKEVNT
5116 *
5117 *===kkevnt=============================================================*
5118 *
5119       SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
5120
5121 ************************************************************************
5122 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering   *
5123 * without nuclear effects (one event).                                 *
5124 * This subroutine is an update of the previous version (KKEVT) written *
5125 * by J. Ranft/ H.-J. Moehring.                                         *
5126 * This version dated 20.04.95 is written by S. Roesler                 *
5127 ************************************************************************
5128
5129       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5130       SAVE
5131       PARAMETER ( LINP = 10 ,
5132      &            LOUT = 6 ,
5133      &            LDAT = 9 )
5134       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
5135
5136       PARAMETER ( MAXNCL = 260,
5137      &            MAXVQU = MAXNCL,
5138      &            MAXSQU = 20*MAXVQU,
5139      &            MAXINT = MAXVQU+MAXSQU)
5140 * event history
5141       PARAMETER (NMXHKK=200000)
5142       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5143      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5144      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5145 * extended event history
5146       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5147      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5148      &                IHIST(2,NMXHKK)
5149 * flags for input different options
5150       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5151       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5152      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5153 * rejection counter
5154       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
5155      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
5156      &                IREXCI(3),IRDIFF(2),IRINC
5157 * statistics
5158       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5159      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5160      &                ICEVTG(8,0:30)
5161 * properties of interacting particles
5162       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5163 * Lorentz-parameters of the current interaction
5164       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5165      &                UMO,PPCM,EPROJ,PPROJ
5166 * flags for diffractive interactions (DTUNUC 1.x)
5167       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5168 * interface HADRIN-DPM
5169       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5170 * nucleon-nucleon event-generator
5171       CHARACTER*8 CMODEL
5172       LOGICAL LPHOIN
5173       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
5174 * coordinates of nucleons
5175       COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
5176 * interface between Glauber formalism and DPM
5177       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
5178      &                INTER1(MAXINT),INTER2(MAXINT)
5179 * Glauber formalism: collision properties
5180       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5181      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
5182      &                NCP,NCT
5183 * central particle production, impact parameter biasing
5184       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5185 **temporary
5186 * statistics: Glauber-formalism
5187       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5188 **
5189
5190       DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5191
5192       IREJ   = 0
5193       ICREQU = ICREQU+1
5194       NC     = 0
5195       NCP    = 0
5196       NCT    = 0
5197
5198     1 CONTINUE
5199       ICSAMP = ICSAMP+1
5200       NC     = NC+1
5201       IF (MOD(NC,10).EQ.0) THEN
5202          WRITE(LOUT,1000) NEVHKK
5203  1000    FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5204          GOTO 9999
5205       ENDIF
5206
5207 * initialize DTEVT1/DTEVT2
5208       CALL DT_EVTINI
5209
5210 * We need the following only in order to sample nucleon coordinates.
5211 * However we don't have parameters (cross sections, slope etc.)
5212 * for neutrinos available. Therefore switch projectile to proton
5213 * in this case.
5214       IF (MCGENE.EQ.4) THEN
5215          JJPROJ = 1
5216       ELSE
5217          JJPROJ = IJPROJ
5218       ENDIF
5219
5220    10 CONTINUE
5221       IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5222 * make sure that Glauber-formalism is called each time the interaction
5223 * configuration changed
5224      &     (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5225      &     (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5226 * sample number of nucleon-nucleon coll. according to Glauber-form.
5227          CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5228          NWTSAM = NN
5229          NWASAM = NP
5230          NWBSAM = NT
5231          NEVOLD = NEVHKK
5232          IPOLD  = IP
5233          ITOLD  = IT
5234          JJPOLD = JJPROJ
5235          EPROLD = EPROJ
5236          DO 8 I=1, IP
5237             NCP = NCP+JSSH(I)
5238 *           WRITE(6,*)' PROJ.NUCL. ',I,' NCOLL = ',NCP
5239     8 CONTINUE
5240          DO 9 I=1, IT
5241             NCT = NCT+JTSH(I)
5242 *           WRITE(6,*)' TAR.NUCL. ',I,' NCOLL = ',NCT
5243     9 CONTINUE
5244       ENDIF
5245
5246 * force diffractive particle production in h-K interactions
5247       IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5248      &    (IP.EQ.1).AND.(NN.NE.1)) THEN
5249          NEVOLD = 0
5250          GOTO 10
5251       ENDIF
5252
5253 * check number of involved proj. nucl. (NP) if central prod.is requested
5254       IF (ICENTR.GT.0) THEN
5255          CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5256          IF (IBACK.GT.0) GOTO 10
5257       ENDIF
5258
5259 * get initial nucleon-configuration in projectile and target
5260 * rest-system (including Fermi-momenta if requested)
5261       CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5262       MODE = 2
5263       IF (EPROJ.LE.EHADTH) MODE = 3
5264       CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5265
5266       IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5267
5268 * activate HADRIN at low energies (implemented for h-N scattering only)
5269          IF (EPROJ.LE.EHADHI) THEN
5270             IF (EHADTH.LT.ZERO) THEN
5271 *   smooth transition btwn. DPM and HADRIN
5272                FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5273                RR   = DT_RNDM(FRAC)
5274                IF (RR.GT.FRAC) THEN
5275                   IF (IP.EQ.1) THEN
5276                      CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5277                      IF (IREJ1.GT.0) GOTO 1
5278                      RETURN
5279                   ELSE
5280                      WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5281                   ENDIF
5282                ENDIF
5283             ELSE
5284 *   fixed threshold for onset of production via HADRIN
5285                IF (EPROJ.LE.EHADTH) THEN
5286                   IF (IP.EQ.1) THEN
5287                      CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5288                      IF (IREJ1.GT.0) GOTO 1
5289                      RETURN
5290                   ELSE
5291                      WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5292                   ENDIF
5293                ENDIF
5294             ENDIF
5295          ENDIF
5296  1001    FORMAT(1X,'KKEVNT:   warning! interaction of proj. (m=',
5297      &          I3,') with target (m=',I3,')',/,11X,
5298      &          'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5299      &          'GeV) cannot be handled')
5300
5301 * sampling of momentum-x fractions & flavors of chain ends
5302          CALL DT_SPLPTN(NN)
5303
5304 * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5305          CALL DT_NUC2CM
5306
5307 * collect momenta of chain ends and put them into DTEVT1
5308          CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5309          IF (IREJ1.NE.0) GOTO 1
5310
5311       ENDIF
5312
5313 * handle chains including fragmentation (two-chain approximation)
5314       IF (MCGENE.EQ.1) THEN
5315 *  two-chain approximation
5316          CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5317          IF (IREJ1.NE.0) THEN
5318             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5319             GOTO 1
5320          ENDIF
5321       ELSEIF (MCGENE.EQ.2) THEN
5322 *  multiple-Po exchange including minijets
5323          CALL DT_EVENTB(NCSY,IREJ1)
5324          IF (IREJ1.NE.0) THEN
5325             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5326             GOTO 1
5327          ENDIF
5328       ELSEIF (MCGENE.EQ.3) THEN
5329          STOP ' This version does not contain LEPTO !'
5330       ELSEIF (MCGENE.EQ.4) THEN
5331 *  quasi-elastic neutrino scattering
5332          CALL DT_EVENTD(IREJ1)
5333          IF (IREJ1.NE.0) THEN
5334             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5335             GOTO 1
5336          ENDIF
5337       ELSE
5338          WRITE(LOUT,1002) MCGENE
5339  1002    FORMAT(1X,'KKEVNT:   warning! event-generator',I4,
5340      &         ' not available - program stopped')
5341          STOP
5342       ENDIF
5343
5344       RETURN
5345
5346  9999 CONTINUE
5347       IREJ = 1
5348       RETURN
5349       END
5350
5351 *$ CREATE DT_CHKCEN.FOR
5352 *COPY DT_CHKCEN
5353 *
5354 *===chkcen=============================================================*
5355 *
5356       SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5357
5358 ************************************************************************
5359 * Check of number of involved projectile nucleons if central production*
5360 * is requested.                                                        *
5361 * Adopted from a part of the old KKEVT routine which was written by    *
5362 * J. Ranft/H.-J.Moehring.                                              *
5363 * This version dated 13.01.95 is written by S. Roesler                 *
5364 ************************************************************************
5365
5366       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5367       SAVE
5368       PARAMETER ( LINP = 10 ,
5369      &            LOUT = 6 ,
5370      &            LDAT = 9 )
5371
5372 * statistics
5373       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5374      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5375      &                ICEVTG(8,0:30)
5376 * central particle production, impact parameter biasing
5377       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5378
5379       IBACK = 0
5380
5381 * old version
5382       IF (ICENTR.EQ.2) THEN
5383          IF (IP.LT.IT) THEN
5384             IF (IP.LE.8) THEN
5385                IF (NP.LT.IP-1) IBACK = 1
5386             ELSEIF (IP.LE.16) THEN
5387                IF (NP.LT.IP-2) IBACK = 1
5388             ELSEIF (IP.LE.32) THEN
5389                IF (NP.LT.IP-3) IBACK = 1
5390             ELSEIF (IP.GE.33) THEN
5391                IF (NP.LT.IP-5) IBACK = 1
5392             ENDIF
5393          ELSEIF (IP.EQ.IT) THEN
5394             IF (IP.EQ.32) THEN
5395                IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5396             ELSE
5397                IF (NP.LT.IP-IP/8) IBACK = 1
5398             ENDIF
5399          ELSEIF (ABS(IP-IT).LT.3) THEN
5400             IF (NP.LT.IP-IP/8) IBACK = 1
5401          ENDIF
5402       ELSE
5403 * new version (DPMJET, 5.6.99)
5404          IF (IP.LT.IT) THEN
5405             IF (IP.LE.8) THEN
5406                IF (NP.LT.IP-1) IBACK = 1
5407             ELSEIF (IP.LE.16) THEN
5408                IF (NP.LT.IP-2) IBACK = 1
5409             ELSEIF (IP.LT.32) THEN
5410                IF (NP.LT.IP-3) IBACK = 1
5411             ELSEIF (IP.GE.32) THEN
5412                IF (IT.LE.150) THEN
5413 *   Example: S-Ag
5414                   IF (NP.LT.IP-1) IBACK = 1
5415                ELSE
5416 *   Example: S-Au
5417                   IF (NP.LT.IP) IBACK = 1
5418                ENDIF
5419             ENDIF
5420          ELSEIF (IP.EQ.IT) THEN
5421 *   Example: S-S
5422            IF (IP.EQ.32) THEN
5423               IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5424 *   Example: Pb-Pb
5425            ELSE
5426               IF (NP.LT.IP-IP/4) IBACK = 1
5427            ENDIF
5428          ELSEIF (ABS(IP-IT).LT.3) THEN
5429             IF (NP.LT.IP-IP/8) IBACK = 1
5430          ENDIF
5431       ENDIF
5432
5433       ICCPRO = ICCPRO+1
5434
5435       RETURN
5436       END
5437
5438 *$ CREATE DT_ININUC.FOR
5439 *COPY DT_ININUC
5440 *
5441 *===ininuc=============================================================*
5442 *
5443       SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5444
5445 ************************************************************************
5446 * Samples initial configuration of nucleons in nucleus with mass NMASS *
5447 * including Fermi-momenta (if reqested).                               *
5448 *          ID             BAMJET-code for hadrons (instead of nuclei)  *
5449 *          NMASS          mass number of nucleus (number of nucleons)  *
5450 *          NCH            charge of nucleus                            *
5451 *          COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5452 *          JS(NMASS) > 0  nucleon undergoes nucleon-nucleon interact.  *
5453 *          IMODE = 1      projectile nucleus                           *
5454 *                = 2      target     nucleus                           *
5455 *                = 3      target     nucleus (E_lab<E_thr for HADRIN)  *
5456 * Adopted from a part of the old KKEVT routine which was written by    *
5457 * J. Ranft/H.-J.Moehring.                                              *
5458 * This version dated 13.01.95 is written by S. Roesler                 *
5459 ************************************************************************
5460
5461       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5462       SAVE
5463       PARAMETER ( LINP = 10 ,
5464      &            LOUT = 6 ,
5465      &            LDAT = 9 )
5466       PARAMETER (FM2MM=1.0D-12)
5467
5468       PARAMETER ( MAXNCL = 260,
5469      &            MAXVQU = MAXNCL,
5470      &            MAXSQU = 20*MAXVQU,
5471      &            MAXINT = MAXVQU+MAXSQU)
5472 * event history
5473       PARAMETER (NMXHKK=200000)
5474       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5475      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5476      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5477 * extended event history
5478       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5479      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5480      &                IHIST(2,NMXHKK)
5481 * flags for input different options
5482       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5483       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5484      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5485 * auxiliary common for chain system storage (DTUNUC 1.x)
5486       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5487 * nuclear potential
5488       LOGICAL LFERMI
5489       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5490      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5491      &                ETACOU(2),ICOUL,LFERMI
5492 * properties of photon/lepton projectiles
5493       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5494 * particle properties (BAMJET index convention)
5495       CHARACTER*8  ANAME
5496       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5497      &                IICH(210),IIBAR(210),K1(210),K2(210)
5498 * Glauber formalism: collision properties
5499       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5500      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5501 * flavors of partons (DTUNUC 1.x)
5502       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5503      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5504      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5505      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5506      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5507      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5508      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5509 * interface HADRIN-DPM
5510       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5511
5512       DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5513
5514 * number of neutrons
5515       NNEU = NMASS-NCH
5516 * initializations
5517       NP = 0
5518       NN = 0
5519       DO 1 K=1,4
5520          PFTOT(K) = 0.0D0
5521     1 CONTINUE
5522       MODE   = IMODE
5523       IF (IMODE.GT.2) MODE = 2
5524 **sr 29.5. new NPOINT(1)-definition
5525 C     IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5526 **
5527       NHADRI = 0
5528       NC     = NHKK
5529
5530 * get initial configuration
5531       DO 2 I=1,NMASS
5532          NHKK = NHKK+1
5533          IF (JS(I).GT.0) THEN
5534             ISTHKK(NHKK) = 10+MODE
5535             IF (IMODE.EQ.3) THEN
5536 *   additional treatment if HADRIN-generator is requested
5537                NHADRI = NHADRI+1
5538                IF (NHADRI.EQ.1) IDXTA  = NHKK
5539                IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5540             ENDIF
5541          ELSE
5542             ISTHKK(NHKK) = 12+MODE
5543          ENDIF
5544          IF (NMASS.GE.2) THEN
5545 *   treatment for nuclei
5546             FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5547             RR   = DT_RNDM(FRAC)
5548             IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5549                IDX = 8
5550                NN  = NN+1
5551             ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5552                IDX = 1
5553                NP  = NP+1
5554             ELSEIF (NN.LT.NNEU) THEN
5555                IDX = 8
5556                NN  = NN+1
5557             ELSEIF (NP.LT.NCH)  THEN
5558                IDX = 1
5559                NP  = NP+1
5560             ENDIF
5561             IDHKK(NHKK) = IDT_IPDGHA(IDX)
5562             IDBAM(NHKK) = IDX
5563             IF (MODE.EQ.1) THEN
5564                IPOSP(I)  = NHKK
5565                KKPROJ(I) = IDX
5566             ELSE
5567                IPOST(I)  = NHKK
5568                KKTARG(I) = IDX
5569             ENDIF
5570             IF (IDX.EQ.1) THEN
5571                PFER = PFERMP(MODE)
5572                PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5573             ELSE
5574                PFER = PFERMN(MODE)
5575                PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5576             ENDIF
5577             CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5578             DO 3 K=1,4
5579                PFTOT(K) = PFTOT(K)+PF(K)
5580                PHKK(K,NHKK) = PF(K)
5581     3       CONTINUE
5582             PHKK(5,NHKK) = AAM(IDX)
5583          ELSE
5584 *   treatment for hadrons
5585             IDHKK(NHKK)  = IDT_IPDGHA(ID)
5586             IDBAM(NHKK)  = ID
5587             PHKK(4,NHKK) = AAM(ID)
5588             PHKK(5,NHKK) = AAM(ID)
5589 C* VDM assumption
5590 C            IF (IDHKK(NHKK).EQ.22) THEN
5591 C               PHKK(4,NHKK) = AAM(33)
5592 C               PHKK(5,NHKK) = AAM(33)
5593 C            ENDIF
5594             IF (MODE.EQ.1) THEN
5595                IPOSP(I)  = NHKK
5596                KKPROJ(I) = ID
5597                PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5598             ELSE
5599                IPOST(I)  = NHKK
5600                KKTARG(I) = ID
5601             ENDIF
5602          ENDIF
5603          DO 4 K=1,3
5604             VHKK(K,NHKK) = COORD(K,I)*FM2MM
5605             WHKK(K,NHKK) = COORD(K,I)*FM2MM
5606     4    CONTINUE
5607          IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5608          IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5609          VHKK(4,NHKK) = 0.0D0
5610          WHKK(4,NHKK) = 0.0D0
5611     2 CONTINUE
5612
5613 * balance Fermi-momenta
5614       IF (NMASS.GE.2) THEN
5615          DO 5 I=1,NMASS
5616             NC = NC+1
5617             DO 6 K=1,3
5618                PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5619     6       CONTINUE
5620             PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5621      &                        PHKK(2,NC)**2+PHKK(3,NC)**2)
5622     5    CONTINUE
5623       ENDIF
5624
5625       RETURN
5626       END
5627
5628 *$ CREATE DT_FER4M.FOR
5629 *COPY DT_FER4M
5630 *
5631 *===fer4m==============================================================*
5632 *
5633       SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
5634
5635 ************************************************************************
5636 * Sampling of nucleon Fermi-momenta from distributions at T=0.         *
5637 *                                   processed by S. Roesler, 17.10.95  *
5638 ************************************************************************
5639
5640       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5641       SAVE
5642       PARAMETER ( LINP = 10 ,
5643      &            LOUT = 6 ,
5644      &            LDAT = 9 )
5645
5646       LOGICAL LSTART
5647
5648 * particle properties (BAMJET index convention)
5649       CHARACTER*8  ANAME
5650       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5651      &                IICH(210),IIBAR(210),K1(210),K2(210)
5652 * nuclear potential
5653       LOGICAL LFERMI
5654       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5655      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5656      &                ETACOU(2),ICOUL,LFERMI
5657
5658       DATA LSTART /.TRUE./
5659
5660       ILOOP = 0
5661       IF (LFERMI) THEN
5662          IF (LSTART) THEN
5663             WRITE(LOUT,1000)
5664  1000       FORMAT(/,1X,'FER4M:   sampling of Fermi-momenta activated')
5665             LSTART = .FALSE.
5666          ENDIF
5667     1    CONTINUE
5668          CALL DT_DFERMI(PABS)
5669          PABS = PFERM*PABS
5670 C        IF (PABS.GE.PBIND) THEN
5671 C           ILOOP = ILOOP+1
5672 C           IF (MOD(ILOOP,500).EQ.0) THEN
5673 C              WRITE(LOUT,1001) PABS,PBIND,ILOOP
5674 C1001          FORMAT(1X,'FER4M:    Fermi-mom. corr. for binding',
5675 C    &                ' energy ',2E12.3,I6)
5676 C           ENDIF
5677 C           GOTO 1
5678 C        ENDIF
5679          CALL DT_DPOLI(POLC,POLS)
5680          CALL DT_DSFECF(SFE,CFE)
5681          CXTA = POLS*CFE
5682          CYTA = POLS*SFE
5683          CZTA = POLC
5684          ET   = SQRT(PABS*PABS+AAM(KT)**2)
5685          PXT  = CXTA*PABS
5686          PYT  = CYTA*PABS
5687          PZT  = CZTA*PABS
5688       ELSE
5689          ET   = AAM(KT)
5690          PXT  = 0.0D0
5691          PYT  = 0.0D0
5692          PZT  = 0.0D0
5693       ENDIF
5694
5695       RETURN
5696       END
5697
5698 *$ CREATE DT_NUC2CM.FOR
5699 *COPY DT_NUC2CM
5700 *
5701 *===nuc2cm=============================================================*
5702 *
5703       SUBROUTINE DT_NUC2CM
5704
5705 ************************************************************************
5706 * Lorentz-transformation of all wounded nucleons from Lab. to nucl.-   *
5707 * nucl. cms. (This subroutine replaces NUCMOM.)                        *
5708 * This version dated 15.01.95 is written by S. Roesler                 *
5709 ************************************************************************
5710
5711       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5712       SAVE
5713       PARAMETER ( LINP = 10 ,
5714      &            LOUT = 6 ,
5715      &            LDAT = 9 )
5716       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
5717
5718 * event history
5719       PARAMETER (NMXHKK=200000)
5720       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5721      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5722      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5723 * extended event history
5724       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5725      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5726      &                IHIST(2,NMXHKK)
5727 * statistics
5728       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5729      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5730      &                ICEVTG(8,0:30)
5731 * properties of photon/lepton projectiles
5732       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5733 * particle properties (BAMJET index convention)
5734       CHARACTER*8  ANAME
5735       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5736      &                IICH(210),IIBAR(210),K1(210),K2(210)
5737 * Glauber formalism: collision properties
5738       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5739      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5740 **temporary
5741 * statistics: Glauber-formalism
5742       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5743 **
5744
5745       ICWP = 0
5746       ICWT = 0
5747       NWTACC = 0
5748       NWAACC = 0
5749       NWBACC = 0
5750
5751       NPOINT(1) = NHKK+1
5752       NEND      = NHKK
5753       DO 1 I=1,NEND
5754          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
5755             IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
5756             IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
5757             MODE = ISTHKK(I)-9
5758 C            IF (IDHKK(I).EQ.22) THEN
5759 C* VDM assumption
5760 C               PEIN = AAM(33)
5761 C               IDB  = 33
5762 C            ELSE
5763 C               PEIN = PHKK(4,I)
5764 C               IDB  = IDBAM(I)
5765 C            ENDIF
5766 C            CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
5767 C     &           PX,PY,PZ,PE,IDB,MODE)
5768             IF (PHKK(5,I).GT.ZERO) THEN
5769                CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
5770      &              PX,PY,PZ,PE,IDBAM(I),MODE)
5771             ELSE
5772                PX = PGAMM(1)
5773                PY = PGAMM(2)
5774                PZ = PGAMM(3)
5775                PE = PGAMM(4)
5776             ENDIF
5777             IST = ISTHKK(I)-2
5778             ID  = IDHKK(I)
5779 C* VDM assumption
5780 C            IF (ID.EQ.22) ID = 113
5781             CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
5782             IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
5783             IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
5784          ENDIF
5785     1 CONTINUE
5786
5787       NWTACC = MAX(NWAACC,NWBACC)
5788       ICDPR  = ICDPR+ICWP
5789       ICDTA  = ICDTA+ICWT
5790 **temporary
5791       IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
5792          CALL DT_EVTOUT(4)
5793          STOP
5794       ENDIF
5795
5796       RETURN
5797       END
5798
5799 *$ CREATE DT_SPLPTN.FOR
5800 *COPY DT_SPLPTN
5801 *
5802 *===splptn=============================================================*
5803 *
5804       SUBROUTINE DT_SPLPTN(NN)
5805
5806 ************************************************************************
5807 * SamPLing of ParToN momenta and flavors.                              *
5808 * This version dated 15.01.95 is written by S. Roesler                 *
5809 ************************************************************************
5810
5811       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5812       SAVE
5813       PARAMETER ( LINP = 10 ,
5814      &            LOUT = 6 ,
5815      &            LDAT = 9 )
5816
5817 * Lorentz-parameters of the current interaction
5818       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5819      &                UMO,PPCM,EPROJ,PPROJ
5820
5821 * sample flavors of sea-quarks
5822       CALL DT_SPLFLA(NN,1)
5823
5824 * sample x-values of partons at chain ends
5825       ECM = UMO
5826       CALL DT_XKSAMP(NN,ECM)
5827
5828 * samle flavors
5829       CALL DT_SPLFLA(NN,2)
5830
5831       RETURN
5832       END
5833
5834 *$ CREATE DT_SPLFLA.FOR
5835 *COPY DT_SPLFLA
5836 *
5837 *===splfla=============================================================*
5838 *
5839       SUBROUTINE DT_SPLFLA(NN,MODE)
5840
5841 ************************************************************************
5842 * SamPLing of FLAvors of partons at chain ends.                        *
5843 * This subroutine replaces FLKSAA/FLKSAM.                              *
5844 *            NN            number of nucleon-nucleon interactions      *
5845 *            MODE = 1      sea-flavors                                 *
5846 *                 = 2      valence-flavors                             *
5847 * Based on the original version written by J. Ranft/H.-J. Moehring.    *
5848 * This version dated 16.01.95 is written by S. Roesler                 *
5849 ************************************************************************
5850
5851       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5852       SAVE
5853       PARAMETER ( LINP = 10 ,
5854      &            LOUT = 6 ,
5855      &            LDAT = 9 )
5856
5857       PARAMETER ( MAXNCL = 260,
5858      &            MAXVQU = MAXNCL,
5859      &            MAXSQU = 20*MAXVQU,
5860      &            MAXINT = MAXVQU+MAXSQU)
5861 * flavors of partons (DTUNUC 1.x)
5862       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5863      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5864      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5865      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5866      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5867      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5868      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5869 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5870       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5871      &                IXPV,IXPS,IXTV,IXTS,
5872      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
5873      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
5874      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
5875      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
5876      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
5877      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
5878      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
5879      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
5880 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5881       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5882      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5883 * particle properties (BAMJET index convention)
5884       CHARACTER*8  ANAME
5885       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5886      &                IICH(210),IIBAR(210),K1(210),K2(210)
5887 * various options for treatment of partons (DTUNUC 1.x)
5888 * (chain recombination, Cronin,..)
5889       LOGICAL LCO2CR,LINTPT
5890       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
5891      &                LCO2CR,LINTPT
5892
5893       IF (MODE.EQ.1) THEN
5894 * sea-flavors
5895          DO 1 I=1,NN
5896             IPSQ(I)  = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5897             IPSAQ(I) = -IPSQ(I)
5898     1    CONTINUE
5899          DO 2 I=1,NN
5900             ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5901             ITSAQ(I)= -ITSQ(I)
5902     2    CONTINUE
5903       ELSEIF (MODE.EQ.2) THEN
5904 * valence flavors
5905          DO 3 I=1,IXPV
5906             CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
5907     3    CONTINUE
5908          DO 4 I=1,IXTV
5909             CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
5910     4    CONTINUE
5911       ENDIF
5912
5913       RETURN
5914       END
5915
5916 *$ CREATE DT_GETPTN.FOR
5917 *COPY DT_GETPTN
5918 *
5919 *===getptn=============================================================*
5920 *
5921       SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
5922
5923 ************************************************************************
5924 * This subroutine collects partons at chain ends from temporary        *
5925 * commons and puts them into DTEVT1.                                   *
5926 * This version dated 15.01.95 is written by S. Roesler                 *
5927 ************************************************************************
5928
5929       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5930       SAVE
5931       PARAMETER ( LINP = 10 ,
5932      &            LOUT = 6 ,
5933      &            LDAT = 9 )
5934       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
5935
5936       LOGICAL LCHK
5937
5938       PARAMETER ( MAXNCL = 260,
5939      &            MAXVQU = MAXNCL,
5940      &            MAXSQU = 20*MAXVQU,
5941      &            MAXINT = MAXVQU+MAXSQU)
5942 * event history
5943       PARAMETER (NMXHKK=200000)
5944       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5945      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5946      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5947 * extended event history
5948       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5949      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5950      &                IHIST(2,NMXHKK)
5951 * flags for input different options
5952       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5953       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5954      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5955 * auxiliary common for chain system storage (DTUNUC 1.x)
5956       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5957 * statistics
5958       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5959      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5960      &                ICEVTG(8,0:30)
5961 * flags for diffractive interactions (DTUNUC 1.x)
5962       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5963 * x-values of partons (DTUNUC 1.x)
5964       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
5965      &                XTVQ(MAXVQU),XTVD(MAXVQU),
5966      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
5967      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
5968 * flavors of partons (DTUNUC 1.x)
5969       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5970      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5971      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5972      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5973      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5974      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5975      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5976 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5977       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5978      &                IXPV,IXPS,IXTV,IXTS,
5979      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
5980      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
5981      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
5982      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
5983      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
5984      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
5985      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
5986      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
5987 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5988       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5989      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5990
5991       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
5992
5993       DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
5994
5995       IREJ      = 0
5996       NCSY      = 0
5997       NPOINT(2) = NHKK+1
5998
5999 * sea-sea chains
6000       DO 10 I=1,NSS
6001          IF (ISKPCH(1,I).EQ.99) GOTO 10
6002          ICCHAI(1,1) = ICCHAI(1,1)+2
6003          IDXP = INTSS1(I)
6004          IDXT = INTSS2(I)
6005          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6006          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6007          DO 11 K=1,4
6008             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6009             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6010             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6011             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6012    11    CONTINUE
6013          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6014      &                                  +(PP1(3)+PT1(3))**2)
6015          ECH   = PP1(4)+PT1(4)
6016          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6017          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6018      &                                  +(PP2(3)+PT2(3))**2)
6019          ECH   = PP2(4)+PT2(4)
6020          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6021          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6022             AM1 = SQRT(AM1)
6023             AM2 = SQRT(AM2)
6024             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6025 C              WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6026  5000          FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6027             ENDIF
6028          ELSE
6029             WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6030          ENDIF
6031          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6032          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6033          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6034          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6035          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6036      &                                                    0,0,1)
6037          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6038      &                                                    0,0,1)
6039          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6040      &                                                    0,0,1)
6041          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6042      &                                                    0,0,1)
6043          NCSY = NCSY+1
6044    10 CONTINUE
6045
6046 * disea-sea chains
6047       DO 20 I=1,NDS
6048          IF (ISKPCH(2,I).EQ.99) GOTO 20
6049          ICCHAI(1,2) = ICCHAI(1,2)+2
6050          IDXP = INTDS1(I)
6051          IDXT = INTDS2(I)
6052          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6053          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6054          DO 21 K=1,4
6055             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6056             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6057             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6058             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6059    21    CONTINUE
6060          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6061      &                                  +(PP1(3)+PT1(3))**2)
6062          ECH   = PP1(4)+PT1(4)
6063          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6064          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6065      &                                  +(PP2(3)+PT2(3))**2)
6066          ECH   = PP2(4)+PT2(4)
6067          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6068          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6069             AM1 = SQRT(AM1)
6070             AM2 = SQRT(AM2)
6071             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6072 C              WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6073  5001          FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6074             ENDIF
6075          ELSE
6076             WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6077          ENDIF
6078          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6079          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6080          IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6081          IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6082          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6083      &                                                    0,0,2)
6084          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6085      &                                                    0,0,2)
6086          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6087      &                                                    0,0,2)
6088          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6089      &                                                    0,0,2)
6090          NCSY = NCSY+1
6091    20 CONTINUE
6092
6093 * sea-disea chains
6094       DO 30 I=1,NSD
6095          IF (ISKPCH(3,I).EQ.99) GOTO 30
6096          ICCHAI(1,3) = ICCHAI(1,3)+2
6097          IDXP = INTSD1(I)
6098          IDXT = INTSD2(I)
6099          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6100          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6101          DO 31 K=1,4
6102             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6103             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6104             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6105             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6106    31    CONTINUE
6107          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6108      &                                  +(PP1(3)+PT1(3))**2)
6109          ECH   = PP1(4)+PT1(4)
6110          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6111          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6112      &                                  +(PP2(3)+PT2(3))**2)
6113          ECH   = PP2(4)+PT2(4)
6114          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6115          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6116             AM1 = SQRT(AM1)
6117             AM2 = SQRT(AM2)
6118             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6119 C              WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6120  5002          FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6121             ENDIF
6122          ELSE
6123             WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6124          ENDIF
6125          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6126          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6127          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6128          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6129          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6130      &                                                    0,0,3)
6131          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6132      &                                                    0,0,3)
6133          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6134      &                                                    0,0,3)
6135          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6136      &                                                    0,0,3)
6137          NCSY = NCSY+1
6138    30 CONTINUE
6139
6140 * disea-valence chains
6141       DO 50 I=1,NDV
6142          IF (ISKPCH(5,I).EQ.99) GOTO 50
6143          ICCHAI(1,5) = ICCHAI(1,5)+2
6144          IDXP = INTDV1(I)
6145          IDXT = INTDV2(I)
6146          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6147          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6148          DO 51 K=1,4
6149             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6150             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6151             PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6152             PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6153    51    CONTINUE
6154          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6155      &                                  +(PP1(3)+PT1(3))**2)
6156          ECH   = PP1(4)+PT1(4)
6157          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6158          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6159      &                                  +(PP2(3)+PT2(3))**2)
6160          ECH   = PP2(4)+PT2(4)
6161          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6162          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6163             AM1 = SQRT(AM1)
6164             AM2 = SQRT(AM2)
6165             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6166 C              WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6167  5003          FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6168             ENDIF
6169          ELSE
6170             WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6171          ENDIF
6172          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6173          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6174          IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6175          IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6176          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6177      &                                                    0,0,5)
6178          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6179      &                                                    0,0,5)
6180          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6181      &                                                    0,0,5)
6182          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6183      &                                                    0,0,5)
6184          NCSY = NCSY+1
6185    50 CONTINUE
6186
6187 * valence-sea chains
6188       DO 60 I=1,NVS
6189          IF (ISKPCH(6,I).EQ.99) GOTO 60
6190          ICCHAI(1,6) = ICCHAI(1,6)+2
6191          IDXP = INTVS1(I)
6192          IDXT = INTVS2(I)
6193          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6194          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6195          DO 61 K=1,4
6196             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6197             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6198             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6199             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6200    61    CONTINUE
6201          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6202          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6203          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6204          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6205          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6206          IF (LCHK) THEN
6207             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6208      &                                                       0,0,6)
6209             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6210      &                                                       0,0,6)
6211             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6212      &                                                       0,0,6)
6213             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6214      &                                                       0,0,6)
6215             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6216      &                                     +(PP1(3)+PT1(3))**2)
6217             ECH   = PP1(4)+PT1(4)
6218             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6219             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6220      &                                     +(PP2(3)+PT2(3))**2)
6221             ECH   = PP2(4)+PT2(4)
6222             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6223          ELSE
6224             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6225      &                                                       0,0,6)
6226             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6227      &                                                       0,0,6)
6228             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6229      &                                                       0,0,6)
6230             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6231      &                                                       0,0,6)
6232             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6233      &                                     +(PP1(3)+PT2(3))**2)
6234             ECH   = PP1(4)+PT2(4)
6235             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6236             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6237      &                                     +(PP2(3)+PT1(3))**2)
6238             ECH   = PP2(4)+PT1(4)
6239             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6240          ENDIF
6241          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6242             AM1 = SQRT(AM1)
6243             AM2 = SQRT(AM2)
6244             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6245 C              WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6246  5004          FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6247             ENDIF
6248          ELSE
6249             WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6250          ENDIF
6251          NCSY = NCSY+1
6252    60 CONTINUE
6253
6254 * sea-valence chains
6255       DO 40 I=1,NSV
6256          IF (ISKPCH(4,I).EQ.99) GOTO 40
6257          ICCHAI(1,4) = ICCHAI(1,4)+2
6258          IDXP = INTSV1(I)
6259          IDXT = INTSV2(I)
6260          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6261          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6262          DO 41 K=1,4
6263             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6264             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6265             PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6266             PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6267    41    CONTINUE
6268          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6269      &                                  +(PP1(3)+PT1(3))**2)
6270          ECH   = PP1(4)+PT1(4)
6271          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6272          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6273      &                                  +(PP2(3)+PT2(3))**2)
6274          ECH   = PP2(4)+PT2(4)
6275          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6276          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6277             AM1 = SQRT(AM1)
6278             AM2 = SQRT(AM2)
6279             IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6280 C              WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6281  5005          FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6282             ENDIF
6283          ELSE
6284             WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6285          ENDIF
6286          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6287          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6288          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6289          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6290          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6291      &                                                    0,0,4)
6292          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6293      &                                                    0,0,4)
6294          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6295      &                                                    0,0,4)
6296          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6297      &                                                    0,0,4)
6298          NCSY = NCSY+1
6299    40 CONTINUE
6300
6301 * valence-disea chains
6302       DO 70 I=1,NVD
6303          IF (ISKPCH(7,I).EQ.99) GOTO 70
6304          ICCHAI(1,7) = ICCHAI(1,7)+2
6305          IDXP = INTVD1(I)
6306          IDXT = INTVD2(I)
6307          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6308          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6309          DO 71 K=1,4
6310             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6311             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6312             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6313             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6314    71    CONTINUE
6315          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6316          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6317          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6318          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6319          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6320          IF (LCHK) THEN
6321             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6322      &                                                       0,0,7)
6323             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6324      &                                                       0,0,7)
6325             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6326      &                                                       0,0,7)
6327             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6328      &                                                       0,0,7)
6329             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6330      &                                     +(PP1(3)+PT1(3))**2)
6331             ECH   = PP1(4)+PT1(4)
6332             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6333             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6334      &                                     +(PP2(3)+PT2(3))**2)
6335             ECH   = PP2(4)+PT2(4)
6336             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6337          ELSE
6338             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6339      &                                                       0,0,7)
6340             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6341      &                                                       0,0,7)
6342             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6343      &                                                       0,0,7)
6344             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6345      &                                                       0,0,7)
6346             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6347      &                                     +(PP1(3)+PT2(3))**2)
6348             ECH   = PP1(4)+PT2(4)
6349             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6350             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6351      &                                     +(PP2(3)+PT1(3))**2)
6352             ECH   = PP2(4)+PT1(4)
6353             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6354          ENDIF
6355          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6356             AM1 = SQRT(AM1)
6357             AM2 = SQRT(AM2)
6358             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6359 C              WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6360  5006          FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6361             ENDIF
6362          ELSE
6363             WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6364          ENDIF
6365          NCSY = NCSY+1
6366    70 CONTINUE
6367
6368 * valence-valence chains
6369       DO 80 I=1,NVV
6370          IF (ISKPCH(8,I).EQ.99) GOTO 80
6371          ICCHAI(1,8) = ICCHAI(1,8)+2
6372          IDXP = INTVV1(I)
6373          IDXT = INTVV2(I)
6374          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6375          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6376          DO 81 K=1,4
6377             PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6378             PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6379             PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6380             PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6381    81    CONTINUE
6382          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6383          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6384          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6385          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6386
6387 * check for diffractive event
6388          IDIFF = 0
6389          IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6390      &        (IP.EQ.1).AND.(NN.EQ.1)) THEN
6391             DO 800 K=1,4
6392                PP(K) = PP1(K)+PP2(K)
6393                PT(K) = PT1(K)+PT2(K)
6394   800       CONTINUE
6395             ISTCK = NHKK
6396             CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6397      &                  IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6398 C           IF (IREJ1.NE.0) GOTO 9999
6399             IF (IREJ1.NE.0) THEN
6400                IDIFF = 0
6401                NHKK  = ISTCK
6402             ENDIF
6403          ELSE
6404             IDIFF = 0
6405          ENDIF
6406
6407          IF (IDIFF.EQ.0) THEN
6408 *   valence-valence chain system
6409             CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6410             IF (LCHK) THEN
6411 *    baryon-baryon
6412                CALL DT_EVTPUT(-21,IFP1,MOP,0,
6413      &                     PP1(1),PP1(2),PP1(3),PP1(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                CALL DT_EVTPUT(-21,IFP2,MOP,0,
6417      &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6418                CALL DT_EVTPUT(-22,IFT2,MOT,0,
6419      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6420                PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6421      &                                        +(PP1(3)+PT1(3))**2)
6422                ECH   = PP1(4)+PT1(4)
6423                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6424                PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6425      &                                        +(PP2(3)+PT2(3))**2)
6426                ECH   = PP2(4)+PT2(4)
6427                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6428             ELSE
6429 *    antibaryon-baryon
6430                CALL DT_EVTPUT(-21,IFP1,MOP,0,
6431      &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6432                CALL DT_EVTPUT(-22,IFT2,MOT,0,
6433      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6434                CALL DT_EVTPUT(-21,IFP2,MOP,0,
6435      &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6436                CALL DT_EVTPUT(-22,IFT1,MOT,0,
6437      &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6438                PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6439      &                                        +(PP1(3)+PT2(3))**2)
6440                ECH   = PP1(4)+PT2(4)
6441                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6442                PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6443      &                                        +(PP2(3)+PT1(3))**2)
6444                ECH   = PP2(4)+PT1(4)
6445                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6446             ENDIF
6447             IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6448                AM1 = SQRT(AM1)
6449                AM2 = SQRT(AM2)
6450                IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6451 C                 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6452  5007             FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6453                ENDIF
6454             ELSE
6455                WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6456             ENDIF
6457             NCSY = NCSY+1
6458          ENDIF
6459    80 CONTINUE
6460       IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6461
6462 * energy-momentum & flavor conservation check
6463       IF (ABS(IDIFF).NE.1) THEN
6464          IF (IDIFF.NE.0) THEN
6465             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6466      &                                              1,3,10,IREJ)
6467          ELSE
6468             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6469      &                                              1,3,10,IREJ)
6470          ENDIF
6471          IF (IREJ.NE.0) THEN
6472             CALL DT_EVTOUT(4)
6473             STOP
6474          ENDIF
6475       ENDIF
6476
6477       RETURN
6478
6479  9999 CONTINUE
6480       IREJ  = 1
6481       RETURN
6482       END
6483
6484 *$ CREATE DT_CHKCSY.FOR
6485 *COPY DT_CHKCSY
6486 *
6487 *===chkcsy=============================================================*
6488 *
6489       SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6490
6491 ************************************************************************
6492 * CHeCk Chain SYstem for consistency of partons at chain ends.         *
6493 *            ID1,ID2        PDG-numbers of partons at chain ends       *
6494 *            LCHK = .true.  consistent chain                           *
6495 *                 = .false. inconsistent chain                         *
6496 * This version dated 18.01.95 is written by S. Roesler                 *
6497 ************************************************************************
6498
6499       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6500       SAVE
6501       PARAMETER ( LINP = 10 ,
6502      &            LOUT = 6 ,
6503      &            LDAT = 9 )
6504
6505       LOGICAL LCHK
6506
6507       LCHK = .TRUE.
6508
6509 * q-aq chain
6510       IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6511          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6512 * q-qq, aq-aqaq chain
6513       ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6514      &        ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6515          IF (ID1*ID2.LT.0) LCHK = .FALSE.
6516 * qq-aqaq chain
6517       ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6518          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6519       ENDIF
6520
6521       RETURN
6522       END
6523
6524 *$ CREATE DT_EVENTA.FOR
6525 *COPY DT_EVENTA
6526 *
6527 *===eventa=============================================================*
6528 *
6529       SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6530
6531 ************************************************************************
6532 * Treatment of nucleon-nucleon interactions in a two-chain             *
6533 * approximation.                                                       *
6534 *  (input) ID       BAMJET-index of projectile hadron (in case of      *
6535 *                   h-K scattering)                                    *
6536 *          IP/IT    mass number of projectile/target nucleus           *
6537 *          NCSY     number of two chain systems                        *
6538 *          IREJ     rejection flag                                     *
6539 * This version dated 15.01.95 is written by S. Roesler                 *
6540 ************************************************************************
6541
6542       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6543       SAVE
6544       PARAMETER ( LINP = 10 ,
6545      &            LOUT = 6 ,
6546      &            LDAT = 9 )
6547       PARAMETER (TINY10=1.0D-10)
6548
6549 * event history
6550       PARAMETER (NMXHKK=200000)
6551       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6552      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6553      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6554 * extended event history
6555       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6556      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6557      &                IHIST(2,NMXHKK)
6558 * rejection counter
6559       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6560      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6561      &                IREXCI(3),IRDIFF(2),IRINC
6562 * flags for diffractive interactions (DTUNUC 1.x)
6563       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6564 * particle properties (BAMJET index convention)
6565       CHARACTER*8  ANAME
6566       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6567      &                IICH(210),IIBAR(210),K1(210),K2(210)
6568 * flags for input different options
6569       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6570       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6571      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6572 * various options for treatment of partons (DTUNUC 1.x)
6573 * (chain recombination, Cronin,..)
6574       LOGICAL LCO2CR,LINTPT
6575       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6576      &                LCO2CR,LINTPT
6577
6578       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
6579
6580       IREJ      = 0
6581       NPOINT(3) = NHKK+1
6582
6583 * skip following treatment for low-mass diffraction
6584       IF (ABS(IFLAGD).EQ.1) THEN
6585          NPOINT(3) = NPOINT(2)
6586          GOTO 5
6587       ENDIF
6588
6589 * multiple scattering of chain ends
6590       IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
6591       IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
6592
6593       NC = NPOINT(2)
6594 * get a two-chain system from DTEVT1
6595       DO 3 I=1,NCSY
6596          IFP1 = IDHKK(NC)
6597          IFT1 = IDHKK(NC+1)
6598          IFP2 = IDHKK(NC+2)
6599          IFT2 = IDHKK(NC+3)
6600          DO 4 K=1,4
6601             PP1(K) = PHKK(K,NC)
6602             PT1(K) = PHKK(K,NC+1)
6603             PP2(K) = PHKK(K,NC+2)
6604             PT2(K) = PHKK(K,NC+3)
6605     4    CONTINUE
6606          MOP1 = NC
6607          MOT1 = NC+1
6608          MOP2 = NC+2
6609          MOT2 = NC+3
6610          CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
6611      &               IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
6612          IF (IREJ1.GT.0) THEN
6613             IRHHA = IRHHA+1
6614             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
6615             GOTO 9999
6616          ENDIF
6617          NC = NC+4
6618     3 CONTINUE
6619
6620 * meson/antibaryon projectile:
6621 * sample single-chain valence-valence systems (Reggeon contrib.)
6622       IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
6623          IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
6624       ENDIF
6625
6626       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6627 * check DTEVT1 for remaining resonance mass corrections
6628          CALL DT_EVTRES(IREJ1)
6629          IF (IREJ1.GT.0) THEN
6630             IRRES(1) = IRRES(1)+1
6631             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
6632             GOTO 9999
6633          ENDIF
6634       ENDIF
6635
6636 * assign p_t to two-"chain" systems consisting of two resonances only
6637 * since only entries for chains will be affected, this is obsolete
6638 * in case of JETSET-fragmetation
6639       CALL DT_RESPT
6640
6641 * combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
6642       IF (LCO2CR) CALL DT_COM2CR
6643
6644     5 CONTINUE
6645
6646 * fragmentation of the complete event
6647 **uncomment for internal phojet-fragmentation
6648 C     CALL DT_EVTFRA(IREJ1)
6649       CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
6650       IF (IREJ1.GT.0) THEN
6651          IRFRAG = IRFRAG+1
6652          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
6653          GOTO 9999
6654       ENDIF
6655
6656 * decay of possible resonances (should be obsolete)
6657       CALL DT_DECAY1
6658
6659       RETURN
6660
6661  9999 CONTINUE
6662       IREVT = IREVT+1
6663       IREJ  = 1
6664       RETURN
6665       END
6666
6667 *$ CREATE DT_GETCSY.FOR
6668 *COPY DT_GETCSY
6669 *
6670 *===getcsy=============================================================*
6671 *
6672       SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
6673      &                  IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
6674
6675 ************************************************************************
6676 * This version dated 15.01.95 is written by S. Roesler                 *
6677 ************************************************************************
6678
6679       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6680       SAVE
6681       PARAMETER ( LINP = 10 ,
6682      &            LOUT = 6 ,
6683      &            LDAT = 9 )
6684       PARAMETER (TINY10=1.0D-10)
6685
6686 * event history
6687       PARAMETER (NMXHKK=200000)
6688       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6689      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6690      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6691 * extended event history
6692       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6693      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6694      &                IHIST(2,NMXHKK)
6695 * rejection counter
6696       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6697      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6698      &                IREXCI(3),IRDIFF(2),IRINC
6699 * flags for input different options
6700       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6701       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6702      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6703 * flags for diffractive interactions (DTUNUC 1.x)
6704       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6705
6706       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
6707      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
6708
6709       IREJ  = 0
6710
6711 * get quark content of partons
6712       DO 1 I=1,2
6713          IFP1(I) = 0
6714          IFP2(I) = 0
6715          IFT1(I) = 0
6716          IFT2(I) = 0
6717     1 CONTINUE
6718       IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
6719       IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
6720       IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
6721       IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
6722       IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
6723       IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
6724       IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
6725       IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
6726
6727 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
6728       IDCH1 = 2
6729       IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
6730       IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
6731       IDCH2 = 2
6732       IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
6733       IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
6734
6735 * store initial configuration for energy-momentum cons. check
6736       IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
6737
6738 * sample intrinsic p_t at chain-ends
6739       CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
6740      &            PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
6741      &            AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
6742       IF (IREJ1.NE.0) THEN
6743          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
6744          IRPT = IRPT+1
6745          GOTO 9999
6746       ENDIF
6747
6748 C      IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6749 C         IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
6750 C* check second chain for resonance
6751 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6752 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
6753 C            IF (IREJ1.NE.0) GOTO 9999
6754 C            IF (IDR2.NE.0) THEN
6755 C               CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6756 C     &                     AMCH2,AMCH2N,AMCH1,IREJ1)
6757 C               IF (IREJ1.NE.0) GOTO 9999
6758 C            ENDIF
6759 C* check first chain for resonance
6760 C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6761 C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
6762 C            IF (IREJ1.NE.0) GOTO 9999
6763 C            IF (IDR1.NE.0) IDR1 = 100*IDR1
6764 C         ELSE
6765 C* check first chain for resonance
6766 C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6767 C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
6768 C            IF (IREJ1.NE.0) GOTO 9999
6769 C            IF (IDR1.NE.0) THEN
6770 C               CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6771 C     &                     AMCH1,AMCH1N,AMCH2,IREJ1)
6772 C               IF (IREJ1.NE.0) GOTO 9999
6773 C            ENDIF
6774 C* check second chain for resonance
6775 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6776 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
6777 C            IF (IREJ1.NE.0) GOTO 9999
6778 C            IF (IDR2.NE.0) IDR2 = 100*IDR2
6779 C         ENDIF
6780 C      ENDIF
6781
6782       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6783 * check chains for resonances
6784          CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6785      &               AMCH1,AMCH1N,IDCH1,IREJ1)
6786          IF (IREJ1.NE.0) GOTO 9999
6787          CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6788      &               AMCH2,AMCH2N,IDCH2,IREJ1)
6789          IF (IREJ1.NE.0) GOTO 9999
6790 * change kinematics corresponding to resonance-masses
6791          IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
6792             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6793      &                                 AMCH1,AMCH1N,AMCH2,IREJ1)
6794             IF (IREJ1.GT.0) GOTO 9999
6795             IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6796             CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6797      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
6798             IF (IREJ1.NE.0) GOTO 9999
6799             IF (IDR2.NE.0) IDR2 = 100*IDR2
6800          ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
6801             CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6802      &                                 AMCH2,AMCH2N,AMCH1,IREJ1)
6803             IF (IREJ1.GT.0) GOTO 9999
6804             IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6805             CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6806      &                  AMCH1,AMCH1N,IDCH1,IREJ1)
6807             IF (IREJ1.NE.0) GOTO 9999
6808             IF (IDR1.NE.0) IDR1 = 100*IDR1
6809          ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
6810             AMDIF1 = ABS(AMCH1-AMCH1N)
6811             AMDIF2 = ABS(AMCH2-AMCH2N)
6812             IF (AMDIF2.LT.AMDIF1) THEN
6813                CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6814      &                                    AMCH2,AMCH2N,AMCH1,IREJ1)
6815                IF (IREJ1.GT.0) GOTO 9999
6816                IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6817                CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
6818      &                     IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
6819                IF (IREJ1.NE.0) GOTO 9999
6820                IF (IDR1.NE.0) IDR1 = 100*IDR1
6821             ELSE
6822                CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6823      &                                    AMCH1,AMCH1N,AMCH2,IREJ1)
6824                IF (IREJ1.GT.0) GOTO 9999
6825                IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6826                CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
6827      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
6828                IF (IREJ1.NE.0) GOTO 9999
6829                IF (IDR2.NE.0) IDR2 = 100*IDR2
6830             ENDIF
6831          ENDIF
6832       ENDIF
6833
6834 * store final configuration for energy-momentum cons. check
6835       IF (LEMCCK) THEN
6836          CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
6837          CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
6838          IF (IREJ1.NE.0) GOTO 9999
6839       ENDIF
6840
6841 * put partons and chains into DTEVT1
6842       DO 10 I=1,4
6843          PCH1(I) = PP1(I)+PT1(I)
6844          PCH2(I) = PP2(I)+PT2(I)
6845    10 CONTINUE
6846       CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
6847      &                                      PP1(3),PP1(4),0,0,0)
6848       CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
6849      &                                      PT1(3),PT1(4),0,0,0)
6850       KCH = 100+IDCH(MOP1)*10+1
6851       CALL DT_EVTPUT(KCH,88888,-2,-1,
6852      &           PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
6853       CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
6854      &                                      PP2(3),PP2(4),0,0,0)
6855       CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
6856      &                                      PT2(3),PT2(4),0,0,0)
6857       KCH = KCH+1
6858       CALL DT_EVTPUT(KCH,88888,-2,-1,
6859      &           PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
6860
6861       RETURN
6862
6863  9999 CONTINUE
6864       IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
6865 * "cancel" sea-sea chains
6866          CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
6867          IF (IREJ1.NE.0) GOTO 9998
6868 **sr 16.5. flag for EVENTB
6869          IREJ = -1
6870          RETURN
6871       ENDIF
6872  9998 CONTINUE
6873       IREJ = 1
6874       RETURN
6875       END
6876
6877 *$ CREATE DT_CHKINE.FOR
6878 *COPY DT_CHKINE
6879 *
6880 *===chkine=============================================================*
6881 *
6882       SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
6883      &                  AMCH1,AMCH1N,AMCH2,IREJ)
6884
6885 ************************************************************************
6886 * This subroutine replaces CORMOM.                                     *
6887 * This version dated 05.01.95 is written by S. Roesler                 *
6888 ************************************************************************
6889
6890       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6891       SAVE
6892       PARAMETER ( LINP = 10 ,
6893      &            LOUT = 6 ,
6894      &            LDAT = 9 )
6895       PARAMETER (TINY10=1.0D-10)
6896
6897 * flags for input different options
6898       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6899       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6900      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6901 * rejection counter
6902       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6903      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6904      &                IREXCI(3),IRDIFF(2),IRINC
6905
6906       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
6907      &          PP1I(4),PP2I(4),PT1I(4),PT2I(4)
6908
6909       IREJ  = 0
6910       JMSHL = IMSHL
6911
6912       SCALE  = AMCH1N/MAX(AMCH1,TINY10)
6913       DO 10 I=1,4
6914          PP1(I) = PP1I(I)
6915          PP2(I) = PP2I(I)
6916          PT1(I) = PT1I(I)
6917          PT2(I) = PT2I(I)
6918          PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
6919          PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
6920          PP1(I) = SCALE*PP1(I)
6921          PT1(I) = SCALE*PT1(I)
6922    10 CONTINUE
6923       IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
6924      &    (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
6925
6926       ECH = PP2(4)+PT2(4)
6927       PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
6928      &                               (PP2(3)+PT2(3))**2 )
6929       AMCH22 = (ECH-PCH)*(ECH+PCH)
6930       IF (AMCH22.LT.0.0D0) THEN
6931          IF (IOULEV(1).GT.0)
6932      &      WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
6933          GOTO 9997
6934       ENDIF
6935
6936       AMCH1 = AMCH1N
6937       AMCH2 = SQRT(AMCH22)
6938
6939 * put partons again on mass shell
6940    13 CONTINUE
6941       XM1 = 0.0D0
6942       XM2 = 0.0D0
6943       IF (JMSHL.EQ.1) THEN
6944          XM1 = PYMASS(IFP1)
6945          XM2 = PYMASS(IFT1)
6946       ENDIF
6947       CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
6948       IF (IREJ1.NE.0) THEN
6949          IF (JMSHL.EQ.0) GOTO 9998
6950          JMSHL = 0
6951          GOTO 13
6952       ENDIF
6953       JMSHL = IMSHL
6954       DO 11 I=1,4
6955          PP1(I) = P1(I)
6956          PT1(I) = P2(I)
6957    11 CONTINUE
6958    14 CONTINUE
6959       XM1 = 0.0D0
6960       XM2 = 0.0D0
6961       IF (JMSHL.EQ.1) THEN
6962          XM1 = PYMASS(IFP2)
6963          XM2 = PYMASS(IFT2)
6964       ENDIF
6965       CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
6966       IF (IREJ1.NE.0) THEN
6967          IF (JMSHL.EQ.0) GOTO 9998
6968          JMSHL = 0
6969          GOTO 14
6970       ENDIF
6971       DO 12 I=1,4
6972          PP2(I) = P1(I)
6973          PT2(I) = P2(I)
6974    12 CONTINUE
6975       DO 15 I=1,4
6976          PP1I(I) = PP1(I)
6977          PP2I(I) = PP2(I)
6978          PT1I(I) = PT1(I)
6979          PT2I(I) = PT2(I)
6980    15 CONTINUE
6981       RETURN
6982
6983  9997 IRCHKI(1) = IRCHKI(1)+1
6984 **sr
6985 C     GOTO 9999
6986       IREJ = -1
6987       RETURN
6988 **
6989  9998 IRCHKI(2) = IRCHKI(2)+1
6990
6991  9999 CONTINUE
6992       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
6993       IREJ = 1
6994       RETURN
6995       END
6996
6997 *$ CREATE DT_CH2RES.FOR
6998 *COPY DT_CH2RES
6999 *
7000 *===ch2res=============================================================*
7001 *
7002       SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7003      &                  AM,AMN,IMODE,IREJ)
7004
7005 ************************************************************************
7006 * Check chains for resonance production.                               *
7007 * This subroutine replaces COMCMA/COBCMA/COMCM2                        *
7008 *    input:                                                            *
7009 *          IF1,2,3,4    input flavors (q,aq in any order)              *
7010 *          AM           chain mass                                     *
7011 *          MODE = 1     check q-aq chain for meson-resonance           *
7012 *               = 2     check q-qq, aq-aqaq chain for baryon-resonance *
7013 *               = 3     check qq-aqaq chain for lower mass cut         *
7014 *    output:                                                           *
7015 *          IDR = 0      no resonances found                            *
7016 *              = -1     pseudoscalar meson/octet baryon                *
7017 *              = 1      vector-meson/decuplet baryon                   *
7018 *          IDXR         BAMJET-index of corresponding resonance        *
7019 *          AMN          mass of corresponding resonance                *
7020 *                                                                      *
7021 *          IREJ         rejection flag                                 *
7022 * This version dated 06.01.95 is written by S. Roesler                 *
7023 ************************************************************************
7024
7025       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7026       SAVE
7027       PARAMETER ( LINP = 10 ,
7028      &            LOUT = 6 ,
7029      &            LDAT = 9 )
7030
7031 * particle properties (BAMJET index convention)
7032       CHARACTER*8  ANAME
7033       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7034      &                IICH(210),IIBAR(210),K1(210),K2(210)
7035 * quark-content to particle index conversion (DTUNUC 1.x)
7036       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7037      &                IA08(6,21),IA10(6,21)
7038 * rejection counter
7039       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7040      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7041      &                IREXCI(3),IRDIFF(2),IRINC
7042 * flags for input different options
7043       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7044       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7045      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7046
7047       DIMENSION IF(4),JF(4)
7048
7049 **sr 4.7. test
7050 C     DATA AMLOM,AMLOB /0.08D0,0.2D0/
7051       DATA AMLOM,AMLOB /0.1D0,0.7D0/
7052 **
7053 C     DATA AMLOM,AMLOB /0.001D0,0.001D0/
7054
7055       MODE = ABS(IMODE)
7056
7057       IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7058          WRITE(LOUT,1000) MODE
7059  1000    FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7060      &          1X,'        program stopped')
7061          STOP
7062       ENDIF
7063
7064       AMX  = AM
7065       IREJ = 0
7066       IDR  = 0
7067       IDXR = 0
7068       AMN  = AMX
7069       IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7070       IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7071
7072       IF(1) = IF1
7073       IF(2) = IF2
7074       IF(3) = IF3
7075       IF(4) = IF4
7076       NF = 0
7077       DO 100 I=1,4
7078          IF (IF(I).NE.0) THEN
7079             NF = NF+1
7080             JF(NF) = IF(I)
7081          ENDIF
7082   100 CONTINUE
7083       IF (NF.LE.MODE) THEN
7084          WRITE(LOUT,1001) MODE,IF
7085  1001    FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7086      &   I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7087          GOTO 9999
7088       ENDIF
7089
7090       GOTO (1,2,3) MODE
7091
7092 * check for meson resonance
7093     1 CONTINUE
7094       IFQ  = JF(1)
7095       IFAQ = ABS(JF(2))
7096       IF (JF(2).GT.0) THEN
7097          IFQ  = JF(2)
7098          IFAQ = ABS(JF(1))
7099       ENDIF
7100       IFPS = IMPS(IFAQ,IFQ)
7101       IFV  = IMVE(IFAQ,IFQ)
7102       AMPS = AAM(IFPS)
7103       AMV  = AAM(IFV)
7104       AMHI = AMV+0.3D0
7105       IF (AMX.LT.AMV) THEN
7106          IF (AMX.LT.AMPS) THEN
7107             IF (IMODE.GT.0) THEN
7108                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7109             ELSE
7110                IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7111             ENDIF
7112             LOMRES = LOMRES+1
7113          ENDIF
7114 *    replace chain by pseudoscalar meson
7115          IDR  = -1
7116          IDXR = IFPS
7117          AMN  = AMPS
7118       ELSEIF (AMX.LT.AMHI) THEN
7119 *    replace chain by vector-meson
7120          IDR  = 1
7121          IDXR = IFV
7122          AMN  = AMV
7123       ENDIF
7124       RETURN
7125
7126 * check for baryon resonance
7127     2 CONTINUE
7128       CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7129       AM8  = AAM(JB8)
7130       AM10 = AAM(JB10)
7131       AMHI = AM10+0.3D0
7132       IF (AMX.LT.AM10) THEN
7133          IF (AMX.LT.AM8) THEN
7134             IF (IMODE.GT.0) THEN
7135                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7136             ELSE
7137                IF (AMX.LT.0.8D0*AM8) GOTO 9999
7138             ENDIF
7139             LOBRES = LOBRES+1
7140          ENDIF
7141 *    replace chain by oktet baryon
7142          IDR  = -1
7143          IDXR = JB8
7144          AMN  = AM8
7145       ELSEIF (AMX.LT.AMHI) THEN
7146          IDR  = 1
7147          IDXR = JB10
7148          AMN  = AM10
7149       ENDIF
7150       RETURN
7151
7152 * check qq-aqaq for lower mass cut
7153     3 CONTINUE
7154 *   empirical definition of AMHI to allow for (b-antib)-pair prod.
7155       AMHI = 2.5D0
7156       IF (AMX.LT.AMHI) GOTO 9999
7157       RETURN
7158
7159  9999 CONTINUE
7160       IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7161      &    WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7162       IREJ = 1
7163       IRRES(2) = IRRES(2)+1
7164       RETURN
7165       END
7166
7167 *$ CREATE DT_RJSEAC.FOR
7168 *COPY DT_RJSEAC
7169 *
7170 *===rjseac=============================================================*
7171 *
7172       SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7173
7174 ************************************************************************
7175 * ReJection of SEA-sea Chains.                                         *
7176 *         MOP1/2       entries of projectile sea-partons in DTEVT1     *
7177 *         MOT1/2       entries of projectile sea-partons in DTEVT1     *
7178 * This version dated 16.01.95 is written by S. Roesler                 *
7179 ************************************************************************
7180
7181       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7182       SAVE
7183       PARAMETER ( LINP = 10 ,
7184      &            LOUT = 6 ,
7185      &            LDAT = 9 )
7186       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7187
7188 * event history
7189       PARAMETER (NMXHKK=200000)
7190       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7191      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7192      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7193 * extended event history
7194       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7195      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7196      &                IHIST(2,NMXHKK)
7197 * statistics
7198       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7199      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7200      &                ICEVTG(8,0:30)
7201
7202       DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7203
7204       IREJ = 0
7205
7206 * projectile sea q-aq-pair
7207 *    indices of sea-pair
7208       IDXSEA(1,1) = MOP1
7209       IDXSEA(1,2) = MOP2
7210 *    index of mother-nucleon
7211       IDXNUC(1)   = JMOHKK(1,MOP1)
7212 *    status of valence quarks to be corrected
7213       ISTVAL(1)   = -21
7214
7215 * target sea q-aq-pair
7216 *    indices of sea-pair
7217       IDXSEA(2,1) = MOT1
7218       IDXSEA(2,2) = MOT2
7219 *    index of mother-nucleon
7220       IDXNUC(2)   = JMOHKK(1,MOT1)
7221 *    status of valence quarks to be corrected
7222       ISTVAL(2)   = -22
7223
7224       DO 1 N=1,2
7225          IDONE = 0
7226          DO 2 I=NPOINT(2),NHKK
7227             IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7228      &          (JMOHKK(1,I).EQ.IDXNUC(N)))   THEN
7229 * valence parton found
7230 *    inrease 4-momentum by sea 4-momentum
7231                DO 3 K=1,4
7232                   PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7233      &                                  PHKK(K,IDXSEA(N,2))
7234     3          CONTINUE
7235                PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7236      &                              PHKK(2,I)**2-PHKK(3,I)**2))
7237 *    "cancel" sea-pair
7238                DO 4 J=1,2
7239                   ISTHKK(IDXSEA(N,J))   = 100
7240                   IDHKK(IDXSEA(N,J))    = 0
7241                   JMOHKK(1,IDXSEA(N,J)) = 0
7242                   JMOHKK(2,IDXSEA(N,J)) = 0
7243                   JDAHKK(1,IDXSEA(N,J)) = 0
7244                   JDAHKK(2,IDXSEA(N,J)) = 0
7245                   DO 5 K=1,4
7246                      PHKK(K,IDXSEA(N,J)) = ZERO
7247                      VHKK(K,IDXSEA(N,J)) = ZERO
7248                      WHKK(K,IDXSEA(N,J)) = ZERO
7249     5             CONTINUE
7250                   PHKK(5,IDXSEA(N,J)) = ZERO
7251     4          CONTINUE
7252                IDONE = 1
7253             ENDIF
7254     2    CONTINUE
7255          IF (IDONE.NE.1) THEN
7256             WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7257  1000       FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7258      &                '-record!',/,1X,'        sea-quark pairs   ',
7259      &                2I5,4X,2I5,'   could not be canceled!')
7260             GOTO 9999
7261          ENDIF
7262     1 CONTINUE
7263       ICRJSS = ICRJSS+1
7264       RETURN
7265
7266  9999 CONTINUE
7267       IREJ = 1
7268       RETURN
7269       END
7270
7271 *$ CREATE DT_VV2SCH.FOR
7272 *COPY DT_VV2SCH
7273 *
7274 *===vv2sch=============================================================*
7275 *
7276       SUBROUTINE DT_VV2SCH
7277
7278 ************************************************************************
7279 * Change Valence-Valence chain systems to Single CHain systems for     *
7280 * hadron-nucleus collisions with meson or antibaryon projectile.       *
7281 * (Reggeon contribution)                                               *
7282 * The single chain system is approximately treated as one chain and a  *
7283 * meson at rest.                                                       *
7284 * This version dated 18.01.95 is written by S. Roesler                 *
7285 ************************************************************************
7286
7287       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7288       SAVE
7289       PARAMETER ( LINP = 10 ,
7290      &            LOUT = 6 ,
7291      &            LDAT = 9 )
7292       PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7293
7294       LOGICAL LSTART
7295
7296 * event history
7297       PARAMETER (NMXHKK=200000)
7298       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7299      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7300      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7301 * extended event history
7302       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7303      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7304      &                IHIST(2,NMXHKK)
7305 * flags for input different options
7306       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7307       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7308      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7309 * statistics
7310       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7311      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7312      &                ICEVTG(8,0:30)
7313
7314       DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7315      &          PCH2(4)
7316
7317       DATA LSTART /.TRUE./
7318
7319       IFSC  = 0
7320       IF (LSTART) THEN
7321          WRITE(LOUT,1000)
7322  1000    FORMAT(/,1X,'VV2SCH:  Reggeon contribution to valance-',
7323      &          'valence chains treated')
7324          LSTART = .FALSE.
7325       ENDIF
7326
7327       NSTOP = NHKK
7328
7329 * get index of first chain
7330       DO 1 I=NPOINT(3),NHKK
7331          IF (IDHKK(I).EQ.88888) THEN
7332             NC = I
7333             GOTO 2
7334          ENDIF
7335     1 CONTINUE
7336
7337     2 CONTINUE
7338       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7339      &                        .AND.(NC.LT.NSTOP)) THEN
7340 * get valence-valence chains
7341          IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7342 *   get "mother"-hadron indices
7343             MO1   = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7344             MO2   = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7345             KPROJ = IDT_ICIHAD(IDHKK(MO1))
7346             KTARG = IDT_ICIHAD(IDHKK(MO2))
7347 *   Lab momentum of projectile hadron
7348             CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7349             PTOT  = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7350      &                                  PHKK(3,MO1)**2)
7351
7352             SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7353             IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7354                ICVV2S = ICVV2S+1
7355 *   single chain requested
7356 *      get flavors of chain-end partons
7357                MO(1) = JMOHKK(1,NC)
7358                MO(2) = JMOHKK(2,NC)
7359                MO(3) = JMOHKK(1,NC+3)
7360                MO(4) = JMOHKK(2,NC+3)
7361                DO 3 I=1,4
7362                   IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7363                   IF(I,2) = 0
7364                   IF (ABS(IDHKK(MO(I))).GE.1000)
7365      &               IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7366     3          CONTINUE
7367 *      which one is the q-aq chain?
7368 *        N1,N1+1 - DTEVT1-entries for q-aq system
7369 *        N2,N2+1 - DTEVT1-entries for the other chain
7370                IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7371                   K1 = 1
7372                   K2 = 3
7373                   N1 = NC-2
7374                   N2 = NC+1
7375                ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7376                   K1 = 3
7377                   K2 = 1
7378                   N1 = NC+1
7379                   N2 = NC-2
7380                ELSE
7381                   GOTO 10
7382                ENDIF
7383                DO 4 K=1,4
7384                   PP1(K) = PHKK(K,N1)
7385                   PT1(K) = PHKK(K,N1+1)
7386                   PP2(K) = PHKK(K,N2)
7387                   PT2(K) = PHKK(K,N2+1)
7388     4          CONTINUE
7389                AMCH1 = PHKK(5,N1+2)
7390                AMCH2 = PHKK(5,N2+2)
7391 *      get meson-identity corresponding to flavors of q-aq chain
7392                ITMP   = IRESRJ
7393                IRESRJ = 0
7394                CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7395      &                     ZERO,AMCH1N,1,IDUM)
7396                IRESRJ = ITMP
7397 *      change kinematics of chains
7398                CALL DT_CHKINE(PP1,IDHKK(N1),  PP2,IDHKK(N2),
7399      &                     PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7400      &                     AMCH1,AMCH1N,AMCH2,IREJ1)
7401                IF (IREJ1.NE.0) GOTO 10
7402 *      check second chain for resonance
7403                IDCHAI = 2
7404                IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7405                CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7406      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7407                IF (IREJ1.NE.0) GOTO 10
7408                IF (IDR2.NE.0) IDR2 = 100*IDR2
7409 *      add partons and chains to DTEVT1
7410                DO 5 K=1,4
7411                   PCH1(K) = PP1(K)+PT1(K)
7412                   PCH2(K) = PP2(K)+PT2(K)
7413     5          CONTINUE
7414                CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7415      &                                             PP1(3),PP1(4),0,0,0)
7416                CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7417      &                                      PT1(2),PT1(3),PT1(4),0,0,0)
7418                KCH = ISTHKK(N1+2)+100
7419                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7420      &                     PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7421                IDHKK(N1+2) = 22222
7422                CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7423      &                                             PP2(3),PP2(4),0,0,0)
7424                CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7425      &                                      PT2(2),PT2(3),PT2(4),0,0,0)
7426                KCH = ISTHKK(N2+2)+100
7427                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7428      &                     PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7429                IDHKK(N2+2) = 22222
7430             ENDIF
7431          ENDIF
7432       ELSE
7433          GOTO 11
7434       ENDIF
7435    10 CONTINUE
7436       NC = NC+6
7437       GOTO 2
7438
7439    11 CONTINUE
7440
7441       RETURN
7442       END
7443
7444 *$ CREATE DT_PHNSCH.FOR
7445 *COPY DT_PHNSCH
7446 *
7447 *=== phnsch ===========================================================*
7448 *
7449       DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7450
7451 *----------------------------------------------------------------------*
7452 *                                                                      *
7453 *     Probability for Hadron Nucleon Single CHain interactions:        *
7454 *                                                                      *
7455 *     Created on 30 december 1993  by    Alfredo Ferrari & Paola Sala  *
7456 *                                                   Infn - Milan       *
7457 *                                                                      *
7458 *     Last change on 04-jan-94     by    Alfredo Ferrari               *
7459 *                                                                      *
7460 *             modified by J.R.for use in DTUNUC  6.1.94                *
7461 *                                                                      *
7462 *     Input variables:                                                 *
7463 *                      Kp = hadron projectile index (Part numbering    *
7464 *                           scheme)                                    *
7465 *                   Ktarg = target nucleon index (1=proton, 8=neutron) *
7466 *                    Plab = projectile laboratory momentum (GeV/c)     *
7467 *     Output variable:                                                 *
7468 *                  Phnsch = probability per single chain (particle     *
7469 *                           exchange) interactions                     *
7470 *                                                                      *
7471 *----------------------------------------------------------------------*
7472
7473       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7474       SAVE
7475
7476       PARAMETER ( LUNOUT = 6  )
7477       PARAMETER ( LUNERR = 6  )
7478       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
7479       PARAMETER ( ZERZER = 0.D+00 )
7480       PARAMETER ( ONEONE = 1.D+00 )
7481       PARAMETER ( TWOTWO = 2.D+00 )
7482       PARAMETER ( FIVFIV = 5.D+00 )
7483       PARAMETER ( HLFHLF = 0.5D+00 )
7484
7485       PARAMETER ( NALLWP = 39   )
7486       PARAMETER ( IDMAXP = 210  )
7487
7488       DIMENSION ICHRGE(39),AM(39)
7489
7490 * particle properties (BAMJET index convention)
7491       CHARACTER*8  ANAME
7492       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7493      &                IICH(210),IIBAR(210),K1(210),K2(210)
7494
7495       DIMENSION KPTOIP(210)
7496 * auxiliary common for reggeon exchange (DTUNUC 1.x)
7497       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7498      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7499      &                IQTCHR(-6:6),MQUARK(3,39)
7500
7501       DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7502       DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7503 CPH      SAVE SGTCOE, IHLP
7504 CPH      SAVE IQFSC1, IQFSC2, IQBSC1, IQBSC2
7505       EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7506       EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7507       EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7508
7509 * Conversion from part to paprop numbering
7510       DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7511      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7512      & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7513
7514 *  1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7515       DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7516      &    2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7517 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7518       DATA  SGTCO1  /
7519 * 1st reaction: gamma p total
7520      &0.147 D+00, ZERZER  , ZERZER   , 0.0022D+00, -0.0170D+00,
7521 * 2nd reaction: gamma d total
7522      &0.300 D+00, ZERZER  , ZERZER   , 0.0095D+00, -0.057 D+00,
7523 * 3rd reaction: pi+ p total
7524      &16.4  D+00, 19.3D+00, -0.42D+00, 0.19  D+00, ZERZER     ,
7525 * 4th reaction: pi- p total
7526      &33.0  D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03  D+00,
7527 * 5th reaction: pi+/- d total
7528      &56.8  D+00, 42.2D+00, -1.45D+00, 0.65  D+00, -5.39  D+00,
7529 * 6th reaction: K+ p total
7530      &18.1  D+00, ZERZER  , ZERZER   , 0.26  D+00, -1.0   D+00,
7531 * 7th reaction: K+ n total
7532      &18.7  D+00, ZERZER  , ZERZER   , 0.21  D+00, -0.89  D+00,
7533 * 8th reaction: K+ d total
7534      &34.2  D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99  D+00,
7535 * 9th reaction: K- p total
7536      &32.1  D+00, ZERZER  , ZERZER   , 0.66  D+00, -5.6   D+00,
7537 * 10th reaction: K- n total
7538      &25.2  D+00, ZERZER  , ZERZER   , 0.38  D+00, -2.9   D+00/
7539 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7540       DATA  SGTCO2  /
7541 * 11th reaction: K- d total
7542      &57.6  D+00, ZERZER  , ZERZER   , 1.17  D+00, -9.5   D+00,
7543 * 12th reaction: p p total
7544      &48.0  D+00, ZERZER  , ZERZER   , 0.522 D+00, -4.51  D+00,
7545 * 13th reaction: p n total
7546      &47.30 D+00, ZERZER  , ZERZER   , 0.513 D+00, -4.27  D+00,
7547 * 14th reaction: p d total
7548      &91.3  D+00, ZERZER  , ZERZER   , 1.05  D+00, -8.8   D+00,
7549 * 15th reaction: pbar p total
7550      &38.4  D+00, 77.6D+00, -0.64D+00, 0.26  D+00, -1.2   D+00,
7551 * 16th reaction: pbar n total
7552      &ZERZER    ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7   D+00,
7553 * 17th reaction: pbar d total
7554      &112.  D+00, 125.D+00, -1.08D+00, 1.14  D+00, -12.4  D+00,
7555 * 18th reaction: Lamda p total
7556      &30.4  D+00, ZERZER  , ZERZER   , ZERZER    , 1.6    D+00/
7557 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
7558       DATA SGTCO3  /
7559 * 19th reaction: pi+ p elastic
7560      &ZERZER    , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER     ,
7561 * 20th reaction: pi- p elastic
7562      &1.76  D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER     ,
7563 * 21st reaction: K+ p elastic
7564      &5.0   D+00, 8.1 D+00, -1.8 D+00, 0.16  D+00, -1.3   D+00,
7565 * 22nd reaction: K- p elastic
7566      &7.3   D+00, ZERZER  , ZERZER   , 0.29  D+00, -2.40  D+00,
7567 * 23rd reaction: p p elastic
7568      &11.9  D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85  D+00,
7569 * 24th reaction: p d elastic
7570      &16.1  D+00, ZERZER  , ZERZER   , 0.32  D+00, -3.4   D+00,
7571 * 25th reaction: pbar p elastic
7572      &10.2  D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28  D+00,
7573 * 26th reaction: pbar p elastic bis
7574      &10.6  D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41  D+00,
7575 * 27th reaction: pbar n elastic
7576      &36.5  D+00, ZERZER  , ZERZER   , ZERZER    , -11.9  D+00,
7577 * 28th reaction: Lamda p elastic
7578      &12.3  D+00, ZERZER  , ZERZER   , ZERZER    , -2.4   D+00,
7579 * 29th reaction: K- p ela bis
7580      &7.24  D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35  D+00,
7581 * 30th reaction: pi- p cx
7582      &ZERZER    ,0.912D+00, -1.22D+00, ZERZER    , ZERZER     ,
7583 * 31st reaction: K- p cx
7584      &ZERZER    , 3.39D+00, -1.75D+00, ZERZER    , ZERZER     ,
7585 * 32nd reaction: K+ n cx
7586      &ZERZER    , 7.18D+00, -2.01D+00, ZERZER    , ZERZER     ,
7587 * 33rd reaction: pbar p cx
7588      &ZERZER    , 18.8D+00, -2.01D+00, ZERZER    , ZERZER     /
7589 *
7590 *  +-------------------------------------------------------------------*
7591          ICHRGE(KTARG)=IICH(KTARG)
7592          AM    (KTARG)=AAM (KTARG)
7593 *  |  Check for pi0 (d-dbar)
7594       IF ( KP .NE. 26 ) THEN
7595          IP  = KPTOIP (KP)
7596          IF(IP.EQ.0)IP=1
7597          ICHRGE(IP)=IICH(KP)
7598          AM    (IP)=AAM (KP)
7599 *  |
7600 *  +-------------------------------------------------------------------*
7601 *  |
7602       ELSE
7603          IP = 23
7604          ICHRGE(IP)=0
7605       END IF
7606 *  |
7607 *  +-------------------------------------------------------------------*
7608 *  +-------------------------------------------------------------------*
7609 *  |  No such interactions for baryon-baryon
7610       IF ( IIBAR (KP) .GT. 0 ) THEN
7611          DT_PHNSCH = ZERZER
7612          RETURN
7613 *  |
7614 *  +-------------------------------------------------------------------*
7615 *  |  No "annihilation" diagram possible for K+ p/n
7616       ELSE IF ( IP .EQ. 15 ) THEN
7617          DT_PHNSCH = ZERZER
7618          RETURN
7619 *  |
7620 *  +-------------------------------------------------------------------*
7621 *  |  No "annihilation" diagram possible for K0 p/n
7622       ELSE IF ( IP .EQ. 24 ) THEN
7623          DT_PHNSCH = ZERZER
7624          RETURN
7625 *  |
7626 *  +-------------------------------------------------------------------*
7627 *  |  No "annihilation" diagram possible for Omebar p/n
7628       ELSE IF ( IP .GE. 38 ) THEN
7629          DT_PHNSCH = ZERZER
7630          RETURN
7631       END IF
7632 *  |
7633 *  +-------------------------------------------------------------------*
7634 *  +-------------------------------------------------------------------*
7635 *  |  If the momentum is larger than 50 GeV/c, compute the single
7636 *  |  chain probability at 50 GeV/c and extrapolate to the present
7637 *  |  momentum according to 1/sqrt(s)
7638 *  |  sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
7639 *  |  P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
7640 *  |  sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
7641 *  |  sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
7642 *  |                        x sqrt(s/s(50))
7643 *  |  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
7644       IF ( PLAB .GT. 50.D+00 ) THEN
7645          PLA    = 50.D+00
7646          AMPSQ  = AM (IP)**2
7647          AMTSQ  = AM (KTARG)**2
7648          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
7649          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7650          EPROJ  = SQRT ( PLA**2 + AMPSQ )
7651          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7652          UMORAT = SQRT ( UMOSQ / UMO50 )
7653 *  |
7654 *  +-------------------------------------------------------------------*
7655 *  |  P < 3 GeV/c
7656       ELSE IF ( PLAB .LT. 3.D+00 ) THEN
7657          PLA    = 3.D+00
7658          AMPSQ  = AM (IP)**2
7659          AMTSQ  = AM (KTARG)**2
7660          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
7661          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7662          EPROJ  = SQRT ( PLA**2 + AMPSQ )
7663          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7664          UMORAT = SQRT ( UMOSQ / UMO50 )
7665 *  |
7666 *  +-------------------------------------------------------------------*
7667 *  |  P < 50 GeV/c
7668       ELSE
7669          PLA    = PLAB
7670          UMORAT = ONEONE
7671       END IF
7672 *  |
7673 *  +-------------------------------------------------------------------*
7674       ALGPLA = LOG (PLA)
7675 *  +-------------------------------------------------------------------*
7676 *  |  Pions:
7677       IF ( IHLP (IP) .EQ. 2 ) THEN
7678          ACOF = SGTCOE (1,3)
7679          BCOF = SGTCOE (2,3)
7680          ENNE = SGTCOE (3,3)
7681          CCOF = SGTCOE (4,3)
7682          DCOF = SGTCOE (5,3)
7683 *  |  Compute the pi+ p total cross section:
7684          SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7685      &          + DCOF * ALGPLA
7686          ACOF = SGTCOE (1,19)
7687          BCOF = SGTCOE (2,19)
7688          ENNE = SGTCOE (3,19)
7689          CCOF = SGTCOE (4,19)
7690          DCOF = SGTCOE (5,19)
7691 *  |  Compute the pi+ p elastic cross section:
7692          SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7693      &          + DCOF * ALGPLA
7694 *  |  Compute the pi+ p inelastic cross section:
7695          SPPPIN = SPPPTT - SPPPEL
7696          ACOF = SGTCOE (1,4)
7697          BCOF = SGTCOE (2,4)
7698          ENNE = SGTCOE (3,4)
7699          CCOF = SGTCOE (4,4)
7700          DCOF = SGTCOE (5,4)
7701 *  |  Compute the pi- p total cross section:
7702          SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7703      &          + DCOF * ALGPLA
7704          ACOF = SGTCOE (1,20)
7705          BCOF = SGTCOE (2,20)
7706          ENNE = SGTCOE (3,20)
7707          CCOF = SGTCOE (4,20)
7708          DCOF = SGTCOE (5,20)
7709 *  |  Compute the pi- p elastic cross section:
7710          SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7711      &          + DCOF * ALGPLA
7712 *  |  Compute the pi- p inelastic cross section:
7713          SPMPIN = SPMPTT - SPMPEL
7714          SIGDIA = SPMPIN - SPPPIN
7715 *  |  +----------------------------------------------------------------*
7716 *  |  |  Charged pions: besides isospin consideration it is supposed
7717 *  |  |                 that (pi+ n)el is almost equal to (pi- p)el
7718 *  |  |                 and  (pi+ p)el "    "     "    "  (pi- n)el
7719 *  |  |                 and all are almost equal among each others
7720 *  |  |                 (reasonable above 5 GeV/c)
7721          IF ( ICHRGE (IP) .NE. 0 ) THEN
7722             KHELP = KTARG / 8
7723             JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
7724             ACOF = SGTCOE (1,JREAC)
7725             BCOF = SGTCOE (2,JREAC)
7726             ENNE = SGTCOE (3,JREAC)
7727             CCOF = SGTCOE (4,JREAC)
7728             DCOF = SGTCOE (5,JREAC)
7729 *  |  |  Compute the total cross section:
7730             SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7731      &             + DCOF * ALGPLA
7732             JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
7733             ACOF = SGTCOE (1,JREAC)
7734             BCOF = SGTCOE (2,JREAC)
7735             ENNE = SGTCOE (3,JREAC)
7736             CCOF = SGTCOE (4,JREAC)
7737             DCOF = SGTCOE (5,JREAC)
7738 *  |  |  Compute the elastic cross section:
7739             SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7740      &             + DCOF * ALGPLA
7741 *  |  |  Compute the inelastic cross section:
7742             SHNCIN = SHNCTT - SHNCEL
7743 *  |  |  Number of diagrams:
7744             NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
7745 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7746             IQFSC1 = 1 + IP - 13
7747             IQFSC2 = 0
7748             IQBSC1 = 1 + KHELP
7749             IQBSC2 = 1 + IP - 13
7750 *  |  |
7751 *  |  +----------------------------------------------------------------*
7752 *  |  |  pi0: besides isospin consideration it is supposed that the
7753 *  |  |       elastic cross section is not very different from
7754 *  |  |       pi+ p and/or pi- p (reasonable above 5 GeV/c)
7755          ELSE
7756             KHELP  = KTARG / 8
7757             K2HLP  = ( KP - 23 ) / 3
7758 *  |  |  Number of diagrams:
7759 *  |  |  For u ubar (k2hlp=0):
7760 *           NDIAGR = 2 - KHELP
7761 *  |  |  For d dbar (k2hlp=1):
7762 *           NDIAGR = 2 + KHELP - K2HLP
7763             NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
7764             SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
7765 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7766             IQFSC1 = 1 + K2HLP
7767             IQFSC2 = 0
7768             IQBSC1 = 1 + KHELP
7769             IQBSC2 = 2 - K2HLP
7770          END IF
7771 *  |  |
7772 *  |  +----------------------------------------------------------------*
7773 *  |                                                   end pi's
7774 *  +-------------------------------------------------------------------*
7775 *  |  Kaons:
7776       ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
7777          ACOF = SGTCOE (1,6)
7778          BCOF = SGTCOE (2,6)
7779          ENNE = SGTCOE (3,6)
7780          CCOF = SGTCOE (4,6)
7781          DCOF = SGTCOE (5,6)
7782 *  |  Compute the K+ p total cross section:
7783          SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7784      &          + DCOF * ALGPLA
7785          ACOF = SGTCOE (1,21)
7786          BCOF = SGTCOE (2,21)
7787          ENNE = SGTCOE (3,21)
7788          CCOF = SGTCOE (4,21)
7789          DCOF = SGTCOE (5,21)
7790 *  |  Compute the K+ p elastic cross section:
7791          SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7792      &          + DCOF * ALGPLA
7793 *  |  Compute the K+ p inelastic cross section:
7794          SKPPIN = SKPPTT - SKPPEL
7795          ACOF = SGTCOE (1,9)
7796          BCOF = SGTCOE (2,9)
7797          ENNE = SGTCOE (3,9)
7798          CCOF = SGTCOE (4,9)
7799          DCOF = SGTCOE (5,9)
7800 *  |  Compute the K- p total cross section:
7801          SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7802      &          + DCOF * ALGPLA
7803          ACOF = SGTCOE (1,22)
7804          BCOF = SGTCOE (2,22)
7805          ENNE = SGTCOE (3,22)
7806          CCOF = SGTCOE (4,22)
7807          DCOF = SGTCOE (5,22)
7808 *  |  Compute the K- p elastic cross section:
7809          SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7810      &          + DCOF * ALGPLA
7811 *  |  Compute the K- p inelastic cross section:
7812          SKMPIN = SKMPTT - SKMPEL
7813          SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
7814 *  |  +----------------------------------------------------------------*
7815 *  |  |  Charged Kaons: actually only K-
7816          IF ( ICHRGE (IP) .NE. 0 ) THEN
7817             KHELP = KTARG / 8
7818 *  |  |  +-------------------------------------------------------------*
7819 *  |  |  |  Proton target:
7820             IF ( KHELP .EQ. 0 ) THEN
7821                SHNCIN = SKMPIN
7822 *  |  |  |  Number of diagrams:
7823                NDIAGR = 2
7824 *  |  |  |
7825 *  |  |  +-------------------------------------------------------------*
7826 *  |  |  |  Neutron target: besides isospin consideration it is supposed
7827 *  |  |  |              that (K- n)el is almost equal to (K- p)el
7828 *  |  |  |              (reasonable above 5 GeV/c)
7829             ELSE
7830                ACOF = SGTCOE (1,10)
7831                BCOF = SGTCOE (2,10)
7832                ENNE = SGTCOE (3,10)
7833                CCOF = SGTCOE (4,10)
7834                DCOF = SGTCOE (5,10)
7835 *  |  |  |  Compute the total cross section:
7836                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7837      &                + DCOF * ALGPLA
7838 *  |  |  |  Compute the elastic cross section:
7839                SHNCEL = SKMPEL
7840 *  |  |  |  Compute the inelastic cross section:
7841                SHNCIN = SHNCTT - SHNCEL
7842 *  |  |  |  Number of diagrams:
7843                NDIAGR = 1
7844             END IF
7845 *  |  |  |
7846 *  |  |  +-------------------------------------------------------------*
7847 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7848             IQFSC1 = 3
7849             IQFSC2 = 0
7850             IQBSC1 = 1 + KHELP
7851             IQBSC2 = 2
7852 *  |  |
7853 *  |  +----------------------------------------------------------------*
7854 *  |  |  K0's: (actually only K0bar)
7855          ELSE
7856             KHELP  = KTARG / 8
7857 *  |  |  +-------------------------------------------------------------*
7858 *  |  |  |  Proton target: (K0bar p)in supposed to be given by
7859 *  |  |  |                 (K- p)in - Sig_diagr
7860             IF ( KHELP .EQ. 0 ) THEN
7861                SHNCIN = SKMPIN - SIGDIA
7862 *  |  |  |  Number of diagrams:
7863                NDIAGR = 1
7864 *  |  |  |
7865 *  |  |  +-------------------------------------------------------------*
7866 *  |  |  |  Neutron target: (K0bar n)in supposed to be given by
7867 *  |  |  |                 (K- n)in + Sig_diagr
7868 *  |  |  |              besides isospin consideration it is supposed
7869 *  |  |  |              that (K- n)el is almost equal to (K- p)el
7870 *  |  |  |              (reasonable above 5 GeV/c)
7871             ELSE
7872                ACOF = SGTCOE (1,10)
7873                BCOF = SGTCOE (2,10)
7874                ENNE = SGTCOE (3,10)
7875                CCOF = SGTCOE (4,10)
7876                DCOF = SGTCOE (5,10)
7877 *  |  |  |  Compute the total cross section:
7878                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7879      &                + DCOF * ALGPLA
7880 *  |  |  |  Compute the elastic cross section:
7881                SHNCEL = SKMPEL
7882 *  |  |  |  Compute the inelastic cross section:
7883                SHNCIN = SHNCTT - SHNCEL + SIGDIA
7884 *  |  |  |  Number of diagrams:
7885                NDIAGR = 2
7886             END IF
7887 *  |  |  |
7888 *  |  |  +-------------------------------------------------------------*
7889 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7890             IQFSC1 = 3
7891             IQFSC2 = 0
7892             IQBSC1 = 1
7893             IQBSC2 = 1 + KHELP
7894          END IF
7895 *  |  |
7896 *  |  +----------------------------------------------------------------*
7897 *  |                                                   end Kaon's
7898 *  +-------------------------------------------------------------------*
7899 *  |  Antinucleons:
7900       ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
7901 *  |  For momenta between 3 and 5 GeV/c the use of tabulated data
7902 *  |  should be implemented!
7903          ACOF = SGTCOE (1,15)
7904          BCOF = SGTCOE (2,15)
7905          ENNE = SGTCOE (3,15)
7906          CCOF = SGTCOE (4,15)
7907          DCOF = SGTCOE (5,15)
7908 *  |  Compute the pbar p total cross section:
7909          SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7910      &          + DCOF * ALGPLA
7911          IF ( PLA .LT. FIVFIV ) THEN
7912             JREAC = 26
7913          ELSE
7914             JREAC = 25
7915          END IF
7916          ACOF = SGTCOE (1,JREAC)
7917          BCOF = SGTCOE (2,JREAC)
7918          ENNE = SGTCOE (3,JREAC)
7919          CCOF = SGTCOE (4,JREAC)
7920          DCOF = SGTCOE (5,JREAC)
7921 *  |  Compute the pbar p elastic cross section:
7922          SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7923      &          + DCOF * ALGPLA
7924 *  |  Compute the pbar p inelastic cross section:
7925          SAPPIN = SAPPTT - SAPPEL
7926          ACOF = SGTCOE (1,12)
7927          BCOF = SGTCOE (2,12)
7928          ENNE = SGTCOE (3,12)
7929          CCOF = SGTCOE (4,12)
7930          DCOF = SGTCOE (5,12)
7931 *  |  Compute the p p total cross section:
7932          SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7933      &          + DCOF * ALGPLA
7934          ACOF = SGTCOE (1,23)
7935          BCOF = SGTCOE (2,23)
7936          ENNE = SGTCOE (3,23)
7937          CCOF = SGTCOE (4,23)
7938          DCOF = SGTCOE (5,23)
7939 *  |  Compute the p p elastic cross section:
7940          SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7941      &          + DCOF * ALGPLA
7942 *  |  Compute the K- p inelastic cross section:
7943          SPPINE = SPPTOT - SPPELA
7944          SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
7945          KHELP  = KTARG / 8
7946 *  |  +----------------------------------------------------------------*
7947 *  |  |  Pbar:
7948          IF ( ICHRGE (IP) .NE. 0 ) THEN
7949             NDIAGR = 5 - KHELP
7950 *  |  |  +-------------------------------------------------------------*
7951 *  |  |  |  Proton target:
7952             IF ( KHELP .EQ. 0 ) THEN
7953 *  |  |  |  Number of diagrams:
7954                SHNCIN = SAPPIN
7955                PUUBAR = 0.8D+00
7956 *  |  |  |
7957 *  |  |  +-------------------------------------------------------------*
7958 *  |  |  |  Neutron target: it is supposed that (ap n)el is almost equal
7959 *  |  |  |                  to (ap p)el (reasonable above 5 GeV/c)
7960             ELSE
7961                ACOF = SGTCOE (1,16)
7962                BCOF = SGTCOE (2,16)
7963                ENNE = SGTCOE (3,16)
7964                CCOF = SGTCOE (4,16)
7965                DCOF = SGTCOE (5,16)
7966 *  |  |  |  Compute the total cross section:
7967                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7968      &                + DCOF * ALGPLA
7969 *  |  |  |  Compute the elastic cross section:
7970                SHNCEL = SAPPEL
7971 *  |  |  |  Compute the inelastic cross section:
7972                SHNCIN = SHNCTT - SHNCEL
7973                PUUBAR = HLFHLF
7974             END IF
7975 *  |  |  |
7976 *  |  |  +-------------------------------------------------------------*
7977 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7978 *  |  |  there are different possibilities, make a random choiche:
7979             IQFSC1 = -1
7980             RNCHEN = DT_RNDM(PUUBAR)
7981             IF ( RNCHEN .LT. PUUBAR ) THEN
7982                IQFSC2 = -2
7983             ELSE
7984                IQFSC2 = -1
7985             END IF
7986             IQBSC1 = -IQFSC1 + KHELP
7987             IQBSC2 = -IQFSC2
7988 *  |  |
7989 *  |  +----------------------------------------------------------------*
7990 *  |  |  nbar:
7991          ELSE
7992             NDIAGR = 4 + KHELP
7993 *  |  |  +-------------------------------------------------------------*
7994 *  |  |  |  Proton target: (nbar p)in supposed to be given by
7995 *  |  |  |                 (pbar p)in - Sig_diagr
7996             IF ( KHELP .EQ. 0 ) THEN
7997                SHNCIN = SAPPIN - SIGDIA
7998                PDDBAR = HLFHLF
7999 *  |  |  |
8000 *  |  |  +-------------------------------------------------------------*
8001 *  |  |  |  Neutron target: (nbar n)el is supposed to be equal to
8002 *  |  |  |                  (pbar p)el (reasonable above 5 GeV/c)
8003             ELSE
8004 *  |  |  |  Compute the total cross section:
8005                SHNCTT = SAPPTT
8006 *  |  |  |  Compute the elastic cross section:
8007                SHNCEL = SAPPEL
8008 *  |  |  |  Compute the inelastic cross section:
8009                SHNCIN = SHNCTT - SHNCEL
8010                PDDBAR = 0.8D+00
8011             END IF
8012 *  |  |  |
8013 *  |  |  +-------------------------------------------------------------*
8014 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8015 *  |  |  there are different possibilities, make a random choiche:
8016             IQFSC1 = -2
8017             RNCHEN = DT_RNDM(RNCHEN)
8018             IF ( RNCHEN .LT. PDDBAR ) THEN
8019                IQFSC2 = -1
8020             ELSE
8021                IQFSC2 = -2
8022             END IF
8023             IQBSC1 = -IQFSC1 + KHELP - 1
8024             IQBSC2 = -IQFSC2
8025          END IF
8026 *  |  |
8027 *  |  +----------------------------------------------------------------*
8028 *  |
8029 *  +-------------------------------------------------------------------*
8030 *  |  Others: not yet implemented
8031       ELSE
8032          SIGDIA = ZERZER
8033          SHNCIN = ONEONE
8034          NDIAGR = 0
8035          DT_PHNSCH = ZERZER
8036          RETURN
8037       END IF
8038 *  |                                                   end others
8039 *  +-------------------------------------------------------------------*
8040       DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8041       IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8042      &       + IQECHR (IQBSC2)
8043       IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8044      &       + IQBCHR (IQBSC2)
8045       IQECHC = IQECHC / 3
8046       IQBCHC = IQBCHC / 3
8047       IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8048      &       + IQSCHR (IQBSC2)
8049       IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8050      &       + IQSCHR (MQUARK(3,IP))
8051 *  +-------------------------------------------------------------------*
8052 *  |  Consistency check:
8053       IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8054          WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8055      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8056          WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8057      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8058          DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8059          DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8060       END IF
8061 *  |
8062 *  +-------------------------------------------------------------------*
8063 *  +-------------------------------------------------------------------*
8064 *  |  Consistency check:
8065       IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8066      &     .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8067          WRITE (LUNOUT,*)
8068      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8069      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8070          WRITE (LUNERR,*)
8071      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8072      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8073       END IF
8074 *  |
8075 *  +-------------------------------------------------------------------*
8076 *  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8077       IF ( UMORAT .GT. ONEPLS )
8078      &   DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8079      &                                 - ONEONE ) * UMORAT + ONEONE )
8080       RETURN
8081 *
8082       ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8083       DT_SCHQUA = ONEONE
8084       JQFSC1 = IQFSC1
8085       JQFSC2 = IQFSC2
8086       JQBSC1 = IQBSC1
8087       JQBSC2 = IQBSC2
8088 *=== End of function Phnsch ===========================================*
8089       RETURN
8090       END
8091
8092 *$ CREATE DT_RESPT.FOR
8093 *COPY DT_RESPT
8094 *
8095 *===respt==============================================================*
8096 *
8097       SUBROUTINE DT_RESPT
8098
8099 ************************************************************************
8100 * Check DTEVT1 for two-resonance systems and sample intrinsic p_t.     *
8101 * This version dated 18.01.95 is written by S. Roesler                 *
8102 ************************************************************************
8103
8104       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8105       SAVE
8106       PARAMETER ( LINP = 10 ,
8107      &            LOUT = 6 ,
8108      &            LDAT = 9 )
8109       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8110
8111 * event history
8112       PARAMETER (NMXHKK=200000)
8113       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8114      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8115      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8116 * extended event history
8117       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8118      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8119      &                IHIST(2,NMXHKK)
8120
8121 * get index of first chain
8122       DO 1 I=NPOINT(3),NHKK
8123          IF (IDHKK(I).EQ.88888) THEN
8124             NC = I
8125             GOTO 2
8126          ENDIF
8127     1 CONTINUE
8128
8129     2 CONTINUE
8130       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8131 C        WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8132 * skip VV-,SS- systems
8133          IF ((IDCH(NC  ).NE.1).AND.(IDCH(NC  ).NE.8).AND.
8134      &       (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8135 * check if both "chains" are resonances
8136             IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8137                CALL DT_SAPTRE(NC,NC+3)
8138             ENDIF
8139          ENDIF
8140       ELSE
8141          GOTO 3
8142       ENDIF
8143       NC = NC+6
8144       GOTO 2
8145
8146     3 CONTINUE
8147
8148       RETURN
8149       END
8150
8151 *$ CREATE DT_EVTRES.FOR
8152 *COPY DT_EVTRES
8153 *
8154 *===evtres=============================================================*
8155 *
8156       SUBROUTINE DT_EVTRES(IREJ)
8157
8158 ************************************************************************
8159 * This version dated 14.12.94 is written by S. Roesler                 *
8160 ************************************************************************
8161
8162       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8163       SAVE
8164       PARAMETER ( LINP = 10 ,
8165      &            LOUT = 6 ,
8166      &            LDAT = 9 )
8167       PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8168
8169 * event history
8170       PARAMETER (NMXHKK=200000)
8171       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8172      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8173      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8174 * extended event history
8175       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8176      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8177      &                IHIST(2,NMXHKK)
8178 * flags for input different options
8179       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8180       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8181      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8182 * particle properties (BAMJET index convention)
8183       CHARACTER*8  ANAME
8184       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8185      &                IICH(210),IIBAR(210),K1(210),K2(210)
8186
8187       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8188
8189       IREJ = 0
8190
8191       DO 1 I=NPOINT(3),NHKK
8192          IF (ABS(IDRES(I)).GE.100) THEN
8193             AMMX = 0.0D0
8194             DO 2 J=NPOINT(3),NHKK
8195                IF (IDHKK(J).EQ.88888) THEN
8196                   IF (PHKK(5,J).GT.AMMX) THEN
8197                      AMMX = PHKK(5,J)
8198                      IMMX = J
8199                   ENDIF
8200                ENDIF
8201     2       CONTINUE
8202             IF (IDRES(IMMX).NE.0) THEN
8203                IF (IOULEV(3).GT.0) THEN
8204                   WRITE(LOUT,'(1X,A)')
8205      &               'EVTRES: no chain for correc. found'
8206 C                 GOTO 6
8207                   GOTO 9999
8208                ELSE
8209                   GOTO 9999
8210                ENDIF
8211             ENDIF
8212             IMO11  = JMOHKK(1,I)
8213             IMO12  = JMOHKK(2,I)
8214             IF (PHKK(3,IMO11).LT.0.0D0) THEN
8215                IMO11 = JMOHKK(2,I)
8216                IMO12 = JMOHKK(1,I)
8217             ENDIF
8218             IMO21  = JMOHKK(1,IMMX)
8219             IMO22  = JMOHKK(2,IMMX)
8220             IF (PHKK(3,IMO21).LT.0.0D0) THEN
8221                IMO21 = JMOHKK(2,IMMX)
8222                IMO22 = JMOHKK(1,IMMX)
8223             ENDIF
8224             AMCH1  = PHKK(5,I)
8225             AMCH1N = AAM(IDXRES(I))
8226
8227             IFPR1 = IDHKK(IMO11)
8228             IFPR2 = IDHKK(IMO21)
8229             IFTA1 = IDHKK(IMO12)
8230             IFTA2 = IDHKK(IMO22)
8231             DO 4 J=1,4
8232                PP1(J) = PHKK(J,IMO11)
8233                PP2(J) = PHKK(J,IMO21)
8234                PT1(J) = PHKK(J,IMO12)
8235                PT2(J) = PHKK(J,IMO22)
8236     4       CONTINUE
8237 * store initial configuration for energy-momentum cons. check
8238             IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8239 * correct kinematics of second chain
8240             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8241      &                  AMCH1,AMCH1N,AMCH2,IREJ1)
8242             IF (IREJ1.NE.0) GOTO 9999
8243 * check now this chain for resonance mass
8244             IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8245             IFP(2) = 0
8246             IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8247             IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8248             IFT(2) = 0
8249             IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8250             IDCH2 = 2
8251             IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8252             IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8253             CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8254      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
8255             IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8256                IF (IOULEV(1).GT.0)
8257      &            WRITE(LOUT,*) ' correction for resonance not poss.'
8258 **sr test
8259 C              GOTO 1
8260 C              GOTO 9999
8261 **
8262             ENDIF
8263 * store final configuration for energy-momentum cons. check
8264             IF (LEMCCK) THEN
8265                CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8266                CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8267                IF (IREJ1.NE.0) GOTO 9999
8268             ENDIF
8269             DO 5 J=1,4
8270                PHKK(J,IMO11) = PP1(J)
8271                PHKK(J,IMO21) = PP2(J)
8272                PHKK(J,IMO12) = PT1(J)
8273                PHKK(J,IMO22) = PT2(J)
8274     5       CONTINUE
8275 * correct entries of chains
8276             DO 3 K=1,4
8277                PHKK(K,I)    = PHKK(K,IMO11)+PHKK(K,IMO12)
8278                PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8279     3       CONTINUE
8280             AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8281             AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8282      &            PHKK(3,IMMX)**2
8283 * ?? the following should now be obsolete
8284 **sr test
8285 C           IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8286             IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8287 **
8288                WRITE(LOUT,'(1X,A,4G10.3)')
8289      &          'EVTRES: inonsistent mass-corr.',AM1,AM2
8290 C              GOTO 9999
8291                GOTO 1
8292             ENDIF
8293             PHKK(5,I)    = SQRT(AM1)
8294             PHKK(5,IMMX) = SQRT(AM2)
8295             IDRES(I)     = IDRES(I)/100
8296             IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8297      &          (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8298                WRITE(LOUT,'(1X,A,4G10.3)')
8299      &          'EVTRES: inconsistent chain-masses',
8300      &          PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8301                GOTO 9999
8302             ENDIF
8303          ENDIF
8304     1 CONTINUE
8305     6 CONTINUE
8306       RETURN
8307
8308  9999 CONTINUE
8309       IREJ = 1
8310       RETURN
8311       END
8312
8313 *$ CREATE DT_GETSPT.FOR
8314 *COPY DT_GETSPT
8315 *
8316 *===getspt=============================================================*
8317 *
8318       SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8319      &                  PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8320      &                  AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8321
8322 ************************************************************************
8323 * This version dated 12.12.94 is written by S. Roesler                 *
8324 ************************************************************************
8325
8326       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8327       SAVE
8328       PARAMETER ( LINP = 10 ,
8329      &            LOUT = 6 ,
8330      &            LDAT = 9 )
8331       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8332
8333 * various options for treatment of partons (DTUNUC 1.x)
8334 * (chain recombination, Cronin,..)
8335       LOGICAL LCO2CR,LINTPT
8336       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8337      &                LCO2CR,LINTPT
8338 * flags for input different options
8339       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8340       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8341      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8342 * flags for diffractive interactions (DTUNUC 1.x)
8343       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8344
8345       DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8346      &          PT2(4),PT2I(4),P1(4),P2(4),
8347      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8348      &          PTOTI(4),PTOTF(4),DIFF(4)
8349
8350       IC   = 0
8351       IREJ = 0
8352 C     B33P = 4.0D0
8353 C     B33T = 4.0D0
8354 C     IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8355 C     IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8356       REDU = 1.0D0
8357 C     B33P = 3.5D0
8358 C     B33T = 3.5D0
8359       B33P = 4.0D0
8360       B33T = 4.0D0
8361       IF (IDIFF.NE.0) THEN
8362          B33P = 16.0D0
8363          B33T = 16.0D0
8364       ENDIF
8365
8366       DO 1 I=1,4
8367          PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8368          PP1(I)   = PP1I(I)
8369          PP2(I)   = PP2I(I)
8370          PT1(I)   = PT1I(I)
8371          PT2(I)   = PT2I(I)
8372     1 CONTINUE
8373 * get initial chain masses
8374       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8375      &                               +(PP1(3)+PT1(3))**2)
8376       ECH   = PP1(4)+PT1(4)
8377       AM1   = (ECH+PTOCH)*(ECH-PTOCH)
8378       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8379      &                               +(PP2(3)+PT2(3))**2)
8380       ECH   = PP2(4)+PT2(4)
8381       AM2   = (ECH+PTOCH)*(ECH-PTOCH)
8382       IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8383          IF (IOULEV(1).GT.0)
8384      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8385      &                              AM1,AM2
8386          GOTO 9999
8387       ENDIF
8388       AM1  = SQRT(AM1)
8389       AM2  = SQRT(AM2)
8390       AM1N = ZERO
8391       AM2N = ZERO
8392
8393       MODE = 0
8394 C      IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8395 C        MODE = 0
8396 C      ELSE
8397 C         MODE = 1
8398 C         IF (AM1.LT.0.6) THEN
8399 C            B33P = 10.0D0
8400 C         ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8401 CC           B33P = 4.0D0
8402 C         ENDIF
8403 C         IF (AM2.LT.0.6) THEN
8404 C            B33T = 10.0D0
8405 C         ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8406 CC           B33T = 4.0D0
8407 C         ENDIF
8408 C      ENDIF
8409
8410 * check chain masses for very low mass chains
8411 C     CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8412 C    &            AM1,DUM,-IDCH1,IREJ1)
8413 C     CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8414 C    &            AM2,DUM,-IDCH2,IREJ2)
8415 C     IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8416 C        B33P = 20.0D0
8417 C        B33T = 20.0D0
8418 C     ENDIF
8419
8420       JMSHL = IMSHL
8421
8422     2 CONTINUE
8423       IC = IC+1
8424       IF (MOD(IC,15).EQ.0) B33P  = 2.0D0*B33P
8425       IF (MOD(IC,15).EQ.0) B33T  = 2.0D0*B33T
8426       IF (MOD(IC,18).EQ.0) REDU  = 0.0D0
8427 C     IF (MOD(IC,19).EQ.0) JMSHL = 0
8428       IF (MOD(IC,20).EQ.0) GOTO 7
8429 C        WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8430 C        RETURN
8431 C        GOTO 9999
8432 C     ENDIF
8433
8434 * get transverse momentum
8435       IF (LINTPT) THEN
8436          ES   = -2.0D0/(B33P**2)
8437      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8438          HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8439          HPSP = HPSP*REDU
8440          ES   = -2.0D0/(B33T**2)
8441      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8442          HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8443          HPST = HPST*REDU
8444       ELSE
8445          HPSP = ZERO
8446          HPST = ZERO
8447       ENDIF
8448       CALL DT_DSFECF(SFE1,CFE1)
8449       CALL DT_DSFECF(SFE2,CFE2)
8450       IF (MODE.EQ.0) THEN
8451          PP1(1) = PP1I(1)+HPSP*CFE1
8452          PP1(2) = PP1I(2)+HPSP*SFE1
8453          PP2(1) = PP2I(1)-HPSP*CFE1
8454          PP2(2) = PP2I(2)-HPSP*SFE1
8455          PT1(1) = PT1I(1)+HPST*CFE2
8456          PT1(2) = PT1I(2)+HPST*SFE2
8457          PT2(1) = PT2I(1)-HPST*CFE2
8458          PT2(2) = PT2I(2)-HPST*SFE2
8459       ELSE
8460          PP1(1) = PP1I(1)+HPSP*CFE1
8461          PP1(2) = PP1I(2)+HPSP*SFE1
8462          PT1(1) = PT1I(1)-HPSP*CFE1
8463          PT1(2) = PT1I(2)-HPSP*SFE1
8464          PP2(1) = PP2I(1)+HPST*CFE2
8465          PP2(2) = PP2I(2)+HPST*SFE2
8466          PT2(1) = PT2I(1)-HPST*CFE2
8467          PT2(2) = PT2I(2)-HPST*SFE2
8468       ENDIF
8469
8470 * put partons on mass shell
8471       XMP1 = 0.0D0
8472       XMT1 = 0.0D0
8473       IF (JMSHL.EQ.1) THEN
8474          XMP1 = PYMASS(IFPR1)
8475          XMT1 = PYMASS(IFTA1)
8476       ENDIF
8477       CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8478       IF (IREJ1.NE.0) GOTO 2
8479       DO 3 I=1,4
8480          PTOTF(I) = P1(I)+P2(I)
8481          PP1(I)   = P1(I)
8482          PT1(I)   = P2(I)
8483     3 CONTINUE
8484       XMP2 = 0.0D0
8485       XMT2 = 0.0D0
8486       IF (JMSHL.EQ.1) THEN
8487          XMP2 = PYMASS(IFPR2)
8488          XMT2 = PYMASS(IFTA2)
8489       ENDIF
8490       CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8491       IF (IREJ1.NE.0) GOTO 2
8492       DO 4 I=1,4
8493          PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8494          PP2(I)   = P1(I)
8495          PT2(I)   = P2(I)
8496     4 CONTINUE
8497
8498 * check consistency
8499       DO 5 I=1,4
8500          DIFF(I) = PTOTI(I)-PTOTF(I)
8501     5 CONTINUE
8502       IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8503      &    (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8504          WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8505          GOTO 9999
8506       ENDIF
8507       PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8508       AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8509       PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8510       AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8511       PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8512       AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8513       PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8514       AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8515       IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8516      &    (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8517      &                                                           THEN
8518          WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8519      &     'GETSPT: inconsistent masses',
8520      &     AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8521 * sr 22.11.00: commented. It should only have inconsistent masses for
8522 * ultrahigh energies due to rounding problems
8523 C        GOTO 9999
8524       ENDIF
8525
8526 * get chain masses
8527       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8528      &                               +(PP1(3)+PT1(3))**2)
8529       ECH   = PP1(4)+PT1(4)
8530       AM1N  = (ECH+PTOCH)*(ECH-PTOCH)
8531       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8532      &                               +(PP2(3)+PT2(3))**2)
8533       ECH   = PP2(4)+PT2(4)
8534       AM2N  = (ECH+PTOCH)*(ECH-PTOCH)
8535       IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
8536          IF (IOULEV(1).GT.0)
8537      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
8538      &                              AM1N,AM2N
8539          GOTO 2
8540       ENDIF
8541       AM1N = SQRT(AM1N)
8542       AM2N = SQRT(AM2N)
8543
8544 * check chain masses for very low mass chains
8545       CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8546      &            AM1N,DUM,-IDCH1,IREJ1)
8547       IF (IREJ1.NE.0) GOTO 2
8548       CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8549      &            AM2N,DUM,-IDCH2,IREJ2)
8550       IF (IREJ2.NE.0) GOTO 2
8551
8552     7 CONTINUE
8553       IF (AM1N.GT.ZERO) THEN
8554          AM1 = AM1N
8555          AM2 = AM2N
8556       ENDIF
8557       DO 6 I=1,4
8558          PP1I(I)   = PP1(I)
8559          PP2I(I)   = PP2(I)
8560          PT1I(I)   = PT1(I)
8561          PT2I(I)   = PT2(I)
8562     6 CONTINUE
8563
8564       RETURN
8565
8566  9999 CONTINUE
8567       IREJ = 1
8568       RETURN
8569       END
8570
8571 *$ CREATE DT_SAPTRE.FOR
8572 *COPY DT_SAPTRE
8573 *
8574 *===saptre=============================================================*
8575 *
8576       SUBROUTINE DT_SAPTRE(IDX1,IDX2)
8577
8578 ************************************************************************
8579 * p-t sampling for two-resonance systems. ("BAMJET-like" method)       *
8580 *        IDX1,IDX2       indices of resonances ("chains") in DTEVT1    *
8581 * Adopted from the original SAPTRE written by J. Ranft.                *
8582 * This version dated 18.01.95 is written by S. Roesler                 *
8583 ************************************************************************
8584
8585       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8586       SAVE
8587       PARAMETER ( LINP = 10 ,
8588      &            LOUT = 6 ,
8589      &            LDAT = 9 )
8590       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8591
8592 * event history
8593       PARAMETER (NMXHKK=200000)
8594       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8595      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8596      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8597 * extended event history
8598       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8599      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8600      &                IHIST(2,NMXHKK)
8601 * flags for input different options
8602       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8603       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8604      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8605
8606       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
8607
8608       DATA B3 /4.0D0/
8609
8610       ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
8611       ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
8612       ESMAX  = MIN(ESMAX1,ESMAX2)
8613       IF (ESMAX.LE.0.05D0) RETURN
8614
8615       HMA    = PHKK(5,IDX1)
8616       DO 1 K=1,4
8617          PA1(K) = PHKK(K,IDX1)
8618          PA2(K) = PHKK(K,IDX2)
8619     1 CONTINUE
8620
8621       IF (LEMCCK) THEN
8622          CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
8623          CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
8624       ENDIF
8625
8626       EXEB   = 0.0D0
8627       IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
8628       BEXP   = HMA*(1.0D0-EXEB)/B3
8629       AXEXP  = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
8630       WA     = AXEXP/(BEXP+AXEXP)
8631       XAB    = DT_RNDM(WA)
8632    10 CONTINUE
8633 * ES is the transverse kinetic energy
8634       IF (XAB.LT.WA)THEN
8635         X  = DT_RNDM(WA)
8636         Y  = DT_RNDM(WA)
8637         ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
8638       ELSE
8639         X  = DT_RNDM(Y)
8640         ES = ABS(-LOG(X+TINY7)/B3)
8641       ENDIF
8642       IF (ES.GT.ESMAX) GOTO 10
8643       ES  = ES+HMA
8644 * transverse momentum
8645       HPS = SQRT((ES-HMA)*(ES+HMA))
8646
8647       CALL DT_DSFECF(SFE,CFE)
8648       HPX = HPS*CFE
8649       HPY = HPS*SFE
8650       PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
8651       PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
8652       IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
8653
8654 C     PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
8655 C     PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
8656       PA1(1) = PA1(1)+HPX
8657       PA1(2) = PA1(2)+HPY
8658       PA2(1) = PA2(1)-HPX
8659       PA2(2) = PA2(2)-HPY
8660
8661 * put resonances on mass-shell again
8662       XM1 = PHKK(5,IDX1)
8663       XM2 = PHKK(5,IDX2)
8664       CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
8665       IF (IREJ1.NE.0) RETURN
8666
8667       IF (LEMCCK) THEN
8668          CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
8669          CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
8670          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
8671          IF (IREJ1.NE.0) RETURN
8672       ENDIF
8673
8674       DO 2 K=1,4
8675          PHKK(K,IDX1) = P1(K)
8676          PHKK(K,IDX2) = P2(K)
8677     2 CONTINUE
8678
8679       RETURN
8680       END
8681
8682 *$ CREATE DT_CRONIN.FOR
8683 *COPY DT_CRONIN
8684 *
8685 *===cronin=============================================================*
8686 *
8687       SUBROUTINE DT_CRONIN(INCL)
8688
8689 ************************************************************************
8690 * Cronin-Effect. Multiple scattering of partons at chain ends.         *
8691 *             INCL = 1     multiple sc. in projectile                  *
8692 *                  = 2     multiple sc. in target                      *
8693 * This version dated 05.01.96 is written by S. Roesler.                *
8694 ************************************************************************
8695
8696       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8697       SAVE
8698       PARAMETER ( LINP = 10 ,
8699      &            LOUT = 6 ,
8700      &            LDAT = 9 )
8701       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8702
8703 * event history
8704       PARAMETER (NMXHKK=200000)
8705       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8706      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8707      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8708 * extended event history
8709       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8710      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8711      &                IHIST(2,NMXHKK)
8712 * rejection counter
8713       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8714      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8715      &                IREXCI(3),IRDIFF(2),IRINC
8716 * Glauber formalism: collision properties
8717       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8718      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8719
8720       DIMENSION R(3),PIN(4),POUT(4),DEV(4)
8721
8722       DO 1 K=1,4
8723          DEV(K) = ZERO
8724     1 CONTINUE
8725
8726       DO 2 I=NPOINT(2),NHKK
8727          IF (ISTHKK(I).LT.0) THEN
8728 * get z-position of the chain
8729             R(1) = VHKK(1,I)*1.0D12
8730             IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
8731             R(2) = VHKK(2,I)*1.0D12
8732             IDXNU = JMOHKK(1,I)
8733             IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
8734      &                             IDXNU = JMOHKK(1,I-1)
8735             IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
8736      &                             IDXNU = JMOHKK(1,I+1)
8737             R(3) = VHKK(3,IDXNU)*1.0D12
8738 * position of target parton the chain is connected to
8739             DO 3 K=1,4
8740                PIN(K) = PHKK(K,I)
8741     3       CONTINUE
8742 * multiple scattering of parton with DTEVT1-index I
8743             CALL DT_CROMSC(PIN,R,POUT,INCL)
8744 **testprint
8745 C           IF (NEVHKK.EQ.5) THEN
8746 C              AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
8747 C              AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
8748 C              AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
8749 C              AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
8750 C              WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
8751 C              WRITE(6,'(A,4E15.5)')'PIN:       ',PIN
8752 C              WRITE(6,'(A,4E15.5)')'POUT:      ',POUT
8753 C           ENDIF
8754 **
8755 * increase accumulator by energy-momentum difference
8756             DO 4 K=1,4
8757                DEV(K)    = DEV(K)+POUT(K)-PIN(K)
8758                PHKK(K,I) = POUT(K)
8759     4       CONTINUE
8760             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8761      &                           PHKK(2,I)**2-PHKK(3,I)**2))
8762          ENDIF
8763     2 CONTINUE
8764
8765 * dump accumulator to momenta of valence partons
8766       NVAL = 0
8767       ETOT = 0.0D0
8768       DO 5 I=NPOINT(2),NHKK
8769          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8770             NVAL = NVAL+1
8771             ETOT = ETOT+PHKK(4,I)
8772          ENDIF
8773     5 CONTINUE
8774 C     WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
8775  1000 FORMAT(1X,'CRONIN :  number of val. partons ',I4,/,
8776      &       9X,4E12.4)
8777       DO 6 I=NPOINT(2),NHKK
8778          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8779             E = PHKK(4,I)
8780             DO 7 K=1,4
8781 C              PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
8782                PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
8783     7       CONTINUE
8784             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8785      &                           PHKK(2,I)**2-PHKK(3,I)**2))
8786          ENDIF
8787     6 CONTINUE
8788
8789       RETURN
8790       END
8791
8792 *$ CREATE DT_CROMSC.FOR
8793 *COPY DT_CROMSC
8794 *
8795 *===cromsc=============================================================*
8796 *
8797       SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
8798
8799 ************************************************************************
8800 * Cronin-Effect. Multiple scattering of one parton passing through     *
8801 * nuclear matter.                                                      *
8802 *            PIN(4)       input 4-momentum of parton                   *
8803 *            POUT(4)      4-momentum of parton after mult. scatt.      *
8804 *            R(3)         spatial position of parton in target nucleus *
8805 *            INCL = 1     multiple sc. in projectile                   *
8806 *                 = 2     multiple sc. in target                       *
8807 * This is a revised version of the original version written by J. Ranft*
8808 * This version dated 17.01.95 is written by S. Roesler.                *
8809 ************************************************************************
8810
8811       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8812       SAVE
8813       PARAMETER ( LINP = 10 ,
8814      &            LOUT = 6 ,
8815      &            LDAT = 9 )
8816       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8817
8818       LOGICAL LSTART
8819
8820 * rejection counter
8821       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8822      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8823      &                IREXCI(3),IRDIFF(2),IRINC
8824 * Glauber formalism: collision properties
8825       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8826      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8827 * various options for treatment of partons (DTUNUC 1.x)
8828 * (chain recombination, Cronin,..)
8829       LOGICAL LCO2CR,LINTPT
8830       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8831      &                LCO2CR,LINTPT
8832
8833       DIMENSION PIN(4),POUT(4),R(3)
8834
8835       DATA LSTART /.TRUE./
8836
8837       IRCRON(1) = IRCRON(1)+1
8838
8839       IF (LSTART) THEN
8840          WRITE(LOUT,1000) CRONCO
8841  1000    FORMAT(/,1X,'CROMSC:  multiple scattering of chain ends',
8842      &          ' treated',/,10X,'with parameter CRONCO = ',F5.2)
8843          LSTART = .FALSE.
8844       ENDIF
8845
8846       NCBACK = 0
8847       RNCL   = RPROJ
8848       IF (INCL.EQ.2) RNCL = RTARG
8849
8850 * Lorentz-transformation into Lab.
8851       MODE = -(INCL+1)
8852       CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
8853
8854       PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
8855       IF (PTOT.LE.8.0D0) GOTO 9997
8856
8857 * direction cosines of parton before mult. scattering
8858       COSX = PIN(1)/PTOT
8859       COSY = PIN(2)/PTOT
8860       COSZ = PZ/PTOT
8861
8862       RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
8863       IF (RTESQ.GE.-TINY3) GOTO 9999
8864
8865 * calculate distance (DIST) from R to surface of nucleus (radius RNCL)
8866 * in the direction of particle motion
8867
8868       A    = COSX*R(1)+COSY*R(2)+COSZ*R(3)
8869       TMP  = A**2-RTESQ
8870       IF (TMP.LT.ZERO) GOTO 9998
8871       DIST = -A+SQRT(TMP)
8872
8873 * multiple scattering angle
8874       THETO = CRONCO*SQRT(DIST)/PTOT
8875       IF (THETO.GT.0.1D0) THETO=0.1D0
8876
8877     1 CONTINUE
8878 * Gaussian sampling of spatial angle
8879       CALL DT_RANNOR(R1,R2)
8880       THETA = ABS(R1*THETO)
8881       IF (THETA.GT.0.3D0) GOTO 9997
8882       CALL DT_DSFECF(SFE,CFE)
8883       COSTH = COS(THETA)
8884       SINTH = SIN(THETA)
8885
8886 * new direction cosines
8887       CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
8888      &                               COSXN,COSYN,COSZN)
8889
8890       POUT(1) = COSXN*PTOT
8891       POUT(2) = COSYN*PTOT
8892       PZ      = COSZN*PTOT
8893 * Lorentz-transformation into nucl.-nucl. cms
8894       MODE = INCL+1
8895       CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
8896
8897 C     IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
8898 C     IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
8899       IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
8900          THETO = THETO/2.0D0
8901          NCBACK = NCBACK+1
8902          IF (MOD(NCBACK,200).EQ.0) THEN
8903             WRITE(LOUT,1001) THETO,PIN,POUT
8904  1001       FORMAT(1X,'CROMSC: inconsistent scattering angle ',
8905      &             E12.4,/,1X,'        PIN :',4E12.4,/,
8906      &             1X,'       POUT:',4E12.4)
8907             GOTO 9997
8908          ENDIF
8909          GOTO 1
8910       ENDIF
8911
8912       RETURN
8913
8914  9997 IRCRON(2) = IRCRON(2)+1
8915       GOTO 9999
8916  9998 IRCRON(3) = IRCRON(3)+1
8917
8918  9999 CONTINUE
8919       DO 100 K=1,4
8920          POUT(K) = PIN(K)
8921   100 CONTINUE
8922       RETURN
8923       END
8924
8925 *$ CREATE DT_COM2CR.FOR
8926 *COPY DT_COM2CR
8927 *
8928 *===com2sr=============================================================*
8929 *
8930       SUBROUTINE DT_COM2CR
8931
8932 ************************************************************************
8933 * COMbine q-aq chains to Color Ropes (qq-aqaq).                        *
8934 *        CUTOF      parameter determining minimum number of not        *
8935 *                   combined q-aq chains                               *
8936 * This subroutine replaces KKEVCC etc.                                 *
8937 * This version dated 11.01.95 is written by S. Roesler.                *
8938 ************************************************************************
8939
8940       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8941       SAVE
8942       PARAMETER ( LINP = 10 ,
8943      &            LOUT = 6 ,
8944      &            LDAT = 9 )
8945
8946 * event history
8947       PARAMETER (NMXHKK=200000)
8948       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8949      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8950      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8951 * extended event history
8952       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8953      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8954      &                IHIST(2,NMXHKK)
8955 * statistics
8956       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
8957      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
8958      &                ICEVTG(8,0:30)
8959 * various options for treatment of partons (DTUNUC 1.x)
8960 * (chain recombination, Cronin,..)
8961       LOGICAL LCO2CR,LINTPT
8962       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8963      &                LCO2CR,LINTPT
8964
8965       DIMENSION IDXQA(248),IDXAQ(248)
8966
8967       ICCHAI(1,9) = ICCHAI(1,9)+1
8968       NQA = 0
8969       NAQ = 0
8970 * scan DTEVT1 for q-aq, aq-q chains
8971       DO 10 I=NPOINT(3),NHKK
8972 * skip "chains" which are resonances
8973          IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
8974             MO1 = JMOHKK(1,I)
8975             MO2 = JMOHKK(2,I)
8976             IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
8977 * q-aq, aq-q chain found, keep index
8978                IF (IDHKK(MO1).GT.0) THEN
8979                   NQA = NQA+1
8980                   IDXQA(NQA) = I
8981                ELSE
8982                   NAQ = NAQ+1
8983                   IDXAQ(NAQ) = I
8984                ENDIF
8985             ENDIF
8986          ENDIF
8987    10 CONTINUE
8988
8989 * minimum number of q-aq chains requested for the same projectile/
8990 * target
8991       NCHMIN = IDT_NPOISS(CUTOF)
8992
8993 * combine q-aq chains of the same projectile
8994       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
8995 * combine q-aq chains of the same target
8996       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
8997 * combine aq-q chains of the same projectile
8998       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
8999 * combine aq-q chains of the same target
9000       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
9001
9002       RETURN
9003       END
9004
9005 *$ CREATE DT_SCN4CR.FOR
9006 *COPY DT_SCN4CR
9007 *
9008 *===scn4cr=============================================================*
9009 *
9010       SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9011
9012 ************************************************************************
9013 * SCan q-aq chains for Color Ropes.                                    *
9014 * This version dated 11.01.95 is written by S. Roesler.                *
9015 ************************************************************************
9016
9017       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9018       SAVE
9019       PARAMETER ( LINP = 10 ,
9020      &            LOUT = 6 ,
9021      &            LDAT = 9 )
9022
9023 * event history
9024       PARAMETER (NMXHKK=200000)
9025       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9026      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9027      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9028 * extended event history
9029       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9030      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9031      &                IHIST(2,NMXHKK)
9032
9033       DIMENSION IDXCH(248),IDXJN(248)
9034
9035       DO 1 I=1,NCH
9036          IF (IDXCH(I).GT.0) THEN
9037             NJOIN = 1
9038             IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9039             IDXJN(NJOIN) = I
9040             IF (I.LT.NCH) THEN
9041                DO 2 J=I+1,NCH
9042                   IF (IDXCH(J).GT.0) THEN
9043                      IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9044                      IF (IDXMO.EQ.IDXMO1) THEN
9045                         NJOIN = NJOIN+1
9046                         IDXJN(NJOIN) = J
9047                      ENDIF
9048                   ENDIF
9049     2          CONTINUE
9050             ENDIF
9051             IF (NJOIN.GE.NCHMIN+2) THEN
9052                NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9053                DO 3 J=1,2*NJ,2
9054                   CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9055                   IF (IREJ1.NE.0) GOTO 3
9056                   IDXCH(IDXJN(J))   = 0
9057                   IDXCH(IDXJN(J+1)) = 0
9058     3          CONTINUE
9059             ENDIF
9060          ENDIF
9061     1 CONTINUE
9062
9063       RETURN
9064       END
9065
9066 *$ CREATE DT_JOIN.FOR
9067 *COPY DT_JOIN
9068 *
9069 *===join===============================================================*
9070 *
9071       SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9072
9073 ************************************************************************
9074 * This subroutine joins two q-aq chains to one qq-aqaq chain.          *
9075 *     IDX1, IDX2       DTEVT1 indices of chains to be joined           *
9076 * This version dated 11.01.95 is written by S. Roesler.                *
9077 ************************************************************************
9078
9079       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9080       SAVE
9081       PARAMETER ( LINP = 10 ,
9082      &            LOUT = 6 ,
9083      &            LDAT = 9 )
9084
9085 * event history
9086       PARAMETER (NMXHKK=200000)
9087       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9088      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9089      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9090 * extended event history
9091       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9092      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9093      &                IHIST(2,NMXHKK)
9094 * flags for input different options
9095       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9096       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9097      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9098 * statistics
9099       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9100      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9101      &                ICEVTG(8,0:30)
9102
9103       DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9104
9105       IREJ   = 0
9106
9107       IDX(1) = IDX1
9108       IDX(2) = IDX2
9109       DO 1 I=1,2
9110          DO 2 J=1,2
9111             MO(I,J) = JMOHKK(J,IDX(I))
9112             ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9113     2    CONTINUE
9114     1 CONTINUE
9115
9116 * check consistency
9117       IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9118      &    (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9119      &    ((ID(1,1)*ID(2,1)).LT.0).OR.
9120      &    ((ID(1,2)*ID(2,2)).LT.0)) THEN
9121          WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9122      &                    MO(2,2)
9123  1000    FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9124      &             2I5,' chain ',I4,':',2I5)
9125       ENDIF
9126
9127 * join chains
9128       DO 3 K=1,4
9129          PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9130          PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9131     3 CONTINUE
9132       IF1  = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9133       IF2  = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9134       IST1 = ISTHKK(MO(1,1))
9135       IST2 = ISTHKK(MO(1,2))
9136
9137 * put partons again on mass shell
9138       XM1 = 0.0D0
9139       XM2 = 0.0D0
9140       IF (IMSHL.EQ.1) THEN
9141          XM1 = PYMASS(IF1)
9142          XM2 = PYMASS(IF2)
9143       ENDIF
9144       CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9145       IF (IREJ1.NE.0) GOTO 9999
9146       DO 4 I=1,4
9147          PP(I) = P1(I)
9148          PT(I) = P2(I)
9149     4 CONTINUE
9150
9151 * store new partons in DTEVT1
9152       CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9153      &                                                       0,0,0)
9154       CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9155      &                                                       0,0,0)
9156       DO 5 K=1,4
9157          PCH(K) = PP(K)+PT(K)
9158     5 CONTINUE
9159
9160 * check new chain for lower mass limit
9161       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9162          AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9163          CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9164      &               AMCH,AMCHN,3,IREJ1)
9165          IF (IREJ1.NE.0) THEN
9166             NHKK = NHKK-2
9167             GOTO 9999
9168          ENDIF
9169       ENDIF
9170
9171       ICCHAI(2,9) = ICCHAI(2,9)+1
9172 * store new chain in DTEVT1
9173       KCH = 191
9174       CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9175       IDHKK(IDX(1)) = 22222
9176       IDHKK(IDX(2)) = 22222
9177 * special treatment for space-time coordinates
9178       DO 6 K=1,4
9179          VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9180          WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9181     6 CONTINUE
9182       RETURN
9183
9184  9999 CONTINUE
9185       IREJ = 1
9186       RETURN
9187       END
9188
9189 *$ CREATE DT_XSGLAU.FOR
9190 *COPY DT_XSGLAU
9191 *
9192 *===xsglau=============================================================*
9193 *
9194       SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9195
9196 ************************************************************************
9197 * Total, elastic, quasi-elastic, inelastic cross sections according to *
9198 * Glauber's approach.                                                  *
9199 *  NA / NB     mass numbers of proj./target nuclei                     *
9200 *  JJPROJ      bamjet-index of projectile (=1 in case of proj.nucleus) *
9201 *  XI,Q2I,ECMI kinematical variables x, Q^2, E_cm                      *
9202 *  IE,IQ       indices of energy and virtuality (the latter for gamma  *
9203 *              projectiles only)                                       *
9204 *  NIDX        index of projectile/target nucleus                      *
9205 * This version dated 17.3.98  is written by S. Roesler                 *
9206 ************************************************************************
9207
9208       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9209       SAVE
9210       PARAMETER ( LINP = 10 ,
9211      &            LOUT = 6 ,
9212      &            LDAT = 9 )
9213
9214       COMPLEX*16 CZERO,CONE,CTWO
9215       CHARACTER*12 CFILE
9216       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9217      &           ONETHI=ONE/THREE,TINY25=1.0D-25)
9218       PARAMETER (TWOPI  = 6.283185307179586454D+00,
9219      &           PI     = TWOPI/TWO,
9220      &           GEV2MB = 0.38938D0,
9221      &           GEV2FM = 0.1972D0,
9222      &           ALPHEM = ONE/137.0D0,
9223 * proton mass
9224      &           AMP    = 0.938D0,
9225      &           AMP2   = AMP**2,
9226 * approx. nucleon radius
9227      &           RNUCLE = 1.12D0)
9228
9229 * particle properties (BAMJET index convention)
9230       CHARACTER*8  ANAME
9231       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9232      &                IICH(210),IIBAR(210),K1(210),K2(210)
9233       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9234       PARAMETER ( MAXNCL = 260,
9235      &            MAXVQU = MAXNCL,
9236      &            MAXSQU = 20*MAXVQU,
9237      &            MAXINT = MAXVQU+MAXSQU)
9238 * Glauber formalism: parameters
9239       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9240      &                BMAX(NCOMPX),BSTEP(NCOMPX),
9241      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9242      &                NSITEB,NSTATB
9243 * Glauber formalism: cross sections
9244       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9245      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9246      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9247      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9248      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9249      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9250      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9251      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9252      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9253      &                BSLOPE,NEBINI,NQBINI
9254 * Glauber formalism: flags and parameters for statistics
9255       LOGICAL LPROD
9256       CHARACTER*8 CGLB
9257       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9258 * nucleon-nucleon event-generator
9259       CHARACTER*8 CMODEL
9260       LOGICAL LPHOIN
9261       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9262 * VDM parameter for photon-nucleus interactions
9263       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9264 * parameters for hA-diffraction
9265       COMMON /DTDIHA/ DIBETA,DIALPH
9266
9267       COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9268      &           OMPP11,OMPP12,OMPP21,OMPP22,
9269      &           DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9270      &           PPTMP1,PPTMP2
9271       COMPLEX*16 C,CA,CI
9272       DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9273      &          COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9274      &          BPROD(KSITEB)
9275
9276       PARAMETER (NPOINT=16)
9277       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9278
9279       LOGICAL LFIRST,LOPEN
9280       DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9281
9282       NTARG = ABS(NIDX)
9283 * for quasi-elastic neutrino scattering set projectile to proton
9284 * it should not have an effect since the whole Glauber-formalism is
9285 * not needed for these interactions..
9286       IF (MCGENE.EQ.4) THEN
9287          IJPROJ = 1
9288       ELSE
9289          IJPROJ = JJPROJ
9290       ENDIF
9291
9292       IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9293          I = INDEX(CGLB,' ')
9294          IF (I.EQ.0) THEN
9295             CFILE = CGLB//'.glb'
9296             OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9297          ELSEIF (I.GT.1) THEN
9298             CFILE = CGLB(1:I-1)//'.glb'
9299             OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9300          ELSE
9301             STOP 'XSGLAU 1'
9302          ENDIF
9303          LOPEN = .TRUE.
9304       ENDIF
9305
9306       CZERO  = DCMPLX(ZERO,ZERO)
9307       CONE   = DCMPLX(ONE,ZERO)
9308       CTWO   = DCMPLX(TWO,ZERO)
9309       NEBINI = IE
9310       NQBINI = IQ
9311
9312 * re-define kinematics
9313       S  = ECMI**2
9314       Q2 = Q2I
9315       X  = XI
9316 *  g(Q2=0)-A, h-A, A-A scattering
9317       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9318          Q2 = 0.0001D0
9319          X  = Q2/(S+Q2-AMP2)
9320 *  g(Q2>0)-A scattering
9321       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9322          X  = Q2/(S+Q2-AMP2)
9323       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9324          Q2 = (S-AMP2)*X/(ONE-X)
9325       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9326          S  = Q2*(ONE-X)/X+AMP2
9327       ELSE
9328          WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9329          STOP
9330       ENDIF
9331       ECMNN(IE) = SQRT(S)
9332       Q2G(IQ)   = Q2
9333       XNU = (S+Q2-AMP2)/(TWO*AMP)
9334
9335 * parameters determining statistics in evaluating Glauber-xsection
9336       NSTATB = JSTATB
9337       NSITEB = JBINSB
9338       IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9339
9340 * set up interaction geometry (common /DTGLAM/)
9341 *  projectile/target radii
9342       RPRNCL = DT_RNCLUS(NA)
9343       RTANCL = DT_RNCLUS(NB)
9344       IF (IJPROJ.EQ.7) THEN
9345          RASH(1) = ZERO
9346          RBSH(NTARG) = RTANCL
9347          BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9348       ELSE
9349          IF (NIDX.LE.-1) THEN
9350             RASH(1)     = RPRNCL
9351             RBSH(NTARG) = RTANCL
9352             BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9353          ELSE
9354             RASH(NTARG) = RPRNCL
9355             RBSH(1)     = RTANCL
9356             BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9357          ENDIF
9358       ENDIF
9359 *  maximum impact-parameter
9360       BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9361
9362 * slope, rho ( Re(f(0))/Im(f(0)) )
9363       IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9364          IF (MCGENE.EQ.2) THEN
9365             ZERO1 = ZERO
9366             CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9367      &                                                   BSLOPE,0)
9368          ELSE
9369             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9370          ENDIF
9371          IF (ECMNN(IE).LE.3.0D0) THEN
9372             ROSH = -0.43D0
9373          ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9374             ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9375          ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9376             ROSH = 0.1D0
9377          ENDIF
9378       ELSEIF (IJPROJ.EQ.7) THEN
9379          ROSH = 0.1D0
9380       ELSE
9381          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9382          ROSH   = 0.01D0
9383       ENDIF
9384
9385 * projectile-nucleon xsection (in fm)
9386       IF (IJPROJ.EQ.7) THEN
9387          SIGSH = DT_SIGVP(X,Q2)/10.0D0
9388       ELSE
9389          ELAB  = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9390          PLAB  = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9391 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9392          DUMZER = ZERO
9393          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9394          SIGSH = SIGSH/10.0D0
9395       ENDIF
9396
9397 * parameters for projectile diffraction (hA scattering only)
9398       IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9399      &                               .AND.(DIBETA.GE.ZERO)) THEN
9400          ZERO1 = ZERO
9401          CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9402 C        DIBETA = SDIF1/STOT
9403          DIBETA = 0.2D0
9404          DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9405          IF (DIBETA.LE.ZERO) THEN
9406             ALPGAM = ONE
9407          ELSE
9408             ALPGAM = DIALPH/DIGAMM
9409          ENDIF
9410          FACDI1 = ONE-ALPGAM
9411          FACDI2 = ONE+ALPGAM
9412          FACDI  = SQRT(FACDI1*FACDI2)
9413          WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9414       ELSE
9415          DIBETA = -1.0D0
9416          DIALPH = ZERO
9417          DIGAMM = ZERO
9418          FACDI1 = ZERO
9419          FACDI2 = 2.0D0
9420          FACDI  = ZERO
9421       ENDIF
9422
9423 * initializations
9424       DO 10 I=1,NSITEB
9425          BSITE( 0,IQ,NTARG,I) = ZERO
9426          BSITE(IE,IQ,NTARG,I) = ZERO
9427          BPROD(I) = ZERO
9428    10 CONTINUE
9429       STOT  = ZERO
9430       STOT2 = ZERO
9431       SELA  = ZERO
9432       SELA2 = ZERO
9433       SQEP  = ZERO
9434       SQEP2 = ZERO
9435       SQET  = ZERO
9436       SQET2 = ZERO
9437       SQE2  = ZERO
9438       SQE22 = ZERO
9439       SPRO  = ZERO
9440       SPRO2 = ZERO
9441       SDEL  = ZERO
9442       SDEL2 = ZERO
9443       SDQE  = ZERO
9444       SDQE2 = ZERO
9445       FACN   = ONE/DBLE(NSTATB)
9446
9447       IPNT = 0
9448       RPNT = ZERO
9449
9450 *  initialize Gauss-integration for photon-proj.
9451       JPOINT = 1
9452       IF (IJPROJ.EQ.7) THEN
9453          IF (INTRGE(1).EQ.1) THEN
9454             AMLO2 = (3.0D0*AAM(13))**2
9455          ELSEIF (INTRGE(1).EQ.2) THEN
9456             AMLO2 = AAM(33)**2
9457          ELSE
9458             AMLO2 = AAM(96)**2
9459          ENDIF
9460          IF (INTRGE(2).EQ.1) THEN
9461             AMHI2 = S/TWO
9462          ELSEIF (INTRGE(2).EQ.2) THEN
9463             AMHI2 = S/4.0D0
9464          ELSE
9465             AMHI2 = S
9466          ENDIF
9467          AMHI20 = (ECMNN(IE)-AMP)**2
9468          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9469          XAMLO = LOG( AMLO2+Q2 )
9470          XAMHI = LOG( AMHI2+Q2 )
9471 **PHOJET105a
9472 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9473 **PHOJET112
9474          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9475 **
9476          JPOINT = NPOINT
9477 * ratio direct/total photon-nucleon xsection
9478          CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
9479       ENDIF
9480
9481 * read pre-initialized profile-function from file
9482       IF (IOGLB.EQ.1) THEN
9483          READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
9484          IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
9485             WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
9486      &                             NA,NB,NSTATB,NSITEB
9487  1000       FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
9488      &             ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
9489      &             ' (NA,NB,NSTATB,NSITEB) ',4I10)
9490             STOP
9491          ENDIF
9492          IF (LFIRST) WRITE(LOUT,1001) CFILE
9493  1001    FORMAT(/,' XSGLAU: impact parameter distribution read from ',
9494      &          'file ',A12,/)
9495          READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
9496      &                         XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
9497      &                         XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9498          READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
9499      &                         XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
9500      &                         XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9501          NLINES = INT(DBLE(NSITEB)/7.0D0)
9502          IF (NLINES.GT.0) THEN
9503             DO 21 I=1,NLINES
9504                ISTART = 7*I-6
9505                READ(LDAT,'(7E11.4)')
9506      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9507    21       CONTINUE
9508          ENDIF
9509          ISTART = 7*NLINES+1
9510          IF (ISTART.LE.NSITEB) THEN
9511             READ(LDAT,'(7E11.4)')
9512      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9513          ENDIF
9514          LFIRST = .FALSE.
9515          GOTO 100
9516 * variable projectile/target/energy runs:
9517 * read pre-initialized profile-functions from file
9518       ELSEIF (IOGLB.EQ.100) THEN
9519          CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
9520          GOTO 100
9521       ENDIF
9522
9523 * cross sections averaged over NSTATB nucleon configurations
9524       DO 11 IS=1,NSTATB
9525 C        IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
9526          STOTN = ZERO
9527          SELAN = ZERO
9528          SQEPN = ZERO
9529          SQETN = ZERO
9530          SQE2N = ZERO
9531          SPRON = ZERO
9532          SDELN = ZERO
9533          SDQEN = ZERO
9534
9535          IF (NIDX.LE.-1) THEN
9536             CALL DT_CONUCL(COOP1,NA,RASH(1),0)
9537             CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
9538             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9539                CALL DT_CONUCL(COOP2,NA,RASH(1),0)
9540                CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
9541             ENDIF
9542          ELSE
9543             CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
9544             CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
9545             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9546                CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
9547                CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
9548             ENDIF
9549          ENDIF
9550
9551 *  integration over impact parameter B
9552          DO 12 IB=1,NSITEB-1
9553             STOTB = ZERO
9554             SELAB = ZERO
9555             SQEPB = ZERO
9556             SQETB = ZERO
9557             SQE2B = ZERO
9558             SPROB = ZERO
9559             SDIR  = ZERO
9560             SDELB = ZERO
9561             SDQEB = ZERO
9562             B     = DBLE(IB)*BSTEP(NTARG)
9563             FACB  = 10.0D0*TWOPI*B*BSTEP(NTARG)
9564
9565 *   integration over M_V^2 for photon-proj.
9566             DO 14 IM=1,JPOINT
9567                PP11(1) = CONE
9568                PP12(1) = CONE
9569                PP21(1) = CONE
9570                PP22(1) = CONE
9571                IF (IJPROJ.EQ.7) THEN
9572                   DO 13 K=2,NB
9573                      PP11(K) = CONE
9574                      PP12(K) = CONE
9575                      PP21(K) = CONE
9576                      PP22(K) = CONE
9577    13             CONTINUE
9578                ENDIF
9579                SHI  = ZERO
9580                FACM = ONE
9581                DCOH = 1.0D10
9582
9583                IF (IJPROJ.EQ.7) THEN
9584                   AMV2 = EXP(ABSZX(IM))-Q2
9585                   AMV  = SQRT(AMV2)
9586                   IF (AMV2.LT.16.0D0) THEN
9587                      R = TWO
9588                   ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
9589                      R = 10.0D0/3.0D0
9590                   ELSE
9591                      R = 11.0D0/3.0D0
9592                   ENDIF
9593 *    define M_V dependent properties of nucleon scattering amplitude
9594 *     V_M-nucleon xsection
9595                   SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
9596                   SIGMV  = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
9597 *     slope-parametrisation a la Kaidalov
9598                   BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
9599      &                           +0.25D0*LOG(S/(AMV2+Q2)))
9600 *    coherence length
9601                   IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
9602 *    integration weight factor
9603                   FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
9604      &                  R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
9605                ENDIF
9606                GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
9607                GAM = GSH
9608                IF (IJPROJ.EQ.7) THEN
9609                   RCA = GAM*SIGMV/TWOPI
9610                ELSE
9611                   RCA = GAM*SIGSH/TWOPI
9612                ENDIF
9613                FCA = -ROSH*RCA
9614                CA  = DCMPLX(RCA,FCA)
9615                CI  = CONE
9616
9617                DO 15 INA=1,NA
9618                   KK1  = 1
9619                   INT1 = 1
9620                   KK2  = 1
9621                   INT2 = 1
9622                   DO 16 INB=1,NB
9623 *    photon-projectile: check for supression by coherence length
9624                      IF (IJPROJ.EQ.7) THEN
9625                         IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
9626                            KK1  = INB
9627                            INT1 = INT1+1
9628                         ENDIF
9629                         IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
9630                            KK2  = INB
9631                            INT2 = INT2+1
9632                         ENDIF
9633                      ENDIF
9634
9635                      X11 = B+COOT1(1,INB)-COOP1(1,INA)
9636                      Y11 =   COOT1(2,INB)-COOP1(2,INA)
9637                      XY11 = GAM*(X11*X11+Y11*Y11)
9638                      IF (XY11.LE.15.0D0) THEN
9639                         C = CONE-CA*EXP(-XY11)
9640                         AR = DBLE(PP11(INT1))
9641                         AI = DIMAG(PP11(INT1))
9642                         IF (ABS(AR).LT.TINY25) AR = ZERO
9643                         IF (ABS(AI).LT.TINY25) AI = ZERO
9644                         PP11(INT1) = DCMPLX(AR,AI)
9645                         PP11(INT1) = PP11(INT1)*C
9646                         AR  = DBLE(C)
9647                         AI  = DIMAG(C)
9648                         SHI = SHI+LOG(AR*AR+AI*AI)
9649                      ENDIF
9650                      IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9651                         X12 = B+COOT2(1,INB)-COOP1(1,INA)
9652                         Y12 =   COOT2(2,INB)-COOP1(2,INA)
9653                         XY12 = GAM*(X12*X12+Y12*Y12)
9654                         IF (XY12.LE.15.0D0) THEN
9655                            C = CONE-CA*EXP(-XY12)
9656                            AR = DBLE(PP12(INT2))
9657                            AI = DIMAG(PP12(INT2))
9658                            IF (ABS(AR).LT.TINY25) AR = ZERO
9659                            IF (ABS(AI).LT.TINY25) AI = ZERO
9660                            PP12(INT2) = DCMPLX(AR,AI)
9661                            PP12(INT2) = PP12(INT2)*C
9662                         ENDIF
9663                         X21 = B+COOT1(1,INB)-COOP2(1,INA)
9664                         Y21 =   COOT1(2,INB)-COOP2(2,INA)
9665                         XY21 = GAM*(X21*X21+Y21*Y21)
9666                         IF (XY21.LE.15.0D0) THEN
9667                            C = CONE-CA*EXP(-XY21)
9668                            AR = DBLE(PP21(INT1))
9669                            AI = DIMAG(PP21(INT1))
9670                            IF (ABS(AR).LT.TINY25) AR = ZERO
9671                            IF (ABS(AI).LT.TINY25) AI = ZERO
9672                            PP21(INT1) = DCMPLX(AR,AI)
9673                            PP21(INT1) = PP21(INT1)*C
9674                         ENDIF
9675                         X22 = B+COOT2(1,INB)-COOP2(1,INA)
9676                         Y22 =   COOT2(2,INB)-COOP2(2,INA)
9677                         XY22 = GAM*(X22*X22+Y22*Y22)
9678                         IF (XY22.LE.15.0D0) THEN
9679                            C = CONE-CA*EXP(-XY22)
9680                            AR = DBLE(PP22(INT2))
9681                            AI = DIMAG(PP22(INT2))
9682                            IF (ABS(AR).LT.TINY25) AR = ZERO
9683                            IF (ABS(AI).LT.TINY25) AI = ZERO
9684                            PP22(INT2) = DCMPLX(AR,AI)
9685                            PP22(INT2) = PP22(INT2)*C
9686                         ENDIF
9687                      ENDIF
9688    16             CONTINUE
9689    15          CONTINUE
9690
9691                OMPP11 = CZERO
9692                OMPP21 = CZERO
9693                DIPP11 = CZERO
9694                DIPP21 = CZERO
9695                DO 17 K=1,INT1
9696                   IF (PP11(K).EQ.CZERO) THEN
9697                      PPTMP1 = CZERO
9698                      PPTMP2 = CZERO
9699                   ELSE
9700                      PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
9701                      PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
9702                   ENDIF
9703                   AVDIPP = 0.5D0*
9704      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9705                   OMPP11 = OMPP11+AVDIPP
9706 C                 OMPP11 = OMPP11+(CONE-PP11(K))
9707                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9708                   DIPP11 = DIPP11+AVDIPP
9709                   IF (PP21(K).EQ.CZERO) THEN
9710                      PPTMP1 = CZERO
9711                      PPTMP2 = CZERO
9712                   ELSE
9713                      PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
9714                      PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
9715                   ENDIF
9716                   AVDIPP = 0.5D0*
9717      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9718                   OMPP21 = OMPP21+AVDIPP
9719 C                 OMPP21 = OMPP21+(CONE-PP21(K))
9720                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9721                   DIPP21 = DIPP21+AVDIPP
9722    17          CONTINUE
9723                OMPP12 = CZERO
9724                OMPP22 = CZERO
9725                DIPP12 = CZERO
9726                DIPP22 = CZERO
9727                DO 18 K=1,INT2
9728                   IF (PP12(K).EQ.CZERO) THEN
9729                      PPTMP1 = CZERO
9730                      PPTMP2 = CZERO
9731                   ELSE
9732                      PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
9733                      PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
9734                   ENDIF
9735                   AVDIPP = 0.5D0*
9736      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9737                   OMPP12 = OMPP12+AVDIPP
9738 C                 OMPP12 = OMPP12+(CONE-PP12(K))
9739                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9740                   DIPP12 = DIPP12+AVDIPP
9741                   IF (PP22(K).EQ.CZERO) THEN
9742                      PPTMP1 = CZERO
9743                      PPTMP2 = CZERO
9744                   ELSE
9745                      PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
9746                      PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
9747                   ENDIF
9748                   AVDIPP = 0.5D0*
9749      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9750                   OMPP22 = OMPP22+AVDIPP
9751 C                 OMPP22 = OMPP22+(CONE-PP22(K))
9752                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9753                   DIPP22 = DIPP22+AVDIPP
9754    18          CONTINUE
9755
9756                SPROM = ONE-EXP(SHI)
9757                SPROB = SPROB+FACM*SPROM
9758                IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9759                   STOTM = DBLE(OMPP11+OMPP22)
9760                   SELAM = DBLE(OMPP11*DCONJG(OMPP22))
9761                   SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
9762                   SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
9763                   SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
9764                   SDELM = DBLE(DIPP11*DCONJG(DIPP22))
9765                   SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
9766                   STOTB = STOTB+FACM*STOTM
9767                   SELAB = SELAB+FACM*SELAM
9768                   SDELB = SDELB+FACM*SDELM
9769                   IF (NB.GT.1) THEN
9770                      SQEPB = SQEPB+FACM*SQEPM
9771                      SDQEB = SDQEB+FACM*SDQEM
9772                   ENDIF
9773                   IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
9774                   IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
9775                   IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
9776                ENDIF
9777
9778    14       CONTINUE
9779
9780             STOTN = STOTN+FACB*STOTB
9781             SELAN = SELAN+FACB*SELAB
9782             SQEPN = SQEPN+FACB*SQEPB
9783             SQETN = SQETN+FACB*SQETB
9784             SQE2N = SQE2N+FACB*SQE2B
9785             SPRON = SPRON+FACB*SPROB
9786             SDELN = SDELN+FACB*SDELB
9787             SDQEN = SDQEN+FACB*SDQEB
9788
9789             IF (IJPROJ.EQ.7) THEN
9790                BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
9791             ELSE
9792                IF (DIBETA.GT.ZERO) THEN
9793                   BPROD(IB+1)= BPROD(IB+1)
9794      &                        +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
9795                ELSE
9796                   BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
9797                ENDIF
9798             ENDIF
9799
9800    12    CONTINUE
9801
9802          STOT  = STOT +FACN*STOTN
9803          STOT2 = STOT2+FACN*STOTN**2
9804          SELA  = SELA +FACN*SELAN
9805          SELA2 = SELA2+FACN*SELAN**2
9806          SQEP  = SQEP +FACN*SQEPN
9807          SQEP2 = SQEP2+FACN*SQEPN**2
9808          SQET  = SQET +FACN*SQETN
9809          SQET2 = SQET2+FACN*SQETN**2
9810          SQE2  = SQE2 +FACN*SQE2N
9811          SQE22 = SQE22+FACN*SQE2N**2
9812          SPRO  = SPRO +FACN*SPRON
9813          SPRO2 = SPRO2+FACN*SPRON**2
9814          SDEL  = SDEL +FACN*SDELN
9815          SDEL2 = SDEL2+FACN*SDELN**2
9816          SDQE  = SDQE +FACN*SDQEN
9817          SDQE2 = SDQE2+FACN*SDQEN**2
9818
9819    11 CONTINUE
9820
9821 * final cross sections
9822 * 1) total
9823       XSTOT(IE,IQ,NTARG) = STOT
9824       IF (IJPROJ.EQ.7)
9825      &   XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
9826 * 2) elastic
9827       XSELA(IE,IQ,NTARG) = SELA
9828 * 3) quasi-el.: A+B-->A+X (excluding 2)
9829       XSQEP(IE,IQ,NTARG) = SQEP
9830 * 4) quasi-el.: A+B-->X+B (excluding 2)
9831       XSQET(IE,IQ,NTARG) = SQET
9832 * 5) quasi-el.: A+B-->X (excluding 2-4)
9833       XSQE2(IE,IQ,NTARG) = SQE2
9834 * 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
9835       IF (SDEL.GT.ZERO) THEN
9836          XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
9837       ELSE
9838          XSPRO(IE,IQ,NTARG) = SPRO
9839       ENDIF
9840 * 7) projectile diffraction (el. scatt. off target)
9841       XSDEL(IE,IQ,NTARG) = SDEL
9842 * 8) projectile diffraction (quasi-el. scatt. off target)
9843       XSDQE(IE,IQ,NTARG) = SDQE
9844 *  stat. errors
9845       XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
9846       XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
9847       XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
9848       XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
9849       XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
9850       XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
9851       XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
9852       XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
9853
9854       IF (IJPROJ.EQ.7) THEN
9855          BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
9856      &          -XSQEP(IE,IQ,NTARG)
9857       ELSE
9858          BNORM = XSPRO(IE,IQ,NTARG)
9859       ENDIF
9860       DO 19 I=2,NSITEB
9861          BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
9862          IF ((IE.EQ.1).AND.(IQ.EQ.1))
9863      &      BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
9864    19 CONTINUE
9865
9866 * write profile function data into file
9867       IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
9868          WRITE(LDAT,'(5I10,1P,E15.5)')
9869      &      IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
9870          WRITE(LDAT,'(1P,6E12.5)')
9871      &      XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
9872      &      XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9873          WRITE(LDAT,'(1P,6E12.5)')
9874      &      XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
9875      &      XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9876          NLINES = INT(DBLE(NSITEB)/7.0D0)
9877          IF (NLINES.GT.0) THEN
9878             DO 20 I=1,NLINES
9879                ISTART = 7*I-6
9880                WRITE(LDAT,'(1P,7E11.4)')
9881      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9882    20       CONTINUE
9883          ENDIF
9884          ISTART = 7*NLINES+1
9885          IF (ISTART.LE.NSITEB) THEN
9886             WRITE(LDAT,'(1P,7E11.4)')
9887      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9888          ENDIF
9889       ENDIF
9890
9891   100 CONTINUE
9892
9893 C     IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
9894
9895       RETURN
9896       END
9897
9898 *$ CREATE DT_GETBXS.FOR
9899 *COPY DT_GETBXS
9900 *
9901 *===getbxs=============================================================*
9902 *
9903       SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
9904
9905 ************************************************************************
9906 * Biasing in impact parameter space.                                   *
9907 *     XSFRAC = 0 :  BLO    - minimum impact parameter  (input)         *
9908 *                   BHI    - maximum impact parameter  (input)         *
9909 *                   XSFRAC - fraction of cross section corresponding   *
9910 *                            to impact parameter range (BLO,BHI)       *
9911 *                                                      (output)        *
9912 *     XSFRAC > 0 :  XSFRAC - fraction of cross section (input)         *
9913 *                   BHI    - maximum impact parameter giving requested *
9914 *                            fraction of cross section in impact       *
9915 *                            parameter range (0,BMAX)  (output)        *
9916 * This version dated 17.03.00  is written by S. Roesler                *
9917 ************************************************************************
9918
9919       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9920       SAVE
9921       PARAMETER ( LINP = 10 ,
9922      &            LOUT = 6 ,
9923      &            LDAT = 9 )
9924
9925       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9926 * Glauber formalism: parameters
9927       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9928      &                BMAX(NCOMPX),BSTEP(NCOMPX),
9929      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9930      &                NSITEB,NSTATB
9931
9932       NTARG = ABS(NIDX)
9933       IF (XSFRAC.LE.0.0D0) THEN
9934          ILO    = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
9935          IHI    = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
9936          IF (ILO.GE.IHI) THEN
9937             XSFRAC = 0.0D0
9938             RETURN
9939          ENDIF
9940          IF (ILO.EQ.NSITEB-1) THEN
9941             FRCLO = BSITE(0,1,NTARG,NSITEB)
9942          ELSE
9943             FRCLO = BSITE(0,1,NTARG,ILO+1)
9944      &              +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
9945      &              *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
9946          ENDIF
9947          IF (IHI.EQ.NSITEB-1) THEN
9948             FRCHI = BSITE(0,1,NTARG,NSITEB)
9949          ELSE
9950             FRCHI = BSITE(0,1,NTARG,IHI+1)
9951      &              +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
9952      &              *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
9953          ENDIF
9954          XSFRAC = FRCHI-FRCLO
9955       ELSE
9956          BLO = 0.0D0
9957          BHI = BMAX(NTARG)
9958          DO 1 I=1,NSITEB-1
9959             IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
9960                FAC = (XSFRAC              -BSITE(0,1,NTARG,I))/
9961      &               (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
9962                BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
9963                GOTO 2
9964             ENDIF
9965     1    CONTINUE
9966     2    CONTINUE
9967       ENDIF
9968
9969       RETURN
9970       END
9971
9972 *$ CREATE DT_CONUCL.FOR
9973 *COPY DT_CONUCL
9974 *
9975 *===conucl=============================================================*
9976 *
9977       SUBROUTINE DT_CONUCL(X,N,R,MODE)
9978
9979 ************************************************************************
9980 * Calculation of coordinates of nucleons within nuclei.                *
9981 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
9982 *        N / R    number of nucleons / radius of nucleus   (input)     *
9983 *        MODE = 0 coordinates not sorted                               *
9984 *             = 1 coordinates sorted with increasing X(3,i)            *
9985 *             = 2 coordinates sorted with decreasing X(3,i)            *
9986 * This version dated 26.10.95 is revised by S. Roesler                 *
9987 ************************************************************************
9988
9989       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9990       SAVE
9991       PARAMETER ( LINP = 10 ,
9992      &            LOUT = 6 ,
9993      &            LDAT = 9 )
9994
9995       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9996      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
9997
9998       PARAMETER (TWOPI = 6.283185307179586454D+00 )
9999
10000       PARAMETER (NSRT=10)
10001       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10002       DIMENSION X(3,N),XTMP(3,260)
10003
10004       CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10005
10006       IF ((MODE.NE.0).AND.(N.GT.4)) THEN
10007          K = 0
10008          DO 1 I=1,NSRT
10009             IF (MODE.EQ.2) THEN
10010                ISRT = NSRT+1-I
10011             ELSE
10012                ISRT = I
10013             ENDIF
10014             K1 = K
10015             DO 2 J=1,ICSRT(ISRT)
10016                K = K+1
10017                X(1,K) = XTMP(1,IDXSRT(ISRT,J))
10018                X(2,K) = XTMP(2,IDXSRT(ISRT,J))
10019                X(3,K) = XTMP(3,IDXSRT(ISRT,J))
10020     2       CONTINUE
10021             IF (ICSRT(ISRT).GT.1) THEN
10022                I0 = K1+1
10023                I1 = K
10024                CALL DT_SORT(X,N,I0,I1,MODE)
10025             ENDIF
10026     1    CONTINUE
10027       ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
10028          DO 3 I=1,N
10029             X(1,I) = XTMP(1,I)
10030             X(2,I) = XTMP(2,I)
10031             X(3,I) = XTMP(3,I)
10032     3    CONTINUE
10033          CALL DT_SORT(X,N,1,N,MODE)
10034       ELSE
10035          DO 4 I=1,N
10036             X(1,I) = XTMP(1,I)
10037             X(2,I) = XTMP(2,I)
10038             X(3,I) = XTMP(3,I)
10039     4    CONTINUE
10040       ENDIF
10041
10042       RETURN
10043       END
10044
10045 *$ CREATE DT_COORDI.FOR
10046 *COPY DT_COORDI
10047 *
10048 *===coordi=============================================================*
10049 *
10050       SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10051
10052 ************************************************************************
10053 * Calculation of coordinates of nucleons within nuclei.                *
10054 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
10055 *        N / R    number of nucleons / radius of nucleus   (input)     *
10056 * Based on the original version by Shmakov et al.                      *
10057 * This version dated 26.10.95 is revised by S. Roesler                 *
10058 ************************************************************************
10059
10060       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10061       SAVE
10062       PARAMETER ( LINP = 10 ,
10063      &            LOUT = 6 ,
10064      &            LDAT = 9 )
10065
10066       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10067      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10068
10069       PARAMETER (TWOPI = 6.283185307179586454D+00 )
10070
10071       LOGICAL LSTART
10072
10073       PARAMETER (NSRT=10)
10074       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10075       DIMENSION X(3,260),WD(4),RD(3)
10076
10077       DATA PDIF/0.545D0/,R2MIN/0.16D0/
10078       DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10079       DATA RD /2.09D0, 0.935D0, 0.697D0/
10080
10081       X1SUM = ZERO
10082       X2SUM = ZERO
10083       X3SUM = ZERO
10084
10085       IF (N.EQ.1) THEN
10086          X(1,1) = ZERO
10087          X(2,1) = ZERO
10088          X(3,1) = ZERO
10089       ELSEIF (N.EQ.2) THEN
10090          EPS = DT_RNDM(RD(1))
10091          DO 30 I=1,3
10092             IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10093    30    CONTINUE
10094    40    CONTINUE
10095          DO 50 J=1,3
10096             CALL DT_RANNOR(X1,X2)
10097             X(J,1) = RD(I)*X1
10098             X(J,2) = -X(J,1)
10099    50    CONTINUE
10100       ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10101          SIGMA = R/SQRTWO
10102          LSTART = .TRUE.
10103          CALL DT_RANNOR(X3,X4)
10104          DO 100 I=1,N
10105             CALL DT_RANNOR(X1,X2)
10106             X(1,I) = SIGMA*X1
10107             X(2,I) = SIGMA*X2
10108             IF (LSTART) GOTO 80
10109             X(3,I) = SIGMA*X4
10110             CALL DT_RANNOR(X3,X4)
10111             GOTO 90
10112    80       CONTINUE
10113             X(3,I) = SIGMA*X3
10114    90       CONTINUE
10115             LSTART = .NOT.LSTART
10116             X1SUM = X1SUM+X(1,I)
10117             X2SUM = X2SUM+X(2,I)
10118             X3SUM = X3SUM+X(3,I)
10119   100    CONTINUE
10120          X1SUM = X1SUM/DBLE(N)
10121          X2SUM = X2SUM/DBLE(N)
10122          X3SUM = X3SUM/DBLE(N)
10123          DO 101 I=1,N
10124             X(1,I) = X(1,I)-X1SUM
10125             X(2,I) = X(2,I)-X2SUM
10126             X(3,I) = X(3,I)-X3SUM
10127   101    CONTINUE
10128       ELSE
10129
10130 * maximum nuclear radius for coordinate sampling
10131          RMAX = R+4.605D0*PDIF
10132
10133 * initialize pre-sorting
10134          DO 121 I=1,NSRT
10135             ICSRT(I) = 0
10136   121    CONTINUE
10137          DR = TWO*RMAX/DBLE(NSRT)
10138
10139 * sample coordinates for N nucleons
10140          DO 140 I=1,N
10141   120       CONTINUE
10142             RAD = RMAX*(DT_RNDM(DR))**ONETHI
10143             F   = DT_DENSIT(N,RAD,R)
10144             IF (DT_RNDM(RAD).GT.F) GOTO 120
10145 *   theta, phi uniformly distributed
10146             CT  = ONE-TWO*DT_RNDM(F)
10147             ST  = SQRT((ONE-CT)*(ONE+CT))
10148             CALL DT_DSFECF(SFE,CFE)
10149             X(1,I) = RAD*ST*CFE
10150             X(2,I) = RAD*ST*SFE
10151             X(3,I) = RAD*CT
10152 *   ensure that distance between two nucleons is greater than R2MIN
10153             IF (I.LT.2) GOTO 122
10154             I1 = I-1
10155             DO 130 I2=1,I1
10156                DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10157      &                 (X(3,I)-X(3,I2))**2
10158                IF (DIST2.LE.R2MIN) GOTO 120
10159   130       CONTINUE
10160   122       CONTINUE
10161 *   save index according to z-bin
10162             IDXZ        = INT( (X(3,I)+RMAX)/DR )+1
10163             ICSRT(IDXZ) = ICSRT(IDXZ)+1
10164             IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10165             X1SUM = X1SUM+X(1,I)
10166             X2SUM = X2SUM+X(2,I)
10167             X3SUM = X3SUM+X(3,I)
10168   140    CONTINUE
10169          X1SUM = X1SUM/DBLE(N)
10170          X2SUM = X2SUM/DBLE(N)
10171          X3SUM = X3SUM/DBLE(N)
10172          DO 141 I=1,N
10173             X(1,I) = X(1,I)-X1SUM
10174             X(2,I) = X(2,I)-X2SUM
10175             X(3,I) = X(3,I)-X3SUM
10176   141    CONTINUE
10177
10178       ENDIF
10179
10180       RETURN
10181       END
10182
10183 *$ CREATE DT_DENSIT.FOR
10184 *COPY DT_DENSIT
10185 *
10186 *===densit=============================================================*
10187 *
10188       DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10189
10190       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10191       SAVE
10192
10193       PARAMETER ( LINP = 10 ,
10194      &            LOUT = 6 ,
10195      &            LDAT = 9 )
10196       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10197       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10198      &           PI    = TWOPI/TWO)
10199
10200       DIMENSION R0(18),FNORM(18)
10201       DATA R0 /  ZERO,   ZERO,   ZERO,   ZERO, 2.12D0,
10202      &         2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10203      &         2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10204      &         2.72D0, 2.66D0, 2.79D0/
10205       DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10206      &            .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10207      &            .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10208      &            .1214D+01,.1265D+01,.1318D+01/
10209       DATA PDIF /0.545D0/
10210
10211       DT_DENSIT = ZERO
10212 * shell model
10213       IF (NA.LE.4) THEN
10214          STOP 'DT_DENSIT-0'
10215       ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10216          R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10217          DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10218      &            *EXP(-(R/R1)**2)/FNORM(NA)
10219 * Woods-Saxon
10220       ELSEIF (NA.GT.18) THEN
10221          DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10222       ENDIF
10223
10224       RETURN
10225       END
10226
10227 *$ CREATE DT_RNCLUS.FOR
10228 *COPY DT_RNCLUS
10229 *
10230 *===rnclus=============================================================*
10231 *
10232       DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10233
10234 ************************************************************************
10235 * Nuclear radius for nucleus with mass number N.                       *
10236 * This version dated 26.9.00  is written by S. Roesler                 *
10237 ************************************************************************
10238
10239       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10240       SAVE
10241
10242       PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10243
10244 * nucleon radius
10245       PARAMETER (RNUCLE = 1.12D0)
10246
10247 * nuclear radii for selected nuclei
10248       DIMENSION RADNUC(18)
10249       DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10250      &               2.58D0,2.71D0,2.66D0,2.71D0/
10251
10252       IF (N.LE.18) THEN
10253          IF (RADNUC(N).GT.0.0D0) THEN
10254             DT_RNCLUS = RADNUC(N)
10255          ELSE
10256             DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10257          ENDIF
10258       ELSE
10259          DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10260       ENDIF
10261
10262       RETURN
10263       END
10264
10265 *$ CREATE DT_DENTST.FOR
10266 *COPY DT_DENTST
10267 *
10268 *===dentst=============================================================*
10269 *
10270 C      PROGRAM DT_DENTST
10271       SUBROUTINE DT_DENTST
10272
10273       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10274       SAVE
10275
10276       OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10277       OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10278
10279       RMIN  = 0.0D0
10280       RMAX  = 8.0D0
10281       NBINS = 500.0D0
10282       DR    = (RMAX-RMIN)/DBLE(NBINS)
10283       DO 1 IA=5,18
10284          FMAX = 0.0D0
10285          DO 2 IR=1,NBINS+1
10286             R = RMIN+DBLE(IR-1)*DR
10287             F = DT_DENSIT(IA,R,R)
10288             IF (F.GT.FMAX) FMAX = F
10289             WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10290     2    CONTINUE
10291          WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10292     1 CONTINUE
10293
10294       CLOSE(40)
10295       CLOSE(41)
10296
10297       END
10298
10299 *$ CREATE DT_SHMAKI.FOR
10300 *COPY DT_SHMAKI
10301 *
10302 *===shmaki=============================================================*
10303 *
10304       SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10305
10306 ************************************************************************
10307 * Initialisation of Glauber formalism. This subroutine has to be       *
10308 * called once (in case of target emulsions as often as many different  *
10309 * target nuclei are considered) before events are sampled.             *
10310 *         NA / NCA   mass number/charge of projectile nucleus          *
10311 *         NB / NCB   mass number/charge of target     nucleus          *
10312 *         IJP        identity of projectile (hadrons/leptons/photons)  *
10313 *         PPN        projectile momentum (for projectile nuclei:       *
10314 *                    momentum per nucleon) in target rest system       *
10315 *         MODE = 0   Glauber formalism invoked                         *
10316 *              = 1   fitted results are loaded from data-file          *
10317 *              = 99  NTARG is forced to be 1                           *
10318 *                    (used in connection with GLAUBERI-card only)      *
10319 * This version dated 22.03.96 is based on the original SHMAKI-routine  *
10320 * and revised by S. Roesler.                                           *
10321 ************************************************************************
10322
10323       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10324       SAVE
10325       PARAMETER ( LINP = 10 ,
10326      &            LOUT = 6 ,
10327      &            LDAT = 9 )
10328       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10329      &           THREE=3.0D0)
10330
10331       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10332 * Glauber formalism: parameters
10333       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10334      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10335      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10336      &                NSITEB,NSTATB
10337 * Lorentz-parameters of the current interaction
10338       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10339      &                UMO,PPCM,EPROJ,PPROJ
10340 * properties of photon/lepton projectiles
10341       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10342 * kinematical cuts for lepton-nucleus interactions
10343       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10344      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10345 * Glauber formalism: cross sections
10346       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10347      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10348      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10349      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10350      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10351      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10352      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10353      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10354      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10355      &                BSLOPE,NEBINI,NQBINI
10356 * cuts for variable energy runs
10357       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10358 * nucleon-nucleon event-generator
10359       CHARACTER*8 CMODEL
10360       LOGICAL LPHOIN
10361       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10362 * Glauber formalism: flags and parameters for statistics
10363       LOGICAL LPROD
10364       CHARACTER*8 CGLB
10365       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10366
10367       DATA NTARG,ICOUT,IVEOUT /0,0,0/
10368
10369 C     CALL DT_HISHAD
10370 C     STOP
10371
10372       NTARG = NTARG+1
10373       IF (MODE.EQ.99) NTARG = 1
10374       NIDX = -NTARG
10375       IF (MODE.EQ.-1) NIDX = NTARG
10376
10377       IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10378       IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10379  1000    FORMAT(//,1X,'SHMAKI:    Glauber formalism (Shmakov et. al) -',
10380      &          ' initialization',/,12X,'--------------------------',
10381      &          '-------------------------',/)
10382
10383       IF (MODE.EQ.2) THEN
10384          CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10385          CALL DT_SHFAST(MODE,PPN,IBACK)
10386          STOP ' Glauber pre-initialization done'
10387       ENDIF
10388       IF (MODE.EQ.1) THEN
10389          CALL DT_PROFBI(NA,NB,PPN,NTARG)
10390       ELSE
10391          IBACK = 1
10392          IF (MODE.EQ.3)  CALL DT_SHFAST(MODE,PPN,IBACK)
10393          IF (IBACK.EQ.1) THEN
10394 * lepton-nucleus (variable energy runs)
10395             IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10396      &          (IJP.EQ.10).OR.(IJP.EQ.11))   THEN
10397                IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10398      &            WRITE(LOUT,1002) NB,NCB
10399  1002          FORMAT(1X,'variable energy run:     projectile-id:  7',
10400      &                '    target A/Z: ',I3,' /',I3,/,/,8X,
10401      &                'E_cm (GeV)    Q^2 (GeV^2)',
10402      &                '    Sigma_tot (mb)     Sigma_in (mb)',/,7X,
10403      &                '--------------------------------',
10404      &                '------------------------------')
10405                AECMLO = LOG10(MIN(UMO,ECMLI))
10406                AECMHI = LOG10(MIN(UMO,ECMHI))
10407                IESTEP = NEB-1
10408                DAECM  = (AECMHI-AECMLO)/DBLE(IESTEP)
10409                IF (AECMLO.EQ.AECMHI) IESTEP = 0
10410                DO 1 I=1,IESTEP+1
10411                   ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10412                   IF (Q2HI.GT.0.1D0) THEN
10413                      IF (Q2LI.LT.0.01D0) THEN
10414                         CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10415                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10416      &                     WRITE(LOUT,1003)
10417      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10418                         Q2LI = 0.01D0
10419                         IBIN = 2
10420                      ELSE
10421                         IBIN = 1
10422                      ENDIF
10423                      IQSTEP = NQB-IBIN
10424                      AQ2LO  = LOG10(Q2LI)
10425                      AQ2HI  = LOG10(Q2HI)
10426                      DAQ2   = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10427                      DO 2 J=IBIN,IQSTEP+IBIN
10428                         Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10429                         CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10430                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10431      &                     WRITE(LOUT,1003) ECMNN(I),
10432      &                     Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10433     2                CONTINUE
10434                   ELSE
10435                      CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10436                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10437      &                  WRITE(LOUT,1003)
10438      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10439                   ENDIF
10440  1003             FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10441     1          CONTINUE
10442                IVEOUT = 1
10443             ELSE
10444 * hadron/photon/nucleus-nucleus
10445                IF ((ABS(VAREHI).GT.ZERO).AND.
10446      &             (ABS(VAREHI).GT.ABS(VARELO))) THEN
10447                   IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10448                      WRITE(LOUT,1004) NA,NB,NCB
10449  1004                FORMAT(1X,'variable energy run:    projectile-id:',
10450      &                      I3,'    target A/Z: ',I3,' /',I3,/)
10451                      WRITE(LOUT,1005)
10452  1005                FORMAT('  E_cm (GeV)  E_Lab (GeV)  sig_tot^pp (mb)'
10453      &                      ,'  Sigma_tot (mb)  Sigma_prod (mb)',/,
10454      &                      ' -------------------------------------',
10455      &                      '--------------------------------------')
10456                   ENDIF
10457                   AECMLO = LOG10(VARCLO)
10458                   AECMHI = LOG10(VARCHI)
10459                   IESTEP = NEB-1
10460                   DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10461                   IF (AECMLO.EQ.AECMHI) IESTEP = 0
10462                   DO 3 I=1,IESTEP+1
10463                      ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10464                      AMP = 0.938D0
10465                      AMT = 0.938D0
10466                      AMP2 = AMP**2
10467                      AMT2 = AMT**2
10468                      ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
10469                      PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
10470                      CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
10471                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10472      &                 WRITE(LOUT,1006)
10473      &                 ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10474  1006             FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
10475     3             CONTINUE
10476                   IVEOUT = 1
10477                ELSE
10478                   CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10479                ENDIF
10480             ENDIF
10481          ENDIF
10482       ENDIF
10483
10484       IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
10485      &    (IOGLB.NE.100)) THEN
10486          WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
10487      &                    BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
10488  1001    FORMAT(38X,'projectile',
10489      &          '      target',/,1X,'Mass number / charge',
10490      &          17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
10491      &          'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
10492      &          'Parameters of elastic scattering amplitude:',/,5X,
10493      &          'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
10494      &          F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
10495      &          'statistics at each b-step',4X,I5,/,/,1X,
10496      &          'Prod. cross section  ',5X,F10.4,' mb',/)
10497       ENDIF
10498
10499       RETURN
10500       END
10501
10502 *$ CREATE DT_PROFBI.FOR
10503 *COPY DT_PROFBI
10504 *
10505 *===profbi=============================================================*
10506 *
10507       SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
10508
10509 ************************************************************************
10510 * Integral over profile function (to be used for impact-parameter      *
10511 * sampling during event generation).                                   *
10512 * Fitted results are used.                                             *
10513 *         NA / NB    mass numbers of proj./target nuclei               *
10514 *         PPN        projectile momentum (for projectile nuclei:       *
10515 *                    momentum per nucleon) in target rest system       *
10516 *         NTARG      index of target material (i.e. kind of nucleus)   *
10517 * This version dated 31.05.95 is revised by S. Roesler                 *
10518 ************************************************************************
10519
10520       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10521       SAVE
10522       PARAMETER ( LINP = 10 ,
10523      &            LOUT = 6 ,
10524      &            LDAT = 9 )
10525 CPH      SAVE
10526
10527       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
10528
10529       LOGICAL LSTART
10530       CHARACTER CNAME*80
10531
10532       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10533 * Glauber formalism: parameters
10534       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10535      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10536      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10537      &                NSITEB,NSTATB
10538 * Glauber formalism: cross sections
10539       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10540      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10541      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10542      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10543      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10544      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10545      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10546      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10547      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10548      &                BSLOPE,NEBINI,NQBINI
10549
10550       PARAMETER (NGLMAX=8000)
10551       DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
10552      &          GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
10553
10554       DATA LSTART /.TRUE./
10555
10556       IF (LSTART) THEN
10557 * read fit-parameters from file
10558          OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
10559          I = 0
10560     1    CONTINUE
10561          READ(47,'(A80)') CNAME
10562          IF (CNAME.EQ.'STOP') GOTO 2
10563          I = I+1
10564          READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
10565      &                 GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
10566      &                 GLAFIT(4,I),GLAFIT(5,I)
10567          IF (I+1.GT.NGLMAX) THEN
10568             WRITE(LOUT,1000)
10569  1000       FORMAT(1X,'PROFBI:    warning! array size exceeded - ',
10570      &             'program stopped')
10571             STOP
10572          ENDIF
10573          GOTO 1
10574     2    CONTINUE
10575          NGLPAR = I
10576          LSTART = .FALSE.
10577       ENDIF
10578
10579       NNA = NA
10580       NNB = NB
10581       IF (NA.GT.NB) THEN
10582          NNA = NB
10583          NNB = NA
10584       ENDIF
10585       IDXGLA = 0
10586       DO 3 J=1,NGLPAR
10587          IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
10588             IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
10589             DO 4 K=1,J-1
10590                IPOINT = J-K
10591                IF (J.EQ.NGLPAR) IPOINT = J+1-K
10592                IF ((NNA.GT.NGLIP(IPOINT)).OR.
10593      &             (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
10594                   IF (IPOINT.EQ.1) IPOINT = 0
10595                   NATMP = NGLIP(IPOINT+1)
10596                   IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
10597                      IDXGLA = IPOINT+1
10598                      GOTO 6
10599                   ELSE
10600                      J1BEG = IPOINT+1
10601                      J1END = J
10602 C                    IF (J.EQ.NGLPAR) THEN
10603 C                       J1BEG = IPOINT
10604 C                       J1END = J
10605 C                    ENDIF
10606                      DO 5 J1=J1BEG,J1END
10607                         IF (NGLIP(J1).EQ.NATMP) THEN
10608                            IF (PPN.LT.GLAPPN(J1)) THEN
10609                               IDXGLA = J1
10610                               GOTO 6
10611                            ENDIF
10612                         ELSE
10613                            IDXGLA = J1-1
10614                            GOTO 6
10615                         ENDIF
10616     5                CONTINUE
10617                      IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
10618      &                  IDXGLA = NGLPAR
10619                   ENDIF
10620                ENDIF
10621     4       CONTINUE
10622          ENDIF
10623     3 CONTINUE
10624
10625     6 CONTINUE
10626       IF (IDXGLA.EQ.0) THEN
10627          WRITE(LOUT,1001) NNA,NNB,PPN
10628  1001    FORMAT(1X,'PROFBI:   configuration (NA,NB,PPN = ',
10629      &          2I4,F6.0,') not found ')
10630          STOP
10631       ENDIF
10632
10633 * no interpolation yet available
10634       XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
10635
10636       BSITE(1,1,NTARG,1) = ZERO
10637       DO 10 I=2,NSITEB
10638          XX = DBLE(I)
10639          POLY  = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
10640      &           GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
10641      &           GLAFIT(5,IDXGLA)*XX**4
10642          IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
10643          BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
10644          IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
10645    10 CONTINUE
10646
10647       RETURN
10648       END
10649
10650 *$ CREATE DT_GLAUBE.FOR
10651 *COPY DT_GLAUBE
10652 *
10653 *===glaube=============================================================*
10654 *
10655       SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
10656
10657 ************************************************************************
10658 * Calculation of configuartion of interacting nucleons for one event.  *
10659 *    NB / NB    mass numbers of proj./target nuclei           (input)  *
10660 *    B          impact parameter                              (output) *
10661 *    INTT       total number of wounded nucleons                 "     *
10662 *    INTA / INTB number of wounded nucleons in proj. / target    "     *
10663 *    JS / JT(i) number of collisions proj. / target nucleon i is       *
10664 *                                                   involved  (output) *
10665 *    NIDX       index of projectile/target material            (input) *
10666 *               = -2 call within FLUKA transport calculation           *
10667 * This is an update of the original routine SHMAKO by J.Ranft/HJM      *
10668 * This version dated 22.03.96 is revised by S. Roesler                 *
10669 *                                                                      *
10670 * Last change 27.12.2006 by S. Roesler.                                *
10671 ************************************************************************
10672
10673       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10674       SAVE
10675       PARAMETER ( LINP = 10 ,
10676      &            LOUT = 6 ,
10677      &            LDAT = 9 )
10678       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
10679      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
10680
10681       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10682       PARAMETER ( MAXNCL = 260,
10683      &            MAXVQU = MAXNCL,
10684      &            MAXSQU = 20*MAXVQU,
10685      &            MAXINT = MAXVQU+MAXSQU)
10686 * Glauber formalism: parameters
10687       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10688      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10689      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10690      &                NSITEB,NSTATB
10691 * Glauber formalism: cross sections
10692       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10693      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10694      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10695      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10696      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10697      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10698      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10699      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10700      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10701      &                BSLOPE,NEBINI,NQBINI
10702 * Lorentz-parameters of the current interaction
10703       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10704      &                UMO,PPCM,EPROJ,PPROJ
10705 * properties of photon/lepton projectiles
10706       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10707 * Glauber formalism: collision properties
10708       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
10709      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
10710 * Glauber formalism: flags and parameters for statistics
10711       LOGICAL LPROD
10712       CHARACTER*8 CGLB
10713       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10714
10715       DIMENSION JS(MAXNCL),JT(MAXNCL)
10716
10717       NTARG = ABS(NIDX)
10718
10719 * get actual energy from /DTLTRA/
10720       ECMNOW = UMO
10721       Q2     = VIRT
10722 *
10723 * new patch for pre-initialized variable projectile/target/energy runs,
10724 * bypassed for use within FLUKA (Nidx=-2)
10725       IF (IOGLB.EQ.100) THEN
10726          IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
10727 *
10728 * variable energy run, interpolate profile function
10729       ELSE
10730          I1   = 1
10731          I2   = 1
10732          RATE = ONE
10733          IF (NEBINI.GT.1) THEN
10734             IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
10735                I1   = NEBINI
10736                I2   = NEBINI
10737                RATE = ONE
10738             ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
10739                DO 1 I=2,NEBINI
10740                   IF (ECMNOW.LT.ECMNN(I)) THEN
10741                      I1   = I-1
10742                      I2   = I
10743                      RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
10744                      GOTO 2
10745                   ENDIF
10746     1          CONTINUE
10747     2          CONTINUE
10748             ENDIF
10749          ENDIF
10750          J1   = 1
10751          J2   = 1
10752          RATQ = ONE
10753          IF (NQBINI.GT.1) THEN
10754             IF (Q2.GE.Q2G(NQBINI)) THEN
10755                J1   = NQBINI
10756                J2   = NQBINI
10757                RATQ = ONE
10758             ELSEIF (Q2.GT.Q2G(1)) THEN
10759                DO 3 I=2,NQBINI
10760                   IF (Q2.LT.Q2G(I)) THEN
10761                      J1   = I-1
10762                      J2   = I
10763                      RATQ = LOG10(     Q2/MAX(Q2G(J1),TINY14))/
10764      &                      LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
10765 C                    RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
10766                      GOTO 4
10767                   ENDIF
10768     3          CONTINUE
10769     4          CONTINUE
10770             ENDIF
10771          ENDIF
10772
10773          DO 5 I=1,KSITEB
10774             BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
10775      &         RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10776      &         RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10777      &         RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
10778      &                    BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
10779     5    CONTINUE
10780       ENDIF
10781
10782       CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
10783       IF (NIDX.LE.-1) THEN
10784          RPROJ = RASH(1)
10785          RTARG = RBSH(NTARG)
10786       ELSE
10787          RPROJ = RASH(NTARG)
10788          RTARG = RBSH(1)
10789       ENDIF
10790
10791       RETURN
10792       END
10793
10794 *$ CREATE DT_DIAGR.FOR
10795 *COPY DT_DIAGR
10796 *
10797 *===diagr==============================================================*
10798 *
10799       SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
10800      &                                                         NIDX)
10801
10802 ************************************************************************
10803 * Based on the original version by Shmakov et al.                      *
10804 * This version dated 21.04.95 is revised by S. Roesler                 *
10805 ************************************************************************
10806
10807       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10808       SAVE
10809       PARAMETER ( LINP = 10 ,
10810      &            LOUT = 6 ,
10811      &            LDAT = 9 )
10812       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10813       PARAMETER (TWOPI  = 6.283185307179586454D+00,
10814      &           PI     = TWOPI/TWO,
10815      &           GEV2MB = 0.38938D0,
10816      &           GEV2FM = 0.1972D0,
10817      &           ALPHEM = ONE/137.0D0,
10818 * proton mass
10819      &           AMP    = 0.938D0,
10820      &           AMP2   = AMP**2,
10821 * rho0 mass
10822      &           AMRHO0 = 0.77D0)
10823
10824       COMPLEX*16 C,CA,CI
10825       PARAMETER ( MAXNCL = 260,
10826      &            MAXVQU = MAXNCL,
10827      &            MAXSQU = 20*MAXVQU,
10828      &            MAXINT = MAXVQU+MAXSQU)
10829 * particle properties (BAMJET index convention)
10830       CHARACTER*8  ANAME
10831       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
10832      &                IICH(210),IIBAR(210),K1(210),K2(210)
10833       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10834 * emulsion treatment
10835       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
10836      &                NCOMPO,IEMUL
10837 * Glauber formalism: parameters
10838       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10839      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10840      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10841      &                NSITEB,NSTATB
10842 * Glauber formalism: cross sections
10843       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10844      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10845      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10846      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10847      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10848      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10849      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10850      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10851      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10852      &                BSLOPE,NEBINI,NQBINI
10853 * VDM parameter for photon-nucleus interactions
10854       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
10855 * nucleon-nucleon event-generator
10856       CHARACTER*8 CMODEL
10857       LOGICAL LPHOIN
10858       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10859 **PHOJET105a
10860 C     COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10861 **PHOJET112
10862 C  obsolete cut-off information
10863       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
10864       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10865 **
10866 * coordinates of nucleons
10867       COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
10868 * interface between Glauber formalism and DPM
10869       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
10870      &                INTER1(MAXINT),INTER2(MAXINT)
10871 * statistics: Glauber-formalism
10872       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
10873 * n-n cross section fluctuations
10874       PARAMETER (NBINS = 1000)
10875       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
10876
10877       DIMENSION JS(MAXNCL),JT(MAXNCL),
10878      &          JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
10879      &          JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
10880       DIMENSION NWA(0:210),NWB(0:210)
10881
10882       LOGICAL LFIRST
10883       DATA LFIRST /.TRUE./
10884
10885       DATA NTARGO,ICNT /0,0/
10886
10887       NTARG = ABS(NIDX)
10888
10889       IF (LFIRST) THEN
10890          LFIRST = .FALSE.
10891          IF (NCOMPO.EQ.0) THEN
10892             NCALL  = 0
10893             NWAMAX = NA
10894             NWBMAX = NB
10895             DO 17 I=0,210
10896                NWA(I) = 0
10897                NWB(I) = 0
10898    17       CONTINUE
10899          ENDIF
10900       ENDIF
10901       IF (NTARG.EQ.-1) THEN
10902          IF (NCOMPO.EQ.0) THEN
10903             WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
10904             WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
10905      &                                NCALL,NWAMAX,NWBMAX
10906             DO 18 I=1,MAX(NWAMAX,NWBMAX)
10907                WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
10908      &                          I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
10909      &                            NWB(I),DBLE(NWB(I))/DBLE(NCALL)
10910    18       CONTINUE
10911          ENDIF
10912          RETURN
10913       ENDIF
10914
10915       DCOH   = 1.0D10
10916       IPNT   = 0
10917
10918       SQ2  = Q2
10919       IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
10920       S   = ECMNOW**2
10921       X   = SQ2/(S+SQ2-AMP2)
10922       XNU = (S+SQ2-AMP2)/(TWO*AMP)
10923 * photon projectiles: recalculate photon-nucleon amplitude
10924       IF (IJPROJ.EQ.7) THEN
10925    15    CONTINUE
10926 *  VDM assumption: mass of V-meson
10927          AMV2   = DT_SAM2(SQ2,ECMNOW)
10928          AMV    = SQRT(AMV2)
10929          IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
10930 *  check for pointlike interaction
10931          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
10932 **sr 27.10.
10933 C        SIGSH  = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10934          SIGSH  = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10935 **
10936          ROSH   = 0.1D0
10937          BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
10938      &                   +0.25D0*LOG(S/(AMV2+SQ2)))
10939 *  coherence length
10940          IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
10941       ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
10942          IF (MCGENE.EQ.2) THEN
10943             ZERO1 = ZERO
10944             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
10945      &                                                BSLOPE,0)
10946          ELSE
10947             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
10948          ENDIF
10949          IF (ECMNOW.LE.3.0D0) THEN
10950             ROSH = -0.43D0
10951          ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
10952             ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
10953          ELSEIF (ECMNOW.GT.50.0D0) THEN
10954             ROSH = 0.1D0
10955          ENDIF
10956          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10957          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10958          IF (MCGENE.EQ.2) THEN
10959             ZERO1 = ZERO
10960             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
10961      &                                                  BDUM,0)
10962             SIGSH = SIGSH/10.0D0
10963          ELSE
10964 C           SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10965             DUMZER = ZERO
10966             CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10967             SIGSH = SIGSH/10.0D0
10968          ENDIF
10969       ELSE
10970          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
10971          ROSH   = 0.01D0
10972          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10973          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10974 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10975          DUMZER = ZERO
10976          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10977          SIGSH = SIGSH/10.0D0
10978       ENDIF
10979       GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
10980       GAM = GSH
10981       RCA = GAM*SIGSH/TWOPI
10982       FCA = -ROSH*RCA
10983       CA  = DCMPLX(RCA,FCA)
10984       CI  = DCMPLX(ONE,ZERO)
10985
10986    16 CONTINUE
10987 * impact parameter
10988       IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
10989
10990       NTRY = 0
10991     3 CONTINUE
10992       NTRY = NTRY+1
10993 * initializations
10994       JNT  = 0
10995       DO 1 I=1,NA
10996          JS(I) = 0
10997     1 CONTINUE
10998       DO 2 I=1,NB
10999          JT(I) = 0
11000     2 CONTINUE
11001       IF (IJPROJ.EQ.7) THEN
11002          DO 8 I=1,MAXNCL
11003             JS0(I) = 0
11004             JNT0(I)= 0
11005             DO 9 J=1,NB
11006                JT0(I,J) = 0
11007     9       CONTINUE
11008     8    CONTINUE
11009       ENDIF
11010
11011 * nucleon configuration
11012 C     IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11013       IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11014 C        CALL DT_CONUCL(PKOO,NA,RASH,2)
11015 C        CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
11016          IF (NIDX.LE.-1) THEN
11017             CALL DT_CONUCL(PKOO,NA,RASH(1),0)
11018             CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
11019          ELSE
11020             CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11021             CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11022          ENDIF
11023          NTARGO = NTARG
11024       ENDIF
11025       ICNT = ICNT+1
11026
11027 * LEPTO: pick out one struck nucleon
11028       IF (MCGENE.EQ.3) THEN
11029          JNT     = 1
11030          JS(1)   = 1
11031          IDX     = INT(DT_RNDM(X)*NB)+1
11032          JT(IDX) = 1
11033          B       = ZERO
11034          GOTO 19
11035       ENDIF
11036
11037       DO 4 INA=1,NA
11038 * cross section fluctuations
11039          AFLUC = ONE
11040          IF (IFLUCT.EQ.1) THEN
11041             IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11042             AFLUC = FLUIXX(IFLUK)
11043          ENDIF
11044          KK1  = 1
11045          KINT = 1
11046          DO 5 INB=1,NB
11047 * photon-projectile: check for supression by coherence length
11048             IF (IJPROJ.EQ.7) THEN
11049                IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11050                   KK1  = INB
11051                   KINT = KINT+1
11052                ENDIF
11053             ENDIF
11054             QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11055             QQ2 =   TKOO(2,INB)-PKOO(2,INA)
11056             XY  = GAM*(QQ1*QQ1+QQ2*QQ2)
11057             IF (XY.LE.15.0D0) THEN
11058                C  = CI-CA*AFLUC*EXP(-XY)
11059                AR = DBLE(C)
11060                AI = DIMAG(C)
11061                P  = AR*AR+AI*AI
11062                IF (DT_RNDM(XY).GE.P) THEN
11063                   JNT = JNT+1
11064                   IF (IJPROJ.EQ.7) THEN
11065                      JNT0(KINT) = JNT0(KINT)+1
11066                      IF (JNT0(KINT).GT.MAXNCL) THEN
11067                         WRITE(LOUT,1001) MAXNCL
11068  1001                   FORMAT(1X,
11069      &                        'DIAGR:  no. of requested interactions',
11070      &                        ' exceeds array dimensions ',I4)
11071                         STOP
11072                      ENDIF
11073                      JS0(KINT)      = JS0(KINT)+1
11074                      JT0(KINT,INB)  = JT0(KINT,INB)+1
11075                      JI1(KINT,JNT0(KINT)) = INA
11076                      JI2(KINT,JNT0(KINT)) = INB
11077                   ELSE
11078                      IF (JNT.GT.MAXINT) THEN
11079                         WRITE(LOUT,1000) JNT, MAXINT
11080  1000                   FORMAT(1X,
11081      &                        'DIAGR:  no. of requested interactions ('
11082      &                        ,I4,') exceeds array dimensions (',I4,')')
11083                         STOP
11084                      ENDIF
11085                      JS(INA) = JS(INA)+1
11086                      JT(INB) = JT(INB)+1
11087                      INTER1(JNT) = INA
11088                      INTER2(JNT) = INB
11089                   ENDIF
11090                ENDIF
11091             ENDIF
11092     5    CONTINUE
11093     4 CONTINUE
11094
11095       IF (JNT.EQ.0) THEN
11096          IF (NTRY.LT.500) THEN
11097             GOTO 3
11098          ELSE
11099 C           WRITE(6,*) ' new impact parameter required (old= ',B,')'
11100             GOTO 16
11101          ENDIF
11102       ENDIF
11103
11104       IDIREC = 0
11105       IF (IJPROJ.EQ.7) THEN
11106          K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11107    10    CONTINUE
11108          IF (JNT0(K).EQ.0) THEN
11109             K = K+1
11110             IF (K.GT.KINT) K = 1
11111             GOTO 10
11112          ENDIF
11113 * supress Glauber-cascade by direct photon processes
11114          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11115          IF (IPNT.GT.0) THEN
11116             JNT   = 1
11117             JS(1) = 1
11118             DO 11 INB=1,NB
11119                JT(INB) = JT0(K,INB)
11120                IF (JT(INB).GT.0) GOTO 12
11121    11       CONTINUE
11122    12       CONTINUE
11123             INTER1(1) = 1
11124             INTER2(1) = INB
11125             IDIREC    = IPNT
11126          ELSE
11127             JNT   = JNT0(K)
11128             JS(1) = JS0(K)
11129             DO 13 INB=1,NB
11130                JT(INB) = JT0(K,INB)
11131    13       CONTINUE
11132             DO 14 I=1,JNT
11133                INTER1(I) = JI1(K,I)
11134                INTER2(I) = JI2(K,I)
11135    14       CONTINUE
11136          ENDIF
11137       ENDIF
11138
11139    19 CONTINUE
11140       INTA = 0
11141       INTB = 0
11142       DO 6 I=1,NA
11143         IF (JS(I).NE.0) INTA=INTA+1
11144     6 CONTINUE
11145       DO 7 I=1,NB
11146         IF (JT(I).NE.0) INTB=INTB+1
11147     7 CONTINUE
11148       ICWPG = INTA
11149       ICWTG = INTB
11150       ICIG  = JNT
11151       IPGLB = IPGLB+INTA
11152       ITGLB = ITGLB+INTB
11153       NGLB = NGLB+1
11154
11155       IF (NCOMPO.EQ.0) THEN
11156          NCALL = NCALL+1
11157          NWA(INTA) = NWA(INTA)+1
11158          NWB(INTB) = NWB(INTB)+1
11159       ENDIF
11160
11161       RETURN
11162       END
11163
11164 *$ CREATE DT_MODB.FOR
11165 *COPY DT_MODB
11166 *
11167 *===modb===============================================================*
11168 *
11169       SUBROUTINE DT_MODB(B,NIDX)
11170
11171 ************************************************************************
11172 * Sampling of impact parameter of collision.                           *
11173 *    B          impact parameter    (output)                           *
11174 *    NIDX       index of projectile/target material             (input)*
11175 * Based on the original version by Shmakov et al.                      *
11176 * This version dated 21.04.95 is revised by S. Roesler                 *
11177 *                                                                      *
11178 * Last change 27.12.2006 by S. Roesler.                                *
11179 ************************************************************************
11180
11181       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11182       SAVE
11183       PARAMETER ( LINP = 10 ,
11184      &            LOUT = 6 ,
11185      &            LDAT = 9 )
11186       PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11187
11188       LOGICAL LEFT,LFIRST
11189
11190 * central particle production, impact parameter biasing
11191       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11192       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11193 * Glauber formalism: parameters
11194       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11195      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11196      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11197      &                NSITEB,NSTATB
11198 * Glauber formalism: cross sections
11199       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11200      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11201      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11202      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11203      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11204      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11205      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11206      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11207      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11208      &                BSLOPE,NEBINI,NQBINI
11209
11210       DATA LFIRST /.TRUE./
11211
11212       NTARG = ABS(NIDX)
11213       IF (NIDX.LE.-1) THEN
11214          RA = RASH(1)
11215          RB = RBSH(NTARG)
11216       ELSE
11217          RA = RASH(NTARG)
11218          RB = RBSH(1)
11219       ENDIF
11220
11221       IF (ICENTR.EQ.2) THEN
11222          IF (RA.EQ.RB) THEN
11223             BB = DT_RNDM(B)*(0.3D0*RA)**2
11224             B  = SQRT(BB)
11225          ELSEIF(RA.LT.RB)THEN
11226             BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11227             B  = SQRT(BB)
11228          ELSEIF(RA.GT.RB)THEN
11229             BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11230             B  = SQRT(BB)
11231          ENDIF
11232       ELSE
11233     9    CONTINUE
11234          Y  = DT_RNDM(BB)
11235          I0 = 1
11236          I2 = NSITEB
11237    10    CONTINUE
11238          I1 = (I0+I2)/2
11239          LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11240      &          *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11241          IF (LEFT) GOTO 20
11242          I0 = I1
11243          GOTO 30
11244    20    CONTINUE
11245          I2 = I1
11246    30    CONTINUE
11247          IF (I2-I0-2) 40,50,60
11248    40    CONTINUE
11249          I1 = I2+1
11250          IF (I1.GT.NSITEB) I1 = I0-1
11251          GOTO 70
11252    50    CONTINUE
11253          I1 = I0+1
11254          GOTO 70
11255    60    CONTINUE
11256          GOTO 10
11257    70    CONTINUE
11258          X0 = DBLE(I0-1)*BSTEP(NTARG)
11259          X1 = DBLE(I1-1)*BSTEP(NTARG)
11260          X2 = DBLE(I2-1)*BSTEP(NTARG)
11261          Y0 = BSITE(0,1,NTARG,I0)
11262          Y1 = BSITE(0,1,NTARG,I1)
11263          Y2 = BSITE(0,1,NTARG,I2)
11264    80    CONTINUE
11265          B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11266      &       X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11267      &       X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11268 **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11269          B = B+0.5D0*BSTEP(NTARG)
11270          IF (B.LT.ZERO) B = X1
11271          IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11272          IF (ICENTR.LT.0) THEN
11273             IF (LFIRST) THEN
11274                LFIRST = .FALSE.
11275                IF (ICENTR.LE.-100) THEN
11276                   BIMIN  = 0.0D0
11277                ELSE
11278                   XSFRAC = 0.0D0
11279                ENDIF
11280                CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11281                WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11282      &                          BIMIN,BIMAX,XSFRAC*100.0D0,
11283      &                          XSFRAC*XSPRO(1,1,NTARG)
11284  10000         FORMAT(/,1X,'DT_MODB:      Biasing in impact parameter',
11285      &                /,15X,'---------------------------'/,/,4X,
11286      &                'average radii of proj / targ :',F10.3,' fm /',
11287      &                F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11288      &                F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11289      &                F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11290      &                ' cross section :',F10.3,' %',/,5X,
11291      &                'corresponding cross section :',F10.3,' mb',/)
11292             ENDIF
11293             IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11294                B = BIMIN
11295             ELSE
11296                IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11297             ENDIF
11298          ENDIF
11299       ENDIF
11300
11301       RETURN
11302       END
11303
11304 *$ CREATE DT_SHFAST.FOR
11305 *COPY DT_SHFAST
11306 *
11307 *===shfast=============================================================*
11308 *
11309       SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11310
11311       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11312       SAVE
11313       PARAMETER ( LINP = 10 ,
11314      &            LOUT = 6 ,
11315      &            LDAT = 9 )
11316       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11317      &           ONE=1.0D0,TWO=2.0D0)
11318
11319       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11320 * Glauber formalism: parameters
11321       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11322      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11323      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11324      &                NSITEB,NSTATB
11325 * properties of interacting particles
11326       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11327 * Glauber formalism: cross sections
11328       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11329      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11330      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11331      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11332      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11333      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11334      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11335      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11336      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11337      &                BSLOPE,NEBINI,NQBINI
11338
11339       IBACK = 0
11340
11341       IF (MODE.EQ.2) THEN
11342          OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11343          WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11344  1000    FORMAT(1X,8I5,E15.5)
11345          WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11346  1001    FORMAT(1X,4E15.5)
11347          WRITE(47,1002) SIGSH,ROSH,GSH
11348  1002    FORMAT(1X,3E15.5)
11349          DO 10 I=1,100
11350             WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11351    10    CONTINUE
11352          WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11353  1003    FORMAT(1X,2I10,3E15.5)
11354          CLOSE(47)
11355       ELSE
11356          OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11357          READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11358          IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11359      &       (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11360      &       .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11361      &       (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11362             READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11363             READ(47,1002) SIGSH,ROSH,GSH
11364             DO 11 I=1,100
11365                READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11366    11       CONTINUE
11367             READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11368          ELSE
11369             IBACK = 1
11370          ENDIF
11371          CLOSE(47)
11372       ENDIF
11373
11374       RETURN
11375       END
11376
11377 *$ CREATE DT_POILIK.FOR
11378 *COPY DT_POILIK
11379 *
11380 *===poilik=============================================================*
11381 *
11382       SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11383
11384       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11385       SAVE
11386
11387       PARAMETER ( LINP = 10 ,
11388      &            LOUT = 6 ,
11389      &            LDAT = 9 )
11390       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11391       PARAMETER (NE = 8)
11392
11393 **PHOJET105a
11394 C     CHARACTER*8 MDLNA
11395 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11396 C     PARAMETER (IEETAB=10)
11397 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11398 **PHOJET110
11399 C  model switches and parameters
11400       CHARACTER*8 MDLNA
11401       INTEGER ISWMDL,IPAMDL
11402       DOUBLE PRECISION PARMDL
11403       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11404 C  energy-interpolation table
11405       INTEGER IEETA2
11406       PARAMETER ( IEETA2 = 20 )
11407       INTEGER ISIMAX
11408       DOUBLE PRECISION SIGTAB,SIGECM
11409       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11410 **
11411 * VDM parameter for photon-nucleus interactions
11412       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11413 **sr 22.7.97
11414       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11415 * Glauber formalism: cross sections
11416       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11417      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11418      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11419      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11420      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11421      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11422      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11423      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11424      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11425      &                BSLOPE,NEBINI,NQBINI
11426 **
11427
11428       DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
11429
11430       IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
11431
11432 * load cross sections from interpolation table
11433       IP = 1
11434       IF(ECM.LE.SIGECM(IP,1)) THEN
11435         I1 = 1
11436         I2 = 1
11437       ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
11438         DO 50 I=2,ISIMAX
11439           IF(ECM.LE.SIGECM(IP,I)) GOTO 200
11440   50    CONTINUE
11441  200    CONTINUE
11442         I1 = I-1
11443         I2 = I
11444       ELSE
11445         WRITE(LOUT,'(/1X,A,2E12.3)')
11446      &    'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
11447         I1 = ISIMAX
11448         I2 = ISIMAX
11449       ENDIF
11450       FAC2 = ZERO
11451       IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
11452      &                     /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
11453       FAC1 = ONE-FAC2
11454
11455       SIGANO = DT_SANO(ECM)
11456
11457 * cross section dependence on photon virtuality
11458       FSUP1 = ZERO
11459       DO  150 I=1,3
11460          FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
11461      &                             /(ONE+VIRT/PARMDL(30+I))**2
11462  150  CONTINUE
11463       FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
11464       FAC1  = FAC1*FSUP1
11465       FAC2  = FAC2*FSUP1
11466       FSUP2 = ONE
11467
11468       ECMOLD = ECM
11469       Q2OLD  = VIRT
11470
11471     3 CONTINUE
11472
11473 C     SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
11474       CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
11475       IF (ISHAD(1).EQ.1) THEN
11476          SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
11477       ELSE
11478          SIGDIR = ZERO
11479       ENDIF
11480       SIGANO = FSUP1*FSUP2*SIGANO
11481       SIGTOT = SIGTOT-SIGDIR-SIGANO
11482       SIGDIR = SIGDIR/(FSUP1*FSUP2)
11483       SIGANO = SIGANO/(FSUP1*FSUP2)
11484       SIGTOT = SIGTOT+SIGDIR+SIGANO
11485
11486       RR = DT_RNDM(SIGTOT)
11487       IF (RR.LT.SIGDIR/SIGTOT) THEN
11488          IPNT = 1
11489       ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
11490      &        (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
11491          IPNT = 2
11492       ELSE
11493          IPNT = 0
11494       ENDIF
11495       RPNT = (SIGDIR+SIGANO)/SIGTOT
11496 C     WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
11497 C     WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
11498 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
11499 C     WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
11500       IF (MODE.EQ.1) RETURN
11501
11502 **sr 22.7.97
11503       K1   = 1
11504       K2   = 1
11505       RATE = ZERO
11506       IF (ECM.GE.ECMNN(NEBINI)) THEN
11507          K1   = NEBINI
11508          K2   = NEBINI
11509          RATE = ONE
11510       ELSEIF (ECM.GT.ECMNN(1)) THEN
11511          DO 10 I=2,NEBINI
11512             IF (ECM.LT.ECMNN(I)) THEN
11513                K1   = I-1
11514                K2   = I
11515                RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
11516                GOTO 11
11517             ENDIF
11518    10    CONTINUE
11519    11    CONTINUE
11520       ENDIF
11521       J1   = 1
11522       J2   = 1
11523       RATQ = ZERO
11524       IF (NQBINI.GT.1) THEN
11525          IF (VIRT.GE.Q2G(NQBINI)) THEN
11526             J1   = NQBINI
11527             J2   = NQBINI
11528             RATQ = ONE
11529          ELSEIF (VIRT.GT.Q2G(1)) THEN
11530             DO 12 I=2,NQBINI
11531                IF (VIRT.LT.Q2G(I)) THEN
11532                   J1   = I-1
11533                   J2   = I
11534                   RATQ = LOG10(   VIRT/MAX(Q2G(J1),TINY14))/
11535      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11536                   GOTO 13
11537                ENDIF
11538    12       CONTINUE
11539    13       CONTINUE
11540          ENDIF
11541       ENDIF
11542       SGA = XSPRO(K1,J1,NTARG)+
11543      &      RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
11544      &      RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
11545      &      RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
11546      &                 XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
11547       SDI = DBLE(NB)*SIGDIR
11548       SAN = DBLE(NB)*SIGANO
11549       SPL = SDI+SAN
11550       RR = DT_RNDM(SPL)
11551       IF (RR.LT.SDI/SGA) THEN
11552          IPNT = 1
11553       ELSEIF ((RR.GE.SDI/SGA).AND.
11554      &        (RR.LT.SPL/SGA)) THEN
11555          IPNT = 2
11556       ELSE
11557          IPNT = 0
11558       ENDIF
11559       RPNT = SPL/SGA
11560 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
11561 **
11562
11563       RETURN
11564       END
11565
11566 *$ CREATE DT_GLBINI.FOR
11567 *COPY DT_GLBINI
11568 *
11569 *===glbini=============================================================*
11570 *
11571       SUBROUTINE DT_GLBINI(WHAT)
11572
11573 ************************************************************************
11574 * Pre-initialization of profile function                               *
11575 * This version dated 28.11.00 is written by S. Roesler.                *
11576 *                                                                      *
11577 * Last change 27.12.2006 by S. Roesler.                                *
11578 ************************************************************************
11579
11580       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11581       SAVE
11582
11583       PARAMETER ( LINP = 10 ,
11584      &            LOUT = 6 ,
11585      &            LDAT = 9 )
11586       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
11587
11588       LOGICAL LCMS
11589
11590 * particle properties (BAMJET index convention)
11591       CHARACTER*8  ANAME
11592       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11593      &                IICH(210),IIBAR(210),K1(210),K2(210)
11594 * properties of interacting particles
11595       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11596       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11597 * emulsion treatment
11598       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11599      &                NCOMPO,IEMUL
11600 * Glauber formalism: flags and parameters for statistics
11601       LOGICAL LPROD
11602       CHARACTER*8 CGLB
11603       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11604 * number of data sets other than protons and nuclei
11605 * at the moment = 2 (pions and kaons)
11606       PARAMETER (MAXOFF=2)
11607       DIMENSION IJPINI(5),IOFFST(25)
11608       DATA IJPINI / 13, 15,  0,  0,  0/
11609 * Glauber data-set to be used for hadron projectiles
11610 * (0=proton, 1=pion, 2=kaon)
11611       DATA (IOFFST(K),K=1,25) /
11612      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11613      &  0, 0, 1, 2, 2/
11614 * Acceptance interval for target nucleus mass
11615       PARAMETER (KBACC = 6)
11616 * flags for input different options
11617       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
11618       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
11619      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
11620
11621       PARAMETER (MAXMSS = 100)
11622       DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
11623       DIMENSION WHAT(6)
11624
11625       DATA JPEACH,JPSTEP / 18, 5 /
11626
11627 * temporary patch until fix has been implemented in phojet:
11628 *  maximum energy for pion projectile
11629       DATA ECMXPI / 100000.0D0 /
11630 *
11631 *--------------------------------------------------------------------------
11632 * general initializations
11633 *
11634 *  steps in projectile mass number for initialization
11635       IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
11636       IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
11637 *
11638 *  energy range and binning
11639       ELO  = ABS(WHAT(1))
11640       EHI  = ABS(WHAT(2))
11641       IF (ELO.GT.EHI) ELO = EHI
11642       NEBIN = MAX(INT(WHAT(3)),1)
11643       IF (ELO.EQ.EHI) NEBIN = 0
11644       LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
11645       IF (LCMS) THEN
11646          ECMINI = EHI
11647       ELSE
11648          ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
11649      &                 +2.0D0*AAM(IJTARG)*EHI)
11650       ENDIF
11651 *
11652 *  default arguments for Glauber-routine
11653       XI  = ZERO
11654       Q2I = ZERO
11655 *
11656 *  initialize nuclear parameters, etc.
11657       CALL DT_BERTTP
11658       CALL DT_INCINI
11659 *
11660 *  open Glauber-data output file
11661       IDX = INDEX(CGLB,' ')
11662       K   = 12
11663       IF (IDX.GT.1) K = IDX-1
11664       OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11665 *
11666 *--------------------------------------------------------------------------
11667 * Glauber-initialization for proton and nuclei projectiles
11668 *
11669 *  initialize phojet for proton-proton interactions
11670       ELAB = ZERO
11671       PLAB = ZERO
11672       CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11673       CALL DT_PHOINI
11674 *
11675 *  record projectile masses
11676       NASAV = 0
11677       NPROJ = MIN(IP,JPEACH)
11678       DO 10 KPROJ=1,NPROJ
11679          NASAV = NASAV+1
11680          IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11681          IASAV(NASAV) = KPROJ
11682    10 CONTINUE
11683       IF (IP.GT.JPEACH) THEN
11684          NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
11685          IF (NPROJ.EQ.0) THEN
11686             NASAV = NASAV+1
11687             IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11688             IASAV(NASAV) = IP
11689          ELSE
11690             DO 11 IPROJ=1,NPROJ
11691                KPROJ = JPEACH+IPROJ*JPSTEP
11692                NASAV = NASAV+1
11693                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11694                IASAV(NASAV) = KPROJ
11695    11       CONTINUE
11696             IF (KPROJ.LT.IP) THEN
11697                NASAV = NASAV+1
11698                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11699                IASAV(NASAV) = IP
11700             ENDIF
11701          ENDIF
11702       ENDIF
11703 *
11704 *  record target masses
11705       NBSAV = 0
11706       NTARG = 1
11707       IF (NCOMPO.GT.0) NTARG = NCOMPO
11708       DO 12 ITARG=1,NTARG
11709          NBSAV = NBSAV+1
11710          IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
11711          IF (NCOMPO.GT.0) THEN
11712             IBSAV(NBSAV) = IEMUMA(ITARG)
11713          ELSE
11714             IBSAV(NBSAV) = IT
11715          ENDIF
11716    12 CONTINUE
11717 *
11718 *  print masses
11719       WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
11720  1000 FORMAT(I4,A,1P,2E13.5)
11721       NLINES = DBLE(NASAV)/18.0D0
11722       IF (NLINES.GT.0) THEN
11723          DO 13 I=1,NLINES
11724             IF (I.EQ.1) THEN
11725                WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
11726             ELSE
11727                WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
11728             ENDIF
11729    13    CONTINUE
11730       ENDIF
11731       I0 = 18*NLINES+1
11732       IF (I0.LE.NASAV) THEN
11733          IF (I0.EQ.1) THEN
11734             WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
11735          ELSE
11736             WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
11737          ENDIF
11738       ENDIF
11739       NLINES = DBLE(NBSAV)/18.0D0
11740       IF (NLINES.GT.0) THEN
11741          DO 14 I=1,NLINES
11742             IF (I.EQ.1) THEN
11743                WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
11744             ELSE
11745                WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
11746             ENDIF
11747    14    CONTINUE
11748       ENDIF
11749       I0 = 18*NLINES+1
11750       IF (I0.LE.NBSAV) THEN
11751          IF (I0.EQ.1) THEN
11752             WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
11753          ELSE
11754             WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
11755          ENDIF
11756       ENDIF
11757 *
11758 *  calculate Glauber-data for each energy and mass combination
11759 *
11760 *   loop over energy bins
11761       ELO = LOG10(ELO)
11762       EHI = LOG10(EHI)
11763       DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
11764       DO 1 IE=1,NEBIN+1
11765          E = ELO+DBLE(IE-1)*DEBIN
11766          E = 10**E
11767          IF (LCMS) THEN
11768             E   = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
11769             ECM = E
11770          ELSE
11771             PLAB = ZERO
11772             ECM  = ZERO
11773             E    = MAX(AAM(IJPROJ)+0.1D0,E)
11774             CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11775          ENDIF
11776 *
11777 *   loop over projectile and target masses
11778          DO 2 ITARG=1,NBSAV
11779             DO 3 IPROJ=1,NASAV
11780                CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
11781      &                                       XI,Q2I,ECM,1,1,-1)
11782     3       CONTINUE
11783     2    CONTINUE
11784 *
11785     1 CONTINUE
11786 *
11787 *--------------------------------------------------------------------------
11788 * Glauber-initialization for pion, kaon, ... projectiles
11789 *
11790       DO 6 IJ=1,MAXOFF
11791 *
11792 *  initialize phojet for this interaction
11793          ELAB = ZERO
11794          PLAB = ZERO
11795          IJPROJ = IJPINI(IJ)
11796          IP     = 1
11797          IPZ    = 1
11798 *
11799 *   temporary patch until fix has been implemented in phojet:
11800          IF (ECMINI.GT.ECMXPI) THEN
11801             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
11802          ELSE
11803             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11804          ENDIF
11805          CALL DT_PHOINI
11806 *
11807 *  calculate Glauber-data for each energy and mass combination
11808 *
11809 *   loop over energy bins
11810          DO 4 IE=1,NEBIN+1
11811             E = ELO+DBLE(IE-1)*DEBIN
11812             E = 10**E
11813             IF (LCMS) THEN
11814                E   = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
11815                ECM = E
11816             ELSE
11817                PLAB = ZERO
11818                ECM  = ZERO
11819                E    = MAX(AAM(IJPROJ)+TINY14,E)
11820                CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11821             ENDIF
11822 *
11823 *   loop over projectile and target masses
11824             DO 5 ITARG=1,NBSAV
11825                CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
11826     5       CONTINUE
11827 *
11828     4    CONTINUE
11829 *
11830     6 CONTINUE
11831
11832 *--------------------------------------------------------------------------
11833 * close output unit(s), etc.
11834 *
11835       CLOSE(LDAT)
11836
11837       RETURN
11838       END
11839
11840 *$ CREATE DT_GLBSET.FOR
11841 *COPY DT_GLBSET
11842 *
11843 *===glbset=============================================================*
11844 *
11845       SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
11846 ************************************************************************
11847 * Interpolation of pre-initialized profile functions                   *
11848 * This version dated 28.11.00 is written by S. Roesler.                *
11849 ************************************************************************
11850
11851       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11852       SAVE
11853
11854       PARAMETER ( LINP = 10 ,
11855      &            LOUT = 6 ,
11856      &            LDAT = 9 )
11857       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
11858
11859       LOGICAL LCMS,LREAD,LFRST1,LFRST2
11860
11861 * particle properties (BAMJET index convention)
11862       CHARACTER*8  ANAME
11863       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11864      &                IICH(210),IIBAR(210),K1(210),K2(210)
11865 * Glauber formalism: flags and parameters for statistics
11866       LOGICAL LPROD
11867       CHARACTER*8 CGLB
11868       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11869       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11870 * Glauber formalism: parameters
11871       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11872      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11873      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11874      &                NSITEB,NSTATB
11875 * Glauber formalism: cross sections
11876       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11877      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11878      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11879      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11880      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11881      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11882      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11883      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11884      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11885      &                BSLOPE,NEBINI,NQBINI
11886 * number of data sets other than protons and nuclei
11887 * at the moment = 2 (pions and kaons)
11888       PARAMETER (MAXOFF=2)
11889       DIMENSION IJPINI(5),IOFFST(25)
11890       DATA IJPINI / 13, 15,  0,  0,  0/
11891 * Glauber data-set to be used for hadron projectiles
11892 * (0=proton, 1=pion, 2=kaon)
11893       DATA (IOFFST(K),K=1,25) /
11894      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11895      &  0, 0, 1, 2, 2/
11896 * Acceptance interval for target nucleus mass
11897       PARAMETER (KBACC = 6)
11898 * emulsion treatment
11899       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11900      &                NCOMPO,IEMUL
11901
11902       PARAMETER (MAXSET=5000,
11903      &           MAXBIN=100)
11904       DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
11905       DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
11906      &          BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
11907      &          IAIDX(10)
11908
11909       DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
11910 *
11911 * read data from file
11912 *
11913       IF (MODE.EQ.0) THEN
11914
11915          IF (LREAD) RETURN
11916
11917          DO 1 I=1,MAXSET
11918             DO 2 J=1,6
11919                XSIG(I,J) = ZERO
11920                XERR(I,J) = ZERO
11921     2       CONTINUE
11922             DO 3 J=1,KSITEB
11923                BPROFL(I,J) = ZERO
11924     3       CONTINUE
11925     1    CONTINUE
11926          DO 4 I=1,MAXBIN
11927             IABIN(I) = 0
11928             IBBIN(I) = 0
11929     4    CONTINUE
11930          DO 5 I=1,KSITEB
11931             BPRO0(I) = ZERO
11932             BPRO1(I) = ZERO
11933             BPRO(I)  = ZERO
11934     5    CONTINUE
11935
11936          IDX = INDEX(CGLB,' ')
11937          K   = 12
11938          IF (IDX.GT.1) K = IDX-1
11939          OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11940          WRITE(LOUT,1000) CGLB(1:K)//'.glb'
11941  1000    FORMAT(/,' GLBSET: impact parameter distributions read from ',
11942      &          'file ',A12,/)
11943 *
11944 *  read binning information
11945          READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
11946 *  return lower energy threshold to Fluka-interface
11947          ELAB = ELO
11948          LCMS = ELO.LT.ZERO
11949          WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
11950          IF (LCMS) THEN
11951             WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
11952          ELSE
11953             WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
11954          ENDIF
11955  1001    FORMAT(2X,A5,'  E_lo = ',1P,E9.3,'  E_hi = ',1P,E9.3,4X,
11956      &          'No. of bins:',I5,/)
11957          ELO  = LOG10(ABS(ELO))
11958          EHI  = LOG10(ABS(EHI))
11959          DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
11960          WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
11961          READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
11962          IF (NABIN.LT.18) THEN
11963             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
11964          ELSE
11965             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
11966          ENDIF
11967          IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
11968          IF (NABIN.GT.18) THEN
11969             NLINES = DBLE(NABIN-18)/18.0D0
11970             IF (NLINES.GT.0) THEN
11971                DO 7 I=1,NLINES
11972                   I0 = 18*(I+1)-17
11973                   READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11974                   WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11975     7          CONTINUE
11976             ENDIF
11977             I0 = 18*(NLINES+1)+1
11978             IF (I0.LE.NABIN) THEN
11979                READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11980                WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11981             ENDIF
11982          ENDIF
11983          WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
11984          READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
11985          IF (NBBIN.LT.18) THEN
11986             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
11987          ELSE
11988             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
11989          ENDIF
11990          IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
11991          IF (NBBIN.GT.18) THEN
11992             NLINES = DBLE(NBBIN-18)/18.0D0
11993             IF (NLINES.GT.0) THEN
11994                DO 8 I=1,NLINES
11995                   I0 = 18*(I+1)-17
11996                   READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
11997                   WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
11998     8          CONTINUE
11999             ENDIF
12000             I0 = 18*(NLINES+1)+1
12001             IF (I0.LE.NBBIN) THEN
12002                READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12003                WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12004             ENDIF
12005          ENDIF
12006 *  number of data sets to follow in the Glauber data file
12007 *   this variable is used for checks of consistency of projectile
12008 *   and target mass configurations given in header of Glauber data
12009 *   file and the data-sets which follow in this file
12010          NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
12011 *
12012 *  read profile function data
12013          NSET  = 0
12014          NAIDX = 0
12015          IPOLD = 0
12016    10    CONTINUE
12017          NSET = NSET+1
12018          IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
12019          READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
12020  1002    FORMAT(5I10,E15.5)
12021          IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12022             NAIDX = NAIDX+1
12023             IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12024             IAIDX(NAIDX) = IP
12025             IPOLD = IP
12026          ENDIF
12027          READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12028          READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12029          NLINES = INT(DBLE(ISITEB)/7.0D0)
12030          IF (NLINES.GT.0) THEN
12031             DO 11 I=1,NLINES
12032                READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12033    11       CONTINUE
12034          ENDIF
12035          I0 = 7*NLINES+1
12036          IF (I0.LE.ISITEB)
12037      &      READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12038          GOTO 10
12039   100    CONTINUE
12040          NSET = NSET-1
12041          IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12042          WRITE(LOUT,'(/,1X,A)')
12043      &   ' projectiles other than protons and nuclei: (particle index)'
12044          IF (NAIDX.GT.0) THEN
12045             WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12046          ELSE
12047             WRITE(LOUT,'(6X,A)') 'none'
12048          ENDIF
12049 *
12050          CLOSE(LDAT)
12051          WRITE(LOUT,*)
12052          LREAD = .TRUE.
12053
12054          IF (NCOMPO.EQ.0) THEN
12055             DO 12 J=1,NBBIN
12056                NCOMPO = NCOMPO+1
12057                IEMUMA(NCOMPO) = IBBIN(J)
12058                IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12059                EMUFRA(NCOMPO) = 1.0D0
12060    12       CONTINUE
12061             IEMUL = 1
12062          ENDIF
12063 *
12064 * calculate profile function for certain set of parameters
12065 *
12066       ELSE
12067
12068 c        write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12069 *
12070 * check for type of projectile and set index-offset to entry in
12071 * Glauber data array correspondingly
12072          IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12073          IF (IOFFST(IDPROJ).EQ.-1) THEN
12074             STOP ' GLBSET: no data for this projectile !'
12075          ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12076             IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12077          ELSE
12078             IDXOFF = 0
12079          ENDIF
12080 *
12081 * get energy bin and interpolation factor
12082          IF (LCMS) THEN
12083             E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12084          ELSE
12085             E = ELAB
12086          ENDIF
12087          E = LOG10(E)
12088          IF (E.LT.ELO) THEN
12089             IF (LFRST1) THEN
12090                WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12091                LFRST1 = .FALSE.
12092             ENDIF
12093             E = ELO
12094          ENDIF
12095          IF (E.GT.EHI) THEN
12096             IF (LFRST2) THEN
12097                WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12098                LFRST2 = .FALSE.
12099             ENDIF
12100             E = EHI
12101          ENDIF
12102          IE0  = (E-ELO)/DEBIN+1
12103          IE1  = IE0+1
12104          FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12105 *
12106 * get target nucleus index
12107          KB = 0
12108          NBACC = KBACC
12109          DO 20 I=1,NBBIN
12110             NBDIFF = ABS(NB-IBBIN(I))
12111             IF (NB.EQ.IBBIN(I)) THEN
12112                KB = I
12113                GOTO 21
12114             ELSEIF (NBDIFF.LE.NBACC) THEN
12115                KB = I
12116                NBACC = NBDIFF
12117             ENDIF
12118    20    CONTINUE
12119          IF (KB.NE.0) GOTO 21
12120          WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12121          STOP
12122    21    CONTINUE
12123 *
12124 * get projectile nucleus bin and interpolation factor
12125          KA0 = 0
12126          KA1 = 0
12127          FACNA = 0
12128          IF (IDXOFF.GT.0) THEN
12129             KA0 = 1
12130             KA1 = 1
12131             KABIN = 1
12132          ELSE
12133             IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12134             DO 22 I=1,NABIN
12135                IF (NA.EQ.IABIN(I)) THEN
12136                   KA0 = I
12137                   KA1 = I
12138                   GOTO 23
12139                ELSEIF (NA.LT.IABIN(I)) THEN
12140                   KA0 = I-1
12141                   KA1 = I
12142                   GOTO 23
12143                ENDIF
12144    22       CONTINUE
12145             WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12146             STOP
12147    23       CONTINUE
12148             IF (KA0.NE.KA1)
12149      &         FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12150             KABIN = NABIN
12151          ENDIF
12152 *
12153 * interpolate profile functions for interactions ka0-kb and ka1-kb
12154 * for energy E separately
12155          IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12156          IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12157          IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12158          IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12159          DO 30 I=1,ISITEB
12160             BPRO0(I) = BPROFL(IDX0,I)
12161      &                 +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12162             BPRO1(I) = BPROFL(IDY0,I)
12163      &                 +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12164    30    CONTINUE
12165          RADB  = DT_RNCLUS(NB)
12166          BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12167          BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12168 *
12169 * interpolate cross sections for energy E and projectile mass
12170          DO 31 I=1,6
12171             XS0   = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12172             XS1   = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12173             XS(I) = XS0+FACNA*(XS1-XS0)
12174             XE0   = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12175             XE1   = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12176             XE(I) = XE0+FACNA*(XE1-XE0)
12177    31    CONTINUE
12178 *
12179 * interpolate between ka0 and ka1
12180          RADA = DT_RNCLUS(NA)
12181          BMX  = 2.0D0*(RADA+RADB)
12182          BSTP = BMX/DBLE(ISITEB-1)
12183          BPRO(1) = ZERO
12184          DO 32 I=1,ISITEB-1
12185             B = DBLE(I)*BSTP
12186 *
12187 *   calculate values of profile functions at B
12188             IDX0 = B/BSTP0+1
12189             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12190             IDX1 = MIN(IDX0+1,ISITEB)
12191             FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12192             BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12193             IDX0 = B/BSTP1+1
12194             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12195             IDX1 = MIN(IDX0+1,ISITEB)
12196             FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12197             BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12198 *
12199             BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12200    32    CONTINUE
12201 *
12202 * fill common dtglam
12203          NSITEB   = ISITEB
12204          RASH(1)  = RADA
12205          RBSH(1)  = RADB
12206          BMAX(1)  = BMX
12207          BSTEP(1) = BSTP
12208          DO 33 I=1,KSITEB
12209             BSITE(0,1,1,I) = BPRO(I)
12210    33    CONTINUE
12211 *
12212 * fill common dtglxs
12213          XSTOT(1,1,1) = XS(1)
12214          XSELA(1,1,1) = XS(2)
12215          XSQEP(1,1,1) = XS(3)
12216          XSQET(1,1,1) = XS(4)
12217          XSQE2(1,1,1) = XS(5)
12218          XSPRO(1,1,1) = XS(6)
12219          XETOT(1,1,1) = XE(1)
12220          XEELA(1,1,1) = XE(2)
12221          XEQEP(1,1,1) = XE(3)
12222          XEQET(1,1,1) = XE(4)
12223          XEQE2(1,1,1) = XE(5)
12224          XEPRO(1,1,1) = XE(6)
12225
12226       ENDIF
12227
12228       RETURN
12229       END
12230
12231 *$ CREATE DT_XKSAMP.FOR
12232 *COPY DT_XKSAMP
12233 *
12234 *===xksamp=============================================================*
12235 *
12236       SUBROUTINE DT_XKSAMP(NN,ECM)
12237
12238 ************************************************************************
12239 * Sampling of parton x-values and chain system for one interaction.    *
12240 *                                   processed by S. Roesler, 9.8.95    *
12241 ************************************************************************
12242
12243       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12244       SAVE
12245       PARAMETER ( LINP = 10 ,
12246      &            LOUT = 6 ,
12247      &            LDAT = 9 )
12248       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12249 CPH      SAVE
12250
12251       PARAMETER (
12252 * lower cuts for (valence-sea/sea-valence) chain masses
12253 *   antiquark-quark (u/d-sea quark)    (s-sea quark)
12254      &               AMIU = 0.5D0,      AMIS = 0.8D0,
12255 *   quark-diquark   (u/d-sea quark)    (s-sea quark)
12256      &               AMAU = 2.6D0,      AMAS = 2.6D0,
12257 * maximum lower valence-x threshold
12258      &           XVMAX  = 0.98D0,
12259 * fraction of sea-diquarks sampled out of sea-partons
12260 **test
12261 C    &           FRCDIQ = 0.9D0,
12262 **
12263 *
12264      &           SQMA   = 0.7D0,
12265 *
12266 * maximum number of trials to generate x's for the required number
12267 * of sea quark pairs for a given hadron
12268      &           NSEATY = 12
12269 C    &           NSEATY = 3
12270      &          )
12271
12272       LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12273
12274       PARAMETER ( MAXNCL = 260,
12275      &            MAXVQU = MAXNCL,
12276      &            MAXSQU = 20*MAXVQU,
12277      &            MAXINT = MAXVQU+MAXSQU)
12278 * event history
12279       PARAMETER (NMXHKK=200000)
12280       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12281      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12282      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12283 * particle properties (BAMJET index convention)
12284       CHARACTER*8  ANAME
12285       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12286      &                IICH(210),IIBAR(210),K1(210),K2(210)
12287 * interface between Glauber formalism and DPM
12288       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12289      &                INTER1(MAXINT),INTER2(MAXINT)
12290 * properties of interacting particles
12291       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12292 * threshold values for x-sampling (DTUNUC 1.x)
12293       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12294      &                SSMIMQ,VVMTHR
12295 * x-values of partons (DTUNUC 1.x)
12296       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12297      &                XTVQ(MAXVQU),XTVD(MAXVQU),
12298      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
12299      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
12300 * flavors of partons (DTUNUC 1.x)
12301       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12302      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12303      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
12304      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12305      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
12306      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12307      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
12308 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12309       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12310      &                IXPV,IXPS,IXTV,IXTS,
12311      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
12312      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
12313      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
12314      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
12315      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
12316      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
12317      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
12318      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
12319 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12320       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12321      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12322 * auxiliary common for chain system storage (DTUNUC 1.x)
12323       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12324 * flags for input different options
12325       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12326       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12327      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12328 * various options for treatment of partons (DTUNUC 1.x)
12329 * (chain recombination, Cronin,..)
12330       LOGICAL LCO2CR,LINTPT
12331       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12332      &                LCO2CR,LINTPT
12333
12334       DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12335      &          INTLO(MAXINT)
12336
12337 * (1) initializations
12338 *-----------------------------------------------------------------------
12339
12340 **test
12341       IF (ECM.LT.4.5D0) THEN
12342 C        FRCDIQ = 0.6D0
12343          FRCDIQ = 0.4D0
12344       ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12345 C        FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12346          FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12347       ELSE
12348 C        FRCDIQ = 0.9D0
12349          FRCDIQ = 0.7D0
12350       ENDIF
12351 **
12352       DO 30 I=1,MAXSQU
12353          ZUOSP(I) = .FALSE.
12354          ZUOST(I) = .FALSE.
12355          IF (I.LE.MAXVQU) THEN
12356             ZUOVP(I) = .FALSE.
12357             ZUOVT(I) = .FALSE.
12358          ENDIF
12359    30 CONTINUE
12360
12361 * lower thresholds for x-selection
12362 *  sea-quarks       (default: CSEA=0.2)
12363       IF (ECM.LT.10.0D0) THEN
12364 **!!test
12365          XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12366 C        XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12367          NSEA  = NSEATY
12368 C        XSTHR = ONE/ECM**2
12369       ELSE
12370 **sr 30.3.98
12371 C        XSTHR = CSEA/ECM
12372          XSTHR = CSEA/ECM**2
12373 C        XSTHR = ONE/ECM**2
12374 **
12375          IF ((IP.GE.150).AND.(IT.GE.150))
12376      &      XSTHR = 2.5D0/(ECM*SQRT(ECM))
12377          NSEA  = NSEATY
12378       ENDIF
12379 *                   (default: SSMIMA=0.14) used for sea-diquarks (?)
12380       XSSTHR = SSMIMA/ECM
12381       BSQMA  = SQMA/ECM
12382 *  valence-quarks   (default: CVQ=1.0)
12383       XVTHR  = CVQ/ECM
12384 *  valence-diquarks (default: CDQ=2.0)
12385       XDTHR  = CDQ/ECM
12386
12387 * maximum-x for sea-quarks
12388       XVCUT  = XVTHR+XDTHR
12389       IF (XVCUT.GT.XVMAX) THEN
12390          XVCUT = XVMAX
12391          XVTHR = XVCUT/3.0D0
12392          XDTHR = XVCUT-XVTHR
12393       ENDIF
12394       XXSEAM = ONE-XVCUT
12395 **sr 18.4. test: DPMJET
12396 C     XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
12397 C    &            - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
12398 C    &             -0.01*(1.D0+1.5D0*DT_RNDM(V3))
12399 **
12400 * maximum number of sea-pairs allowed kinematically
12401 C     NSMAX  = INT(OHALF*XXSEAM/XSTHR)
12402       RNSMAX = OHALF*XXSEAM/XSTHR
12403       IF (RNSMAX.GT.10000.0D0) THEN
12404          NSMAX = 10000
12405       ELSE
12406          NSMAX = INT(OHALF*XXSEAM/XSTHR)
12407       ENDIF
12408 * check kinematical limit for valence-x thresholds
12409 * (should be obsolete now)
12410       IF (XVCUT.GT.XVMAX) THEN
12411          WRITE(LOUT,1000) XVCUT,ECM
12412  1000    FORMAT(' XKSAMP:    kin. limit for valence-x',
12413      &          '  thresholds not allowed (',2E9.3,')')
12414 C        XVTHR = XVMAX-XDTHR
12415 C        IF (XVTHR.LT.ZERO) STOP
12416          STOP
12417       ENDIF
12418
12419 * set eta for valence-x sampling (BETREJ)
12420 *   (UNON per default, UNOM used for projectile mesons only)
12421       IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
12422          UNOPRV = UNOM
12423       ELSE
12424          UNOPRV = UNON
12425       ENDIF
12426
12427 * (2) select parton x-values of interacting projectile nucleons
12428 *-----------------------------------------------------------------------
12429
12430       IXPV = 0
12431       IXPS = 0
12432
12433       DO 100 IPP=1,IP
12434 *   get interacting projectile nucleon as sampled by Glauber
12435          IF (JSSH(IPP).NE.0) THEN
12436             IXSTMP = IXPS
12437             IXVTMP = IXPV
12438    99       CONTINUE
12439             IXPS   = IXSTMP
12440             IXPV   = IXVTMP
12441 *     JIPP is the actual number of sea-pairs sampled for this nucleon
12442             JIPP   = MIN(JSSH(IPP)-1,NSMAX)
12443    41       CONTINUE
12444             XXSEA  = ZERO
12445             IF (JIPP.GT.0) THEN
12446                XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
12447 *???
12448                IF (XSTHR.GE.XSMAX) THEN
12449                   JIPP = JIPP-1
12450                   GOTO 41
12451                ENDIF
12452
12453 *>>>get x-values of sea-quark pairs
12454                NSCOUN = 0
12455                PLW = 0.5D0
12456    40          CONTINUE
12457 *     accumulator for sea x-values
12458                XXSEA  = ZERO
12459                NSCOUN = NSCOUN+1
12460                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12461                IF (NSCOUN.GT.NSEA) THEN
12462 *     decrease the number of interactions after NSEA trials
12463                   JIPP   = JIPP-1
12464                   NSCOUN = 0
12465                ENDIF
12466                DO 70 ISQ=1,JIPP
12467 *     sea-quarks
12468                   IF (IPSQ(IXPS+1).LE.2) THEN
12469 **sr 8.4.98 (1/sqrt(x))
12470 C                    XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12471 C                    XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12472                      XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12473 **
12474                   ELSE
12475                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12476                         XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12477                      ELSE
12478 **sr 8.4.98 (1/sqrt(x))
12479 C                       XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12480 C                       XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12481                         XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12482 **
12483                      ENDIF
12484                   ENDIF
12485 *     sea-antiquarks
12486                   IF (IPSAQ(IXPS+1).GE.-2) THEN
12487 **sr 8.4.98 (1/sqrt(x))
12488 C                    XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12489 C                    XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12490                      XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12491 **
12492                   ELSE
12493                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12494                         XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12495                      ELSE
12496 **sr 8.4.98 (1/sqrt(x))
12497 C                       XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12498 C                       XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12499                         XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12500 **
12501                      ENDIF
12502                   ENDIF
12503                   XXSEA = XXSEA+XPSQI+XPSAQI
12504 *     check for maximum allowed sea x-value
12505                   IF (XXSEA.GE.XXSEAM) THEN
12506                      IXPS = IXPS-ISQ+1
12507                      GOTO 40
12508                   ENDIF
12509 *     accept this sea-quark pair
12510                   IXPS         = IXPS+1
12511                   XPSQ(IXPS)   = XPSQI
12512                   XPSAQ(IXPS)  = XPSAQI
12513                   IFROSP(IXPS) = IPP
12514                   ZUOSP(IXPS)  = .TRUE.
12515    70          CONTINUE
12516             ENDIF
12517
12518 *>>>get x-values of valence partons
12519 *     valence quark
12520             IF (XVTHR.GT.0.05D0) THEN
12521                XVHI  = ONE-XXSEA-XDTHR
12522                XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
12523             ELSE
12524    90          CONTINUE
12525                XPVQI = DT_DBETAR(OHALF,UNOPRV)
12526                IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
12527      &                                                     GOTO 90
12528             ENDIF
12529 *     valence diquark
12530             XPVDI = ONE-XPVQI-XXSEA
12531 *       reject according to x**1.5
12532             XDTMP = XPVDI**1.5D0
12533             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
12534 *     accept these valence partons
12535             IXPV         = IXPV+1
12536             XPVQ(IXPV)   = XPVQI
12537             XPVD(IXPV)   = XPVDI
12538             IFROVP(IXPV) = IPP
12539             ITOVP(IPP)   = IXPV
12540             ZUOVP(IXPV)  = .TRUE.
12541
12542          ENDIF
12543   100 CONTINUE
12544
12545 * (3) select parton x-values of interacting target nucleons
12546 *-----------------------------------------------------------------------
12547
12548       IXTV = 0
12549       IXTS = 0
12550
12551       DO 170 ITT=1,IT
12552 *   get interacting target nucleon as sampled by Glauber
12553          IF (JTSH(ITT).NE.0) THEN
12554             IXSTMP = IXTS
12555             IXVTMP = IXTV
12556   169       CONTINUE
12557             IXTS   = IXSTMP
12558             IXTV   = IXVTMP
12559 *     JITT is the actual number of sea-pairs sampled for this nucleon
12560             JITT   = MIN(JTSH(ITT)-1,NSMAX)
12561   111       CONTINUE
12562             XXSEA  = ZERO
12563             IF (JITT.GT.0) THEN
12564                XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
12565 *???
12566                IF (XSTHR.GE.XSMAX) THEN
12567                   JITT = JITT-1
12568                   GOTO 111
12569                ENDIF
12570
12571 *>>>get x-values of sea-quark pairs
12572                NSCOUN = 0
12573                PLW = 0.5D0
12574   110          CONTINUE
12575 *     accumulator for sea x-values
12576                XXSEA  = ZERO
12577                NSCOUN = NSCOUN+1
12578                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12579                IF (NSCOUN.GT.NSEA)THEN
12580 *     decrease the number of interactions after NSEA trials
12581                   JITT   = JITT-1
12582                   NSCOUN = 0
12583                ENDIF
12584                DO 140 ISQ=1,JITT
12585 *     sea-quarks
12586                   IF (ITSQ(IXTS+1).LE.2) THEN
12587 **sr 8.4.98 (1/sqrt(x))
12588 C                    XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12589 C                    XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12590                      XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12591 **
12592                   ELSE
12593                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12594                         XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12595                      ELSE
12596 **sr 8.4.98 (1/sqrt(x))
12597 C                       XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12598 C                       XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12599                         XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12600 **
12601                      ENDIF
12602                   ENDIF
12603 *     sea-antiquarks
12604                   IF (ITSAQ(IXTS+1).GE.-2) THEN
12605 **sr 8.4.98 (1/sqrt(x))
12606 C                    XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12607 C                    XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12608                      XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12609 **
12610                   ELSE
12611                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12612                         XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12613                      ELSE
12614 **sr 8.4.98 (1/sqrt(x))
12615 C                       XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12616 C                       XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12617                         XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12618 **
12619                      ENDIF
12620                   ENDIF
12621                   XXSEA = XXSEA+XTSQI+XTSAQI
12622 *     check for maximum allowed sea x-value
12623                   IF (XXSEA.GE.XXSEAM) THEN
12624                      IXTS = IXTS-ISQ+1
12625                      GOTO 110
12626                   ENDIF
12627 *     accept this sea-quark pair
12628                   IXTS         = IXTS+1
12629                   XTSQ(IXTS)   = XTSQI
12630                   XTSAQ(IXTS)  = XTSAQI
12631                   IFROST(IXTS) = ITT
12632                   ZUOST(IXTS)  = .TRUE.
12633   140          CONTINUE
12634             ENDIF
12635
12636 *>>>get x-values of valence partons
12637 *     valence quark
12638             IF (XVTHR.GT.0.05D0) THEN
12639                XVHI  = ONE-XXSEA-XDTHR
12640                XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
12641             ELSE
12642   160          CONTINUE
12643                XTVQI = DT_DBETAR(OHALF,UNON)
12644                IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
12645      &                                                    GOTO 160
12646             ENDIF
12647 *     valence diquark
12648             XTVDI = ONE-XTVQI-XXSEA
12649 *       reject according to x**1.5
12650             XDTMP = XTVDI**1.5D0
12651             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
12652 *     accept these valence partons
12653             IXTV         = IXTV+1
12654             XTVQ(IXTV)   = XTVQI
12655             XTVD(IXTV)   = XTVDI
12656             IFROVT(IXTV) = ITT
12657             ITOVT(ITT)   = IXTV
12658             ZUOVT(IXTV)  = .TRUE.
12659
12660          ENDIF
12661   170 CONTINUE
12662
12663 * (4) get valence-valence chains
12664 *-----------------------------------------------------------------------
12665
12666       NVV = 0
12667       DO 240 I=1,NN
12668          INTLO(I) = .TRUE.
12669          IPVAL    = ITOVP(INTER1(I))
12670          ITVAL    = ITOVT(INTER2(I))
12671          IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
12672             INTLO(I)      = .FALSE.
12673             ZUOVP(IPVAL)  = .FALSE.
12674             ZUOVT(ITVAL)  = .FALSE.
12675             NVV           = NVV+1
12676             ISKPCH(8,NVV) = 0
12677             INTVV1(NVV)   = IPVAL
12678             INTVV2(NVV)   = ITVAL
12679          ENDIF
12680   240 CONTINUE
12681
12682 * (5) get sea-valence chains
12683 *-----------------------------------------------------------------------
12684
12685       NSV = 0
12686       NDV = 0
12687       PLW = 0.5D0
12688       DO 270 I=1,NN
12689          IF (INTLO(I)) THEN
12690             IPVAL = ITOVP(INTER1(I))
12691             ITVAL = ITOVT(INTER2(I))
12692             DO 250 J=1,IXPS
12693                IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
12694      &                                ZUOVT(ITVAL)) THEN
12695                   ZUOSP(J)     = .FALSE.
12696                   ZUOVT(ITVAL) = .FALSE.
12697                   INTLO(I)     = .FALSE.
12698                   IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
12699 *   sample sea-diquark pair
12700                      CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
12701                      IF (IREJ1.EQ.0) GOTO 260
12702                   ENDIF
12703                   NSV           = NSV+1
12704                   ISKPCH(4,NSV) = 0
12705                   INTSV1(NSV)   = J
12706                   INTSV2(NSV)   = ITVAL
12707
12708 *>>>correct chain kinematics according to minimum chain masses
12709 *     the actual chain masses
12710                   AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
12711                   AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
12712 *     get lower mass cuts
12713                   IF (IPSQ(J).EQ.3) THEN
12714 *       q being s-quark
12715                      AMCHK1 = AMAS
12716                      AMCHK2 = AMIS
12717                   ELSE
12718 *       q being u/d-quark
12719                      AMCHK1 = AMAU
12720                      AMCHK2 = AMIU
12721                   ENDIF
12722 *       q-qq chain
12723 *         chain mass above minimum - resampling of sea-q x-value
12724                   IF (AMSVQ1.GT.AMCHK1) THEN
12725                      XPSQTH      = AMCHK1/(XTVD(ITVAL)*ECM**2)
12726 **sr 8.4.98 (1/sqrt(x))
12727 C                    XPSQXX      = DT_SAMPEX(XPSQTH,XPSQ(J))
12728 C                    XPSQXX      = DT_SAMSQX(XPSQTH,XPSQ(J))
12729                      XPSQXX      = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
12730 **
12731                      XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
12732                      XPSQ(J)     = XPSQXX
12733 *         chain mass below minimum - reset sea-q x-value and correct
12734 *                                    diquark-x of the same nucleon
12735                   ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12736                      XPSQW       = AMCHK1/(XTVD(ITVAL)*ECM**2)
12737                      DXPSQ       = XPSQW-XPSQ(J)
12738                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12739                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12740                         XPSQ(J)     = XPSQW
12741                      ENDIF
12742                   ENDIF
12743 *       aq-q chain
12744 *         chain mass below minimum - reset sea-aq x-value and correct
12745 *                                    diquark-x of the same nucleon
12746                   IF (AMSVQ2.LT.AMCHK2) THEN
12747                      XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
12748                      DXPSQ = XPSQW-XPSAQ(J)
12749                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12750                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12751                         XPSAQ(J)    = XPSQW
12752                      ENDIF
12753                   ENDIF
12754 *>>>end of chain mass correction
12755
12756                   GOTO 260
12757                ENDIF
12758   250       CONTINUE
12759          ENDIF
12760   260    CONTINUE
12761   270 CONTINUE
12762
12763 * (6) get valence-sea chains
12764 *-----------------------------------------------------------------------
12765
12766       NVS = 0
12767       NVD = 0
12768       DO 300 I=1,NN
12769          IF (INTLO(I)) THEN
12770             IPVAL = ITOVP(INTER1(I))
12771             ITVAL = ITOVT(INTER2(I))
12772             DO 280 J=1,IXTS
12773                IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
12774      &                  (IFROST(J).EQ.INTER2(I))) THEN
12775                   ZUOST(J)     = .FALSE.
12776                   ZUOVP(IPVAL) = .FALSE.
12777                   INTLO(I)     = .FALSE.
12778                   IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
12779 *   sample sea-diquark pair
12780                      CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
12781                      IF (IREJ1.EQ.0) GOTO 290
12782                   ENDIF
12783                   NVS           = NVS + 1
12784                   ISKPCH(6,NVS) = 0
12785                   INTVS1(NVS)   = IPVAL
12786                   INTVS2(NVS)   = J
12787
12788 *>>>correct chain kinematics according to minimum chain masses
12789 *     the actual chain masses
12790                   AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
12791                   AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
12792 *     get lower mass cuts
12793                   IF (ITSQ(J).EQ.3) THEN
12794 *       q being s-quark
12795                      AMCHK1 = AMIS
12796                      AMCHK2 = AMAS
12797                   ELSE
12798 *       q being u/d-quark
12799                      AMCHK1 = AMIU
12800                      AMCHK2 = AMAU
12801                   ENDIF
12802 *       q-aq chain
12803 *         chain mass below minimum - reset sea-aq x-value and correct
12804 *                                    diquark-x of the same nucleon
12805                   IF (AMVSQ1.LT.AMCHK1) THEN
12806                      XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
12807                      DXTSQ = XTSQW-XTSAQ(J)
12808                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12809                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12810                         XTSAQ(J)    = XTSQW
12811                      ENDIF
12812                   ENDIF
12813 *       qq-q chain
12814 *         chain mass above minimum - resampling of sea-q x-value
12815                   IF (AMVSQ2.GT.AMCHK2) THEN
12816                      XTSQTH      = AMCHK2/(XPVD(IPVAL)*ECM**2)
12817 **sr 8.4.98 (1/sqrt(x))
12818 C                    XTSQXX      = DT_SAMPEX(XTSQTH,XTSQ(J))
12819 C                    XTSQXX      = DT_SAMSQX(XTSQTH,XTSQ(J))
12820                      XTSQXX      = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
12821 **
12822                      XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
12823                      XTSQ(J)     = XTSQXX
12824 *         chain mass below minimum - reset sea-q x-value and correct
12825 *                                    diquark-x of the same nucleon
12826                   ELSEIF (AMVSQ2.LT.AMCHK2) THEN
12827                      XTSQW       = AMCHK2/(XPVD(IPVAL)*ECM**2)
12828                      DXTSQ       = XTSQW-XTSQ(J)
12829                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12830                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12831                         XTSQ(J)     = XTSQW
12832                      ENDIF
12833                   ENDIF
12834 *>>>end of chain mass correction
12835
12836                   GOTO 290
12837                ENDIF
12838   280       CONTINUE
12839          ENDIF
12840   290    CONTINUE
12841   300 CONTINUE
12842
12843 * (7) get sea-sea chains
12844 *-----------------------------------------------------------------------
12845
12846       NSS = 0
12847       NDS = 0
12848       NSD = 0
12849       DO 420 I=1,NN
12850          IF (INTLO(I)) THEN
12851             IPVAL = ITOVP(INTER1(I))
12852             ITVAL = ITOVT(INTER2(I))
12853 *   loop over target partons not yet matched
12854             DO 400 J=1,IXTS
12855                IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
12856 *   loop over projectile partons not yet matched
12857                   DO 390 JJ=1,IXPS
12858                      IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
12859                         ZUOSP(JJ)     = .FALSE.
12860                         ZUOST(J)      = .FALSE.
12861                         INTLO(I)      = .FALSE.
12862                         NSS           = NSS+1
12863                         ISKPCH(1,NSS) = 0
12864                         INTSS1(NSS)   = JJ
12865                         INTSS2(NSS)   = J
12866
12867 *---->chain recombination option
12868                         VALFRA        = DBLE(NVV/(NVV+IXPS+IXTS))
12869                         IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
12870      &                                                             THEN
12871 *       sea-sea chains may recombine with valence-valence chains
12872 *       only if they have the same projectile or target nucleon
12873                            DO 4201 IVV=1,NVV
12874                               IF (ISKPCH(8,IVV).NE.99) THEN
12875                                  IXVPR = INTVV1(IVV)
12876                                  IXVTA = INTVV2(IVV)
12877                                  IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
12878      &                               (INTER2(I).EQ.IFROVT(IXVTA))) THEN
12879 *         recombination possible, drop old v-v and s-s chains
12880                                     ISKPCH(1,NSS) = 99
12881                                     ISKPCH(8,IVV) = 99
12882
12883 *         (a) assign new s-v chains
12884 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
12885                                     IF (LSEADI.AND.
12886      &                                  (DT_RNDM(VALFRA).GT.FRCDIQ))
12887      &                                                             THEN
12888 *           sample sea-diquark pair
12889                                        CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
12890      &                                                      IREJ1)
12891                                        IF (IREJ1.EQ.0) GOTO 4202
12892                                     ENDIF
12893                                     NSV           = NSV+1
12894                                     ISKPCH(4,NSV) = 0
12895                                     INTSV1(NSV)   = JJ
12896                                     INTSV2(NSV)   = IXVTA
12897 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12898 *           the actual chain masses
12899                                     AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
12900      &                                                     *ECM**2
12901                                     AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
12902      &                                                     *ECM**2
12903 *           get lower mass cuts
12904                                     IF (IPSQ(JJ).EQ.3) THEN
12905 *             q being s-quark
12906                                        AMCHK1 = AMAS
12907                                        AMCHK2 = AMIS
12908                                     ELSE
12909 *             q being u/d-quark
12910                                        AMCHK1 = AMAU
12911                                        AMCHK2 = AMIU
12912                                     ENDIF
12913 *           q-qq chain
12914 *             chain mass above minimum - resampling of sea-q x-value
12915                                     IF (AMSVQ1.GT.AMCHK1) THEN
12916                                        XPSQTH      =
12917      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
12918 **sr 8.4.98 (1/sqrt(x))
12919                                        XPSQXX      =
12920      &                                    DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
12921 C    &                                    DT_SAMSQX(XPSQTH,XPSQ(JJ))
12922 C    &                                    DT_SAMPEX(XPSQTH,XPSQ(JJ))
12923 **
12924                                        XPVD(IPVAL) =
12925      &                                    XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
12926                                        XPSQ(JJ)    = XPSQXX
12927 *             chain mass below minimum - reset sea-q x-value and correct
12928 *                                        diquark-x of the same nucleon
12929                                     ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12930                                        XPSQW =
12931      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
12932                                        DXPSQ = XPSQW-XPSQ(JJ)
12933                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12934      &                                                            THEN
12935                                           XPVD(IPVAL) =
12936      &                                       XPVD(IPVAL)-DXPSQ
12937                                           XPSQ(JJ)    = XPSQW
12938                                        ENDIF
12939                                     ENDIF
12940 *           aq-q chain
12941 *             chain mass below minimum - reset sea-aq x-value and correct
12942 *                                        diquark-x of the same nucleon
12943                                     IF (AMSVQ2.LT.AMCHK2) THEN
12944                                        XPSQW =
12945      &                                    AMCHK2/(XTVQ(IXVTA)*ECM**2)
12946                                        DXPSQ = XPSQW-XPSAQ(JJ)
12947                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12948      &                                                            THEN
12949                                           XPVD(IPVAL) =
12950      &                                       XPVD(IPVAL)-DXPSQ
12951                                           XPSAQ(JJ)   = XPSQW
12952                                        ENDIF
12953                                     ENDIF
12954 *>>>>>>>>>>>end of chain mass correction
12955  4202                               CONTINUE
12956
12957 *         (b) assign new v-s chains
12958 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
12959                                     IF (LSEADI.AND.(
12960      &                                  DT_RNDM(AMSVQ2).GT.FRCDIQ))
12961      &                                                             THEN
12962 *           sample sea-diquark pair
12963                                        CALL DT_SAMSDQ(ECM,IXVPR,J,1,
12964      &                                                      IREJ1)
12965                                        IF (IREJ1.EQ.0) GOTO 4203
12966                                     ENDIF
12967                                     NVS           = NVS+1
12968                                     ISKPCH(6,NVS) = 0
12969                                     INTVS1(NVS)   = IXVPR
12970                                     INTVS2(NVS)   = J
12971 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12972 *           the actual chain masses
12973                                     AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
12974                                     AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
12975 *           get lower mass cuts
12976                                     IF (ITSQ(J).EQ.3) THEN
12977 *             q being s-quark
12978                                        AMCHK1 = AMIS
12979                                        AMCHK2 = AMAS
12980                                     ELSE
12981 *             q being u/d-quark
12982                                        AMCHK1 = AMIU
12983                                        AMCHK2 = AMAU
12984                                     ENDIF
12985 *           q-aq chain
12986 *             chain mass below minimum - reset sea-aq x-value and correct
12987 *                                        diquark-x of the same nucleon
12988                                     IF (AMVSQ1.LT.AMCHK1) THEN
12989                                        XTSQW =
12990      &                                    AMCHK1/(XPVQ(IXVPR)*ECM**2)
12991                                        DXTSQ = XTSQW-XTSAQ(J)
12992                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
12993      &                                                            THEN
12994                                           XTVD(ITVAL) =
12995      &                                       XTVD(ITVAL)-DXTSQ
12996                                           XTSAQ(J)    = XTSQW
12997                                        ENDIF
12998                                     ENDIF
12999                                     IF (AMVSQ2.GT.AMCHK2) THEN
13000                                        XTSQTH      =
13001      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
13002 **sr 8.4.98 (1/sqrt(x))
13003                                        XTSQXX      =
13004      &                                    DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13005 C    &                                    DT_SAMSQX(XTSQTH,XTSQ(J))
13006 C    &                                    DT_SAMPEX(XTSQTH,XTSQ(J))
13007 **
13008                                        XTVD(ITVAL) =
13009      &                                    XTVD(ITVAL)+XTSQ(J)-XTSQXX
13010                                        XTSQ(J)     = XTSQXX
13011                                     ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13012                                        XTSQW =
13013      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
13014                                        DXTSQ = XTSQW-XTSQ(J)
13015                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13016      &                                                            THEN
13017                                           XTVD(ITVAL) =
13018      &                                       XTVD(ITVAL)-DXTSQ
13019                                           XTSQ(J)     = XTSQW
13020                                        ENDIF
13021                                     ENDIF
13022 *>>>>>>>>>end of chain mass correction
13023  4203                               CONTINUE
13024 *       jump out of s-s chain loop
13025                                     GOTO 420
13026                                  ENDIF
13027                               ENDIF
13028  4201                      CONTINUE
13029                         ENDIF
13030 *---->end of chain recombination option
13031
13032 *     sample sea-diquark pair (projectile)
13033                         IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13034                            CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13035                            IF (IREJ1.EQ.0) THEN
13036                               ISKPCH(1,NSS) = 99
13037                               GOTO 410
13038                            ENDIF
13039                         ENDIF
13040 *     sample sea-diquark pair (target)
13041                         IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13042                            CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13043                            IF (IREJ1.EQ.0) THEN
13044                               ISKPCH(1,NSS) = 99
13045                               GOTO 410
13046                            ENDIF
13047                         ENDIF
13048 *>>>>>correct chain kinematics according to minimum chain masses
13049 *     the actual chain masses
13050                         SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13051                         SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13052 *     check for lower mass cuts
13053                         IF ((SSMA1Q.LT.SSMIMQ).OR.
13054      &                      (SSMA2Q.LT.SSMIMQ)) THEN
13055                            IPVAL = ITOVP(INTER1(I))
13056                            ITVAL = ITOVT(INTER2(I))
13057                            IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13058      &                         (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13059 *       maximum allowed x values for sea quarks
13060                               XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13061      &                                           1.2D0*XSSTHR
13062                               XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13063      &                                           1.2D0*XSSTHR
13064 *       resampling of x values not possible - skip sea-sea chains
13065                               IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13066      &                            (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13067 *       resampling of x for projectile sea quark pair
13068                               ICOUS = 0
13069   310                         CONTINUE
13070                               ICOUS = ICOUS+1
13071                               IF (XSSTHR.GT.0.05D0) THEN
13072                                  XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13073      &                                                         XSPMAX)
13074                                  XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13075      &                                                         XSPMAX)
13076                               ELSE
13077   320                            CONTINUE
13078                                  XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13079                                  IF ((XPSQI.LT.XSSTHR).OR.
13080      &                               (XPSQI.GT.XSPMAX))  GOTO 320
13081   330                            CONTINUE
13082                                  XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13083                                  IF ((XPSAQI.LT.XSSTHR).OR.
13084      &                               (XPSAQI.GT.XSPMAX)) GOTO 330
13085                               ENDIF
13086 *       final test of remaining x for projectile diquark
13087                               XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13088      &                                            +XPSQ(JJ)+XPSAQ(JJ)
13089                               IF (XPVDCO.LE.XDTHR) THEN
13090 *!!!
13091 C                                IF (ICOUS.LT.5) GOTO 310
13092                                  IF (ICOUS.LT.0.5D0) GOTO 310
13093                                  GOTO 380
13094                               ENDIF
13095 *       resampling of x for target sea quark pair
13096                               ICOUS = 0
13097   350                         CONTINUE
13098                               ICOUS = ICOUS+1
13099                               IF (XSSTHR.GT.0.05D0) THEN
13100                                  XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13101      &                                                         XSTMAX)
13102                                  XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13103      &                                                         XSTMAX)
13104                               ELSE
13105   360                            CONTINUE
13106                                  XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13107                                  IF ((XTSQI.LT.XSSTHR).OR.
13108      &                               (XTSQI.GT.XSTMAX))  GOTO 360
13109   370                            CONTINUE
13110                                  XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13111                                  IF ((XTSAQI.LT.XSSTHR).OR.
13112      &                               (XTSAQI.GT.XSTMAX)) GOTO 370
13113                               ENDIF
13114 *       final test of remaining x for target diquark
13115                               XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13116      &                                            +XTSQ(J)+XTSAQ(J)
13117                               IF (XTVDCO.LT.XDTHR) THEN
13118                                  IF (ICOUS.LT.5) GOTO 350
13119                                  GOTO 380
13120                               ENDIF
13121                               XPVD(IPVAL) = XPVDCO
13122                               XTVD(ITVAL) = XTVDCO
13123                               XPSQ(JJ)    = XPSQI
13124                               XPSAQ(JJ)   = XPSAQI
13125                               XTSQ(J)     = XTSQI
13126                               XTSAQ(J)    = XTSAQI
13127 *>>>>>end of chain mass correction
13128                               GOTO 410
13129                            ENDIF
13130 *     come here to discard s-s interaction
13131 *     resampling of x values not allowed or unsuccessful
13132   380                      CONTINUE
13133                            INTLO(I)  = .FALSE.
13134                            ZUOST(J)  = .TRUE.
13135                            ZUOSP(JJ) = .TRUE.
13136                            NSS       = NSS-1
13137                         ENDIF
13138 *   consider next s-s interaction
13139                         GOTO 410
13140                      ENDIF
13141   390             CONTINUE
13142                ENDIF
13143   400       CONTINUE
13144          ENDIF
13145   410    CONTINUE
13146   420 CONTINUE
13147
13148 * correct x-values of valence quarks for non-matching sea quarks
13149       DO 430 I=1,IXPS
13150          IF (ZUOSP(I)) THEN
13151             IPVAL       = ITOVP(IFROSP(I))
13152             XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13153             XPSQ(I)     = ZERO
13154             XPSAQ(I)    = ZERO
13155             ZUOSP(I)    = .FALSE.
13156          ENDIF
13157   430 CONTINUE
13158       DO 440 I=1,IXTS
13159          IF (ZUOST(I)) THEN
13160             ITVAL       = ITOVT(IFROST(I))
13161             XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13162             XTSQ(I)     = ZERO
13163             XTSAQ(I)    = ZERO
13164             ZUOST(I)    = .FALSE.
13165          ENDIF
13166   440 CONTINUE
13167       DO 450 I=1,IXPV
13168          IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13169   450 CONTINUE
13170       DO 460 I=1,IXTV
13171          IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13172   460 CONTINUE
13173
13174       RETURN
13175       END
13176
13177 *$ CREATE DT_SAMSDQ.FOR
13178 *COPY DT_SAMSDQ
13179 *
13180 *===samsdq=============================================================*
13181 *
13182       SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13183
13184 ************************************************************************
13185 * SAMpling of Sea-DiQuarks                                             *
13186 *              ECM        cm-energy of the nucleon-nucleon system      *
13187 *              IDX1,2     indices of x-values of the participating     *
13188 *                         partons (IDX2 is always the sea-q-pair to be *
13189 *                         changed to sea-qq-pair)                      *
13190 *              MODE       = 1  valence-q - sea-diq                     *
13191 *                         = 2  sea-diq   - valence-q                   *
13192 *                         = 3  sea-q     - sea-diq                     *
13193 *                         = 4  sea-diq   - sea-q                       *
13194 * Based on DIQVS, DIQSV, DIQSSD, DIQDSS.                               *
13195 * This version dated 17.10.95 is written by S. Roesler                 *
13196 ************************************************************************
13197
13198       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13199       SAVE
13200
13201       PARAMETER (ZERO=0.0D0)
13202
13203 * threshold values for x-sampling (DTUNUC 1.x)
13204       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13205      &                SSMIMQ,VVMTHR
13206 * various options for treatment of partons (DTUNUC 1.x)
13207 * (chain recombination, Cronin,..)
13208       LOGICAL LCO2CR,LINTPT
13209       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13210      &                LCO2CR,LINTPT
13211       PARAMETER ( MAXNCL = 260,
13212      &            MAXVQU = MAXNCL,
13213      &            MAXSQU = 20*MAXVQU,
13214      &            MAXINT = MAXVQU+MAXSQU)
13215 * x-values of partons (DTUNUC 1.x)
13216       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13217      &                XTVQ(MAXVQU),XTVD(MAXVQU),
13218      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
13219      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
13220 * flavors of partons (DTUNUC 1.x)
13221       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13222      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13223      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
13224      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13225      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
13226      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13227      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
13228 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13229       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13230      &                IXPV,IXPS,IXTV,IXTS,
13231      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
13232      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
13233      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
13234      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
13235      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
13236      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
13237      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
13238      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
13239 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13240       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13241      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13242 * auxiliary common for chain system storage (DTUNUC 1.x)
13243       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13244
13245       IREJ = 0
13246 *  threshold-x for valence diquarks
13247       XDTHR = CDQ/ECM
13248
13249       GOTO (1,2,3,4) MODE
13250
13251 *---------------------------------------------------------------------
13252 * proj. valence partons - targ. sea partons
13253 * get x-values and flavors for target sea-diquark pair
13254
13255     1 CONTINUE
13256       IDXVP = IDX1
13257       IDXST = IDX2
13258
13259 *  index of corr. val-diquark-x in target nucleon
13260       IDXVT = ITOVT(IFROST(IDXST))
13261 *  available x above diquark thresholds for valence- and sea-diquarks
13262       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13263
13264       IF (XXD.GE.ZERO) THEN
13265 *  x-values for the three diquarks of the target nucleon
13266          RR1    = DT_RNDM(XXD)
13267          RR2    = DT_RNDM(RR1)
13268          RR3    = DT_RNDM(RR2)
13269          SR123  = RR1+RR2+RR3
13270          XXTV   = XDTHR+RR1*XXD/SR123
13271          XXTSQ  = XDTHR+RR2*XXD/SR123
13272          XXTSAQ = XDTHR+RR3*XXD/SR123
13273       ELSE
13274          XXTV   = XTVD(IDXVT)
13275          XXTSQ  = XTSQ(IDXST)
13276          XXTSAQ = XTSAQ(IDXST)
13277       ENDIF
13278 *  flavor of the second quarks in the sea-diquark pair
13279       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13280       ITSAQ2(IDXST) = -ITSQ2(IDXST)
13281 *  check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13282       AM1    = XXTSQ *XPVQ(IDXVP)*ECM**2
13283       AM2    = XXTSAQ*XPVD(IDXVP)*ECM**2
13284       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13285 *    ss-asas pair
13286      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13287          IREJ = 1
13288          RETURN
13289       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13290 *    at least one strange quark
13291      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13292          IREJ = 1
13293          RETURN
13294       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13295          IREJ = 1
13296          RETURN
13297       ENDIF
13298 *  accept the new sea-diquark
13299       XTVD(IDXVT)   = XXTV
13300       XTSQ(IDXST)   = XXTSQ
13301       XTSAQ(IDXST)  = XXTSAQ
13302       NVD           = NVD+1
13303       INTVD1(NVD)   = IDXVP
13304       INTVD2(NVD)   = IDXST
13305       ISKPCH(7,NVD) = 0
13306       RETURN
13307
13308 *---------------------------------------------------------------------
13309 * proj. sea partons - targ. valence partons
13310 * get x-values and flavors for projectile sea-diquark pair
13311
13312     2 CONTINUE
13313       IDXSP = IDX2
13314       IDXVT = IDX1
13315
13316 *  index of corr. val-diquark-x in projectile nucleon
13317       IDXVP = ITOVP(IFROSP(IDXSP))
13318 *  available x above diquark thresholds for valence- and sea-diquarks
13319       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13320
13321       IF (XXD.GE.ZERO) THEN
13322 *  x-values for the three diquarks of the projectile nucleon
13323          RR1    = DT_RNDM(XXD)
13324          RR2    = DT_RNDM(RR1)
13325          RR3    = DT_RNDM(RR2)
13326          SR123  = RR1+RR2+RR3
13327          XXPV   = XDTHR+RR1*XXD/SR123
13328          XXPSQ  = XDTHR+RR2*XXD/SR123
13329          XXPSAQ = XDTHR+RR3*XXD/SR123
13330       ELSE
13331          XXPV   = XPVD(IDXVP)
13332          XXPSQ  = XPSQ(IDXSP)
13333          XXPSAQ = XPSAQ(IDXSP)
13334       ENDIF
13335 *  flavor of the second quarks in the sea-diquark pair
13336       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13337       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13338 *  check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13339       AM1    = XXPSQ *XTVQ(IDXVT)*ECM**2
13340       AM2    = XXPSAQ*XTVD(IDXVT)*ECM**2
13341       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13342 *    ss-asas pair
13343      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13344          IREJ = 1
13345          RETURN
13346       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13347 *    at least one strange quark
13348      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13349          IREJ = 1
13350          RETURN
13351       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13352          IREJ = 1
13353          RETURN
13354       ENDIF
13355 *  accept the new sea-diquark
13356       XPVD(IDXVP)   = XXPV
13357       XPSQ(IDXSP)   = XXPSQ
13358       XPSAQ(IDXSP)  = XXPSAQ
13359       NDV           = NDV+1
13360       INTDV1(NDV)   = IDXSP
13361       INTDV2(NDV)   = IDXVT
13362       ISKPCH(5,NDV) = 0
13363       RETURN
13364
13365 *---------------------------------------------------------------------
13366 * proj. sea partons - targ. sea partons
13367 * get x-values and flavors for target sea-diquark pair
13368
13369     3 CONTINUE
13370       IDXSP = IDX1
13371       IDXST = IDX2
13372
13373 *  index of corr. val-diquark-x in target nucleon
13374       IDXVT = ITOVT(IFROST(IDXST))
13375 *  available x above diquark thresholds for valence- and sea-diquarks
13376       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13377
13378       IF (XXD.GE.ZERO) THEN
13379 *  x-values for the three diquarks of the target nucleon
13380          RR1    = DT_RNDM(XXD)
13381          RR2    = DT_RNDM(RR1)
13382          RR3    = DT_RNDM(RR2)
13383          SR123  = RR1+RR2+RR3
13384          XXTV   = XDTHR+RR1*XXD/SR123
13385          XXTSQ  = XDTHR+RR2*XXD/SR123
13386          XXTSAQ = XDTHR+RR3*XXD/SR123
13387       ELSE
13388          XXTV   = XTVD(IDXVT)
13389          XXTSQ  = XTSQ(IDXST)
13390          XXTSAQ = XTSAQ(IDXST)
13391       ENDIF
13392 *  flavor of the second quarks in the sea-diquark pair
13393       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13394       ITSAQ2(IDXST) = -ITSQ2(IDXST)
13395 *  check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
13396       AM1    = XXTSQ *XPSQ(IDXSP)*ECM**2
13397       AM2    = XXTSAQ*XPSAQ(IDXSP)*ECM**2
13398       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13399 *    ss-asas pair
13400      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
13401          IREJ = 1
13402          RETURN
13403       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13404 *    at least one strange quark
13405      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
13406          IREJ = 1
13407          RETURN
13408       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13409          IREJ = 1
13410          RETURN
13411       ENDIF
13412 *  accept the new sea-diquark
13413       XTVD(IDXVT)   = XXTV
13414       XTSQ(IDXST)   = XXTSQ
13415       XTSAQ(IDXST)  = XXTSAQ
13416       NSD           = NSD+1
13417       INTSD1(NSD)   = IDXSP
13418       INTSD2(NSD)   = IDXST
13419       ISKPCH(3,NSD) = 0
13420       RETURN
13421
13422 *---------------------------------------------------------------------
13423 * proj. sea partons - targ. sea partons
13424 * get x-values and flavors for projectile sea-diquark pair
13425
13426     4 CONTINUE
13427       IDXSP = IDX2
13428       IDXST = IDX1
13429
13430 *  index of corr. val-diquark-x in projectile nucleon
13431       IDXVP = ITOVP(IFROSP(IDXSP))
13432 *  available x above diquark thresholds for valence- and sea-diquarks
13433       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13434
13435       IF (XXD.GE.ZERO) THEN
13436 *  x-values for the three diquarks of the projectile nucleon
13437          RR1    = DT_RNDM(XXD)
13438          RR2    = DT_RNDM(RR1)
13439          RR3    = DT_RNDM(RR2)
13440          SR123  = RR1+RR2+RR3
13441          XXPV   = XDTHR+RR1*XXD/SR123
13442          XXPSQ  = XDTHR+RR2*XXD/SR123
13443          XXPSAQ = XDTHR+RR3*XXD/SR123
13444       ELSE
13445          XXPV   = XPVD(IDXVP)
13446          XXPSQ  = XPSQ(IDXSP)
13447          XXPSAQ = XPSAQ(IDXSP)
13448       ENDIF
13449 *  flavor of the second quarks in the sea-diquark pair
13450       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13451       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13452 *  check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
13453       AM1    = XXPSQ *XTSQ(IDXST)*ECM**2
13454       AM2    = XXPSAQ*XTSAQ(IDXST)*ECM**2
13455       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13456 *    ss-asas pair
13457      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
13458          IREJ = 1
13459          RETURN
13460       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13461 *    at least one strange quark
13462      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
13463          IREJ = 1
13464          RETURN
13465       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13466          IREJ = 1
13467          RETURN
13468       ENDIF
13469 *  accept the new sea-diquark
13470       XPVD(IDXVP)   = XXPV
13471       XPSQ(IDXSP)   = XXPSQ
13472       XPSAQ(IDXSP)  = XXPSAQ
13473       NDS           = NDS+1
13474       INTDS1(NDS)   = IDXSP
13475       INTDS2(NDS)   = IDXST
13476       ISKPCH(2,NDS) = 0
13477       RETURN
13478       END
13479
13480 *$ CREATE DT_DIFEVT.FOR
13481 *COPY DT_DIFEVT
13482 *
13483 *===difevt=============================================================*
13484 *
13485       SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
13486      &                  IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
13487
13488 ************************************************************************
13489 * Interface to treatment of diffractive interactions.                  *
13490 *  (input)          IFP1/2        PDG-indizes of projectile partons    *
13491 *                                 (baryon: IFP2 - adiquark)            *
13492 *                   PP(4)         projectile 4-momentum                *
13493 *                   IFT1/2        PDG-indizes of target partons        *
13494 *                                 (baryon: IFT1 - adiquark)            *
13495 *                   PT(4)         target 4-momentum                    *
13496 *  (output)         JDIFF = 0     no diffraction                       *
13497 *                         = 1/-1  LMSD/LMDD                            *
13498 *                         = 2/-2  HMSD/HMDD                            *
13499 *                   NCSY          counter for two-chain systems        *
13500 *                                 dumped to DTEVT1                     *
13501 * This version dated 14.02.95 is written by S. Roesler                 *
13502 ************************************************************************
13503
13504       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13505       SAVE
13506       PARAMETER ( LINP = 10 ,
13507      &            LOUT = 6 ,
13508      &            LDAT = 9 )
13509       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
13510      &           OHALF=0.5D0)
13511
13512 * event history
13513       PARAMETER (NMXHKK=200000)
13514       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
13515      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
13516      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
13517 * extended event history
13518       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
13519      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
13520      &                IHIST(2,NMXHKK)
13521 * flags for diffractive interactions (DTUNUC 1.x)
13522       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
13523
13524       DIMENSION PP(4),PT(4)
13525
13526       LOGICAL LFIRST
13527       DATA LFIRST /.TRUE./
13528
13529       IREJ   = 0
13530       JDIFF  = 0
13531       IFLAGD = JDIFF
13532
13533 * cm. energy
13534       XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
13535      &          (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
13536 * identities of projectile hadron / target nucleon
13537       KPROJ = IDT_ICIHAD(IDHKK(MOP))
13538       KTARG = IDT_ICIHAD(IDHKK(MOT))
13539
13540 * single diffractive xsections
13541       CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
13542 * double diffractive xsections
13543 **!! no double diff yet
13544 C     CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
13545       DDTOT = 0.0D0
13546       DDHM  = 0.0D0
13547 **!!
13548 * total inelastic xsection
13549 C     SIGIN  = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
13550       DUMZER = ZERO
13551       CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
13552       SIGIN  = MAX(SIGTO-SIGEL,ZERO)
13553
13554 * fraction of diffractive processes
13555       FRADIF = (SDTOT+DDTOT)/SIGIN
13556
13557       IF (LFIRST) THEN
13558          WRITE(LOUT,1000) XM,SDTOT,SIGIN
13559  1000    FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
13560      &          F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
13561      &          F5.1,' mb',/)
13562          LFIRST = .FALSE.
13563       ENDIF
13564
13565       IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
13566      &    (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
13567 * diffractive interaction requested by x-section or by user
13568          FRASD  = SDTOT/(SDTOT+DDTOT)
13569          FRASDH = SDHM/SDTOT
13570 **sr needs to be specified!!
13571 C        FRADDH = DDHM/DDTOT
13572          FRADDH = 1.0D0
13573 **
13574          IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
13575 *   single diffraction
13576             KDIFF = 1
13577             IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
13578                KP = 2
13579                KT = 0
13580                IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
13581      &               ISINGD.NE.3) THEN
13582                   KP = 0
13583                   KT = 2
13584                ENDIF
13585             ELSE
13586                KP = 1
13587                KT = 0
13588                IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
13589      &               ISINGD.NE.3) THEN
13590                   KP = 0
13591                   KT = 1
13592                ENDIF
13593             ENDIF
13594          ELSE
13595 *   double diffraction
13596             KDIFF = -1
13597             IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
13598                KP = 2
13599                KT = 2
13600             ELSE
13601                KP = 1
13602                KT = 1
13603             ENDIF
13604          ENDIF
13605          CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13606      &               IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13607          IF (IREJ1.EQ.0) THEN
13608             IFLAGD = 2*KDIFF
13609             IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
13610          ELSE
13611             GOTO 9999
13612          ENDIF
13613       ENDIF
13614       JDIFF = IFLAGD
13615
13616       RETURN
13617
13618  9999 CONTINUE
13619       IREJ  = 1
13620       RETURN
13621       END
13622
13623 *$ CREATE DT_DIFFKI.FOR
13624 *COPY DT_DIFFKI
13625 *
13626 *===difkin=============================================================*
13627 *
13628       SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13629      &                  IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
13630
13631 ************************************************************************
13632 * Kinematics of diffractive nucleon-nucleon interaction.               *
13633 *          IFP1/2   PDG-indizes of projectile partons                  *
13634 *                   (baryon: IFP2 - adiquark)                          *
13635 *          PP(4)    projectile 4-momentum                              *
13636 *          IFT1/2   PDG-indizes of target partons                      *
13637 *                   (baryon: IFT1 - adiquark)                          *
13638 *          PT(4)    target 4-momentum                                  *
13639 *          KP   = 0 projectile quasi-elastically scattered             *
13640 *               = 1            excited to low-mass diff. state         *
13641 *               = 2            excited to high-mass diff. state        *
13642 *          KT   = 0 target     quasi-elastically scattered             *
13643 *               = 1            excited to low-mass diff. state         *
13644 *               = 2            excited to high-mass diff. state        *
13645 * This version dated 12.02.95 is written by S. Roesler                 *
13646 ************************************************************************
13647
13648       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13649       SAVE
13650       PARAMETER ( LINP = 10 ,
13651      &            LOUT = 6 ,
13652      &            LDAT = 9 )
13653       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
13654
13655       LOGICAL LSTART
13656
13657 * particle properties (BAMJET index convention)
13658       CHARACTER*8  ANAME
13659       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
13660      &                IICH(210),IIBAR(210),K1(210),K2(210)
13661 * flags for input different options
13662       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
13663       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
13664      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
13665 * rejection counter
13666       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
13667      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
13668      &                IREXCI(3),IRDIFF(2),IRINC
13669 * kinematics of diffractive interactions (DTUNUC 1.x)
13670       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13671      &                PPF(4),PTF(4),
13672      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13673      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13674
13675       DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
13676      &          PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
13677
13678       DATA LSTART /.TRUE./
13679
13680       IF (LSTART) THEN
13681          WRITE(LOUT,2000)
13682  2000    FORMAT(/,1X,'DIFEVT:  diffractive interactions treated ')
13683          LSTART = .FALSE.
13684       ENDIF
13685
13686       IREJ = 0
13687
13688 * initialize common /DTDIKI/
13689       CALL DT_DIFINI
13690 * store momenta of initial incoming particles for emc-check
13691       IF (LEMCCK) THEN
13692          CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
13693          CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
13694       ENDIF
13695
13696 * masses of initial particles
13697       XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
13698       XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
13699       IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
13700       XMP  = SQRT(XMP2)
13701       XMT  = SQRT(XMT2)
13702 * check quark-input (used to adjust coherence cond. for M-selection)
13703       IBP  = 0
13704       IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
13705       IBT  = 0
13706       IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
13707
13708 * parameter for Lorentz-transformation into nucleon-nucleon cms
13709       DO 3 K=1,4
13710          PITOT(K) = PP(K)+PT(K)
13711     3 CONTINUE
13712       XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
13713       IF (XMTOT2.LE.ZERO) THEN
13714          WRITE(LOUT,1000) XMTOT2
13715  1000    FORMAT(1X,'DIFEVT:   negative cm. energy!  ',
13716      &          'XMTOT2 = ',E12.3)
13717          GOTO 9999
13718       ENDIF
13719       XMTOT = SQRT(XMTOT2)
13720       DO 4 K=1,4
13721          BGTOT(K) = PITOT(K)/XMTOT
13722     4 CONTINUE
13723 * transformation of nucleons into cms
13724       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
13725      &            PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
13726       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
13727      &            PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
13728 * rotation angles
13729       COD = PP1(3)/PPTOT
13730 C     SID = SQRT((ONE-COD)*(ONE+COD))
13731       PPT = SQRT(PP1(1)**2+PP1(2)**2)
13732       SID = PPT/PPTOT
13733       COF = ONE
13734       SIF = ZERO
13735       IF(PPTOT*SID.GT.TINY10) THEN
13736          COF   = PP1(1)/(SID*PPTOT)
13737          SIF   = PP1(2)/(SID*PPTOT)
13738          ANORF = SQRT(COF*COF+SIF*SIF)
13739          COF   = COF/ANORF
13740          SIF   = SIF/ANORF
13741       ENDIF
13742 * check consistency
13743       DO 5 K=1,4
13744          DEV1(K) = ABS(PP1(K)+PT1(K))
13745     5 CONTINUE
13746       DEV1(4) = ABS(DEV1(4)-XMTOT)
13747       IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
13748      &    (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10))     THEN
13749          WRITE(LOUT,1001) DEV1
13750  1001    FORMAT(1X,'DIFEVT:   inconsitent Lorentz-transformation! ',
13751      &          /,8X,4E12.3)
13752          GOTO 9999
13753       ENDIF
13754
13755 * select x-fractions in high-mass diff. interactions
13756       IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
13757
13758 * select diffractive masses
13759 * - projectile
13760       IF (KP.EQ.1) THEN
13761          XMPF = DT_XMLMD(XMTOT)
13762          CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
13763          IF (IREJ1.GT.0) GOTO 9999
13764       ELSEIF (KP.EQ.2) THEN
13765          XMPF = DT_XMHMD(XMTOT,IBP,1)
13766       ELSE
13767          XMPF = XMP
13768       ENDIF
13769 * - target
13770       IF (KT.EQ.1) THEN
13771          XMTF = DT_XMLMD(XMTOT)
13772          CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
13773          IF (IREJ1.GT.0) GOTO 9999
13774       ELSEIF (KT.EQ.2) THEN
13775          XMTF = DT_XMHMD(XMTOT,IBT,2)
13776       ELSE
13777          XMTF = XMT
13778       ENDIF
13779
13780 * kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
13781       XMPF2 = XMPF**2
13782       XMTF2 = XMTF**2
13783       PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
13784       PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
13785
13786 * select momentum transfer (all t-values used here are <0)
13787 *   minimum absolute value to produce diffractive masses
13788       TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
13789       TT   = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
13790       IF (IREJ1.GT.0) GOTO 9999
13791
13792 * longitudinal momentum of excited/elastically scattered projectile
13793       PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
13794 * total transverse momentum due to t-selection
13795       PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
13796       IF (PPBLT2.LT.ZERO) THEN
13797          WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
13798  1002    FORMAT(1X,'DIFEVT:   inconsistent transverse momentum! ',
13799      &          E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
13800          GOTO 9999
13801       ENDIF
13802       CALL DT_DSFECF(SINPHI,COSPHI)
13803       PPBLT     = SQRT(PPBLT2)
13804       PPBLOB(1) = COSPHI*PPBLT
13805       PPBLOB(2) = SINPHI*PPBLT
13806
13807 * rotate excited/elastically scattered projectile into n-n cms.
13808       CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
13809      &                                                    XX,YY,ZZ)
13810       PPBLOB(1) = XX
13811       PPBLOB(2) = YY
13812       PPBLOB(3) = ZZ
13813
13814 * 4-momentum of excited/elastically scattered target and of exchanged
13815 * Pomeron
13816       DO 6 K=1,4
13817          IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
13818          PPOM1(K) = PP1(K)-PPBLOB(K)
13819     6 CONTINUE
13820       PTBLOB(4) = XMTOT-PPBLOB(4)
13821
13822 * Lorentz-transformation back into system of initial diff. collision
13823       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13824      &            PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
13825      &            PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
13826       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13827      &            PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
13828      &            PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
13829       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13830      &            PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
13831      &            PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
13832
13833 * store 4-momentum of elastically scattered particle (in single diff.
13834 * events)
13835       IF (KP.EQ.0) THEN
13836          DO 7 K=1,4
13837             PSC(K) = PPF(K)
13838     7    CONTINUE
13839       ELSEIF (KT.EQ.0) THEN
13840          DO 8 K=1,4
13841             PSC(K) = PTF(K)
13842     8    CONTINUE
13843       ENDIF
13844
13845 * check consistency of kinematical treatment so far
13846       IF (LEMCCK) THEN
13847          CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
13848          CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
13849          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
13850          IF (IREJ1.NE.0) GOTO 9999
13851       ENDIF
13852       DO 9 K=1,4
13853          DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
13854          DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
13855     9 CONTINUE
13856       IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
13857      &    (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
13858      &    (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
13859      &    (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5))     THEN
13860          WRITE(LOUT,1003) DEV1,DEV2
13861  1003    FORMAT(1X,'DIFEVT:   inconsitent kinematical treatment!  ',
13862      &          2(/,8X,4E12.3))
13863          GOTO 9999
13864       ENDIF
13865
13866 * kinematical treatment for low-mass diffraction
13867       CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
13868       IF (IREJ1.NE.0) GOTO 9999
13869
13870 * dump diffractive chains into DTEVT1
13871       CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13872       IF (IREJ1.NE.0) GOTO 9999
13873
13874       RETURN
13875
13876  9999 CONTINUE
13877       IRDIFF(1) = IRDIFF(1)+1
13878       IREJ      = 1
13879       RETURN
13880       END
13881
13882 *$ CREATE DT_XMHMD.FOR
13883 *COPY DT_XMHMD
13884 *
13885 *===xmhmd==============================================================*
13886 *
13887       DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
13888
13889 ************************************************************************
13890 * Diffractive mass in high mass single/double diffractive events.      *
13891 * This version dated 11.02.95 is written by S. Roesler                 *
13892 ************************************************************************
13893
13894       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13895       SAVE
13896       PARAMETER ( LINP = 10 ,
13897      &            LOUT = 6 ,
13898      &            LDAT = 9 )
13899       PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
13900
13901 * kinematics of diffractive interactions (DTUNUC 1.x)
13902       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13903      &                PPF(4),PTF(4),
13904      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13905      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13906
13907 C     DATA XCOLOW /0.05D0/
13908       DATA XCOLOW /0.15D0/
13909
13910       DT_XMHMD = ZERO
13911       XH = XPH(2)
13912       IF (MODE.EQ.2) XH = XTH(2)
13913
13914 * minimum Pomeron-x for high-mass diffraction
13915 * (adjusted to get a smooth transition between HM and LM component)
13916       R = DT_RNDM(XH)
13917       XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
13918       IF (ECM.LE.300.0D0) THEN
13919          RR     = (1.0D0-EXP(-((ECM/140.0D0)**4)))
13920          XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
13921       ENDIF
13922 * maximum Pomeron-x for high-mass diffraction
13923 * (coherence condition, adjusted to fit to experimental data)
13924       IF (IB.NE.0) THEN
13925 *   baryon-diffraction
13926          XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
13927       ELSE
13928 *   meson-diffraction
13929          XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
13930       ENDIF
13931 * check boundaries
13932       IF (XDIMIN.GE.XDIMAX) THEN
13933          XDIMIN = OHALF*XDIMAX
13934       ENDIF
13935
13936       KLOOP = 0
13937     1 CONTINUE
13938       KLOOP = KLOOP+1
13939       IF (KLOOP.GT.20) RETURN
13940 * sample Pomeron-x from 1/x-distribution (critical Pomeron)
13941       XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
13942 * corr. diffr. mass
13943       DT_XMHMD = ECM*SQRT(XDIFF)
13944       IF (DT_XMHMD.LT.2.5D0) GOTO 1
13945
13946       RETURN
13947       END
13948
13949 *$ CREATE DT_XMLMD.FOR
13950 *COPY DT_XMLMD
13951 *
13952 *===xmlmd==============================================================*
13953 *
13954       DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
13955
13956 ************************************************************************
13957 * Diffractive mass in high mass single/double diffractive events.      *
13958 * This version dated 11.02.95 is written by S. Roesler                 *
13959 ************************************************************************
13960
13961       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13962       SAVE
13963       PARAMETER ( LINP = 10 ,
13964      &            LOUT = 6 ,
13965      &            LDAT = 9 )
13966
13967 * minimum Pomeron-x for low-mass diffraction
13968 C     AMO = 1.5D0
13969       AMO = 2.0D0
13970 * maximum Pomeron-x for low-mass diffraction
13971 * (adjusted to get a smooth transition between HM and LM component)
13972       R   = DT_RNDM(AMO)
13973       SAM = 1.0D0
13974       IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
13975       R   = DT_RNDM(AMO)*SAM
13976       AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
13977       AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
13978
13979 * selection of diffractive mass
13980 * (adjusted to get a smooth transition between HM and LM component)
13981       R   = DT_RNDM(AMU)
13982       IF (ECM.LE.50.0D0) THEN
13983          DT_XMLMD = AMO*(AMU/AMO)**R
13984       ELSE
13985          A = 0.7D0
13986          IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
13987          DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
13988       ENDIF
13989
13990       RETURN
13991       END
13992
13993 *$ CREATE DT_TDIFF.FOR
13994 *COPY DT_TDIFF
13995 *
13996 *===tdiff==============================================================*
13997 *
13998       DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
13999
14000 ************************************************************************
14001 * t-selection for single/double diffractive interactions.              *
14002 *          ECM      cm. energy                                         *
14003 *          TMIN     minimum momentum transfer to produce diff. masses  *
14004 *          XM1/XM2  diffractively produced masses                      *
14005 *                   (for single diffraction XM2 is obsolete)           *
14006 *          K1/K2= 0 not excited                                        *
14007 *               = 1 low-mass excitation                                *
14008 *               = 2 high-mass excitation                               *
14009 * This version dated 11.02.95 is written by S. Roesler                 *
14010 ************************************************************************
14011
14012       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14013       SAVE
14014       PARAMETER ( LINP = 10 ,
14015      &            LOUT = 6 ,
14016      &            LDAT = 9 )
14017       PARAMETER (ZERO=0.0D0)
14018
14019       PARAMETER ( BTP0   = 3.7D0,
14020      &            ALPHAP = 0.24D0 )
14021
14022       IREJ   = 0
14023       NCLOOP = 0
14024       DT_TDIFF  = ZERO
14025
14026       IF (K1.GT.0) THEN
14027          XM1 = XM1I
14028          XM2 = XM2I
14029       ELSE
14030          XM1 = XM2I
14031       ENDIF
14032       XDI = (XM1/ECM)**2
14033       IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14034 * slope for single diffraction
14035          SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14036       ELSE
14037 * slope for double diffraction
14038          SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14039       ENDIF
14040
14041     1 CONTINUE
14042       NCLOOP = NCLOOP+1
14043       IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14044       Y = DT_RNDM(XDI)
14045       T = -LOG(1.0D0-Y)/SLOPE
14046       IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14047       DT_TDIFF = -ABS(T)
14048
14049       RETURN
14050
14051  9999 CONTINUE
14052       WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14053  1000 FORMAT(1X,'DT_TDIFF:   t-selection rejected!',/,
14054      &       1X,'ECM  = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14055      &       E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14056       IREJ = 1
14057       RETURN
14058       END
14059
14060 *$ CREATE DT_XVALHM.FOR
14061 *COPY DT_XVALHM
14062 *
14063 *===xvalhm=============================================================*
14064 *
14065       SUBROUTINE DT_XVALHM(KP,KT)
14066
14067 ************************************************************************
14068 * Sampling of parton x-values in high-mass diffractive interactions.   *
14069 * This version dated 12.02.95 is written by S. Roesler                 *
14070 ************************************************************************
14071
14072       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14073       SAVE
14074       PARAMETER ( LINP = 10 ,
14075      &            LOUT = 6 ,
14076      &            LDAT = 9 )
14077       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14078
14079 * kinematics of diffractive interactions (DTUNUC 1.x)
14080       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14081      &                PPF(4),PTF(4),
14082      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14083      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14084 * various options for treatment of partons (DTUNUC 1.x)
14085 * (chain recombination, Cronin,..)
14086       LOGICAL LCO2CR,LINTPT
14087       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14088      &                LCO2CR,LINTPT
14089
14090       DATA UNON,XVQTHR /2.0D0,0.8D0/
14091
14092       IF (KP.EQ.2) THEN
14093 * x-fractions of projectile valence partons
14094     1    CONTINUE
14095          XPH(1) = DT_DBETAR(OHALF,UNON)
14096          IF (XPH(1).GE.XVQTHR) GOTO 1
14097          XPH(2) = ONE-XPH(1)
14098 * x-fractions of Pomeron q-aq-pair
14099          XPOLO = TINY2
14100          XPOHI = ONE-TINY2
14101          XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14102          XPPO(2) = ONE-XPPO(1)
14103 * flavors of Pomeron q-aq-pair
14104          IFLAV    = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14105          IFPPO(1) = IFLAV
14106          IFPPO(2) = -IFLAV
14107          IF (DT_RNDM(UNON).GT.OHALF) THEN
14108             IFPPO(1) = -IFLAV
14109             IFPPO(2) = IFLAV
14110          ENDIF
14111       ENDIF
14112
14113       IF (KT.EQ.2) THEN
14114 * x-fractions of projectile target partons
14115     2    CONTINUE
14116          XTH(1) = DT_DBETAR(OHALF,UNON)
14117          IF (XTH(1).GE.XVQTHR) GOTO 2
14118          XTH(2) = ONE-XTH(1)
14119 * x-fractions of Pomeron q-aq-pair
14120          XPOLO = TINY2
14121          XPOHI = ONE-TINY2
14122          XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14123          XTPO(2) = ONE-XTPO(1)
14124 * flavors of Pomeron q-aq-pair
14125          IFLAV    = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14126          IFTPO(1) = IFLAV
14127          IFTPO(2) = -IFLAV
14128          IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14129             IFTPO(1) = -IFLAV
14130             IFTPO(2) = IFLAV
14131          ENDIF
14132       ENDIF
14133
14134       RETURN
14135       END
14136
14137 *$ CREATE DT_LM2RES.FOR
14138 *COPY DT_LM2RES
14139 *
14140 *===lm2res=============================================================*
14141 *
14142       SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14143
14144 ************************************************************************
14145 * Check low-mass diffractive excitation for resonance mass.            *
14146 *   (input)   IF1/2    PDG-indizes of valence partons                  *
14147 *   (in/out)  XM       diffractive mass requested/corrected            *
14148 *   (output)  IDR/IDXR id./BAMJET-index of resonance                   *
14149 * This version dated 12.02.95 is written by S. Roesler                 *
14150 ************************************************************************
14151
14152       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14153       SAVE
14154       PARAMETER ( LINP = 10 ,
14155      &            LOUT = 6 ,
14156      &            LDAT = 9 )
14157       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14158
14159 * kinematics of diffractive interactions (DTUNUC 1.x)
14160       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14161      &                PPF(4),PTF(4),
14162      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14163      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14164
14165       IREJ = 0
14166       IF1B = 0
14167       IF2B = 0
14168       XMI  = XM
14169
14170 * BAMJET indices of partons
14171       IF1A = IDT_IPDG2B(IF1,1,2)
14172       IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14173       IF2A = IDT_IPDG2B(IF2,1,2)
14174       IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14175
14176 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14177       IDCH = 2
14178       IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14179
14180 * check for resonance mass
14181       CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14182       IF (IREJ1.NE.0) GOTO 9999
14183
14184       XM = XMN
14185       RETURN
14186
14187  9999 CONTINUE
14188       IREJ = 1
14189       RETURN
14190       END
14191
14192 *$ CREATE DT_LMKINE.FOR
14193 *COPY DT_LMKINE
14194 *
14195 *===lmkine=============================================================*
14196 *
14197       SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14198
14199 ************************************************************************
14200 * Kinematical treatment of low-mass excitations.                       *
14201 * This version dated 12.02.95 is written by S. Roesler                 *
14202 ************************************************************************
14203
14204       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14205       SAVE
14206       PARAMETER ( LINP = 10 ,
14207      &            LOUT = 6 ,
14208      &            LDAT = 9 )
14209       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14210
14211 * flags for input different options
14212       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14213       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14214      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14215 * kinematics of diffractive interactions (DTUNUC 1.x)
14216       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14217      &                PPF(4),PTF(4),
14218      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14219      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14220
14221       DIMENSION P1(4),P2(4)
14222
14223       IREJ = 0
14224
14225       IF (KP.EQ.1) THEN
14226          PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14227          POE  = PPF(4)/PABS
14228          FAC1 = OHALF*(POE+ONE)
14229          FAC2 = -OHALF*(POE-ONE)
14230          DO 1 K=1,3
14231             PPLM1(K) = FAC1*PPF(K)
14232             PPLM2(K) = FAC2*PPF(K)
14233     1    CONTINUE
14234          PPLM1(4) = FAC1*PABS
14235          PPLM2(4) = -FAC2*PABS
14236          IF (IMSHL.EQ.1) THEN
14237             XM1 = PYMASS(IFP1)
14238             XM2 = PYMASS(IFP2)
14239             CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14240             IF (IREJ1.NE.0) GOTO 9999
14241             DO 2 K=1,4
14242                PPLM1(K) = P1(K)
14243                PPLM2(K) = P2(K)
14244     2       CONTINUE
14245          ENDIF
14246       ENDIF
14247
14248       IF (KT.EQ.1) THEN
14249          PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14250          POE  = PTF(4)/PABS
14251          FAC1 = OHALF*(POE+ONE)
14252          FAC2 = -OHALF*(POE-ONE)
14253          DO 3 K=1,3
14254             PTLM2(K) = FAC1*PTF(K)
14255             PTLM1(K) = FAC2*PTF(K)
14256     3    CONTINUE
14257          PTLM2(4) = FAC1*PABS
14258          PTLM1(4) = -FAC2*PABS
14259          IF (IMSHL.EQ.1) THEN
14260             XM1 = PYMASS(IFT1)
14261             XM2 = PYMASS(IFT2)
14262             CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14263             IF (IREJ1.NE.0) GOTO 9999
14264             DO 4 K=1,4
14265                PTLM1(K) = P1(K)
14266                PTLM2(K) = P2(K)
14267     4       CONTINUE
14268          ENDIF
14269       ENDIF
14270
14271       RETURN
14272
14273  9999 CONTINUE
14274       WRITE(LOUT,'(A)') 'LMKINE:   kinematical treatment rejected'
14275       IREJ = 1
14276       RETURN
14277       END
14278
14279 *$ CREATE DT_DIFINI.FOR
14280 *COPY DT_DIFINI
14281 *
14282 *===difini=============================================================*
14283 *
14284       SUBROUTINE DT_DIFINI
14285
14286 ************************************************************************
14287 * Initialization of common /DTDIKI/                                    *
14288 * This version dated 12.02.95 is written by S. Roesler                 *
14289 ************************************************************************
14290
14291       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14292       SAVE
14293       PARAMETER ( LINP = 10 ,
14294      &            LOUT = 6 ,
14295      &            LDAT = 9 )
14296       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14297
14298 * kinematics of diffractive interactions (DTUNUC 1.x)
14299       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14300      &                PPF(4),PTF(4),
14301      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14302      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14303
14304       DO 1 K=1,4
14305          PPOM(K)  = ZERO
14306          PSC(K)   = ZERO
14307          PPF(K)   = ZERO
14308          PTF(K)   = ZERO
14309          PPLM1(K) = ZERO
14310          PPLM2(K) = ZERO
14311          PTLM1(K) = ZERO
14312          PTLM2(K) = ZERO
14313     1 CONTINUE
14314       DO 2 K=1,2
14315          XPH(K)   = ZERO
14316          XPPO(K)  = ZERO
14317          XTH(K)   = ZERO
14318          XTPO(K)  = ZERO
14319          IFPPO(K) = 0
14320          IFTPO(K) = 0
14321     2 CONTINUE
14322       IDPR  = 0
14323       IDXPR = 0
14324       IDTR  = 0
14325       IDXTR = 0
14326
14327       RETURN
14328       END
14329
14330 *$ CREATE DT_DIFPUT.FOR
14331 *COPY DT_DIFPUT
14332 *
14333 *===difput=============================================================*
14334 *
14335       SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14336      &                                                          IREJ)
14337
14338 ************************************************************************
14339 * Dump diffractive chains into DTEVT1                                  *
14340 * This version dated 12.02.95 is written by S. Roesler                 *
14341 ************************************************************************
14342
14343       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14344       SAVE
14345       PARAMETER ( LINP = 10 ,
14346      &            LOUT = 6 ,
14347      &            LDAT = 9 )
14348       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14349
14350       LOGICAL LCHK
14351
14352 * kinematics of diffractive interactions (DTUNUC 1.x)
14353       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14354      &                PPF(4),PTF(4),
14355      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14356      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14357 * event history
14358       PARAMETER (NMXHKK=200000)
14359       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14360      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14361      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14362 * extended event history
14363       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14364      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14365      &                IHIST(2,NMXHKK)
14366 * rejection counter
14367       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14368      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14369      &                IREXCI(3),IRDIFF(2),IRINC
14370
14371       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
14372      &          P1(4),P2(4),P3(4),P4(4)
14373
14374       IREJ = 0
14375
14376       IF (KP.EQ.1) THEN
14377          DO 1 K=1,4
14378             PCH(K) = PPLM1(K)+PPLM2(K)
14379     1    CONTINUE
14380          ID1 = IFP1
14381          ID2 = IFP2
14382          IF (DT_RNDM(PT).GT.OHALF) THEN
14383             ID1 = IFP2
14384             ID2 = IFP1
14385          ENDIF
14386          CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
14387      &                                        PPLM1(4),0,0,0)
14388          CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
14389      &                                        PPLM2(4),0,0,0)
14390          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14391      &                                              IDPR,IDXPR,8)
14392       ELSEIF (KP.EQ.2) THEN
14393          DO 2 K=1,4
14394             PP1(K) = XPH(1)*PP(K)
14395             PP2(K) = XPH(2)*PP(K)
14396             PT1(K) = -XPPO(1)*PPOM(K)
14397             PT2(K) = -XPPO(2)*PPOM(K)
14398     2    CONTINUE
14399          CALL  DT_CHKCSY(IFP1,IFPPO(1),LCHK)
14400          XM1 = ZERO
14401          XM2 = ZERO
14402          IF (LCHK) THEN
14403             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14404             IF (IREJ1.NE.0) GOTO 9999
14405             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14406             IF (IREJ1.NE.0) GOTO 9999
14407             DO 3 K=1,4
14408                PP1(K) = P1(K)
14409                PT1(K) = P2(K)
14410                PP2(K) = P3(K)
14411                PT2(K) = P4(K)
14412     3       CONTINUE
14413             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14414      &                                                       0,0,8)
14415             CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14416      &                                             PT1(4),0,0,8)
14417             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14418      &                                                       0,0,8)
14419             CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14420      &                                             PT2(4),0,0,8)
14421          ELSE
14422             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14423             IF (IREJ1.NE.0) GOTO 9999
14424             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14425             IF (IREJ1.NE.0) GOTO 9999
14426             DO 4 K=1,4
14427                PP1(K) = P1(K)
14428                PT2(K) = P2(K)
14429                PP2(K) = P3(K)
14430                PT1(K) = P4(K)
14431     4       CONTINUE
14432             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14433      &                                                       0,0,8)
14434             CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14435      &                                                PT2(4),0,0,8)
14436             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14437      &                                                       0,0,8)
14438             CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14439      &                                                PT1(4),0,0,8)
14440          ENDIF
14441          NCSY = NCSY+1
14442       ELSE
14443          CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
14444      &                                                        0,0,0)
14445       ENDIF
14446
14447       IF (KT.EQ.1) THEN
14448          DO 5 K=1,4
14449             PCH(K) = PTLM1(K)+PTLM2(K)
14450     5    CONTINUE
14451          ID1 = IFT1
14452          ID2 = IFT2
14453          IF (DT_RNDM(PT).GT.OHALF) THEN
14454             ID1 = IFT2
14455             ID2 = IFT1
14456          ENDIF
14457          CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
14458      &                                              PTLM1(4),0,0,0)
14459          CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
14460      &                                              PTLM2(4),0,0,0)
14461          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14462      &                                              IDTR,IDXTR,8)
14463       ELSEIF (KT.EQ.2) THEN
14464          DO 6 K=1,4
14465             PP1(K) = XTPO(1)*PPOM(K)
14466             PP2(K) = XTPO(2)*PPOM(K)
14467             PT1(K) = XTH(2)*PT(K)
14468             PT2(K) = XTH(1)*PT(K)
14469     6    CONTINUE
14470          CALL  DT_CHKCSY(IFTPO(1),IFT1,LCHK)
14471          XM1 = ZERO
14472          XM2 = ZERO
14473          IF (LCHK) THEN
14474             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14475             IF (IREJ1.NE.0) GOTO 9999
14476             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14477             IF (IREJ1.NE.0) GOTO 9999
14478             DO 7 K=1,4
14479                PP1(K) = P1(K)
14480                PT1(K) = P2(K)
14481                PP2(K) = P3(K)
14482                PT2(K) = P4(K)
14483     7       CONTINUE
14484             CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14485      &                                                PP1(4),0,0,8)
14486             CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14487      &                                                       0,0,8)
14488             CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14489      &                                                PP2(4),0,0,8)
14490             CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14491      &                                                       0,0,8)
14492          ELSE
14493             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14494             IF (IREJ1.NE.0) GOTO 9999
14495             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14496             IF (IREJ1.NE.0) GOTO 9999
14497             DO 8 K=1,4
14498                PP1(K) = P1(K)
14499                PT2(K) = P2(K)
14500                PP2(K) = P3(K)
14501                PT1(K) = P4(K)
14502     8       CONTINUE
14503             CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14504      &                                                PP1(4),0,0,8)
14505             CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14506      &                                                       0,0,8)
14507             CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14508      &                                                PP2(4),0,0,8)
14509             CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14510      &                                                       0,0,8)
14511          ENDIF
14512          NCSY = NCSY+1
14513       ELSE
14514          CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
14515      &                                                        0,0,0)
14516       ENDIF
14517
14518       RETURN
14519
14520  9999 CONTINUE
14521       IRDIFF(2) = IRDIFF(2)+1
14522       IREJ      = 1
14523       RETURN
14524       END
14525
14526 *$ CREATE DT_EVTFRG.FOR
14527 *COPY DT_EVTFRG
14528 *
14529 *===evtfrg=============================================================*
14530 *
14531       SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
14532
14533 ************************************************************************
14534 * Hadronization of chains in DTEVT1.                                   *
14535 *                                                                      *
14536 * Input:                                                               *
14537 *   KMODE = 1   hadronization of PHOJET-chains (id=77xxx)              *
14538 *         = 2   hadronization of DTUNUC-chains (id=88xxx)              *
14539 *   NFRG  if KMODE = 1 : upper index of PHOJET-scatterings to be       *
14540 *                        hadronized with one PYEXEC call               *
14541 *         if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
14542 *                        with one PYEXEC call                          *
14543 * Output:                                                              *
14544 *   NPYMEM      number of entries in JETSET-common after hadronization *
14545 *   IREJ        rejection flag                                         *
14546 *                                                                      *
14547 * This version dated 17.09.00 is written by S. Roesler                 *
14548 ************************************************************************
14549
14550       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14551       SAVE
14552       PARAMETER ( LINP = 10 ,
14553      &            LOUT = 6 ,
14554      &            LDAT = 9 )
14555       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
14556       PARAMETER (ONE=1.0D0,ZERO=0.0D0)
14557
14558       LOGICAL LACCEP
14559
14560       PARAMETER (MXJOIN=200)
14561
14562 * event history
14563       PARAMETER (NMXHKK=200000)
14564       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14565      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14566      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14567 * extended event history
14568       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14569      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14570      &                IHIST(2,NMXHKK)
14571 * flags for input different options
14572       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14573       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14574      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14575 * statistics
14576       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
14577      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
14578      &                ICEVTG(8,0:30)
14579 * flags for diffractive interactions (DTUNUC 1.x)
14580       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14581 * nucleon-nucleon event-generator
14582       CHARACTER*8 CMODEL
14583       LOGICAL LPHOIN
14584       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
14585 * phojet
14586 C  model switches and parameters
14587       CHARACTER*8 MDLNA
14588       INTEGER ISWMDL,IPAMDL
14589       DOUBLE PRECISION PARMDL
14590       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14591 * jetset
14592       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14593       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
14594       PARAMETER (MAXLND=4000)
14595       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
14596       INTEGER PYK
14597       DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
14598       INTEGER PYCOMP
14599       MODE = KMODE
14600       ISTSTG = 7
14601       IF (MODE.NE.1) ISTSTG = 8
14602       IREJ = 0
14603
14604       IP     = 0
14605       ISH    = 0
14606       INIEMC = 1
14607       NEND   = NHKK
14608       NACCEP = 0
14609       IFRG   = 0
14610       IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
14611       DO 10 I=NPOINT(3),NEND
14612 * sr 14.02.00: seems to be not necessary anymore, commented
14613 C        LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
14614 C    &            ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
14615          LACCEP = .TRUE.
14616 * pick up chains from dtevt1
14617          IDCHK = IDHKK(I)/10000
14618          IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
14619             IF (IDCHK.EQ.7) THEN
14620                IPJE = IDHKK(I)-IDCHK*10000
14621                IF (IPJE.NE.IFRG) THEN
14622                   IFRG = IPJE
14623                   IF (IFRG.GT.NFRG) GOTO 16
14624                ENDIF
14625             ELSE
14626                IPJE = 1
14627                IFRG = IFRG+1
14628                IF (IFRG.GT.NFRG) THEN
14629                   NFRG = -1
14630                   GOTO 16
14631                ENDIF
14632             ENDIF
14633 *   statistics counter
14634 c           IF (IDCH(I).LE.8)
14635 c    &         ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
14636 c           IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
14637 * special treatment for small chains already corrected to hadrons
14638             IF (IDRES(I).NE.0) THEN
14639                IF (IDRES(I).EQ.11) THEN
14640                   ID = IDXRES(I)
14641                ELSE
14642                   ID = IDT_IPDGHA(IDXRES(I))
14643                ENDIF
14644                IF (LEMCCK) THEN
14645                   CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
14646      &                              PHKK(4,I),INIEMC,IDUM,IDUM)
14647                   INIEMC = 2
14648                ENDIF
14649                IP = IP+1
14650                IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
14651                P(IP,1) = PHKK(1,I)
14652                P(IP,2) = PHKK(2,I)
14653                P(IP,3) = PHKK(3,I)
14654                P(IP,4) = PHKK(4,I)
14655                P(IP,5) = PHKK(5,I)
14656                K(IP,1) = 1
14657                K(IP,2) = ID
14658                K(IP,3) = 0
14659                K(IP,4) = 0
14660                K(IP,5) = 0
14661                IHIST(2,I) = 10000*IPJE+IP
14662                IF (IHIST(1,I).LE.-100) THEN
14663                   ISH = ISH+1
14664                   IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14665                   ISJOIN(ISH) = I
14666                ENDIF
14667                N = IP
14668                IHISMO(IP) = I
14669             ELSE
14670                IJ  = 0
14671                DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
14672                   IF (LEMCCK) THEN
14673                      CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
14674      &                                   PHKK(4,KK),INIEMC,IDUM,IDUM)
14675                      CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
14676                      INIEMC = 2
14677                   ENDIF
14678                   ID = IDHKK(KK)
14679                   IF (ID.EQ.0) ID = 21
14680 c                  PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
14681 c                  AM0  = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
14682 c                  AMRQ   = PYMASS(ID)
14683 c                  AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
14684 c                  IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
14685 c     &                (ABS(IDIFF).EQ.0)) THEN
14686 cC                    WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
14687 c                     DELTA      = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
14688 c                     PHKK(4,KK) = PHKK(4,KK)+DELTA
14689 c                     PTOT1      = PTOT-DELTA
14690 c                     PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
14691 c                     PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
14692 c                     PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
14693 c                     PHKK(5,KK) = AMRQ
14694 c                  ENDIF
14695                   IP = IP+1
14696                   IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
14697                   P(IP,1) = PHKK(1,KK)
14698                   P(IP,2) = PHKK(2,KK)
14699                   P(IP,3) = PHKK(3,KK)
14700                   P(IP,4) = PHKK(4,KK)
14701                   P(IP,5) = PHKK(5,KK)
14702                   K(IP,1) = 1
14703                   K(IP,2) = ID
14704                   K(IP,3) = 0
14705                   K(IP,4) = 0
14706                   K(IP,5) = 0
14707                   IHIST(2,KK) = 10000*IPJE+IP
14708                   IF (IHIST(1,KK).LE.-100) THEN
14709                      ISH = ISH+1
14710                      IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14711                      ISJOIN(ISH) = KK
14712                   ENDIF
14713                   IJ = IJ+1
14714                   IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
14715                   IJOIN(IJ)  = IP
14716                   IHISMO(IP) = I
14717    11          CONTINUE
14718                N = IP
14719 * join the two-parton system
14720                CALL PYJOIN(IJ,IJOIN)
14721             ENDIF
14722             IDHKK(I) = 99999
14723          ENDIF
14724    10 CONTINUE
14725    16 CONTINUE
14726       N = IP
14727
14728       IF (IP.GT.0) THEN
14729
14730 * final state parton shower
14731          DO 136 NPJE=1,IPJE
14732             IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
14733                IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
14734                   DO 130 K1=1,ISH
14735                      IF (ISJOIN(K1).EQ.0) GOTO 130
14736                      I = ISJOIN(K1)
14737                      IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
14738      &                                                       GOTO 130
14739                      IH1 = IHIST(2,I)/10000
14740                      IF (IH1.NE.NPJE) GOTO 130
14741                      IH1 = IHIST(2,I)-IH1*10000
14742                      DO 135 K2=K1+1,ISH
14743                         IF (ISJOIN(K2).EQ.0) GOTO 135
14744                         II = ISJOIN(K2)
14745                         IH2 = IHIST(2,II)/10000
14746                         IF (IH2.NE.NPJE) GOTO 135
14747                         IH2 = IHIST(2,II)-IH2*10000
14748                         IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
14749                            PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
14750                            PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
14751                            RQLUN = MIN(PT1,PT2)
14752                            CALL PYSHOW(IH1,IH2,RQLUN)
14753
14754                            ISJOIN(K1) = 0
14755                            ISJOIN(K2) = 0
14756                            GOTO 130
14757                         ENDIF
14758  135                 CONTINUE
14759  130              CONTINUE
14760                ENDIF
14761             ENDIF
14762  136     CONTINUE
14763
14764          CALL DT_INITJS(MODE)
14765 * hadronization
14766
14767          CALL PYEXEC
14768
14769          IF (MSTU(24).NE.0) THEN
14770             WRITE(LOUT,*) ' JETSET-reject at event',
14771      &                    NEVHKK,MSTU(24),KMODE
14772 C           CALL DT_EVTOUT(4)
14773
14774 C           CALL PYLIST(2)
14775
14776             GOTO 9999
14777          ENDIF
14778
14779 *   number of entries in LUJETS
14780
14781          NLINES = PYK(0,1)
14782
14783          NPYMEM = NLINES
14784
14785          DO 12 I=1,NLINES
14786             IFLG(I) = 0
14787    12    CONTINUE
14788
14789          DO 13 II=1,NLINES
14790
14791             IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
14792
14793 *  pick up mother resonance if possible and put it together with
14794 *  their decay-products into the common
14795                IDXMOR = K(II,3)
14796                IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
14797                   KFMOR = K(IDXMOR,2)
14798                   ISMOR = K(IDXMOR,1)
14799                ELSE
14800                   KFMOR = 91
14801                   ISMOR = 1
14802                ENDIF
14803                IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
14804      &             (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
14805                   ID = K(IDXMOR,2)
14806                   MO = IHISMO(PYK(IDXMOR,15))
14807                   PX = PYP(IDXMOR,1)
14808                   PY = PYP(IDXMOR,2)
14809                   PZ = PYP(IDXMOR,3)
14810                   PE = PYP(IDXMOR,4)
14811                   CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14812                   IFLG(IDXMOR) = 1
14813                   MO = NHKK
14814                   DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
14815                      IF (PYK(JDAUG,7).EQ.1) THEN
14816                         ID = PYK(JDAUG,8)
14817                         PX = PYP(JDAUG,1)
14818                         PY = PYP(JDAUG,2)
14819                         PZ = PYP(JDAUG,3)
14820                         PE = PYP(JDAUG,4)
14821                         CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14822                         IF (LEMCCK) THEN
14823                            PX = -PYP(JDAUG,1)
14824                            PY = -PYP(JDAUG,2)
14825                            PZ = -PYP(JDAUG,3)
14826                            PE = -PYP(JDAUG,4)
14827                            CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14828                         ENDIF
14829                         IFLG(JDAUG) = 1
14830                      ENDIF
14831    15             CONTINUE
14832                ELSE
14833 *  there was no mother resonance
14834                   MO = IHISMO(PYK(II,15))
14835                   ID = PYK(II,8)
14836                   PX = PYP(II,1)
14837                   PY = PYP(II,2)
14838                   PZ = PYP(II,3)
14839                   PE = PYP(II,4)
14840                   CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14841                   IF (LEMCCK) THEN
14842                      PX = -PYP(II,1)
14843                      PY = -PYP(II,2)
14844                      PZ = -PYP(II,3)
14845                      PE = -PYP(II,4)
14846                      CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14847                   ENDIF
14848                ENDIF
14849             ENDIF
14850    13    CONTINUE
14851          IF (LEMCCK) THEN
14852             CHKLEV = TINY1
14853             CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
14854 C           IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
14855          ENDIF
14856
14857 * global energy-momentum & flavor conservation check
14858 **sr 16.5. this check is skipped in case of phojet-treatment
14859          IF (MCGENE.EQ.1)
14860      &      CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
14861
14862 * update statistics-counter for diffraction
14863 c        IF (IFLAGD.NE.0) THEN
14864 c           ICDIFF(1) = ICDIFF(1)+1
14865 c           IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
14866 c           IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
14867 c           IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
14868 c           IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
14869 c        ENDIF
14870
14871       ENDIF
14872
14873       RETURN
14874
14875  9999 CONTINUE
14876       IREJ = 1
14877       RETURN
14878       END
14879
14880 *$ CREATE DT_DECAYS.FOR
14881 *COPY DT_DECAYS
14882 *
14883 *===decay==============================================================*
14884 *
14885       SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
14886
14887 ************************************************************************
14888 * Resonance-decay.                                                     *
14889 * This subroutine replaces DDECAY/DECHKK.                              *
14890 *             PIN(4)      4-momentum of resonance          (input)     *
14891 *             IDXIN       BAMJET-index of resonance        (input)     *
14892 *             POUT(20,4)  4-momenta of decay-products      (output)    *
14893 *             IDXOUT(20)  BAMJET-indices of decay-products (output)    *
14894 *             NSEC        number of secondaries            (output)    *
14895 * Adopted from the original version DECHKK.                            *
14896 * This version dated 09.01.95 is written by S. Roesler                 *
14897 ************************************************************************
14898
14899       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14900       SAVE
14901       PARAMETER ( LINP = 10 ,
14902      &            LOUT = 6 ,
14903      &            LDAT = 9 )
14904       PARAMETER (TINY17=1.0D-17)
14905
14906 * HADRIN: decay channel information
14907       PARAMETER (IDMAX9=602)
14908       CHARACTER*8 ZKNAME
14909       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
14910 * particle properties (BAMJET index convention)
14911       CHARACTER*8  ANAME
14912       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14913      &                IICH(210),IIBAR(210),K1(210),K2(210)
14914 * flags for input different options
14915       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14916       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14917      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14918
14919       DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
14920      &          EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
14921      &          CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
14922
14923 * ISTAB = 1 strong and weak decays
14924 *       = 2 strong decays only
14925 *       = 3 strong decays, weak decays for charmed particles and tau
14926 *           leptons only
14927       DATA ISTAB /2/
14928
14929       IREJ = 0
14930       NSEC = 0
14931 * put initial resonance to stack
14932       NSTK = 1
14933       IDXSTK(NSTK) = IDXIN
14934       DO 5 I=1,4
14935          PI(NSTK,I) = PIN(I)
14936     5 CONTINUE
14937
14938 * store initial configuration for energy-momentum cons. check
14939       IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
14940      &                                   PI(NSTK,4),1,IDUM,IDUM)
14941
14942   100 CONTINUE
14943 * get particle from stack
14944       IDXI = IDXSTK(NSTK)
14945 * skip stable particles
14946       IF (ISTAB.EQ.1) THEN
14947          IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
14948          IF ((IDXI.GE.  1).AND.(IDXI.LE.  7)) GOTO 10
14949       ELSEIF (ISTAB.EQ.2) THEN
14950          IF ((IDXI.GE.  1).AND.(IDXI.LE. 30)) GOTO 10
14951          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14952          IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
14953          IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
14954          IF ( IDXI.EQ.109)                    GOTO 10
14955          IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
14956       ELSEIF (ISTAB.EQ.3) THEN
14957          IF ((IDXI.GE.  1).AND.(IDXI.LE. 23)) GOTO 10
14958          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14959          IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
14960          IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
14961       ENDIF
14962
14963 * calculate direction cosines and Lorentz-parameter of decaying part.
14964       PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
14965       PTOT = MAX(PTOT,TINY17)
14966       DO 1 I=1,3
14967          DCOS(I) = PI(NSTK,I)/PTOT
14968     1 CONTINUE
14969       GAM  = PI(NSTK,4)/AAM(IDXI)
14970       BGAM = PTOT/AAM(IDXI)
14971
14972 * get decay-channel
14973       KCHAN = K1(IDXI)-1
14974     2 CONTINUE
14975       KCHAN = KCHAN+1
14976       IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
14977
14978 * identities of secondaries
14979       IDX(1) = NZK(KCHAN,1)
14980       IDX(2) = NZK(KCHAN,2)
14981       IF (IDX(2).LT.1) GOTO 9999
14982       IDX(3) = NZK(KCHAN,3)
14983
14984 * handle decay in rest system of decaying particle
14985       IF (IDX(3).EQ.0) THEN
14986 *   two-particle decay
14987          NDEC = 2
14988          CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
14989      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
14990      &               AAM(IDX(1)),AAM(IDX(2)))
14991       ELSE
14992 *   three-particle decay
14993          NDEC = 3
14994          CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
14995      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
14996      &               CODF(3),COFF(3),SIFF(3),
14997      &               AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
14998       ENDIF
14999       NSTK = NSTK-1
15000
15001 * transform decay products back
15002       DO 3 I=1,NDEC
15003          NSTK = NSTK+1
15004          CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
15005      &               CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
15006      &               PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
15007 * add particle to stack
15008          IDXSTK(NSTK) = IDX(I)
15009          DO 4 J=1,3
15010             PI(NSTK,J) = DCOSF(J)*PFF(I)
15011     4    CONTINUE
15012     3 CONTINUE
15013       GOTO 100
15014
15015    10 CONTINUE
15016 * stable particle, put to output-arrays
15017       NSEC = NSEC+1
15018       DO 6 I=1,4
15019          POUT(NSEC,I) = PI(NSTK,I)
15020     6 CONTINUE
15021       IDXOUT(NSEC) = IDXSTK(NSTK)
15022 * store secondaries for energy-momentum conservation check
15023       IF (LEMCCK)
15024      &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15025      &            -POUT(NSEC,4),2,IDUM,IDUM)
15026       NSTK = NSTK-1
15027       IF (NSTK.GT.0) GOTO 100
15028
15029 * check energy-momentum conservation
15030       IF (LEMCCK) THEN
15031          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15032          IF (IREJ1.NE.0) GOTO 9999
15033       ENDIF
15034
15035       RETURN
15036
15037  9999 CONTINUE
15038       IREJ = 1
15039       RETURN
15040       END
15041
15042 *$ CREATE DT_DECAY1.FOR
15043 *COPY DT_DECAY1
15044 *
15045 *===decay1=============================================================*
15046 *
15047       SUBROUTINE DT_DECAY1
15048
15049 ************************************************************************
15050 * Decay of resonances stored in DTEVT1.                                *
15051 * This version dated 20.01.95 is written by S. Roesler                 *
15052 ************************************************************************
15053
15054       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15055       SAVE
15056       PARAMETER ( LINP = 10 ,
15057      &            LOUT = 6 ,
15058      &            LDAT = 9 )
15059
15060 * event history
15061       PARAMETER (NMXHKK=200000)
15062       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15063      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15064      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15065 * extended event history
15066       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15067      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15068      &                IHIST(2,NMXHKK)
15069
15070       DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15071
15072       NEND = NHKK
15073 C     DO 1 I=NPOINT(5),NEND
15074       DO 1 I=NPOINT(4),NEND
15075          IF (ABS(ISTHKK(I)).EQ.1) THEN
15076             DO 2 K=1,4
15077                PIN(K) = PHKK(K,I)
15078     2       CONTINUE
15079             IDXIN = IDBAM(I)
15080             CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15081             IF (NSEC.GT.1) THEN
15082                DO 3 N=1,NSEC
15083                   IDHAD = IDT_IPDGHA(IDXOUT(N))
15084                   CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15085      &                               POUT(N,3),POUT(N,4),0,0,0)
15086     3          CONTINUE
15087             ENDIF
15088          ENDIF
15089     1 CONTINUE
15090
15091       RETURN
15092       END
15093
15094 *$ CREATE DT_DECPI0.FOR
15095 *COPY DT_DECPI0
15096 *
15097 *===decpi0=============================================================*
15098 *
15099       SUBROUTINE DT_DECPI0
15100
15101 ************************************************************************
15102 * Decay of pi0 handled with JETSET.                                    *
15103 * This version dated 18.02.96 is written by S. Roesler                 *
15104 ************************************************************************
15105
15106       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15107       SAVE
15108       PARAMETER ( LINP = 10 ,
15109      &            LOUT = 6 ,
15110      &            LDAT = 9 )
15111       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15112
15113 * event history
15114       PARAMETER (NMXHKK=200000)
15115       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15116      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15117      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15118 * extended event history
15119       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15120      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15121      &                IHIST(2,NMXHKK)
15122       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15123       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15124       PARAMETER (MAXLND=4000)
15125       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15126 * flags for input different options
15127       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15128       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15129      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15130
15131       INTEGER PYCOMP,PYK
15132
15133       DIMENSION IHISMO(NMXHKK),P1(4)
15134
15135       TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15136
15137       CALL DT_INITJS(2)
15138 * allow pi0 decay
15139       KC = PYCOMP(111)
15140       MDCY(KC,1) = 1
15141
15142       NN  = 0
15143       INI = 0
15144       DO 1 I=1,NHKK
15145          IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15146             IF (INI.EQ.0) THEN
15147                INI = 1
15148             ELSE
15149                INI = 2
15150             ENDIF
15151             IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15152      &                                    PHKK(4,I),INI,IDUM,IDUM)
15153             PT    = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15154             PTOT  = SQRT(PT**2+PHKK(3,I)**2)
15155             COSTH = PHKK(3,I)/(PTOT+TINY10)
15156             IF (COSTH.GT.ONE) THEN
15157                THETA = ZERO
15158             ELSEIF (COSTH.LT.-ONE) THEN
15159                THETA = TWOPI/2.0D0
15160             ELSE
15161                THETA = ACOS(COSTH)
15162             ENDIF
15163             PHI     = ASIN(PHKK(2,I)/(PT  +TINY10))
15164             IF (PHKK(1,I).LT.0.0D0)
15165      &         PHI  = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15166             ENER    = PHKK(4,I)
15167             NN      = NN+1
15168             KTEMP   = MSTU(10)
15169             MSTU(10)= 1
15170             P(NN,5) = PHKK(5,I)
15171             CALL PY1ENT(NN,111,ENER,THETA,PHI)
15172             MSTU(10)  = KTEMP
15173             IHISMO(NN)= I
15174          ENDIF
15175     1 CONTINUE
15176       IF (NN.GT.0) THEN
15177          CALL PYEXEC
15178          NLINES = PYK(0,1)
15179          DO 2 II=1,NLINES
15180             IF (PYK(II,7).EQ.1) THEN
15181                DO 3 KK=1,4
15182                   P1(KK) = PYP(II,KK)
15183     3          CONTINUE
15184                ID = PYK(II,8)
15185                MO = IHISMO(PYK(II,15))
15186                CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15187                IF (LEMCCK)
15188      &            CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15189      &                                            IDUM,IDUM)
15190 *sr: flag with neg. sign (for HELIOS p/A-W jobs)
15191                ISTHKK(MO) = -2
15192             ENDIF
15193     2    CONTINUE
15194          IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15195       ENDIF
15196       MDCY(KC,1) = 0
15197
15198       RETURN
15199       END
15200
15201 *$ CREATE DT_DTWOPD.FOR
15202 *COPY DT_DTWOPD
15203 *
15204 *===dtwopd=============================================================*
15205 *
15206       SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15207      &                                            COF2,SIF2,AM1,AM2)
15208
15209 ************************************************************************
15210 * Two-particle decay.                                                  *
15211 *  UMO                 cm-energy of the decaying system       (input)  *
15212 *  AM1/AM2             masses of the decay products           (input)  *
15213 *  ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15214 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15215 * Revised by S. Roesler, 20.11.95                                      *
15216 ************************************************************************
15217
15218       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15219       SAVE
15220       PARAMETER ( LINP = 10 ,
15221      &            LOUT = 6 ,
15222      &            LDAT = 9 )
15223       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15224
15225       IF (UMO.LT.(AM1+AM2)) THEN
15226          WRITE(LOUT,1000) UMO,AM1,AM2
15227  1000    FORMAT(1X,'DTWOPD:    inconsistent kinematics - UMO,AM1,AM2 ',
15228      &          3E12.3)
15229          STOP
15230       ENDIF
15231
15232       ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15233       ECM2 = UMO-ECM1
15234       PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15235       PCM2 = PCM1
15236       CALL DT_DSFECF(SIF1,COF1)
15237       COD1 = TWO*DT_RNDM(PCM2)-ONE
15238       COD2 = -COD1
15239       COF2 = -COF1
15240       SIF2 = -SIF1
15241
15242       RETURN
15243       END
15244
15245 *$ CREATE DT_DTHREP.FOR
15246 *COPY DT_DTHREP
15247 *
15248 *===dthrep=============================================================*
15249 *
15250       SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15251      &                  SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15252
15253 ************************************************************************
15254 * Three-particle decay.                                                *
15255 *  UMO                 cm-energy of the decaying system       (input)  *
15256 *  AM1/2/3             masses of the decay products           (input)  *
15257 *  ECM1/2/2,PCM1/2/3   cm-energies/momenta of the decay prod. (output) *
15258 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15259 *                                                                      *
15260 * Threpd89: slight revision by A. Ferrari                              *
15261 * Last change on   11-oct-93   by    Alfredo Ferrari, INFN - Milan     *
15262 * Revised by S. Roesler, 20.11.95                                      *
15263 ************************************************************************
15264
15265       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15266       SAVE
15267       PARAMETER ( LINP = 10 ,
15268      &            LOUT = 6 ,
15269      &            LDAT = 9 )
15270
15271       PARAMETER ( ANGLSQ = 2.5D-31 )
15272       PARAMETER ( AZRZRZ = 1.0D-30 )
15273       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
15274       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
15275       PARAMETER ( ONEONE = 1.D+00 )
15276       PARAMETER ( TWOTWO = 2.D+00 )
15277       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15278
15279       COMMON /HNGAMR/ REDU,AMO,AMM(15)
15280 * flags for input different options
15281       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15282       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15283      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15284
15285       DIMENSION F(5),XX(5)
15286       DATA EPS /AZRZRZ/
15287
15288       UMOO=UMO+UMO
15289 C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
15290 C***J. VON NEUMANN - RANDOM - SELECTION OF S2
15291 C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
15292       UUMO=UMO
15293       AAM1=AM1
15294       AAM2=AM2
15295       AAM3=AM3
15296       GU=(AM2+AM3)**2
15297       GO=(UMO-AM1)**2
15298 *     UFAK=1.0000000000001D0
15299 *     IF (GU.GT.GO) UFAK=0.9999999999999D0
15300       IF (GU.GT.GO) THEN
15301          UFAK=ONEMNS
15302       ELSE
15303          UFAK=ONEPLS
15304       END IF
15305       OFAK=2.D0-UFAK
15306       GU=GU*UFAK
15307       GO=GO*OFAK
15308       DS2=(GO-GU)/99.D0
15309       AM11=AM1*AM1
15310       AM22=AM2*AM2
15311       AM33=AM3*AM3
15312       UMO2=UMO*UMO
15313       RHO2=0.D0
15314       S22=GU
15315       DO 124 I=1,100
15316          S21=S22
15317          S22=GU+(I-1.D0)*DS2
15318          RHO1=RHO2
15319          RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
15320      *                                             (S22+EPS)
15321          IF(RHO2.LT.RHO1) GO TO 125
15322   124 CONTINUE
15323   125 S2SUP=(S22-S21)*.5D0+S21
15324       SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
15325      *                                           (S2SUP+EPS)
15326       SUPRHO=SUPRHO*1.05D0
15327       XO=S21-DS2
15328       IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
15329       IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
15330       XX(1)=XO
15331       XX(3)=S22
15332       X1=(XO+S22)*0.5D0
15333       XX(2)=X1
15334       F(3)=RHO2
15335       F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
15336       F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
15337       DO 126 I=1,16
15338          X4=(XX(1)+XX(2))*0.5D0
15339          X5=(XX(2)+XX(3))*0.5D0
15340          F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
15341      *                                               (X4+EPS)
15342          F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
15343      *                                               (X5+EPS)
15344          XX(4)=X4
15345          XX(5)=X5
15346          DO 128 II=1,5
15347             IA=II
15348             DO 128 III=IA,5
15349                IF (F (II).GE.F (III)) GO TO 128
15350                FH=F(II)
15351                F(II)=F(III)
15352                F(III)=FH
15353                FH=XX(II)
15354                XX(II)=XX(III)
15355                XX(III)=FH
15356 128      CONTINUE
15357          SUPRHO=F(1)
15358          S2SUP=XX(1)
15359          DO 129 II=1,3
15360             IA=II
15361             DO 129 III=IA,3
15362                IF (XX(II).GE.XX(III)) GO TO 129
15363                FH=F(II)
15364                F(II)=F(III)
15365                F(III)=FH
15366                FH=XX(II)
15367                XX(II)=XX(III)
15368                XX(III)=FH
15369 129      CONTINUE
15370 126   CONTINUE
15371       AM23=(AM2+AM3)**2
15372       ITH=0
15373       REDU=2.D0
15374     1 CONTINUE
15375       ITH=ITH+1
15376       IF (ITH.GT.200) REDU=-9.D0
15377       IF (ITH.GT.200) GO TO 400
15378       C=DT_RNDM(REDU)
15379 *     S2=AM23+C*((UMO-AM1)**2-AM23)
15380       S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
15381       Y=DT_RNDM(S2)
15382       Y=Y*SUPRHO
15383       RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
15384       IF(Y.GT.RHO) GO TO 1
15385 C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
15386       S1=DT_RNDM(S2)
15387       S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
15388      &RHO*.5D0
15389       S3=UMO2+AM11+AM22+AM33-S1-S2
15390       ECM1=(UMO2+AM11-S2)/UMOO
15391       ECM2=(UMO2+AM22-S3)/UMOO
15392       ECM3=(UMO2+AM33-S1)/UMOO
15393       PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
15394       PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
15395       PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
15396       CALL DT_DSFECF(SFE,CFE)
15397 C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
15398 C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
15399       PCM12 = PCM1 * PCM2
15400       IF ( PCM12 .LT. ANGLSQ ) GO TO 200
15401       COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
15402       GO TO 300
15403  200  CONTINUE
15404          UW=DT_RNDM(S1)
15405          COSTH=(UW-0.5D+00)*2.D+00
15406  300  CONTINUE
15407 *     IF(ABS(COSTH).GT.0.9999999999999999D0)
15408 *    &COSTH=SIGN(0.9999999999999999D0,COSTH)
15409       IF(ABS(COSTH).GT.ONEONE)
15410      &COSTH=SIGN(ONEONE,COSTH)
15411       IF (REDU.LT.1.D+00) RETURN
15412       COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
15413 *     IF(ABS(COSTH2).GT.0.9999999999999999D0)
15414 *    &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
15415       IF(ABS(COSTH2).GT.ONEONE)
15416      &COSTH2=SIGN(ONEONE,COSTH2)
15417       SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
15418       SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
15419       SINTH1=COSTH2*SINTH-COSTH*SINTH2
15420       COSTH1=COSTH*COSTH2+SINTH2*SINTH
15421 C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
15422 C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
15423 C***THE DIRECTION OF PARTICLE 3
15424 C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
15425       CX11=-COSTH1
15426       CY11=SINTH1*CFE
15427       CZ11=SINTH1*SFE
15428       CX22=-COSTH2
15429       CY22=-SINTH2*CFE
15430       CZ22=-SINTH2*SFE
15431       CALL DT_DSFECF(SIF3,COF3)
15432       COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
15433       SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
15434     2 FORMAT(5F20.15)
15435       COD1=CX11*COD3+CZ11*SID3
15436       CHLP=(ONEONE-COD1)*(ONEONE+COD1)
15437       IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
15438      &CX11,CZ11
15439       SID1=SQRT(CHLP)
15440       COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
15441       SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
15442       COD2=CX22*COD3+CZ22*SID3
15443       SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
15444       COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
15445       SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
15446  400  CONTINUE
15447 * === Energy conservation check: === *
15448       EOCHCK = UMO - ECM1 - ECM2 - ECM3
15449 *     SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
15450 *     SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
15451 *     SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
15452       PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
15453       PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
15454      &       + PCM3 * COF3 * SID3
15455       PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
15456      &       + PCM3 * SIF3 * SID3
15457       EOCMPR = 1.D-12 * UMO
15458       IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
15459      &     .GT. EOCMPR ) THEN
15460 **sr 5.5.95 output-unit changed
15461          IF (IOULEV(1).GT.0) THEN
15462             WRITE(LOUT,*)
15463      &      ' *** Threpd: energy/momentum conservation failure! ***',
15464      &      EOCHCK,PXCHCK,PYCHCK,PZCHCK
15465             WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
15466          ENDIF
15467 **
15468       END IF
15469       RETURN
15470       END
15471
15472 *$ CREATE DT_DBKLAS.FOR
15473 *COPY DT_DBKLAS
15474 *
15475 *===dbklas=============================================================*
15476 *
15477       SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
15478
15479       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15480       SAVE
15481       PARAMETER ( LINP = 10 ,
15482      &            LOUT = 6 ,
15483      &            LDAT = 9 )
15484
15485 * quark-content to particle index conversion (DTUNUC 1.x)
15486       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15487      &                IA08(6,21),IA10(6,21)
15488
15489       IF (I) 20,20,10
15490 * baryons
15491    10 CONTINUE
15492       CALL DT_INDEXD(J,K,IND)
15493       I8  = IB08(I,IND)
15494       I10 = IB10(I,IND)
15495       IF (I8.LE.0) I8 = I10
15496       RETURN
15497 * antibaryons
15498    20 CONTINUE
15499       II = IABS(I)
15500       JJ = IABS(J)
15501       KK = IABS(K)
15502       CALL DT_INDEXD(JJ,KK,IND)
15503       I8  = IA08(II,IND)
15504       I10 = IA10(II,IND)
15505       IF (I8.LE.0) I8 = I10
15506
15507       RETURN
15508       END
15509
15510 *$ CREATE DT_INDEXD.FOR
15511 *COPY DT_INDEXD
15512 *
15513 *===indexd=============================================================*
15514 *
15515       SUBROUTINE DT_INDEXD(KA,KB,IND)
15516
15517       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15518       SAVE
15519       PARAMETER ( LINP = 10 ,
15520      &            LOUT = 6 ,
15521      &            LDAT = 9 )
15522
15523       KP = KA*KB
15524       KS = KA+KB
15525       IF (KP.EQ.1) IND=1
15526       IF (KP.EQ.2) IND=2
15527       IF (KP.EQ.3) IND=3
15528       IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
15529       IF (KP.EQ.5) IND=5
15530       IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
15531       IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
15532       IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
15533       IF (KP.EQ.8)  IND=9
15534       IF (KP.EQ.10) IND=10
15535       IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
15536       IF (KP.EQ.9)  IND=12
15537       IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
15538       IF (KP.EQ.15) IND=14
15539       IF (KP.EQ.18) IND=15
15540       IF (KP.EQ.16) IND=16
15541       IF (KP.EQ.20) IND=17
15542       IF (KP.EQ.24) IND=18
15543       IF (KP.EQ.25) IND=19
15544       IF (KP.EQ.30) IND=20
15545       IF (KP.EQ.36) IND=21
15546
15547       RETURN
15548       END
15549
15550 *$ CREATE DT_DCHANT.FOR
15551 *COPY DT_DCHANT
15552 *
15553 *===dchant=============================================================*
15554 *
15555       SUBROUTINE DT_DCHANT
15556
15557       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15558       SAVE
15559       PARAMETER ( LINP = 10 ,
15560      &            LOUT = 6 ,
15561      &            LDAT = 9 )
15562       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15563
15564 * HADRIN: decay channel information
15565       PARAMETER (IDMAX9=602)
15566       CHARACTER*8 ZKNAME
15567       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15568 * particle properties (BAMJET index convention)
15569       CHARACTER*8  ANAME
15570       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15571      &                IICH(210),IIBAR(210),K1(210),K2(210)
15572
15573       DIMENSION HWT(IDMAX9)
15574
15575 * change of weights wt from absolut values into the sum of wt of a dec.
15576       DO 10 J=1,IDMAX9
15577          HWT(J) = ZERO
15578    10 CONTINUE
15579 C     DO 999 KKK=1,210
15580 C        WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
15581 C    &      ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
15582 C    &      K1(KKK),K2(KKK)
15583 C 999 CONTINUE
15584 C     STOP
15585       DO 30 I=1,210
15586          IK1 = K1(I)
15587          IK2 = K2(I)
15588          HV  = ZERO
15589          DO 20 J=IK1,IK2
15590             HV     = HV+WT(J)
15591             HWT(J) = HV
15592 **sr 13.1.95
15593             IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
15594  1000       FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
15595    20    CONTINUE
15596    30 CONTINUE
15597       DO 40 J=1,IDMAX9
15598          WT(J) = HWT(J)
15599    40 CONTINUE
15600
15601       RETURN
15602       END
15603
15604 *$ CREATE DT_DDATAR.FOR
15605 *COPY DT_DDATAR
15606 *
15607 *===ddatar=============================================================*
15608 *
15609       SUBROUTINE DT_DDATAR
15610
15611       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15612       SAVE
15613       PARAMETER ( LINP = 10 ,
15614      &            LOUT = 6 ,
15615      &            LDAT = 9 )
15616       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15617
15618 * quark-content to particle index conversion (DTUNUC 1.x)
15619       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15620      &                IA08(6,21),IA10(6,21)
15621
15622       DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
15623
15624       DATA IV/ 33, 34, 38,123,  0,  0, 32, 33, 39,124,
15625      &          0,  0, 36, 37, 96,127,  0,  0,126,125,
15626      &        128,129,14*0/
15627       DATA IP/ 23, 14, 16,116,  0,  0, 13, 23, 25,117,
15628      &          0,  0, 15, 24, 31,120,  0,  0,119,118,
15629      &        121,122,14*0/
15630       DATA IB/  0,  1, 21,140,  0,  0,  8, 22,137,  0,
15631      &          0, 97,138,  0,  0,146,  0,  0,  0,  0,
15632      &          0,  1,  8, 22,137,  0,  0,  0, 20,142,
15633      &          0,  0, 98,139,  0,  0,147,  0,  0,  0,
15634      &          0,  0, 21, 22, 97,138,  0,  0, 20, 98,
15635      &        139,  0,  0,  0,145,  0,  0,148,  0,  0,
15636      &          0,  0,  0,140,137,138,146,  0,  0,142,
15637      &        139,147,  0,  0,145,148,           50*0/
15638       DATA IBB/53, 54,104,161,  0,  0, 55,105,162,  0,
15639      &          0,107,164,  0,  0,167,  0,  0,  0,  0,
15640      &          0, 54, 55,105,162,  0,  0, 56,106,163,
15641      &          0,  0,108,165,  0,  0,168,  0,  0,  0,
15642      &          0,  0,104,105,107,164,  0,  0,106,108,
15643      &        165,  0,  0,109,166,  0,  0,169,  0,  0,
15644      &          0,  0,  0,161,162,164,167,  0,  0,163,
15645      &        165,168,  0,  0,166,169,  0,  0,170,47*0/
15646       DATA IA/  0,  2, 99,152,  0,  0,  9,100,149,  0,
15647      &          0,102,150,  0,  0,158,  0,  0,  0,  0,
15648      &          0,  2,  9,100,149,  0,  0,  0,101,154,
15649      &          0,  0,103,151,  0,  0,159,  0,  0,  0,
15650      &          0,  0, 99,100,102,150,  0,  0,101,103,
15651      &        151,  0,  0,  0,157,  0,  0,160,  0,  0,
15652      &          0,  0,  0,152,149,150,158,  0,  0,154,
15653      &        151,159,  0,  0,157,160,           50*0/
15654       DATA IAA/67, 68,110,171,  0,  0, 69,111,172,  0,
15655      &          0,113,174,  0,  0,177,  0,  0,  0,  0,
15656      &          0, 68, 69,111,172,  0,  0, 70,112,173,
15657      &          0,  0,114,175,  0,  0,178,  0,  0,  0,
15658      &          0,  0,110,111,113,174,  0,  0,112,114,
15659      &        175,  0,  0,115,176,  0,  0,179,  0,  0,
15660      &          0,  0,  0,171,172,174,177,  0,  0,173,
15661      &        175,178,  0,  0,176,179,  0,  0,180,47*0/
15662
15663       L=0
15664       DO 2 I=1,6
15665          DO 1 J=1,6
15666             L = L+1
15667             IMPS(I,J) = IP(L)
15668             IMVE(I,J) = IV(L)
15669     1    CONTINUE
15670     2 CONTINUE
15671       L=0
15672       DO 4 I=1,6
15673          DO 3 J=1,21
15674             L = L+1
15675             IB08(I,J) = IB(L)
15676             IB10(I,J) = IBB(L)
15677             IA08(I,J) = IA(L)
15678             IA10(I,J) = IAA(L)
15679     3    CONTINUE
15680     4 CONTINUE
15681 C     A1  = 0.88D0
15682 C     B1  = 3.0D0
15683 C     B2  = 3.0D0
15684 C     B3  = 8.0D0
15685 C     LT  = 0
15686 C     LB  = 0
15687 C     BET = 12.0D0
15688 C     AS  = 0.25D0
15689 C     B8  = 0.33D0
15690 C     AME = 0.95D0
15691 C     DIQ = 0.375D0
15692 C     ISU = 4
15693
15694       RETURN
15695       END
15696
15697 *$ CREATE DT_INITJS.FOR
15698 *COPY DT_INITJS
15699 *
15700 *===initjs=============================================================*
15701 *
15702       SUBROUTINE DT_INITJS(MODE)
15703
15704 ************************************************************************
15705 * Initialize JETSET paramters.                                         *
15706 *           MODE = 0 default settings                                  *
15707 *                = 1 PHOJET settings                                   *
15708 *                = 2 DTUNUC settings                                   *
15709 * This version dated 16.02.96 is written by S. Roesler                 *
15710 *                                                                      *
15711 * Last change 27.12.2006 by S. Roesler.                                *
15712 ************************************************************************
15713
15714       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15715       SAVE
15716       PARAMETER ( LINP = 10 ,
15717      &            LOUT = 6 ,
15718      &            LDAT = 9 )
15719       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15720
15721       LOGICAL LFIRST,LFIRDT,LFIRPH
15722
15723       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15724       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15725       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15726 * flags for particle decays
15727       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
15728      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
15729      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
15730 * flags for input different options
15731       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15732       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15733      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15734
15735       INTEGER PYCOMP
15736
15737       DIMENSION IDXSTA(40)
15738       DATA IDXSTA
15739 *          K0s   pi0  lam   alam  sig+  asig+ sig-  asig- tet0  atet0
15740      &  /  310,  111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
15741 *          tet- atet-  om-  aom-   D+    D-    D0    aD0   Ds+   aDs+
15742      &    3312,-3312, 3334,-3334,  411, -411,  421, -421,  431, -431,
15743 *          etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
15744      &     441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
15745 *         Ksic0 aKsic+aKsic0 sig0 asig0
15746      &    4132,-4232,-4132, 3212,-3212, 5*0/
15747
15748       DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
15749
15750       IF (LFIRST) THEN
15751 * save default settings
15752          PDEF1  = PARJ(1)
15753          PDEF2  = PARJ(2)
15754          PDEF3  = PARJ(3)
15755          PDEF5  = PARJ(5)
15756          PDEF6  = PARJ(6)
15757          PDEF7  = PARJ(7)
15758          PDEF18 = PARJ(18)
15759          PDEF19 = PARJ(19)
15760          PDEF21 = PARJ(21)
15761          PDEF42 = PARJ(42)
15762          MDEF12 = MSTJ(12)
15763 * LUJETS / PYJETS array-dimensions
15764          MSTU(4) = 4000
15765 * increase maximum number of JETSET-error prints
15766          MSTU(22) = 50000
15767 * prevent particles decaying
15768          DO 1 I=1,35
15769             IF (I.LT.34) THEN
15770                KC = PYCOMP(IDXSTA(I))
15771                IF (KC.GT.0) THEN
15772                   IF (I.EQ.2) THEN
15773 *  pi0 decay
15774 C                    MDCY(KC,1) = 1
15775                      MDCY(KC,1) = 0
15776 **cr mode
15777 C                 ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
15778 C   &                    (I.EQ.8).OR.(I.EQ.10)) THEN
15779 C                 ELSEIF (I.EQ.4) THEN
15780 C                    MDCY(KC,1) = 1
15781 **
15782                   ELSE
15783 C AM                     MDCY(KC,1) = 0
15784                   ENDIF
15785                ENDIF
15786             ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
15787                KC = PYCOMP(IDXSTA(I))
15788                IF (KC.GT.0) THEN
15789 C AM                 MDCY(KC,1) = 0
15790                ENDIF
15791             ENDIF
15792     1    CONTINUE
15793 *
15794 *
15795 * popcorn:
15796          IF (PDB.LE.ZERO) THEN
15797 *   no popcorn-mechanism
15798             MSTJ(12) = 1
15799          ELSE
15800             MSTJ(12) = 3
15801             PARJ(5)  = PDB
15802          ENDIF
15803 * set JETSET-parameter requested by input cards
15804          IF (NMSTU.GT.0) THEN
15805             DO 2 I=1,NMSTU
15806                MSTU(IMSTU(I)) = MSTUX(I)
15807     2       CONTINUE
15808          ENDIF
15809          IF (NMSTJ.GT.0) THEN
15810             DO 3 I=1,NMSTJ
15811                MSTJ(IMSTJ(I)) = MSTJX(I)
15812     3       CONTINUE
15813          ENDIF
15814          IF (NPARU.GT.0) THEN
15815             DO 4 I=1,NPARU
15816                PARU(IPARU(I)) = PARUX(I)
15817     4       CONTINUE
15818          ENDIF
15819          LFIRST = .FALSE.
15820       ENDIF
15821 *
15822 * PARJ(1)  suppression of qq-aqaq pair prod. compared to
15823 *          q-aq pair prod.                      (default: 0.1)
15824 * PARJ(2)  strangeness suppression               (default: 0.3)
15825 * PARJ(3)  extra suppression of strange diquarks (default: 0.4)
15826 * PARJ(6)  extra suppression of sas-pair shared by B and
15827 *          aB in BMaB                           (default: 0.5)
15828 * PARJ(7)  extra suppression of strange meson M in BMaB
15829 *          configuration                        (default: 0.5)
15830 * PARJ(18) spin 3/2 baryon suppression           (default: 1.0)
15831 * PARJ(21) width sigma in Gaussian p_x, p_y transverse
15832 *          momentum distrib. for prim. hadrons  (default: 0.35)
15833 * PARJ(42) b-parameter for symmetric Lund-fragmentation
15834 *          function                             (default: 0.9 GeV^-2)
15835 *
15836 * PHOJET settings
15837       IF (MODE.EQ.1) THEN
15838 *   JETSET default
15839 C        PARJ(1)  = PDEF1
15840 C        PARJ(2)  = PDEF2
15841 C        PARJ(3)  = PDEF3
15842 C        PARJ(6)  = PDEF6
15843 C        PARJ(7)  = PDEF7
15844 C        PARJ(18) = PDEF18
15845 C        PARJ(21) = PDEF21
15846 C        PARJ(42) = PDEF42
15847 **sr 18.11.98 parameter tuning
15848 C        PARJ(1)  = 0.092D0
15849 C        PARJ(2)  = 0.25D0
15850 C        PARJ(3)  = 0.45D0
15851 C        PARJ(19) = 0.3D0
15852 C        PARJ(21) = 0.45D0
15853 C        PARJ(42) = 1.0D0
15854 **sr 28.04.99 parameter tuning (May 99 minor modifications)
15855          PARJ(1)  = 0.085D0
15856          PARJ(2)  = 0.26D0
15857          PARJ(3)  = 0.8D0
15858          PARJ(11) = 0.38D0
15859          PARJ(18) = 0.3D0
15860          PARJ(19) = 0.4D0
15861          PARJ(21) = 0.36D0
15862          PARJ(41) = 0.3D0
15863          PARJ(42) = 0.86D0
15864          IF (NPARJ.GT.0) THEN
15865             DO 10 I=1,NPARJ
15866                IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
15867    10       CONTINUE
15868          ENDIF
15869          IF (LFIRPH) THEN
15870             WRITE(LOUT,'(1X,A)')
15871      &         'DT_INITJS: JETSET-parameter for PHOJET'
15872             CALL DT_JSPARA(0)
15873             LFIRPH = .FALSE.
15874          ENDIF
15875 * DTUNUC settings
15876       ELSEIF (MODE.EQ.2) THEN
15877          IF (IFRAG(2).EQ.1) THEN
15878 **sr parameters before 9.3.96
15879 C           PARJ(2)  = 0.27D0
15880 C           PARJ(3)  = 0.6D0
15881 C           PARJ(6)  = 0.75D0
15882 C           PARJ(7)  = 0.75D0
15883 C           PARJ(21) = 0.55D0
15884 C           PARJ(42) = 1.3D0
15885 **sr 18.11.98 parameter tuning
15886 C           PARJ(1)  = 0.05D0
15887 C           PARJ(2)  = 0.27D0
15888 C           PARJ(3)  = 0.4D0
15889 C           PARJ(19) = 0.2D0
15890 C           PARJ(21) = 0.45D0
15891 C           PARJ(42) = 1.0D0
15892 **sr 28.04.99 parameter tuning
15893             PARJ(1)  = 0.11D0
15894             PARJ(2)  = 0.36D0
15895             PARJ(3)  = 0.8D0
15896             PARJ(19) = 0.2D0
15897             PARJ(21) = 0.3D0
15898             PARJ(41) = 0.3D0
15899             PARJ(42) = 0.58D0
15900             IF (NPARJ.GT.0) THEN
15901                DO 20 I=1,NPARJ
15902                   IF (IPARJ(I).LT.0) THEN
15903                      IDX = ABS(IPARJ(I))
15904                      PARJ(IDX) = PARJX(I)
15905                   ENDIF
15906    20          CONTINUE
15907             ENDIF
15908             IF (LFIRDT) THEN
15909                WRITE(LOUT,'(1X,A)')
15910      &           'DT_INITJS: JETSET-parameter for DTUNUC'
15911                CALL DT_JSPARA(0)
15912                LFIRDT = .FALSE.
15913             ENDIF
15914          ELSEIF (IFRAG(2).EQ.2) THEN
15915             PARJ(1)  = 0.11D0
15916             PARJ(2)  = 0.27D0
15917             PARJ(3)  = 0.3D0
15918             PARJ(6)  = 0.35D0
15919             PARJ(7)  = 0.45D0
15920             PARJ(18) = 0.66D0
15921 C           PARJ(21) = 0.55D0
15922 C           PARJ(42) = 1.0D0
15923             PARJ(21) = 0.60D0
15924             PARJ(42) = 1.3D0
15925          ELSE
15926             PARJ(1)  = PDEF1
15927             PARJ(2)  = PDEF2
15928             PARJ(3)  = PDEF3
15929             PARJ(6)  = PDEF6
15930             PARJ(7)  = PDEF7
15931             PARJ(18) = PDEF18
15932             PARJ(21) = PDEF21
15933             PARJ(42) = PDEF42
15934          ENDIF
15935       ELSE
15936          PARJ(1)  = PDEF1
15937          PARJ(2)  = PDEF2
15938          PARJ(3)  = PDEF3
15939          PARJ(5)  = PDEF5
15940          PARJ(6)  = PDEF6
15941          PARJ(7)  = PDEF7
15942          PARJ(18) = PDEF18
15943          PARJ(19) = PDEF19
15944          PARJ(21) = PDEF21
15945          PARJ(42) = PDEF42
15946          MSTJ(12) = MDEF12
15947       ENDIF
15948
15949       RETURN
15950       END
15951
15952 *$ CREATE DT_JSPARA.FOR
15953 *COPY DT_JSPARA
15954 *
15955 *===jspara=============================================================*
15956 *
15957       SUBROUTINE DT_JSPARA(MODE)
15958
15959       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15960       SAVE
15961       PARAMETER ( LINP = 10 ,
15962      &            LOUT = 6 ,
15963      &            LDAT = 9 )
15964       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
15965      &           ONE=1.0D0,ZERO=0.0D0)
15966
15967       LOGICAL LFIRST
15968
15969       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15970
15971       DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
15972
15973       DATA LFIRST /.TRUE./
15974
15975 * save the default JETSET-parameter on the first call
15976       IF (LFIRST) THEN
15977          DO 1 I=1,200
15978             ISTU(I) = MSTU(I)
15979             QARU(I) = PARU(I)
15980             ISTJ(I) = MSTJ(I)
15981             QARJ(I) = PARJ(I)
15982     1    CONTINUE
15983          LFIRST = .FALSE.
15984       ENDIF
15985
15986       WRITE(LOUT,1000)
15987  1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
15988
15989 * compare the default JETSET-parameter with the present values
15990       DO 2 I=1,200
15991          IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
15992             WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
15993 C           ISTU(I) = MSTU(I)
15994          ENDIF
15995          DIFF = ABS(PARU(I)-QARU(I))
15996          IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
15997             WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
15998 C           QARU(I) = PARU(I)
15999          ENDIF
16000          IF (MSTJ(I).NE.ISTJ(I)) THEN
16001             WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16002 C           ISTJ(I) = MSTJ(I)
16003          ENDIF
16004          DIFF = ABS(PARJ(I)-QARJ(I))
16005          IF (DIFF.GE.1.0D-5) THEN
16006             WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16007 C           QARJ(I) = PARJ(I)
16008          ENDIF
16009     2 CONTINUE
16010  1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16011  1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16012
16013       RETURN
16014       END
16015
16016 *$ CREATE DT_FOZOCA.FOR
16017 *COPY DT_FOZOCA
16018 *
16019 *===fozoca=============================================================*
16020 *
16021       SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16022
16023 ************************************************************************
16024 * This subroutine treats the complete FOrmation ZOne supressed intra-  *
16025 * nuclear CAscade.                                                     *
16026 *               LFZC = .true.  cascade has been treated                *
16027 *                    = .false. cascade skipped                         *
16028 * This is a completely revised version of the original FOZOKL.         *
16029 * This version dated 18.11.95 is written by S. Roesler                 *
16030 ************************************************************************
16031
16032       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16033       SAVE
16034       PARAMETER ( LINP = 10 ,
16035      &            LOUT = 6 ,
16036      &            LDAT = 9 )
16037       PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16038       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16039
16040       LOGICAL LSTART,LCAS,LFZC
16041
16042 * event history
16043       PARAMETER (NMXHKK=200000)
16044       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16045      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16046      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16047 * extended event history
16048       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16049      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16050      &                IHIST(2,NMXHKK)
16051 * rejection counter
16052       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16053      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16054      &                IREXCI(3),IRDIFF(2),IRINC
16055 * properties of interacting particles
16056       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16057 * Glauber formalism: collision properties
16058       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16059      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16060 * flags for input different options
16061       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16062       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16063      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16064 * final state after intranuclear cascade step
16065       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16066 * parameter for intranuclear cascade
16067       LOGICAL LPAULI
16068       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16069
16070       DIMENSION NCWOUN(2)
16071
16072       DATA LSTART /.TRUE./
16073
16074       LFZC = .TRUE.
16075       IREJ = 0
16076
16077 * skip cascade if hadron-hadron interaction or if supressed by user
16078       IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16079 * skip cascade if not all possible chains systems are hadronized
16080       DO 1 I=1,8
16081          IF (.NOT.LHADRO(I)) GOTO 9999
16082     1 CONTINUE
16083
16084       IF (LSTART) THEN
16085          WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16086  1000    FORMAT(/,1X,'FOZOCA:  intranuclear cascade treated for a ',
16087      &          'maximum of',I4,' generations',/,10X,'formation time ',
16088      &          'parameter:',F5.1,'  fm/c',9X,'modus:',I2)
16089          IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16090          IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16091  1001    FORMAT(10X,'p_t dependent formation zone',/)
16092  1002    FORMAT(10X,'constant formation zone',/)
16093          LSTART = .FALSE.
16094       ENDIF
16095
16096 * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16097 * which may interact with final state particles are stored in a seperate
16098 * array - here all proj./target nucleon-indices (just for simplicity)
16099       NOINC = 0
16100       DO 9 I=1,NPOINT(1)-1
16101          NOINC = NOINC+1
16102          IDXINC(NOINC) = I
16103     9 CONTINUE
16104
16105 * initialize Pauli-principle treatment (find wounded nucleons)
16106       NWOUND(1) = 0
16107       NWOUND(2) = 0
16108       NCWOUN(1) = 0
16109       NCWOUN(2) = 0
16110       DO 2 J=1,NPOINT(1)
16111          DO 3 I=1,2
16112             IF (ISTHKK(J).EQ.10+I) THEN
16113                NWOUND(I) = NWOUND(I)+1
16114                EWOUND(I,NWOUND(I)) = PHKK(4,J)
16115                IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16116             ENDIF
16117     3    CONTINUE
16118     2 CONTINUE
16119
16120 * modify nuclear potential for wounded nucleons
16121       IPRCL  = IP -NWOUND(1)
16122       IPZRCL = IPZ-NCWOUN(1)
16123       ITRCL  = IT -NWOUND(2)
16124       ITZRCL = ITZ-NCWOUN(2)
16125       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16126
16127       NSTART = NPOINT(4)
16128       NEND   = NHKK
16129
16130     7 CONTINUE
16131       DO 8 I=NSTART,NEND
16132
16133          IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16134 * select nucleus the cascade starts first (proj. - 1, target - -1)
16135             NCAS   = 1
16136 *   projectile/target with probab. 1/2
16137             IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16138                IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16139 *   in the nucleus with highest mass
16140             ELSEIF (INCMOD.EQ.2) THEN
16141                IF (IP.GT.IT) THEN
16142                   NCAS = -NCAS
16143                ELSEIF (IP.EQ.IT) THEN
16144                   IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16145                ENDIF
16146 * the nucleus the cascade starts first is requested to be the one
16147 * moving in the direction of the secondary
16148             ELSEIF (INCMOD.EQ.3) THEN
16149                NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
16150             ENDIF
16151 * check that the selected "nucleus" is not a hadron
16152             IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
16153      &          ((NCAS.EQ.-1).AND.(IT.LE.1)))    NCAS = -NCAS
16154
16155 * treat intranuclear cascade in the nucleus selected first
16156             LCAS = .FALSE.
16157             CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16158             IF (IREJ1.NE.0) GOTO 9998
16159 * treat intranuclear cascade in the other nucleus if this isn't a had.
16160             NCAS = -NCAS
16161             IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
16162      &          ((NCAS.EQ.-1).AND.(IT.GT.1)))    THEN
16163                IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16164                IF (IREJ1.NE.0) GOTO 9998
16165             ENDIF
16166
16167          ENDIF
16168
16169     8 CONTINUE
16170       NSTART = NEND+1
16171       NEND   = NHKK
16172       IF (NSTART.LE.NEND) GOTO 7
16173
16174       RETURN
16175
16176  9998 CONTINUE
16177 * reject this event
16178       IRINC = IRINC+1
16179       IREJ = 1
16180
16181  9999 CONTINUE
16182 * intranucl. cascade not treated because of interaction properties or
16183 * it is supressed by user or it was rejected or...
16184       LFZC = .FALSE.
16185 * reset flag characterizing direction of motion in n-n-cms
16186 **sr14-11-95
16187 C     DO 9990 I=NPOINT(5),NHKK
16188 C        IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
16189 C9990 CONTINUE
16190
16191       RETURN
16192       END
16193
16194 *$ CREATE DT_INUCAS.FOR
16195 *COPY DT_INUCAS
16196 *
16197 *===inucas=============================================================*
16198 *
16199       SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
16200
16201 ************************************************************************
16202 * Formation zone supressed IntraNUclear CAScade for one final state    *
16203 * particle.                                                            *
16204 *           IT, IP    mass numbers of target, projectile nuclei        *
16205 *           IDXCAS    index of final state particle in DTEVT1          *
16206 *           NCAS =  1 intranuclear cascade in projectile               *
16207 *                = -1 intranuclear cascade in target                   *
16208 * This version dated 18.11.95 is written by S. Roesler                 *
16209 ************************************************************************
16210
16211       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16212       SAVE
16213       PARAMETER ( LINP = 10 ,
16214      &            LOUT = 6 ,
16215      &            LDAT = 9 )
16216
16217       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
16218      &           OHALF=0.5D0,ONE=1.0D0)
16219       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16220       PARAMETER (TWOPI=6.283185307179586454D+00)
16221       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
16222
16223       LOGICAL LABSOR,LCAS
16224
16225 * event history
16226       PARAMETER (NMXHKK=200000)
16227       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16228      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16229      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16230 * extended event history
16231       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16232      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16233      &                IHIST(2,NMXHKK)
16234 * final state after inc step
16235       PARAMETER (MAXFSP=10)
16236       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
16237 * flags for input different options
16238       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16239       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16240      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16241 * particle properties (BAMJET index convention)
16242       CHARACTER*8  ANAME
16243       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16244      &                IICH(210),IIBAR(210),K1(210),K2(210)
16245 * Glauber formalism: collision properties
16246       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16247      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16248 * nuclear potential
16249       LOGICAL LFERMI
16250       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
16251      &                EBINDP(2),EBINDN(2),EPOT(2,210),
16252      &                ETACOU(2),ICOUL,LFERMI
16253 * parameter for intranuclear cascade
16254       LOGICAL LPAULI
16255       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16256 * final state after intranuclear cascade step
16257       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16258 * nucleon-nucleon event-generator
16259       CHARACTER*8 CMODEL
16260       LOGICAL LPHOIN
16261       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
16262 * statistics: residual nuclei
16263       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
16264      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
16265      &                NINCST(2,4),NINCEV(2),
16266      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
16267      &                NRESPB(2),NRESCH(2),NRESEV(4),
16268      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
16269      &                NEVAFI(2,2)
16270
16271       DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
16272      &          PCAS1(5),PNUC(5),BGTA(4),
16273      &          BGCAS(2),GACAS(2),BECAS(2),
16274      &          RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
16275
16276       DATA PDIF /0.545D0/
16277
16278       IREJ = 0
16279
16280 * update counter
16281       IF (NINCEV(1).NE.NEVHKK) THEN
16282          NINCEV(1) = NEVHKK
16283          NINCEV(2) = NINCEV(2)+1
16284       ENDIF
16285
16286 * "BAMJET-index" of this hadron
16287       IDCAS = IDBAM(IDXCAS)
16288       IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
16289
16290 * skip gammas, electrons, etc..
16291       IF (AAM(IDCAS).LT.TINY2) RETURN
16292
16293 * Lorentz-trsf. into projectile rest system
16294       IF (IP.GT.1) THEN
16295          CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16296      &               PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
16297      &               PCAS(1,4),IDCAS,-2)
16298          PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
16299          PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
16300          IF (PCAS(1,5).GT.ZERO) THEN
16301             PCAS(1,5) = SQRT(PCAS(1,5))
16302          ELSE
16303             PCAS(1,5) = AAM(IDCAS)
16304          ENDIF
16305          DO 20 K=1,3
16306             COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
16307    20    CONTINUE
16308 * Lorentz-parameters
16309 *   particle rest system --> projectile rest system
16310          BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
16311          GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
16312          BECAS(1) = BGCAS(1)/GACAS(1)
16313       ELSE
16314          DO 21 K=1,5
16315             PCAS(1,K) = ZERO
16316             IF (K.LE.3) COSCAS(1,K) = ZERO
16317    21    CONTINUE
16318          PTOCAS(1) = ZERO
16319          BGCAS(1)  = ZERO
16320          GACAS(1)  = ZERO
16321          BECAS(1)  = ZERO
16322       ENDIF
16323 * Lorentz-trsf. into target rest system
16324       IF (IT.GT.1) THEN
16325 * LEPTO: final state particles are already in target rest frame
16326 C        IF (MCGENE.EQ.3) THEN
16327 C           PCAS(2,1) = PHKK(1,IDXCAS)
16328 C           PCAS(2,2) = PHKK(2,IDXCAS)
16329 C           PCAS(2,3) = PHKK(3,IDXCAS)
16330 C           PCAS(2,4) = PHKK(4,IDXCAS)
16331 C        ELSE
16332             CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16333      &                  PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
16334      &                  PCAS(2,4),IDCAS,-3)
16335 C        ENDIF
16336          PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
16337          PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
16338          IF (PCAS(2,5).GT.ZERO) THEN
16339             PCAS(2,5) = SQRT(PCAS(2,5))
16340          ELSE
16341             PCAS(2,5) = AAM(IDCAS)
16342          ENDIF
16343          DO 22 K=1,3
16344             COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
16345    22    CONTINUE
16346 * Lorentz-parameters
16347 *   particle rest system --> target rest system
16348          BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
16349          GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
16350          BECAS(2) = BGCAS(2)/GACAS(2)
16351       ELSE
16352          DO 23 K=1,5
16353             PCAS(2,K) = ZERO
16354             IF (K.LE.3) COSCAS(2,K) = ZERO
16355    23    CONTINUE
16356          PTOCAS(2) = ZERO
16357          BGCAS(2)  = ZERO
16358          GACAS(2)  = ZERO
16359          BECAS(2)  = ZERO
16360       ENDIF
16361
16362 * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
16363 * potential (see CONUCL)
16364       RNUC(1)  = (RPROJ+4.605D0*PDIF)*FM2MM
16365       RNUC(2)  = (RTARG+4.605D0*PDIF)*FM2MM
16366 * impact parameter (the projectile moving along z)
16367       BIMPC(1) = ZERO
16368       BIMPC(2) = BIMPAC*FM2MM
16369
16370 * get position of initial hadron in projectile/target rest-syst.
16371       DO 3 K=1,4
16372          VTXCAS(1,K) = WHKK(K,IDXCAS)
16373          VTXCAS(2,K) = VHKK(K,IDXCAS)
16374     3 CONTINUE
16375
16376       ICAS = 1
16377       I2   = 2
16378       IF (NCAS.EQ.-1) THEN
16379          ICAS = 2
16380          I2   = 1
16381       ENDIF
16382
16383       IF (PTOCAS(ICAS).LT.TINY10) THEN
16384          WRITE(LOUT,1000) PTOCAS
16385  1000    FORMAT(1X,'INUCAS:   warning! zero momentum of initial',
16386      &          '  hadron ',/,20X,2E12.4)
16387          GOTO 9999
16388       ENDIF
16389
16390 * reset spectator flags
16391       NSPE = 0
16392       IDXSPE(1) = 0
16393       IDXSPE(2) = 0
16394       IDSPE(1)  = 0
16395       IDSPE(2)  = 0
16396
16397 * formation length (in fm)
16398 C     IF (LCAS) THEN
16399 C        DEL0 = ZERO
16400 C     ELSE
16401          DEL0 = TAUFOR*BGCAS(ICAS)
16402          IF (ITAUVE.EQ.1) THEN
16403             AMT  = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
16404             DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
16405          ENDIF
16406 C     ENDIF
16407 *   sample from exp(-del/del0)
16408       DEL1   = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
16409 * save formation time
16410       TAUSA1 = DEL1/BGCAS(ICAS)
16411       REL1   = TAUSA1*BGCAS(I2)
16412
16413       DEL    = DEL1
16414       TAUSAM = DEL/BGCAS(ICAS)
16415       REL    = TAUSAM*BGCAS(I2)
16416
16417 * special treatment for negative particles unable to escape
16418 * nuclear potential (implemented for ap, pi-, K- only)
16419       LABSOR = .FALSE.
16420       IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
16421 *   threshold energy = nuclear potential + Coulomb potential
16422 *   (nuclear potential for hadron-nucleus interactions only)
16423          ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
16424          IF (PCAS(ICAS,4).LT.ETHR) THEN
16425             DO 4 K=1,5
16426                PCAS1(K) = PCAS(ICAS,K)
16427     4       CONTINUE
16428 *   "absorb" negative particle in nucleus
16429             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
16430             IF (IREJ1.NE.0) GOTO 9999
16431             IF (NSPE.GE.1) LABSOR = .TRUE.
16432          ENDIF
16433       ENDIF
16434
16435 * if the initial particle has not been absorbed proceed with
16436 * "normal" cascade
16437       IF (.NOT.LABSOR) THEN
16438
16439 *   calculate coordinates of hadron at the end of the formation zone
16440 *   transport-time and -step in the rest system where this step is
16441 *   treated
16442          DSTEP  = DEL*FM2MM
16443          DTIME  = DSTEP/BECAS(ICAS)
16444          RSTEP  = REL*FM2MM
16445          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16446             RTIME = RSTEP/BECAS(I2)
16447          ELSE
16448             RTIME = ZERO
16449          ENDIF
16450 *   save step whithout considering the overlapping region
16451          DSTEP1 = DEL1*FM2MM
16452          DTIME1 = DSTEP1/BECAS(ICAS)
16453          RSTEP1 = REL1*FM2MM
16454          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16455             RTIME1 = RSTEP1/BECAS(I2)
16456          ELSE
16457             RTIME1 = ZERO
16458          ENDIF
16459 *   transport to the end of the formation zone in this system
16460          DO 5 K=1,3
16461             VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
16462             VTXCA1(I2,K)   = VTXCAS(I2,K)  +RSTEP1*COSCAS(I2,K)
16463             VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
16464             VTXCAS(I2,K)   = VTXCAS(I2,K)  +RSTEP*COSCAS(I2,K)
16465     5    CONTINUE
16466          VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
16467          VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME1
16468          VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16469          VTXCAS(I2,4)   = VTXCAS(I2,4)  +RTIME
16470
16471          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16472             XCAS   = VTXCAS(ICAS,1)
16473             YCAS   = VTXCAS(ICAS,2)
16474             XNCLTA = BIMPAC*FM2MM
16475             RNCLPR = (RPROJ+RNUCLE)*FM2MM
16476             RNCLTA = (RTARG+RNUCLE)*FM2MM
16477 C           RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
16478 C           RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
16479 C           RNCLPR = (RPROJ)*FM2MM
16480 C           RNCLTA = (RTARG)*FM2MM
16481             RCASPR = SQRT( XCAS**2        +YCAS**2)
16482             RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
16483             IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
16484                IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
16485             ENDIF
16486          ENDIF
16487
16488 *   check if particle is already outside of the corresp. nucleus
16489          RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
16490      &                VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
16491          IF (RDIST.GE.RNUC(ICAS)) THEN
16492 *   here: IDCH is the generation of the final state part. starting
16493 *   with zero for hadronization products
16494 *   flag particles of generation 0 being outside the nuclei after
16495 *   formation time (to be used for excitation energy calculation)
16496             IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
16497      &         NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
16498             GOTO 9997
16499          ENDIF
16500          DIST   = DLARGE
16501          DISTP  = DLARGE
16502          DISTN  = DLARGE
16503          IDXP   = 0
16504          IDXN   = 0
16505
16506 *   already here: skip particles being outside HADRIN "energy-window"
16507 *   to avoid wasting of time
16508          NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
16509          IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
16510             NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
16511 C           WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
16512 C1002       FORMAT(1X,'INUCAS:   warning! momentum of particle with ',
16513 C    &             'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
16514 C    &             E12.4,', above or below HADRIN-thresholds',I6)
16515             NSPE = 0
16516             GOTO 9997
16517          ENDIF
16518
16519          DO 7 IDXHKK=1,NOINC
16520             I = IDXINC(IDXHKK)
16521 *   scan DTEVT1 for unwounded or excited nucleons
16522             IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
16523                DO 8 K=1,3
16524                   IF (ICAS.EQ.1) THEN
16525                      VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
16526                   ELSEIF (ICAS.EQ.2) THEN
16527                      VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
16528                   ENDIF
16529     8          CONTINUE
16530                POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
16531      &                  VTXDST(2)*COSCAS(ICAS,2)+
16532      &                  VTXDST(3)*COSCAS(ICAS,3)
16533 *   check if nucleon is situated in forward direction
16534                IF (POSNUC.GT.ZERO) THEN
16535 *   distance between hadron and this nucleon
16536                   DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16537      &                          VTXDST(3)**2)
16538 *   impact parameter
16539                   BIMNU2 = DISTNU**2-POSNUC**2
16540                   IF (BIMNU2.LT.ZERO) THEN
16541                      WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
16542  1001                FORMAT(1X,'INUCAS:   warning! inconsistent impact',
16543      &                      '  parameter ',/,20X,3E12.4)
16544                      GOTO 7
16545                   ENDIF
16546                   BIMNU  = SQRT(BIMNU2)
16547 *   maximum impact parameter to have interaction
16548                   IDNUC  = IDT_ICIHAD(IDHKK(I))
16549                   IDNUC1 = IDT_MCHAD(IDNUC)
16550                   IDCAS1 = IDT_MCHAD(IDCAS)
16551                   DO 19 K=1,5
16552                      PCAS1(K) = PCAS(ICAS,K)
16553                      PNUC(K)  = PHKK(K,I)
16554    19             CONTINUE
16555 * Lorentz-parameter for trafo into rest-system of target
16556                   DO 18 K=1,4
16557                      BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
16558    18             CONTINUE
16559 * transformation of projectile into rest-system of target
16560                   CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
16561      &                        PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
16562      &                        PPTOT,PX,PY,PZ,PE)
16563 **
16564 C                 CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
16565 C                 CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
16566                   DUMZER = ZERO
16567                   CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
16568                   CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
16569                   IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
16570      &                (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
16571                   SIGIN = SIGTOT-SIGEL-SIGAB
16572 C                 SIGTOT = SIGIN+SIGEL+SIGAB
16573 **
16574                   BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
16575 *   check if interaction is possible
16576                   IF (BIMNU.LE.BIMMAX) THEN
16577 *   get nucleon with smallest distance and kind of interaction
16578 *   (elastic/inelastic)
16579                      IF (DISTNU.LT.DIST) THEN
16580                         DIST      = DISTNU
16581                         BINT      = BIMNU
16582                         IF (IDNUC.NE.IDSPE(1)) THEN
16583                            IDSPE(2)  = IDSPE(1)
16584                            IDXSPE(2) = IDXSPE(1)
16585                            IDSPE(1)  = IDNUC
16586                         ENDIF
16587                         IDXSPE(1) = I
16588                         NSPE      = 1
16589 **sr
16590                         SELA = SIGEL
16591                         SABS = SIGAB
16592                         STOT = SIGTOT
16593 C                       IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
16594 C                          SELA = SIGEL
16595 C                          STOT = SIGIN+SIGEL
16596 C                       ELSE
16597 C                          SELA = SIGEL+0.75D0*SIGIN
16598 C                          STOT = 0.25D0*SIGIN+SELA
16599 C                       ENDIF
16600 **
16601                      ENDIF
16602                   ENDIf
16603                ENDIF
16604                DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16605      &                       VTXDST(3)**2)
16606                IDNUC  = IDT_ICIHAD(IDHKK(I))
16607                IF (IDNUC.EQ.1) THEN
16608                   IF (DISTNU.LT.DISTP) THEN
16609                      DISTP = DISTNU
16610                      IDXP  = I
16611                      POSP  = POSNUC
16612                   ENDIF
16613                ELSEIF (IDNUC.EQ.8) THEN
16614                   IF (DISTNU.LT.DISTN) THEN
16615                      DISTN = DISTNU
16616                      IDXN  = I
16617                      POSN  = POSNUC
16618                   ENDIF
16619                ENDIF
16620             ENDIF
16621     7    CONTINUE
16622
16623 * there is no nucleon for a secondary interaction
16624          IF (NSPE.EQ.0) GOTO 9997
16625
16626 C        IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
16627 C    &      WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
16628          IF (IDXSPE(2).EQ.0) THEN
16629             IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
16630 C              DO 80 K=1,3
16631 C                 IF (ICAS.EQ.1) THEN
16632 C                    VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
16633 C                 ELSEIF (ICAS.EQ.2) THEN
16634 C                    VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
16635 C                 ENDIF
16636 C  80          CONTINUE
16637 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16638 C    &                       VTXDST(3)**2)
16639 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
16640                   IDXSPE(2) = IDXN
16641                   IDSPE(2)  = 8
16642 C              ELSE
16643 C                 STOT = STOT-SABS
16644 C                 SABS = ZERO
16645 C              ENDIF
16646             ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
16647 C              DO 81 K=1,3
16648 C                 IF (ICAS.EQ.1) THEN
16649 C                    VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
16650 C                 ELSEIF (ICAS.EQ.2) THEN
16651 C                    VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
16652 C                 ENDIF
16653 C  81          CONTINUE
16654 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16655 C    &                       VTXDST(3)**2)
16656 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
16657                   IDXSPE(2) = IDXP
16658                   IDSPE(2)  = 1
16659 C              ELSE
16660 C                 STOT = STOT-SABS
16661 C                 SABS = ZERO
16662 C              ENDIF
16663             ELSE
16664                STOT = STOT-SABS
16665                SABS = ZERO
16666             ENDIF
16667          ENDIF
16668          RR = DT_RNDM(DIST)
16669          IF (RR.LT.SELA/STOT) THEN
16670             IPROC = 2
16671          ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
16672             IPROC = 3
16673          ELSE
16674             IPROC = 1
16675          ENDIF
16676
16677          DO 9 K=1,5
16678             PCAS1(K) = PCAS(ICAS,K)
16679             PNUC(K)  = PHKK(K,IDXSPE(1))
16680     9    CONTINUE
16681          IF (IPROC.EQ.3) THEN
16682 * 2-nucleon absorption of pion
16683             NSPE = 2
16684             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
16685             IF (IREJ1.NE.0) GOTO 9999
16686             IF (NSPE.GE.1) LABSOR = .TRUE.
16687          ELSE
16688 * sample secondary interaction
16689             IDNUC = IDBAM(IDXSPE(1))
16690             CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
16691             IF (IREJ1.EQ.1) GOTO 9999
16692             IF (IREJ1.GT.1) GOTO 9998
16693          ENDIF
16694       ENDIF
16695
16696 * update arrays to include Pauli-principle
16697       DO 10 I=1,NSPE
16698          IF (NWOUND(ICAS).LE.299) THEN
16699             NWOUND(ICAS) = NWOUND(ICAS)+1
16700             EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
16701          ENDIF
16702    10 CONTINUE
16703
16704 * dump initial hadron for energy-momentum conservation check
16705       IF (LEMCCK)
16706      &   CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
16707      &               PCAS(ICAS,4),1,IDUM,IDUM)
16708
16709 * dump final state particles into DTEVT1
16710
16711 *   check if Pauli-principle is fulfilled
16712       NPAULI = 0
16713       NWTMP(1) = NWOUND(1)
16714       NWTMP(2) = NWOUND(2)
16715       DO 111 I=1,NFSP
16716          NPAULI = 0
16717          J1 = 2
16718          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16719      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
16720          DO 117 J=1,J1
16721             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
16722             IF (J.EQ.1) THEN
16723                IDX = ICAS
16724                PE  = PFSP(4,I)
16725             ELSE
16726                IDX  = I2
16727                MODE = 1
16728                IF (IDX.EQ.1) MODE = -1
16729                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
16730             ENDIF
16731 * first check if cascade step is forbidden due to Pauli-principle
16732 * (in case of absorpion this step is forced)
16733             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16734      &          (IDFSP(I).EQ.8))) THEN
16735 *   get nuclear potential barrier
16736                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16737                IF (IDFSP(I).EQ.1) THEN
16738                   POTLOW = POT-EBINDP(IDX)
16739                ELSE
16740                   POTLOW = POT-EBINDN(IDX)
16741                ENDIF
16742 *   final state particle not able to escape nucleus
16743                IF (PE.LE.POTLOW) THEN
16744 *     check if there are wounded nucleons
16745                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16746      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
16747                      NPAULI      = NPAULI+1
16748                      NWOUND(IDX) = NWOUND(IDX)-1
16749                   ELSE
16750 *     interaction prohibited by Pauli-principle
16751                      NWOUND(1) = NWTMP(1)
16752                      NWOUND(2) = NWTMP(2)
16753                      GOTO 9997
16754                   ENDIF
16755                ENDIF
16756             ENDIF
16757   117    CONTINUE
16758   111 CONTINUE
16759
16760       NPAULI = 0
16761       NWOUND(1) = NWTMP(1)
16762       NWOUND(2) = NWTMP(2)
16763
16764       DO 11 I=1,NFSP
16765
16766          IST = ISTHKK(IDXCAS)
16767
16768          NPAULI = 0
16769          J1 = 2
16770          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16771      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
16772          DO 17 J=1,J1
16773             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
16774             IDX = ICAS
16775             PE  = PFSP(4,I)
16776             IF (J.EQ.2) THEN
16777                IDX = I2
16778                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
16779             ENDIF
16780 * first check if cascade step is forbidden due to Pauli-principle
16781 * (in case of absorpion this step is forced)
16782             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16783      &          (IDFSP(I).EQ.8))) THEN
16784 *   get nuclear potential barrier
16785                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16786                IF (IDFSP(I).EQ.1) THEN
16787                   POTLOW = POT-EBINDP(IDX)
16788                ELSE
16789                   POTLOW = POT-EBINDN(IDX)
16790                ENDIF
16791 *   final state particle not able to escape nucleus
16792                IF (PE.LE.POTLOW) THEN
16793 *     check if there are wounded nucleons
16794                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16795      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
16796                      NWOUND(IDX) = NWOUND(IDX)-1
16797                      NPAULI = NPAULI+1
16798                      IST    = 14+IDX
16799                   ELSE
16800 *     interaction prohibited by Pauli-principle
16801                      NWOUND(1) = NWTMP(1)
16802                      NWOUND(2) = NWTMP(2)
16803                      GOTO 9997
16804                   ENDIF
16805 **sr
16806 c               ELSEIF (PE.LE.POT) THEN
16807 cC              ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
16808 cC                 NWOUND(IDX) = NWOUND(IDX)-1
16809 c**
16810 c                  NPAULI = NPAULI+1
16811 c                  IST    = 14+IDX
16812                ENDIF
16813             ENDIF
16814    17    CONTINUE
16815
16816 * dump final state particles for energy-momentum conservation check
16817          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
16818      &                           -PFSP(4,I),2,IDUM,IDUM)
16819
16820          PX = PFSP(1,I)
16821          PY = PFSP(2,I)
16822          PZ = PFSP(3,I)
16823          PE = PFSP(4,I)
16824          IF (ABS(IST).EQ.1) THEN
16825 * transform particles back into n-n cms
16826 * LEPTO: leave final state particles in target rest frame
16827 C           IF (MCGENE.EQ.3) THEN
16828 C              PFSP(1,I) = PX
16829 C              PFSP(2,I) = PY
16830 C              PFSP(3,I) = PZ
16831 C              PFSP(4,I) = PE
16832 C           ELSE
16833                IMODE = ICAS+1
16834                CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16835      &                     PFSP(4,I),IDFSP(I),IMODE)
16836 C           ENDIF
16837          ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
16838 * target cascade but fsp got stuck in proj. --> transform it into
16839 * proj. rest system
16840             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16841      &                  PFSP(4,I),IDFSP(I),-1)
16842          ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
16843 * proj. cascade but fsp got stuck in target --> transform it into
16844 * target rest system
16845             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16846      &                  PFSP(4,I),IDFSP(I),1)
16847          ENDIF
16848
16849 * dump final state particles into DTEVT1
16850          IGEN = IDCH(IDXCAS)+1
16851          ID   = IDT_IPDGHA(IDFSP(I))
16852          IXR  = 0
16853          IF (LABSOR) IXR = 99
16854          CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
16855      &               PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
16856
16857 * update the counter for particles which got stuck inside the nucleus
16858          IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
16859             NOINC = NOINC+1
16860             IDXINC(NOINC) = NHKK
16861          ENDIF
16862          IF (LABSOR) THEN
16863 *   in case of absorption the spatial treatment is an approximate
16864 *   solution anyway (the positions of the nucleons which "absorb" the
16865 *   cascade particle are not taken into consideration) therefore the
16866 *   particles are produced at the position of the cascade particle
16867             DO 12 K=1,4
16868                WHKK(K,NHKK) = WHKK(K,IDXCAS)
16869                VHKK(K,NHKK) = VHKK(K,IDXCAS)
16870    12       CONTINUE
16871          ELSE
16872 *   DDISTL - distance the cascade particle moves to the intera. point
16873 *   (the position where impact-parameter = distance to the interacting
16874 *   nucleon), DIST - distance to the interacting nucleon at the time of
16875 *   formation of the cascade particle, BINT - impact-parameter of this
16876 *   cascade-interaction
16877             DDISTL = SQRT(DIST**2-BINT**2)
16878             DTIME  = DDISTL/BECAS(ICAS)
16879             DTIMEL = DDISTL/BGCAS(ICAS)
16880             RDISTL = DTIMEL*BGCAS(I2)
16881             IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16882                RTIME = RDISTL/BECAS(I2)
16883             ELSE
16884                RTIME = ZERO
16885             ENDIF
16886 *   RDISTL, RTIME are this step and time in the rest system of the other
16887 *   nucleus
16888             DO 13 K=1,3
16889                VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
16890                VTXCA1(I2,K)   = VTXCAS(I2,K)  +COSCAS(I2,K)  *RDISTL
16891    13       CONTINUE
16892             VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16893             VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME
16894 *   position of particle production is half the impact-parameter to
16895 *   the interacting nucleon
16896             DO 14 K=1,3
16897                WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
16898                VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
16899    14       CONTINUE
16900 *   time of production of secondary = time of interaction
16901             WHKK(4,NHKK) = VTXCA1(1,4)
16902             VHKK(4,NHKK) = VTXCA1(2,4)
16903          ENDIF
16904
16905    11 CONTINUE
16906
16907 * modify status and position of cascade particle (the latter for
16908 * statistics reasons only)
16909       ISTHKK(IDXCAS) = 2
16910       IF (LABSOR) ISTHKK(IDXCAS) = 19
16911       IF (.NOT.LABSOR) THEN
16912          DO 15 K=1,4
16913             WHKK(K,IDXCAS) = VTXCA1(1,K)
16914             VHKK(K,IDXCAS) = VTXCA1(2,K)
16915    15    CONTINUE
16916       ENDIF
16917
16918       DO 16 I=1,NSPE
16919          IS = IDXSPE(I)
16920 * dump interacting nucleons for energy-momentum conservation check
16921          IF (LEMCCK)
16922      &      CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
16923      &                                                  2,IDUM,IDUM)
16924 * modify entry for interacting nucleons
16925          IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
16926          IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
16927          IF (I.GE.2) THEN
16928             JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
16929             JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
16930          ENDIF
16931    16 CONTINUE
16932
16933 * check energy-momentum conservation
16934       IF (LEMCCK) THEN
16935          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
16936          IF (IREJ1.NE.0) GOTO 9999
16937       ENDIF
16938
16939 * update counter
16940       IF (LABSOR) THEN
16941          NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
16942       ELSE
16943          IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
16944          IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
16945       ENDIF
16946
16947       RETURN
16948
16949  9997 CONTINUE
16950  9998 CONTINUE
16951 * transport-step but no cascade step due to configuration (i.e. there
16952 * is no nucleon for interaction etc.)
16953       IF (LCAS) THEN
16954          DO 100 K=1,4
16955 C           WHKK(K,IDXCAS) = VTXCAS(1,K)
16956 C           VHKK(K,IDXCAS) = VTXCAS(2,K)
16957             WHKK(K,IDXCAS) = VTXCA1(1,K)
16958             VHKK(K,IDXCAS) = VTXCA1(2,K)
16959   100    CONTINUE
16960       ENDIF
16961
16962 C9998 CONTINUE
16963 * no cascade-step because of configuration
16964 * (i.e. hadron outside nucleus etc.)
16965       LCAS = .TRUE.
16966       RETURN
16967
16968  9999 CONTINUE
16969 * rejection
16970       IREJ = 1
16971       RETURN
16972       END
16973
16974 *$ CREATE DT_ABSORP.FOR
16975 *COPY DT_ABSORP
16976 *
16977 *===absorp=============================================================*
16978 *
16979       SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
16980
16981 ************************************************************************
16982 * Two-nucleon absorption of antiprotons, pi-, and K-.                  *
16983 * Antiproton absorption is handled by HADRIN.                          *
16984 * The following channels for meson-absorption are considered:          *
16985 *          pi- + p + p ---> n + p                                      *
16986 *          pi- + p + n ---> n + n                                      *
16987 *          K-  + p + p ---> sigma+ + n / Lam + p / sigma0 + p          *
16988 *          K-  + p + n ---> sigma- + n / Lam + n / sigma0 + n          *
16989 *          K-  + p + p ---> sigma- + n                                 *
16990 *      IDCAS, PCAS   identity, momentum of particle to be absorbed     *
16991 *      NCAS =  1     intranuclear cascade in projectile                *
16992 *           = -1     intranuclear cascade in target                    *
16993 *      NSPE          number of spectator nucleons involved             *
16994 *      IDXSPE(2)     DTEVT1-indices of spectator nucleons involved     *
16995 * Revised version of the original STOPIK written by HJM and J. Ranft.  *
16996 * This version dated 24.02.95 is written by S. Roesler                 *
16997 ************************************************************************
16998
16999       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17000       SAVE
17001       PARAMETER ( LINP = 10 ,
17002      &            LOUT = 6 ,
17003      &            LDAT = 9 )
17004       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17005      &           ONETHI=0.3333D0,TWOTHI=0.6666D0)
17006
17007 * event history
17008       PARAMETER (NMXHKK=200000)
17009       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17010      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17011      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17012 * extended event history
17013       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17014      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17015      &                IHIST(2,NMXHKK)
17016 * flags for input different options
17017       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17018       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17019      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17020 * final state after inc step
17021       PARAMETER (MAXFSP=10)
17022       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17023 * particle properties (BAMJET index convention)
17024       CHARACTER*8  ANAME
17025       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17026      &                IICH(210),IIBAR(210),K1(210),K2(210)
17027
17028       DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17029      &          PTOT3P(4),BG3P(4),
17030      &          ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17031
17032       IREJ = 0
17033       NFSP = 0
17034
17035 * skip particles others than ap, pi-, K- for mode=0
17036       IF ((MODE.EQ.0).AND.
17037      &    (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17038 * skip particles others than pions for mode=1
17039 * (2-nucleon absorption in intranuclear cascade)
17040       IF ((MODE.EQ.1).AND.
17041      &    (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17042
17043       NUCAS = NCAS
17044       IF (NUCAS.EQ.-1) NUCAS = 2
17045
17046       IF (MODE.EQ.0) THEN
17047 * scan spectator nucleons for nucleons being able to "absorb"
17048          NSPE      = 0
17049          IDXSPE(1) = 0
17050          IDXSPE(2) = 0
17051          DO 1 I=1,NHKK
17052             IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17053                NSPE         = NSPE+1
17054                IDXSPE(NSPE) = I
17055                IDSPE(NSPE)  = IDBAM(I)
17056                IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17057                IF (NSPE.EQ.2) THEN
17058                   IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17059      &                                  (IDSPE(2).EQ.8)) THEN
17060 *    there is no pi-+n+n channel
17061                      NSPE = 1
17062                      GOTO 1
17063                   ELSE
17064                      GOTO 2
17065                   ENDIF
17066                ENDIF
17067             ENDIF
17068     1    CONTINUE
17069
17070     2    CONTINUE
17071       ENDIF
17072 * transform excited projectile nucleons (status=15) into proj. rest s.
17073       DO 3 I=1,NSPE
17074          DO 4 K=1,5
17075             PSPE(I,K) = PHKK(K,IDXSPE(I))
17076     4    CONTINUE
17077     3 CONTINUE
17078
17079 * antiproton absorption
17080       IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17081          DO 5 K=1,5
17082             PSPE1(K) = PSPE(1,K)
17083     5    CONTINUE
17084          CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17085          IF (IREJ1.NE.0) GOTO 9999
17086
17087 * meson absorption
17088       ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17089      &                      .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17090          IF (IDCAS.EQ.14) THEN
17091 *   pi- absorption
17092             IDFSP(1) = 8
17093             IDFSP(2) = 8
17094             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17095          ELSEIF (IDCAS.EQ.13) THEN
17096 *   pi+ absorption
17097             IDFSP(1) = 1
17098             IDFSP(2) = 1
17099             IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17100          ELSEIF (IDCAS.EQ.23) THEN
17101 *   pi0 absorption
17102             IDFSP(1) = IDSPE(1)
17103             IDFSP(2) = IDSPE(2)
17104          ELSEIF (IDCAS.EQ.16) THEN
17105 *   K- absorption
17106             R = DT_RNDM(PCAS)
17107             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17108                IF (R.LT.ONETHI) THEN
17109                   IDFSP(1) = 21
17110                   IDFSP(2) = 8
17111                ELSEIF (R.LT.TWOTHI) THEN
17112                   IDFSP(1) = 17
17113                   IDFSP(2) = 1
17114                ELSE
17115                   IDFSP(1) = 22
17116                   IDFSP(2) = 1
17117                ENDIF
17118             ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17119                IDFSP(1) = 20
17120                IDFSP(2) = 8
17121             ELSE
17122                IF (R.LT.ONETHI) THEN
17123                   IDFSP(1) = 20
17124                   IDFSP(2) = 1
17125                ELSEIF (R.LT.TWOTHI) THEN
17126                   IDFSP(1) = 17
17127                   IDFSP(2) = 8
17128                ELSE
17129                   IDFSP(1) = 22
17130                   IDFSP(2) = 8
17131                ENDIF
17132             ENDIF
17133          ENDIF
17134 *   dump initial particles for energy-momentum cons. check
17135          IF (LEMCCK) THEN
17136             CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
17137             CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
17138      &                                                    IDUM,IDUM)
17139             CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
17140      &                                                    IDUM,IDUM)
17141          ENDIF
17142 *   get Lorentz-parameter of 3 particle initial state
17143          DO 6 K=1,4
17144             PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
17145     6    CONTINUE
17146          P3P  = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
17147          AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
17148          DO 7 K=1,4
17149             BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
17150     7    CONTINUE
17151 *   2-particle decay of the 3-particle compound system
17152          CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
17153      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
17154      &               AAM(IDFSP(1)),AAM(IDFSP(2)))
17155          DO 8 I=1,2
17156             SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
17157             PX  = PCMF(I)*COFF(I)*SDF
17158             PY  = PCMF(I)*SIFF(I)*SDF
17159             PZ  = PCMF(I)*CODF(I)
17160             CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
17161      &                  ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17162      &                  PFSP(4,I))
17163             PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
17164 *   check consistency of kinematics
17165             IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
17166                WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
17167  1001          FORMAT(1X,'ABSORP:   warning! inconsistent',
17168      &                ' tree-particle kinematics',/,20X,'id: ',I3,
17169      &                ' AAM = ',E10.4,' MFSP = ',E10.4)
17170             ENDIF
17171 *   dump final state particles for energy-momentum cons. check
17172             IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17173      &                              -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17174     8    CONTINUE
17175          NFSP = 2
17176          IF (LEMCCK) THEN
17177             CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
17178             IF (IREJ1.NE.0) THEN
17179                WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
17180      &                      AM3P
17181                GOTO 9999
17182             ENDIF
17183          ENDIF
17184       ELSE
17185          IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
17186  1000    FORMAT(1X,'ABSORP:   warning! absorption for particle ',I3,
17187      &          ' impossible',/,20X,'too few spectators (',I2,')')
17188          NSPE = 0
17189       ENDIF
17190
17191       RETURN
17192
17193  9999 CONTINUE
17194       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
17195       IREJ = 1
17196       RETURN
17197       END
17198
17199 *$ CREATE DT_HADRIN.FOR
17200 *COPY DT_HADRIN
17201 *
17202 *===hadrin=============================================================*
17203 *
17204       SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
17205
17206 ************************************************************************
17207 * Interface to the HADRIN-routines for inelastic and elastic           *
17208 * scattering.                                                          *
17209 *      IDPR,PPR(5)   identity, momentum of projectile                  *
17210 *      IDTA,PTA(5)   identity, momentum of target                      *
17211 *      MODE  = 1     inelastic interaction                             *
17212 *            = 2     elastic   interaction                             *
17213 * Revised version of the original FHAD.                                *
17214 * This version dated 27.10.95 is written by S. Roesler                 *
17215 ************************************************************************
17216
17217       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17218       SAVE
17219       PARAMETER ( LINP = 10 ,
17220      &            LOUT = 6 ,
17221      &            LDAT = 9 )
17222       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
17223      &           TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
17224
17225       LOGICAL LCORR,LMSSG
17226
17227 * flags for input different options
17228       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17229       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17230      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17231 * final state after inc step
17232       PARAMETER (MAXFSP=10)
17233       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17234 * particle properties (BAMJET index convention)
17235       CHARACTER*8  ANAME
17236       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17237      &                IICH(210),IIBAR(210),K1(210),K2(210)
17238 * output-common for DHADRI/ELHAIN
17239 * final state from HADRIN interaction
17240       PARAMETER (MAXFIN=10)
17241       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
17242      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
17243
17244       DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
17245      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
17246
17247       DATA LMSSG /.TRUE./
17248
17249       IREJ  = 0
17250       NFSP  = 0
17251       KCORR = 0
17252       IMCORR(1) = 0
17253       IMCORR(2) = 0
17254       LCORR = .FALSE.
17255
17256 *   dump initial particles for energy-momentum cons. check
17257       IF (LEMCCK) THEN
17258          CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
17259          CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
17260       ENDIF
17261
17262       AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
17263       AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
17264       IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
17265      &    (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
17266      &    (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
17267          IF (LMSSG.AND.(IOULEV(3).GT.0))
17268      &   WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
17269  1000    FORMAT(1X,'HADRIN:   warning! inconsistent projectile/target',
17270      &          ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
17271      &          E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
17272          LMSSG = .FALSE.
17273          LCORR = .TRUE.
17274       ENDIF
17275
17276 * convert initial state particles into particles which can be
17277 * handled by HADRIN
17278       IDHPR = IDPR
17279       IDHTA = IDTA
17280       IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
17281          IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
17282          DO 1 K=1,4
17283             P1IN(K) = PPR(K)
17284             P2IN(K) = PTA(K)
17285     1    CONTINUE
17286          XM1 = AAM(IDHPR)
17287          XM2 = AAM(IDHTA)
17288          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17289          IF (IREJ1.GT.0) THEN
17290             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
17291             GOTO 9999
17292          ENDIF
17293          DO 2 K=1,4
17294             PPR(K) = P1OUT(K)
17295             PTA(K) = P2OUT(K)
17296     2    CONTINUE
17297          PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
17298          PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
17299       ENDIF
17300
17301 * Lorentz-parameter for trafo into rest-system of target
17302       DO 3 K=1,4
17303          BGTA(K) = PTA(K)/PTA(5)
17304     3 CONTINUE
17305 * transformation of projectile into rest-system of target
17306       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
17307      &            PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
17308      &            PPR1(4))
17309
17310 * direction cosines of projectile in target rest system
17311       CX = PPR1(1)/PPRTO1
17312       CY = PPR1(2)/PPRTO1
17313       CZ = PPR1(3)/PPRTO1
17314
17315 * sample inelastic interaction
17316       IF (MODE.EQ.1) THEN
17317          CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
17318          IF (IRH.EQ.1) GOTO 9998
17319 * sample elastic interaction
17320       ELSEIF (MODE.EQ.2) THEN
17321          CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
17322          IF (IREJ1.NE.0) THEN
17323             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
17324             GOTO 9999
17325          ENDIF
17326          IF (IRH.EQ.1) GOTO 9998
17327       ELSE
17328          WRITE(LOUT,1001) MODE,INTHAD
17329  1001    FORMAT(1X,'HADRIN:   warning! inconsistent interaction mode',
17330      &          I4,' (INTHAD =',I4,')')
17331          GOTO 9999
17332       ENDIF
17333
17334 * transform final state particles back into Lab.
17335       DO 4 I=1,IRH
17336          NFSP = NFSP+1
17337          PX   = CXRH(I)*PLRH(I)
17338          PY   = CYRH(I)*PLRH(I)
17339          PZ   = CZRH(I)*PLRH(I)
17340          CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
17341      &               PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
17342      &               PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
17343          IDFSP(NFSP) = ITRH(I)
17344          AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
17345      &                                            PFSP(3,NFSP)**2
17346          IF (AMFSP2.LT.-TINY3) THEN
17347             WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
17348      &                       PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
17349  1002       FORMAT(1X,'HADRIN:   warning! final state particle (id = ',
17350      &             I2,') with negative mass^2',/,1X,5E12.4)
17351             GOTO 9999
17352          ELSE
17353             PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
17354             IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
17355                WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
17356      &                          PFSP(5,NFSP)
17357  1003          FORMAT(1X,'HADRIN:   warning! final state particle',
17358      &                ' (id = ',I2,') with inconsistent mass',/,1X,
17359      &                2E12.4)
17360                KCORR         = KCORR+1
17361                IF (KCORR.GT.2) GOTO 9999
17362                IMCORR(KCORR) = NFSP
17363             ENDIF
17364          ENDIF
17365 *   dump final state particles for energy-momentum cons. check
17366          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17367      &                           -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17368     4 CONTINUE
17369
17370 * transform momenta on mass shell in case of inconsistencies in
17371 * HADRIN
17372       IF (KCORR.GT.0) THEN
17373          IF (KCORR.EQ.2) THEN
17374             I1 = IMCORR(1)
17375             I2 = IMCORR(2)
17376          ELSE
17377             IF (IMCORR(1).EQ.1) THEN
17378                I1 = 1
17379                I2 = 2
17380             ELSE
17381                I1 = 1
17382                I2 = IMCORR(1)
17383             ENDIF
17384          ENDIF
17385          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
17386      &                           PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
17387          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
17388      &                           PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
17389          DO 5 K=1,4
17390             P1IN(K) = PFSP(K,I1)
17391             P2IN(K) = PFSP(K,I2)
17392     5    CONTINUE
17393          XM1 = AAM(IDFSP(I1))
17394          XM2 = AAM(IDFSP(I2))
17395          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17396          IF (IREJ1.GT.0) THEN
17397             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
17398 C           GOTO 9999
17399          ENDIF
17400          DO 6 K=1,4
17401             PFSP(K,I1) = P1OUT(K)
17402             PFSP(K,I2) = P2OUT(K)
17403     6    CONTINUE
17404          PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
17405      &                    -PFSP(2,I1)**2-PFSP(3,I1)**2)
17406          PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
17407      &                    -PFSP(2,I2)**2-PFSP(3,I2)**2)
17408 *   dump final state particles for energy-momentum cons. check
17409          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
17410      &                           -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
17411          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
17412      &                           -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
17413       ENDIF
17414
17415 * check energy-momentum conservation
17416       IF (LEMCCK) THEN
17417          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
17418          IF (IREJ1.NE.0) GOTO 9999
17419       ENDIF
17420
17421       RETURN
17422
17423  9998 CONTINUE
17424       IREJ = 2
17425       RETURN
17426
17427  9999 CONTINUE
17428       IREJ = 1
17429       RETURN
17430       END
17431
17432 *$ CREATE DT_HADCOL.FOR
17433 *COPY DT_HADCOL
17434 *
17435 *===hadcol=============================================================*
17436 *
17437       SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
17438
17439 ************************************************************************
17440 * Interface to the HADRIN-routines for inelastic and elastic           *
17441 * scattering. This subroutine samples hadron-nucleus interactions      *
17442 * below DPM-threshold.                                                 *
17443 *      IDPROJ        BAMJET-index of projectile hadron                 *
17444 *      PPN           projectile momentum in target rest frame          *
17445 *      IDXTAR        DTEVT1-index of target nucleon undergoing         *
17446 *                    interaction with projectile hadron                *
17447 * This subroutine replaces HADHAD.                                     *
17448 * This version dated 5.5.95 is written by S. Roesler                   *
17449 ************************************************************************
17450
17451       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17452       SAVE
17453       PARAMETER ( LINP = 10 ,
17454      &            LOUT = 6 ,
17455      &            LDAT = 9 )
17456       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
17457
17458       LOGICAL LSTART
17459
17460 * event history
17461       PARAMETER (NMXHKK=200000)
17462       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17463      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17464      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17465 * extended event history
17466       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17467      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17468      &                IHIST(2,NMXHKK)
17469 * nuclear potential
17470       LOGICAL LFERMI
17471       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17472      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17473      &                ETACOU(2),ICOUL,LFERMI
17474 * interface HADRIN-DPM
17475       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
17476 * parameter for intranuclear cascade
17477       LOGICAL LPAULI
17478       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17479 * final state after inc step
17480       PARAMETER (MAXFSP=10)
17481       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17482 * particle properties (BAMJET index convention)
17483       CHARACTER*8  ANAME
17484       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17485      &                IICH(210),IIBAR(210),K1(210),K2(210)
17486
17487       DIMENSION PPROJ(5),PNUC(5)
17488
17489       DATA LSTART /.TRUE./
17490
17491       IREJ   = 0
17492
17493       NPOINT(1) = NHKK+1
17494
17495       TAUSAV = TAUFOR
17496 **sr 6/9/01 commented
17497 C     TAUFOR = TAUFOR/2.0D0
17498 **
17499       IF (LSTART) THEN
17500          WRITE(LOUT,1000)
17501  1000    FORMAT(/,1X,'HADCOL:  Scattering handled by HADRIN')
17502          WRITE(LOUT,1001) TAUFOR
17503  1001    FORMAT(/,1X,'HADCOL:  Formation zone parameter set to ',
17504      &          F5.1,' fm/c')
17505          LSTART = .FALSE.
17506       ENDIF
17507
17508       IDNUC  = IDBAM(IDXTAR)
17509       IDNUC1 = IDT_MCHAD(IDNUC)
17510       IDPRO1 = IDT_MCHAD(IDPROJ)
17511
17512       IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
17513          IPROC = INTHAD
17514       ELSE
17515 **
17516 C        CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
17517 C        CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
17518          DUMZER = ZERO
17519          CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
17520          SIGIN = SIGTOT-SIGEL
17521 C        SIGTOT = SIGIN+SIGEL
17522 **
17523          IPROC  = 1
17524          IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
17525       ENDIF
17526
17527       PPROJ(1) = ZERO
17528       PPROJ(2) = ZERO
17529       PPROJ(3) = PPN
17530       PPROJ(5) = AAM(IDPROJ)
17531       PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
17532       DO 1 K=1,5
17533          PNUC(K)  = PHKK(K,IDXTAR)
17534     1 CONTINUE
17535
17536       ILOOP = 0
17537     2 CONTINUE
17538       ILOOP = ILOOP+1
17539       IF (ILOOP.GT.100) GOTO 9999
17540
17541       CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
17542       IF (IREJ1.EQ.1) GOTO 9999
17543
17544       IF (IREJ1.GT.1) THEN
17545 * no interaction possible
17546 *   require Pauli blocking
17547          IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
17548          IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
17549          IF ((IIBAR(IDPROJ).NE.1).AND.
17550      &       (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5)))              GOTO 2
17551 *   store incoming particle as final state particle
17552          CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
17553          CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
17554          NPOINT(4) = NHKK
17555       ELSE
17556 * require Pauli blocking for final state nucleons
17557          DO 4 I=1,NFSP
17558             IF ((IDFSP(I).EQ.1).AND.
17559      &          (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I))))       GOTO 2
17560             IF ((IDFSP(I).EQ.8).AND.
17561      &          (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I))))       GOTO 2
17562             IF ((IIBAR(IDFSP(I)).NE.1).AND.
17563      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
17564     4    CONTINUE
17565 * store final state particles
17566          DO 5 I=1,NFSP
17567             IST = 1
17568             IF ((IIBAR(IDFSP(I)).EQ.1).AND.
17569      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
17570             IDHAD = IDT_IPDGHA(IDFSP(I))
17571             CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
17572             CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
17573      &                                        PCMS,ECMS,0,0,0)
17574             IF (I.EQ.1) NPOINT(4) = NHKK
17575             VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
17576             VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
17577             VHKK(3,NHKK) = VHKK(3,IDXTAR)
17578             VHKK(4,NHKK) = VHKK(4,IDXTAR)
17579             WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
17580             WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
17581             WHKK(3,NHKK) = WHKK(3,1)
17582             WHKK(4,NHKK) = WHKK(4,1)
17583     5    CONTINUE
17584       ENDIF
17585       TAUFOR = TAUSAV
17586       RETURN
17587
17588  9999 CONTINUE
17589       IREJ = 1
17590       TAUFOR = TAUSAV
17591       RETURN
17592       END
17593
17594 *$ CREATE DT_GETEMU.FOR
17595 *COPY DT_GETEMU
17596 *
17597 *===getemu=============================================================*
17598 *
17599       SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
17600
17601 ************************************************************************
17602 * Sampling of emulsion component to be considered as target-nucleus.   *
17603 * This version dated 6.5.95   is written by S. Roesler.                *
17604 ************************************************************************
17605
17606       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17607       SAVE
17608       PARAMETER ( LINP = 10 ,
17609      &            LOUT = 6 ,
17610      &            LDAT = 9 )
17611       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
17612
17613       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
17614 * emulsion treatment
17615       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
17616      &                NCOMPO,IEMUL
17617 * Glauber formalism: flags and parameters for statistics
17618       LOGICAL LPROD
17619       CHARACTER*8 CGLB
17620       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
17621
17622       IF (MODE.EQ.0) THEN
17623          SUMFRA = ZERO
17624          RR = DT_RNDM(SUMFRA)
17625          IT  = 0
17626          ITZ = 0
17627          DO 1 ICOMP=1,NCOMPO
17628             SUMFRA = SUMFRA+EMUFRA(ICOMP)
17629             IF (SUMFRA.GT.RR) THEN
17630                IT    = IEMUMA(ICOMP)
17631                ITZ   = IEMUCH(ICOMP)
17632                KKMAT = ICOMP
17633                GOTO 2
17634             ENDIF
17635     1    CONTINUE
17636     2    CONTINUE
17637          IF (IT.LE.0) THEN
17638             WRITE(LOUT,'(1X,A,E12.3)')
17639      &       'Warning!  norm. failure within emulsion fractions',
17640      &       SUMFRA
17641             STOP
17642          ENDIF
17643       ELSEIF (MODE.EQ.1) THEN
17644          NDIFF = 10000
17645          DO 3 I=1,NCOMPO
17646             IDIFF = ABS(IT-IEMUMA(I))
17647             IF (IDIFF.LT.NDIFF) THEN
17648                KKMAT = I
17649                NDIFF = IDIFF
17650             ENDIF
17651     3    CONTINUE
17652       ELSE
17653          STOP 'DT_GETEMU'
17654       ENDIF
17655
17656 * bypass for variable projectile/target/energy runs: the correct
17657 * Glauber data will be always loaded on kkmat=1
17658       IF (IOGLB.EQ.100) THEN
17659          KKMAT = 1
17660       ENDIF
17661
17662       RETURN
17663       END
17664
17665 *$ CREATE DT_NCLPOT.FOR
17666 *COPY DT_NCLPOT
17667 *
17668 *===nclpot=============================================================*
17669 *
17670       SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
17671
17672 ************************************************************************
17673 * Calculation of Coulomb and nuclear potential for a given configurat. *
17674 *               IPZ, IP       charge/mass number of proj.              *
17675 *               ITZ, IT       charge/mass number of targ.              *
17676 *               AFERP,AFERT   factors modifying proj./target pot.      *
17677 *                             if =0, FERMOD is used                    *
17678 *               MODE = 0      calculation of binding energy            *
17679 *                    = 1      pre-calculated binding energy is used    *
17680 * This version dated 16.11.95  is written by S. Roesler.               *
17681 *                                                                      *
17682 * Last change 28.12.2006 by S. Roesler.                                *
17683 ************************************************************************
17684
17685       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17686       SAVE
17687       PARAMETER ( LINP = 10 ,
17688      &            LOUT = 6 ,
17689      &            LDAT = 9 )
17690       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
17691      &           TINY10=1.0D-10)
17692
17693       LOGICAL LSTART
17694
17695 * particle properties (BAMJET index convention)
17696       CHARACTER*8  ANAME
17697       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17698      &                IICH(210),IIBAR(210),K1(210),K2(210)
17699 * nuclear potential
17700       LOGICAL LFERMI
17701       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17702      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17703      &                ETACOU(2),ICOUL,LFERMI
17704
17705       DIMENSION IDXPOT(14)
17706 *                   ap   an  lam  alam sig- sig+ sig0 tet0 tet- asig-
17707       DATA IDXPOT /   2,   9,  17,  18,  20,  21,  22,  97,  98,  99,
17708 *                 asig0 asig+ atet0 atet+
17709      &              100, 101, 102, 103/
17710
17711       DATA AN     /0.4D0/
17712       DATA LSTART /.TRUE./
17713
17714       IF (MODE.EQ.0) THEN
17715          EBINDP(1) = ZERO
17716          EBINDN(1) = ZERO
17717          EBINDP(2) = ZERO
17718          EBINDN(2) = ZERO
17719       ENDIF
17720       AIP  = DBLE(IP)
17721       AIPZ = DBLE(IPZ)
17722       AIT  = DBLE(IT)
17723       AITZ = DBLE(ITZ)
17724
17725       FERMIP = AFERP
17726       IF (AFERP.LE.ZERO) FERMIP = FERMOD
17727       FERMIT = AFERT
17728       IF (AFERT.LE.ZERO) FERMIT = FERMOD
17729
17730 * Fermi momenta and binding energy for projectile
17731       IF ((IP.GT.1).AND.LFERMI) THEN
17732          IF (MODE.EQ.0) THEN
17733 C           EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
17734 C           EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
17735             BIP  = AIP -ONE
17736             BIPZ = AIPZ-ONE
17737             EBINDP(1) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIP,BIPZ)
17738      &                                            -DT_ENERGY(AIP,AIPZ))
17739             IF (AIP.LE.AIPZ) THEN
17740                EBINDN(1) = EBINDP(1)
17741                WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
17742             ELSE
17743                EBINDN(1) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17744      &                     +DT_ENERGY(BIP,AIPZ)-DT_ENERGY(AIP,AIPZ))
17745             ENDIF
17746          ENDIF
17747          PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
17748          PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
17749       ELSE
17750          PFERMP(1) = ZERO
17751          PFERMN(1) = ZERO
17752       ENDIF
17753 * effective nuclear potential for projectile
17754 C     EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
17755 C     EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
17756       EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
17757       EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
17758
17759 * Fermi momenta and binding energy for target
17760       IF ((IT.GT.1).AND.LFERMI) THEN
17761          IF (MODE.EQ.0) THEN
17762 C           EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
17763 C           EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
17764             BIT  = AIT -ONE
17765             BITZ = AITZ-ONE
17766
17767             EBINDP(2) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIT,BITZ)
17768      &                                            -DT_ENERGY(AIT,AITZ))
17769
17770             IF (AIT.LE.AITZ) THEN
17771                EBINDN(2) = EBINDP(2)
17772                WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
17773             ELSE
17774
17775                EBINDN(2) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17776      &                     +DT_ENERGY(BIT,AITZ)-DT_ENERGY(AIT,AITZ))
17777
17778             ENDIF
17779          ENDIF
17780          PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
17781          PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
17782       ELSE
17783          PFERMP(2) = ZERO
17784          PFERMN(2) = ZERO
17785       ENDIF
17786 * effective nuclear potential for target
17787 C     EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
17788 C     EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
17789       EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
17790       EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
17791
17792       DO 2 I=1,14
17793          EPOT(1,IDXPOT(I)) = EPOT(1,8)
17794          EPOT(2,IDXPOT(I)) = EPOT(2,8)
17795     2 CONTINUE
17796
17797 * Coulomb energy
17798       ETACOU(1) = ZERO
17799       ETACOU(2) = ZERO
17800       IF (ICOUL.EQ.1) THEN
17801          IF (IP.GT.1)
17802      &   ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
17803          IF (IT.GT.1)
17804      &   ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
17805       ENDIF
17806
17807       IF (LSTART) THEN
17808          WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
17809      &                    EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
17810      &                    EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
17811      &                    FERMOD,ETACOU
17812  1000    FORMAT(/,/,1X,'NCLPOT:    quantities for inclusion of nuclear'
17813      &           ,' effects',/,12X,'---------------------------',
17814      &           '----------------',/,/,38X,'projectile',
17815      &           '      target',/,/,1X,'Mass number / charge',
17816      &           17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy  -',
17817      &           ' proton   (GeV) ',2E14.4,/,17X,'- neutron  (GeV)'
17818      &          ,1X,2E14.4,/,1X,'Fermi-potential - proton   (GeV)',
17819      &           1X,2E14.4,/,17X,'- neutron  (GeV) ',2E14.4,/,/,
17820      &           1X,'Scale factor for Fermi-momentum    ',F4.2,/,
17821      &           /,1X,'Coulomb-energy ',2(E14.4,' GeV  '),/,/)
17822          LSTART = .FALSE.
17823       ENDIF
17824
17825       RETURN
17826       END
17827
17828 *$ CREATE DT_RESNCL.FOR
17829 *COPY DT_RESNCL
17830 *
17831 *===resncl=============================================================*
17832 *
17833       SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
17834
17835 ************************************************************************
17836 * Treatment of residual nuclei and nuclear effects.                    *
17837 *         MODE = 1     initializations                                 *
17838 *              = 2     treatment of final state                        *
17839 * This version dated 16.11.95 is written by S. Roesler.                *
17840 *                                                                      *
17841 * Last change 05.01.2007 by S. Roesler.                                *
17842 ************************************************************************
17843
17844       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17845       SAVE
17846       PARAMETER ( LINP = 10 ,
17847      &            LOUT = 6 ,
17848      &            LDAT = 9 )
17849       PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
17850      &           TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
17851      &           ONETHI=ONE/THREE)
17852       PARAMETER (AMUAMU = 0.93149432D0,
17853      &           FM2MM  = 1.0D-12,
17854      &           RNUCLE = 1.12D0)
17855       PARAMETER ( EMVGEV = 1.0                D-03 )
17856       PARAMETER ( AMUGEV = 0.93149432         D+00 )
17857       PARAMETER ( AMPRTN = 0.93827231         D+00 )
17858       PARAMETER ( AMNTRN = 0.93956563         D+00 )
17859       PARAMETER ( AMELCT = 0.51099906         D-03 )
17860       PARAMETER ( HLFHLF = 0.5D+00 )
17861       PARAMETER ( FERTHO = 14.33       D-09 )
17862       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
17863       PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
17864       PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
17865
17866 * event history
17867       PARAMETER (NMXHKK=200000)
17868       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17869      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17870      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17871 * extended event history
17872       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17873      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17874      &                IHIST(2,NMXHKK)
17875 * particle properties (BAMJET index convention)
17876       CHARACTER*8  ANAME
17877       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17878      &                IICH(210),IIBAR(210),K1(210),K2(210)
17879 * flags for input different options
17880       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17881       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17882      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17883 * nuclear potential
17884       LOGICAL LFERMI
17885       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17886      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17887      &                ETACOU(2),ICOUL,LFERMI
17888 * properties of interacting particles
17889       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
17890 * properties of photon/lepton projectiles
17891       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
17892 * Lorentz-parameters of the current interaction
17893       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
17894      &                UMO,PPCM,EPROJ,PPROJ
17895 * treatment of residual nuclei: wounded nucleons
17896       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
17897 * treatment of residual nuclei: 4-momenta
17898       LOGICAL LRCLPR,LRCLTA
17899       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
17900      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
17901
17902       DIMENSION PFSP(4),PSEC(4),PSEC0(4)
17903       DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
17904      &          IDXCOR(15000),IDXOTH(NMXHKK)
17905
17906       GOTO (1,2) MODE
17907
17908 *------- initializations
17909     1 CONTINUE
17910
17911 * initialize arrays for residual nuclei
17912       DO 10 K=1,5
17913          IF (K.LE.4) THEN
17914             PFSP(K)     = ZERO
17915          ENDIF
17916          PINIPR(K) = ZERO
17917          PINITA(K) = ZERO
17918          PRCLPR(K) = ZERO
17919          PRCLTA(K) = ZERO
17920          TRCLPR(K) = ZERO
17921          TRCLTA(K) = ZERO
17922    10 CONTINUE
17923       SCPOT = ONE
17924       NLOOP = 0
17925
17926 * correction of projectile 4-momentum for effective target pot.
17927 * and Coulomb-energy (in case of hadron-nucleus interaction only)
17928       IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
17929          EPNI = EPN
17930 *   Coulomb-energy:
17931 *     positively charged hadron - check energy for Coloumb pot.
17932          IF (IICH(IJPROJ).EQ.1) THEN
17933             THRESH = ETACOU(2)+AAM(IJPROJ)
17934             IF (EPNI.LE.THRESH) THEN
17935                WRITE(LOUT,1000)
17936  1000          FORMAT(/,1X,'KKINC:  WARNING!  projectile energy',
17937      &                ' below Coulomb threshold - event rejected',/)
17938                ISTHKK(1) = 1
17939                RETURN
17940             ENDIF
17941 *     negatively charged hadron - increase energy by Coulomb energy
17942          ELSEIF (IICH(IJPROJ).EQ.-1) THEN
17943             EPNI = EPNI+ETACOU(2)
17944          ENDIF
17945          IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
17946 *   Effective target potential
17947 *sr 6.6. binding energy only (to avoid negative exc. energies)
17948 C           EPNI = EPNI+EPOT(2,IJPROJ)
17949             EBIPOT = EBINDP(2)
17950             IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
17951      &         EBIPOT = EBINDN(2)
17952             EPNI = EPNI+ABS(EBIPOT)
17953 * re-initialization of DTLTRA
17954             DUM1 = ZERO
17955             DUM2 = ZERO
17956             CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
17957          ENDIF
17958       ENDIF
17959
17960 * projectile in n-n cms
17961       IF ((IP.LE.1).AND.(IT.GT.1)) THEN
17962          PMASS1 = AAM(IJPROJ)
17963 C* VDM assumption
17964 C         IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
17965          IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
17966          PMASS2 = AAM(1)
17967          PM1 = SIGN(PMASS1**2,PMASS1)
17968          PM2 = SIGN(PMASS2**2,PMASS2)
17969          PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
17970          PINIPR(5) = PMASS1
17971          IF (PMASS1.GT.ZERO) THEN
17972             PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
17973      &                      *(PINIPR(4)+PINIPR(5)))
17974          ELSE
17975             PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
17976          ENDIF
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       ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
17982          PMASS1 = AAM(1)
17983          PMASS2 = AAM(IJTARG)
17984          PM1 = SIGN(PMASS1**2,PMASS1)
17985          PM2 = SIGN(PMASS2**2,PMASS2)
17986          PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
17987          PINITA(5) = PMASS2
17988          PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
17989      &                    *(PINITA(4)+PINITA(5)))
17990          AIP  = DBLE(IP)
17991          AIPZ = DBLE(IPZ)
17992          PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
17993          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
17994       ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
17995          AIP  = DBLE(IP)
17996          AIPZ = DBLE(IPZ)
17997          PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
17998          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
17999          AIT  = DBLE(IT)
18000          AITZ = DBLE(ITZ)
18001          PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
18002          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18003       ENDIF
18004
18005       RETURN
18006
18007 *------- treatment of final state
18008     2 CONTINUE
18009
18010       NLOOP = NLOOP+1
18011       IF (NLOOP.GT.1) SCPOT = 0.10D0
18012 C     WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18013
18014       JPW  = NPW
18015       JPCW = NPCW
18016       JTW  = NTW
18017       JTCW = NTCW
18018       DO 40 K=1,4
18019          PFSP(K)   = ZERO
18020    40 CONTINUE
18021
18022       NOB = 0
18023       NOM = 0
18024       DO 900 I=NPOINT(4),NHKK
18025          IDXOTH(I) = -1
18026          IF (ISTHKK(I).EQ.1) THEN
18027             IF (IDBAM(I).EQ.7) GOTO 900
18028             IPOT = 0
18029             IOTHER = 0
18030 * particle moving into forward direction
18031             IF (PHKK(3,I).GE.ZERO) THEN
18032 *   most likely to be effected by projectile potential
18033                IPOT = 1
18034 *     there is no projectile nucleus, try target
18035                IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18036                   IPOT   = 2
18037                   IF (IP.GT.1) IOTHER = 1
18038 *       there is no target nucleus --> skip
18039                   IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18040                ENDIF
18041 * particle moving into backward direction
18042             ELSE
18043 *   most likely to be effected by target potential
18044                IPOT = 2
18045 *     there is no target nucleus, try projectile
18046                IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18047                   IPOT   = 1
18048                   IF (IT.GT.1) IOTHER = 1
18049 *       there is no projectile nucleus --> skip
18050                   IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18051                ENDIF
18052             ENDIF
18053             IFLG = -IPOT
18054 * nobam=3: particle is in overlap-region or neither inside proj. nor target
18055 *      =1: particle is not in overlap-region AND is inside target (2)
18056 *      =2: particle is not in overlap-region AND is inside projectile (1)
18057 * flag particles which are inside the nucleus ipot but not in its
18058 * overlap region
18059             IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
18060             IF (IDBAM(I).NE.0) THEN
18061 * baryons: keep all nucleons and all others where flag is set
18062                IF (IIBAR(IDBAM(I)).NE.0) THEN
18063                   IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
18064      &                                                              THEN
18065                      NOB = NOB+1
18066                      PMOMB(NOB) = PHKK(3,I)
18067                      IDXB(NOB)  = SIGN(10000000*IABS(IFLG)
18068      &                           +1000000*IOTHER+I,IFLG)
18069                   ENDIF
18070 * mesons: keep only those mesons where flag is set
18071                ELSE
18072                   IF (IFLG.GT.0) THEN
18073                      NOM = NOM+1
18074                      PMOMM(NOM) = PHKK(3,I)
18075                      IDXM(NOM)  = 10000000*IFLG+1000000*IOTHER+I
18076                   ENDIF
18077                ENDIF
18078             ENDIF
18079          ENDIF
18080   900 CONTINUE
18081 *
18082 * sort particles in the arrays according to increasing long. momentum
18083       CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
18084       CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
18085 *
18086 * shuffle indices into one and the same array according to the later
18087 * sequence of correction
18088       NCOR = 0
18089       IF (IT.GT.1) THEN
18090          DO 910 I=1,NOB
18091             IF (PMOMB(I).GT.ZERO) GOTO 911
18092             NCOR = NCOR+1
18093             IDXCOR(NCOR) = IDXB(I)
18094   910    CONTINUE
18095   911    CONTINUE
18096          IF (IP.GT.1) THEN
18097             DO 912 J=1,NOB
18098                I = NOB+1-J
18099                IF (PMOMB(I).LT.ZERO) GOTO 913
18100                NCOR = NCOR+1
18101                IDXCOR(NCOR) = IDXB(I)
18102   912       CONTINUE
18103   913       CONTINUE
18104          ELSE
18105             DO 914 I=1,NOB
18106                IF (PMOMB(I).GT.ZERO) THEN
18107                   NCOR = NCOR+1
18108                   IDXCOR(NCOR) = IDXB(I)
18109                ENDIF
18110   914       CONTINUE
18111          ENDIF
18112       ELSE
18113          DO 915 J=1,NOB
18114             I = NOB+1-J
18115             NCOR = NCOR+1
18116             IDXCOR(NCOR) = IDXB(I)
18117   915    CONTINUE
18118       ENDIF
18119       DO 925 I=1,NOM
18120          IF (PMOMM(I).GT.ZERO) GOTO 926
18121          NCOR = NCOR+1
18122          IDXCOR(NCOR) = IDXM(I)
18123   925 CONTINUE
18124   926 CONTINUE
18125       DO 927 J=1,NOM
18126          I = NOM+1-J
18127          IF (PMOMM(I).LT.ZERO) GOTO 928
18128          NCOR = NCOR+1
18129          IDXCOR(NCOR) = IDXM(I)
18130   927 CONTINUE
18131   928 CONTINUE
18132 *
18133 C      IF (NEVHKK.EQ.484) THEN
18134 C         WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
18135 C 9000    FORMAT(1X,'wounded nucleons (proj.-p,n  targ.-p,n)',/,4I10)
18136 C         WRITE(LOUT,9001) NOB,NOM,NCOR
18137 C 9001    FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
18138 C         WRITE(LOUT,'(/,A)') ' baryons '
18139 C         DO 950 I=1,NOB
18140 CC           J     = IABS(IDXB(I))
18141 CC           INDEX = J-IABS(J/10000000)*10000000
18142 C            IPOT   = IABS(IDXB(I))/10000000
18143 C            IOTHER = IABS(IDXB(I))/1000000-IPOT*10
18144 C            INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
18145 C            WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
18146 C  950    CONTINUE
18147 C         WRITE(LOUT,'(/,A)') ' mesons '
18148 C         DO 951 I=1,NOM
18149 CC           INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
18150 C            IPOT   = IABS(IDXM(I))/10000000
18151 C            IOTHER = IABS(IDXM(I))/1000000-IPOT*10
18152 C            INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
18153 C            WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
18154 C  951    CONTINUE
18155 C 9002    FORMAT(1X,4I14,E14.5)
18156 C         WRITE(LOUT,'(/,A)') ' all '
18157 C         DO 952 I=1,NCOR
18158 CC           J     = IABS(IDXCOR(I))
18159 CC           INDEX = J-IABS(J/10000000)*10000000
18160 CC            IPOT   = IABS(IDXCOR(I))/10000000
18161 C            IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
18162 C            INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
18163 C            WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
18164 C  952    CONTINUE
18165 C 9003    FORMAT(1X,4I14)
18166 C      ENDIF
18167 *
18168       DO 20 ICOR=1,NCOR
18169          IPOT   = IABS(IDXCOR(ICOR))/10000000
18170          IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
18171          I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
18172          IDXOTH(I) = 1
18173
18174          IDSEC  = IDBAM(I)
18175
18176 * reduction of particle momentum by corresponding nuclear potential
18177 * (this applies only if Fermi-momenta are requested)
18178
18179          IF (LFERMI) THEN
18180
18181 *   Lorentz-transformation into the rest system of the selected nucleus
18182             IMODE = -IPOT-1
18183             CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18184      &                  PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
18185             PSECO  = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
18186             AMSEC  = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
18187             JPMOD  = 0
18188
18189             CHKLEV = TINY3
18190             IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
18191             IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
18192             IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
18193                IF (IOULEV(3).GT.0)
18194      &            WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
18195  2000          FORMAT(1X,'RESNCL: inconsistent mass of particle',
18196      &                ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
18197      &                I4,'   AMSEC: ',E12.3,'  AAM(IDSEC): ',E12.3,/)
18198                GOTO 23
18199             ENDIF
18200
18201             DO 21 K=1,4
18202                PSEC0(K) = PSEC(K)
18203    21       CONTINUE
18204
18205 *   the correction for nuclear potential effects is applied to as many
18206 *   p/n as many nucleons were wounded; the momenta of other final state
18207 *   particles are corrected only if they materialize inside the corresp.
18208 *   nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
18209 *   = 3 part. outside proj. and targ., >=10 in overlapping region)
18210             IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
18211                IF (IPOT.EQ.1) THEN
18212                   IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
18213 *      this is most likely a wounded nucleon
18214 **test
18215 C                    RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
18216 C    &                           +(VHKK(2,IPW(JPW))/FM2MM)**2
18217 C    &                           +(VHKK(3,IPW(JPW))/FM2MM)**2)
18218 C                    RAD   = RNUCLE*DBLE(IP)**ONETHI
18219 C                    FDEN  = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
18220 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18221 **
18222                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18223                      JPW = JPW-1
18224                      JPMOD = 1
18225                   ELSE
18226 *      correct only if part. was materialized inside nucleus
18227 *      and if it is ouside the overlapping region
18228                      IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
18229                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18230                         JPMOD = 1
18231                      ENDIF
18232                   ENDIF
18233                ELSEIF (IPOT.EQ.2) THEN
18234                   IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
18235 *      this is most likely a wounded nucleon
18236 **test
18237 C                    RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
18238 C    &                           +(VHKK(2,ITW(JTW))/FM2MM)**2
18239 C    &                           +(VHKK(3,ITW(JTW))/FM2MM)**2)
18240 C                    RAD   = RNUCLE*DBLE(IT)**ONETHI
18241 C                    FDEN  = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
18242 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18243 **
18244                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18245                      JTW = JTW-1
18246                      JPMOD = 1
18247                   ELSE
18248 *      correct only if part. was materialized inside nucleus
18249                      IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
18250                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18251                         JPMOD = 1
18252                      ENDIF
18253                   ENDIF
18254                ENDIF
18255             ELSE
18256                IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
18257                   PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18258                   JPMOD = 1
18259                ENDIF
18260             ENDIF
18261
18262             IF (NLOOP.EQ.1) THEN
18263 * Coulomb energy correction:
18264 * the treatment of Coulomb potential correction is similar to the
18265 * one for nuclear potential
18266                IF (IDSEC.EQ.1) THEN
18267                   IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
18268                      JPCW = JPCW-1
18269                   ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
18270                      JTCW = JTCW-1
18271                   ELSE
18272                      IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18273                   ENDIF
18274                ELSE
18275                   IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18276                ENDIF
18277                IF (IICH(IDSEC).EQ.1) THEN
18278 *    pos. particles: check if they are able to escape Coulomb potential
18279                   IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
18280                      ISTHKK(I) = 14+IPOT
18281                      IF (ISTHKK(I).EQ.15) THEN
18282                         DO 26 K=1,4
18283                            PHKK(K,I) = PSEC0(K)
18284                            TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18285    26                CONTINUE
18286                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18287                         IF (IDSEC.EQ.1) NPCW = NPCW-1
18288                      ELSEIF (ISTHKK(I).EQ.16) THEN
18289                         DO 27 K=1,4
18290                            PHKK(K,I) = PSEC0(K)
18291                            TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18292    27                   CONTINUE
18293                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18294                         IF (IDSEC.EQ.1) NTCW = NTCW-1
18295                      ENDIF
18296                      GOTO 20
18297                   ENDIF
18298                ELSEIF (IICH(IDSEC).EQ.-1) THEN
18299 *    neg. particles: decrease energy by Coulomb-potential
18300                   PSEC(4) = PSEC(4)-ETACOU(IPOT)
18301                   JPMOD = 1
18302                ENDIF
18303             ENDIF
18304
18305    25       CONTINUE
18306
18307             IF (PSEC(4).LT.AMSEC) THEN
18308                IF (IOULEV(6).GT.0)
18309      &            WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
18310  2001          FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
18311      &                ' is not allowed to escape nucleus',/,
18312      &                8X,'id : ',I3,'   reduced energy: ',E15.4,
18313      &                '   mass: ',E12.3)
18314                ISTHKK(I) = 14+IPOT
18315                IF (ISTHKK(I).EQ.15) THEN
18316                   DO 28 K=1,4
18317                      PHKK(K,I) = PSEC0(K)
18318                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18319    28             CONTINUE
18320                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18321                   IF (IDSEC.EQ.1) NPCW = NPCW-1
18322                ELSEIF (ISTHKK(I).EQ.16) THEN
18323                   DO 29 K=1,4
18324                      PHKK(K,I) = PSEC0(K)
18325                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18326    29             CONTINUE
18327                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18328                   IF (IDSEC.EQ.1) NTCW = NTCW-1
18329                ENDIF
18330                GOTO 20
18331             ENDIF
18332
18333             IF (JPMOD.EQ.1) THEN
18334                PSECN  = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
18335 * 4-momentum after correction for nuclear potential
18336                DO 22 K=1,3
18337                   PSEC(K) = PSEC(K)*PSECN/PSECO
18338    22          CONTINUE
18339
18340 * store recoil momentum from particles escaping the nuclear potentials
18341                DO 30 K=1,4
18342                   IF (IPOT.EQ.1) THEN
18343                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
18344                   ELSEIF (IPOT.EQ.2) THEN
18345                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
18346                   ENDIF
18347    30          CONTINUE
18348
18349 * transform momentum back into n-n cms
18350                IMODE = IPOT+1
18351                CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
18352      &                     PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18353      &                     IDSEC,IMODE)
18354             ENDIF
18355
18356          ENDIF
18357
18358    23    CONTINUE
18359          DO 31 K=1,4
18360             PFSP(K) = PFSP(K)+PHKK(K,I)
18361    31    CONTINUE
18362
18363    20 CONTINUE
18364
18365       DO 33 I=NPOINT(4),NHKK
18366          IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
18367             PFSP(1) = PFSP(1)+PHKK(1,I)
18368             PFSP(2) = PFSP(2)+PHKK(2,I)
18369             PFSP(3) = PFSP(3)+PHKK(3,I)
18370             PFSP(4) = PFSP(4)+PHKK(4,I)
18371          ENDIF
18372    33 CONTINUE
18373
18374       DO 34 K=1,5
18375          PRCLPR(K) = TRCLPR(K)
18376          PRCLTA(K) = TRCLTA(K)
18377    34 CONTINUE
18378
18379       IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18380 * hadron-nucleus interactions: get residual momentum from energy-
18381 * momentum conservation
18382          DO 32 K=1,4
18383             PRCLPR(K) = ZERO
18384             PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
18385    32    CONTINUE
18386       ELSE
18387 * nucleus-hadron, nucleus-nucleus: get residual momentum from
18388 * accumulated recoil momenta of particles leaving the spectators
18389 *   transform accumulated recoil momenta of residual nuclei into
18390 *   n-n cms
18391          PZI = PRCLPR(3)
18392          PEI = PRCLPR(4)
18393          CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
18394          PZI = PRCLTA(3)
18395          PEI = PRCLTA(4)
18396          CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
18397 C        IF (IP.GT.1) THEN
18398             PRCLPR(3) = PRCLPR(3)+PINIPR(3)
18399             PRCLPR(4) = PRCLPR(4)+PINIPR(4)
18400 C        ENDIF
18401          IF (IT.GT.1) THEN
18402             PRCLTA(3) = PRCLTA(3)+PINITA(3)
18403             PRCLTA(4) = PRCLTA(4)+PINITA(4)
18404          ENDIF
18405       ENDIF
18406
18407 * check momenta of residual nuclei
18408       IF (LEMCCK) THEN
18409          CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
18410      &               1,IDUM,IDUM)
18411          CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
18412      &               2,IDUM,IDUM)
18413          CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
18414      &               2,IDUM,IDUM)
18415          CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
18416      &               2,IDUM,IDUM)
18417          CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
18418 **sr 19.12. changed to avoid output when used with phojet
18419 C        CHKLEV = TINY3
18420          CHKLEV = TINY1
18421          CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
18422 C        IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
18423 C    &      CALL DT_EVTOUT(4)
18424          IF (IREJ1.GT.0) RETURN
18425       ENDIF
18426
18427       RETURN
18428       END
18429
18430 *$ CREATE DT_SCN4BA.FOR
18431 *COPY DT_SCN4BA
18432 *
18433 *===scn4ba=============================================================*
18434 *
18435       SUBROUTINE DT_SCN4BA
18436
18437 ************************************************************************
18438 * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot.    *
18439 * This version dated 12.12.95 is written by S. Roesler.                *
18440 ************************************************************************
18441
18442       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18443       SAVE
18444       PARAMETER ( LINP = 10 ,
18445      &            LOUT = 6 ,
18446      &            LDAT = 9 )
18447       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18448      &           TINY10=1.0D-10)
18449
18450 * event history
18451       PARAMETER (NMXHKK=200000)
18452       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18453      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18454      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18455 * extended event history
18456       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18457      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18458      &                IHIST(2,NMXHKK)
18459 * particle properties (BAMJET index convention)
18460       CHARACTER*8  ANAME
18461       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18462      &                IICH(210),IIBAR(210),K1(210),K2(210)
18463 * properties of interacting particles
18464       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18465 * nuclear potential
18466       LOGICAL LFERMI
18467       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18468      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18469      &                ETACOU(2),ICOUL,LFERMI
18470 * treatment of residual nuclei: wounded nucleons
18471       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18472 * treatment of residual nuclei: 4-momenta
18473       LOGICAL LRCLPR,LRCLTA
18474       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18475      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18476
18477       DIMENSION PLAB(2,5),PCMS(4)
18478
18479       IREJ = 0
18480
18481 * get number of wounded nucleons
18482       NPW    = 0
18483       NPW0   = 0
18484       NPCW   = 0
18485       NPSTCK = 0
18486       NTW    = 0
18487       NTW0   = 0
18488       NTCW   = 0
18489       NTSTCK = 0
18490
18491       ISGLPR = 0
18492       ISGLTA = 0
18493       LRCLPR = .FALSE.
18494       LRCLTA = .FALSE.
18495
18496 C     DO 2 I=1,NHKK
18497       DO 2 I=1,NPOINT(1)
18498 * projectile nucleons wounded in primary interaction and in fzc
18499          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
18500             NPW      = NPW+1
18501             IPW(NPW) = I
18502             NPSTCK   = NPSTCK+1
18503             IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
18504             IF (ISTHKK(I).EQ.11)  NPW0 = NPW0+1
18505 C           IF (IP.GT.1) THEN
18506                DO 5 K=1,4
18507                   TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
18508     5          CONTINUE
18509 C           ENDIF
18510 * target nucleons wounded in primary interaction and in fzc
18511          ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
18512             NTW      = NTW+1
18513             ITW(NTW) = I
18514             NTSTCK   = NTSTCK+1
18515             IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
18516             IF (ISTHKK(I).EQ.12)  NTW0 = NTW0+1
18517             IF (IT.GT.1) THEN
18518                DO 6 K=1,4
18519                   TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
18520     6          CONTINUE
18521             ENDIF
18522          ELSEIF (ISTHKK(I).EQ.13) THEN
18523             ISGLPR = I
18524          ELSEIF (ISTHKK(I).EQ.14) THEN
18525             ISGLTA = I
18526          ENDIF
18527     2 CONTINUE
18528
18529       DO 11 I=NPOINT(4),NHKK
18530 * baryons which are unable to escape the nuclear potential of proj.
18531          IF (ISTHKK(I).EQ.15) THEN
18532             ISGLPR = I
18533             NPSTCK = NPSTCK-1
18534             IF (IIBAR(IDBAM(I)).NE.0) THEN
18535                NPW    = NPW-1
18536                IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
18537             ENDIF
18538             DO 7 K=1,4
18539                TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18540     7       CONTINUE
18541 * baryons which are unable to escape the nuclear potential of targ.
18542          ELSEIF (ISTHKK(I).EQ.16) THEN
18543             ISGLTA = I
18544             NTSTCK = NTSTCK-1
18545             IF (IIBAR(IDBAM(I)).NE.0) THEN
18546                NTW    = NTW-1
18547                IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
18548             ENDIF
18549             DO 8 K=1,4
18550                TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18551     8       CONTINUE
18552          ENDIF
18553    11 CONTINUE
18554
18555 * residual nuclei so far
18556       IRESP = IP-NPSTCK
18557       IREST = IT-NTSTCK
18558
18559 * ckeck for "residual nuclei" consisting of one nucleon only
18560 * treat it as final state particle
18561       IF (IRESP.EQ.1) THEN
18562          ID  = IDBAM(ISGLPR)
18563          IST = ISTHKK(ISGLPR)
18564          CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
18565      &               PHKK(3,ISGLPR),PHKK(4,ISGLPR),
18566      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
18567          IF (IST.EQ.13) THEN
18568             ISTHKK(ISGLPR) = 11
18569          ELSE
18570             ISTHKK(ISGLPR) = 2
18571          ENDIF
18572          CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
18573      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18574      &               IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
18575          NOBAM(NHKK)      = NOBAM(ISGLPR)
18576          JDAHKK(1,ISGLPR) = NHKK
18577          DO 21 K=1,4
18578             TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
18579    21    CONTINUE
18580       ENDIF
18581       IF (IREST.EQ.1) THEN
18582          ID  = IDBAM(ISGLTA)
18583          IST = ISTHKK(ISGLTA)
18584          CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
18585      &               PHKK(3,ISGLTA),PHKK(4,ISGLTA),
18586      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
18587          IF (IST.EQ.14) THEN
18588             ISTHKK(ISGLTA) = 12
18589          ELSE
18590             ISTHKK(ISGLTA) = 2
18591          ENDIF
18592          CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
18593      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18594      &               IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
18595          NOBAM(NHKK)      = NOBAM(ISGLTA)
18596          JDAHKK(1,ISGLTA) = NHKK
18597          DO 22 K=1,4
18598             TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
18599    22    CONTINUE
18600       ENDIF
18601
18602 * get nuclear potential corresp. to the residual nucleus
18603       IPRCL  = IP -NPW
18604       IPZRCL = IPZ-NPCW
18605       ITRCL  = IT -NTW
18606       ITZRCL = ITZ-NTCW
18607       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
18608
18609 * baryons unable to escape the nuclear potential are treated as
18610 * excited nucleons (ISTHKK=15,16)
18611       DO 3 I=NPOINT(4),NHKK
18612          IF (ISTHKK(I).EQ.1) THEN
18613             ID  = IDBAM(I)
18614             IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
18615 *   final state n and p not being outside of both nuclei are considered
18616                NPOTP = 1
18617                NPOTT = 1
18618                IF ( (IP.GT.1)      .AND.(IRESP.GT.1).AND.
18619      &              (NOBAM(I).NE.1).AND.(NPW.GT.0)        ) THEN
18620 *     Lorentz-trsf. into proj. rest sys. for those being inside proj.
18621                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18622      &                        PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
18623      &                        PLAB(1,4),ID,-2)
18624                   PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
18625                   PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
18626      &                                  (PLAB(1,4)+PLABT) ))
18627                   EKIN = PLAB(1,4)-PLAB(1,5)
18628                   IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
18629                   IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
18630                ENDIF
18631                IF ( (IT.GT.1)      .AND.(IREST.GT.1).AND.
18632      &              (NOBAM(I).NE.2).AND.(NTW.GT.0)        ) THEN
18633 *     Lorentz-trsf. into targ. rest sys. for those being inside targ.
18634                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18635      &                        PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
18636      &                        PLAB(2,4),ID,-3)
18637                   PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
18638                   PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
18639      &                                  (PLAB(2,4)+PLABT) ))
18640                   EKIN = PLAB(2,4)-PLAB(2,5)
18641                   IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
18642                   IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
18643                ENDIF
18644                IF (PHKK(3,I).GE.ZERO) THEN
18645                   ISTHKK(I) = NPOTT
18646                   IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
18647                ELSE
18648                   ISTHKK(I) = NPOTP
18649                   IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
18650                ENDIF
18651                IF (ISTHKK(I).NE.1) THEN
18652                   J = ISTHKK(I)-14
18653                   DO 4 K=1,5
18654                      PHKK(K,I) = PLAB(J,K)
18655     4             CONTINUE
18656                   IF (ISTHKK(I).EQ.15) THEN
18657                      NPW = NPW-1
18658                      IF (ID.EQ.1) NPCW = NPCW-1
18659                      DO 9 K=1,4
18660                         TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18661     9                CONTINUE
18662                   ELSEIF (ISTHKK(I).EQ.16) THEN
18663                      NTW = NTW-1
18664                      IF (ID.EQ.1) NTCW = NTCW-1
18665                      DO 10 K=1,4
18666                         TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18667    10                CONTINUE
18668                   ENDIF
18669                ENDIF
18670             ENDIF
18671          ENDIF
18672     3 CONTINUE
18673
18674 * again: get nuclear potential corresp. to the residual nucleus
18675       IPRCL  = IP -NPW
18676       IPZRCL = IPZ-NPCW
18677       ITRCL  = IT -NTW
18678       ITZRCL = ITZ-NTCW
18679 c      AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
18680 cC     AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
18681 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
18682 C     AFERP = 0.0D0
18683 c      AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
18684 cC     AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
18685 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
18686 C     AFERT = 0.0D0
18687 C     IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
18688 C     IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
18689 C     IF (AFERP.GT.0.85D0) AFERP = 0.85D0
18690 C     IF (AFERT.GT.0.85D0) AFERT = 0.85D0
18691       AFERP = FERMOD+0.1D0
18692       AFERT = FERMOD+0.1D0
18693
18694       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
18695
18696       RETURN
18697       END
18698
18699 *$ CREATE DT_FICONF.FOR
18700 *COPY DT_FICONF
18701 *
18702 *===ficonf=============================================================*
18703 *
18704       SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
18705
18706 ************************************************************************
18707 * Treatment of FInal CONFiguration including evaporation, fission and  *
18708 * Fermi-break-up (for light nuclei only).                              *
18709 * Adopted from the original routine FINALE and extended to residual    *
18710 * projectile nuclei.                                                   *
18711 * This version dated 12.12.95 is written by S. Roesler.                *
18712 *                                                                      *
18713 * Last change 27.12.2006 by S. Roesler.                                *
18714 ************************************************************************
18715
18716       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18717       SAVE
18718       PARAMETER ( LINP = 10 ,
18719      &            LOUT = 6 ,
18720      &            LDAT = 9 )
18721       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18722       PARAMETER (ANGLGB=5.0D-16)
18723       PARAMETER (AMUAMU=0.93149432D0,AMELEC=0.51099906D-3)
18724
18725 * event history
18726       PARAMETER (NMXHKK=200000)
18727       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18728      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18729      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18730 * extended event history
18731       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18732      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18733      &                IHIST(2,NMXHKK)
18734 * rejection counter
18735       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
18736      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
18737      &                IREXCI(3),IRDIFF(2),IRINC
18738 * central particle production, impact parameter biasing
18739       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
18740 * particle properties (BAMJET index convention)
18741       CHARACTER*8  ANAME
18742       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18743      &                IICH(210),IIBAR(210),K1(210),K2(210)
18744 * treatment of residual nuclei: 4-momenta
18745       LOGICAL LRCLPR,LRCLTA
18746       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18747      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18748 * treatment of residual nuclei: properties of residual nuclei
18749       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
18750      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
18751      &                NTOTFI(2),NPROFI(2)
18752 * statistics: residual nuclei
18753       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
18754      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
18755      &                NINCST(2,4),NINCEV(2),
18756      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
18757      &                NRESPB(2),NRESCH(2),NRESEV(4),
18758      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
18759      &                NEVAFI(2,2)
18760 * flags for input different options
18761       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18762       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18763      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18764 * (original name: FINUC)
18765       PARAMETER (MXP=999)
18766       COMMON /FKFINU/ CXR    (MXP), CYR    (MXP), CZR    (MXP),
18767      &                CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
18768      &                TKI    (MXP), PLR    (MXP), WEI    (MXP),
18769      &                TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
18770      &                KPART  (MXP)
18771 * (original name: RESNUC)
18772       LOGICAL LRNFSS, LFRAGM
18773       COMMON /FKRESN/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
18774      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
18775      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
18776      &                  PYRES,  PZRES, PTRES2,  KTARP,  KTARN, IGREYP,
18777      &                 IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
18778      &                  ICRES,  IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
18779      &                 IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
18780      &                  IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
18781      &                 LFRAGM
18782       COMMON /FKNDAT/ AV0WEL,     APFRMX,     AEFRMX,     AEFRMA,
18783      &                RDSNUC,     V0WELL (2), PFRMMX (2), EFRMMX (2),
18784      &                EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
18785      &                VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
18786      &                PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
18787      &                EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
18788      &                ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV    ,
18789      &                AMRCSQ    , ATO1O3    , ZTO1O3    , ELBNDE (0:100)
18790 * (original name: PAREVT)
18791       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
18792      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
18793       PARAMETER ( NALLWP = 39   )
18794       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
18795      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
18796      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
18797      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
18798 * event flag
18799       COMMON /DTEVNO/ NEVENT,ICASCA
18800
18801       DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
18802      &          PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
18803      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
18804
18805       DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
18806       LOGICAL LLCPOT
18807       DATA EXC,NEXC /520*ZERO,520*0/
18808       DATA EXPNUC /4.0D-3,4.0D-3/
18809
18810       IREJ   = 0
18811       LRCLPR = .FALSE.
18812       LRCLTA = .FALSE.
18813
18814 * skip residual nucleus treatment if not requested or in case
18815 * of central collisions
18816       IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
18817
18818       DO 1 K=1,2
18819          IDPAR(K) = 0
18820          IDXPAR(K)= 0
18821          NTOT(K)  = 0
18822          NTOTFI(K)= 0
18823          NPRO(K)  = 0
18824          NPROFI(K)= 0
18825          NN(K)    = 0
18826          NH(K)    = 0
18827          NHPOS(K) = 0
18828          NQ(K)    = 0
18829          EEXC(K)  = ZERO
18830          MO1(K)   = 0
18831          MO2(K)   = 0
18832          DO 2 I=1,4
18833             VRCL(K,I) = ZERO
18834             WRCL(K,I) = ZERO
18835     2    CONTINUE
18836     1 CONTINUE
18837       NFSP = 0
18838       INUC(1) = IP
18839       INUC(2) = IT
18840
18841       DO 3 I=1,NHKK
18842
18843 * number of final state particles
18844          IF (ABS(ISTHKK(I)).EQ.1) THEN
18845             NFSP  = NFSP+1
18846             IDFSP = IDBAM(I)
18847          ENDIF
18848
18849 * properties of remaining nucleon configurations
18850          KF = 0
18851          IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
18852          IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
18853          IF (KF.GT.0) THEN
18854             IF (MO1(KF).EQ.0) MO1(KF) = I
18855             MO2(KF)  = I
18856 *   position of residual nucleus = average position of nucleons
18857             DO 4 K=1,4
18858                VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
18859                WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
18860     4       CONTINUE
18861 *   total number of particles contributing to each residual nucleus
18862             NTOT(KF)  = NTOT(KF)+1
18863             IDTMP     = IDBAM(I)
18864             IDXTMP    = I
18865 *   total charge of residual nuclei
18866             NQ(KF) = NQ(KF)+IICH(IDTMP)
18867 *   number of protons
18868             IF (IDHKK(I).EQ.2212) THEN
18869                NPRO(KF) = NPRO(KF)+1
18870 *   number of neutrons
18871             ELSEIF (IDHKK(I).EQ.2112) THEN
18872                NN(KF) = NN(KF)+1
18873             ELSE
18874 *   number of baryons other than n, p
18875                IF (IIBAR(IDTMP).EQ.1) THEN
18876                   NH(KF) = NH(KF)+1
18877                   IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
18878                ELSE
18879 *   any other mesons (status set to 1)
18880 C                 WRITE(LOUT,1002) KF,IDTMP
18881 C1002             FORMAT(1X,'FICONF:   residual nucleus ',I2,
18882 C    &                   ' containing meson ',I4,', status set to 1')
18883                   ISTHKK(I) = 1
18884                   IDTMP     = IDPAR(KF)
18885                   IDXTMP    = IDXPAR(KF)
18886                   NTOT(KF)  = NTOT(KF)-1
18887                ENDIF
18888             ENDIF
18889             IDPAR(KF)  = IDTMP
18890             IDXPAR(KF) = IDXTMP
18891          ENDIF
18892     3 CONTINUE
18893
18894 * reject elastic events (def: one final state particle = projectile)
18895       IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
18896          IREXCI(3) = IREXCI(3)+1
18897          GOTO 9999
18898 C        RETURN
18899       ENDIF
18900
18901 * check if one nucleus disappeared..
18902 C     IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
18903 C        DO 5 K=1,4
18904 C           PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
18905 C           PRCLPR(K) = ZERO
18906 C   5    CONTINUE
18907 C     ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
18908 C        DO 6 K=1,4
18909 C           PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
18910 C           PRCLTA(K) = ZERO
18911 C   6    CONTINUE
18912 C     ENDIF
18913
18914       ICOR   = 0
18915       INORCL = 0
18916       DO 7 I=1,2
18917          DO 8 K=1,4
18918 * get the average of the nucleon positions
18919             VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
18920             WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
18921             IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
18922             IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
18923     8    CONTINUE
18924 * mass number and charge of residual nuclei
18925          AIF(I)  = DBLE(NTOT(I))
18926          AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
18927          IF (NTOT(I).GT.1) THEN
18928 * masses of residual nuclei in ground state
18929             AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*DT_ENERGY(AIF(I),AIZF(I))
18930 * masses of residual nuclei
18931             PTORCL   = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
18932             AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
18933             IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
18934 *
18935 *   M_res^2 < 0 : configuration not allowed
18936 *
18937 *      a) re-calculate E_exc with scaled nuclear potential
18938 *         (conditional jump to label 9998)
18939 *      b) or reject event if N_loop(max) is exceeded
18940 *         (conditional jump to label 9999)
18941 *
18942             IF (AMRCL(I).LE.ZERO) THEN
18943                IF (IOULEV(3).GT.0)
18944      &            WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
18945      &                             PRCL(I,4),NTOT
18946  1000          FORMAT(1X,'warning! negative excitation energy',/,
18947      &                I4,4E15.4,2I4)
18948                AMRCL(I) = ZERO
18949                EEXC(I)  = ZERO
18950                IF (NLOOP.LE.500) THEN
18951                   GOTO 9998
18952                ELSE
18953                   IREXCI(2) = IREXCI(2)+1
18954                   GOTO 9999
18955                ENDIF
18956 *
18957 *   0 < M_res < M_res0 : mass below ground-state mass
18958 *
18959 *      a) we had residual nuclei with mass N_tot and reasonable E_exc
18960 *         before- assign average E_exc of those configurations to this
18961 *         one ( Nexc(i,N_tot) > 0 )
18962 *      b) or (and this applies always if run in transport codes) go up
18963 *         one mass number and
18964 *           i) if mass now larger than proj/targ mass or if run in
18965 *              transport codes assign average E_exc per wounded nucleon
18966 *              x number of wounded nucleons (Inuc-Ntot)
18967 *          ii) or assign average E_exc of those configurations to this
18968 *              one ( Nexc(i,m) > 0 )
18969 *
18970             ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
18971      &                                                         THEN
18972                M = MIN(NTOT(I),260)
18973                IF (NEXC(I,M).GT.0) THEN
18974                   AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
18975                ELSE
18976    70             CONTINUE
18977                   M = M+1
18978 **sr corrected 27.12.06
18979 *                 IF (M.GE.INUC(I)) THEN
18980 *                    AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
18981                   IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
18982                      IF ( INUC (I) .GT. NTOT (I) ) THEN
18983                         AMRCL(I) = AMRCL0(I)
18984      &                         + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
18985                      ELSE
18986                         AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
18987                      END IF
18988 **
18989                   ELSE
18990                      IF (NEXC(I,M).GT.0) THEN
18991                         AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
18992                      ELSE
18993                         GOTO 70
18994                      ENDIF
18995                   ENDIF
18996                ENDIF
18997                EEXC(I)  = AMRCL(I)-AMRCL0(I)
18998                ICOR     = ICOR+I
18999 *
19000 *   M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
19001 *
19002 *      a) re-calculate E_exc with scaled nuclear potential
19003 *         (conditional jump to label 9998)
19004 *      b) or reject event if N_loop(max) is exceeded
19005 *         (conditional jump to label 9999)
19006 *
19007 *
19008             ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
19009                IF (IOULEV(3).GT.0)
19010      &            WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
19011  1004          FORMAT(1X,'warning! too high excitation energy',/,
19012      &                I4,1P,2E15.4,3I5)
19013                AMRCL(I) = ZERO
19014                EEXC(I)  = ZERO
19015                IF (NLOOP.LE.500) THEN
19016                   GOTO 9998
19017                ELSE
19018                   IREXCI(2) = IREXCI(2)+1
19019                   GOTO 9999
19020                ENDIF
19021 *
19022 *   Otherwise (reasonable E_exc) :
19023 *      E_exc = M_res - M_res0
19024 *      in addition: calculate and save E_exc per wounded nucleon as
19025 *                   well as E_exc in <E_exc> counter
19026 *
19027             ELSE
19028 * excitation energies of residual nuclei
19029                EEXC(I)   = AMRCL(I)-AMRCL0(I)
19030 **sr 27.12.06 new excitation energy correction by A.F.
19031 *
19032 * all parts with Ilcopt<3 commented since not used
19033 *
19034 * still to be done/decided:
19035 *   Increase Icor and put back both residual nuclei on mass shell
19036 *   with the exciting correction further below.
19037 *   For the moment the modification in the excitation energy is simply
19038 *   corrected by scaling the energy of the residual nucleus.
19039 *
19040                LLCPOT = .TRUE.
19041                ILCOPT = 3
19042                IF ( LLCPOT ) THEN
19043                   NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
19044                   IF ( ILCOPT .LE. 2 ) THEN
19045 C* Patch for Fermi momentum reduction correlated with impact parameter:
19046 C                     FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
19047 C                     DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
19048 C                     AKPRHO = ONE - DLKPRH
19049 C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
19050 C                     FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO  - ONE,
19051 C     &                              0.05D+00 )
19052 C*                    REDORI = 0.75D+00
19053 C*                    REDORI = ONE
19054 C                     REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19055                   ELSE
19056                      DLKPRH = ZERO
19057                      RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
19058 *  Take out roughly one/half of the skin:
19059                      RDCORE = RDCORE - 0.5D+00
19060                      FRCFLL = RDCORE**3
19061                      PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
19062                      PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
19063                      FRCFLL = ONE - PRSKIN
19064                      FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
19065                      REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19066                   END IF
19067                   IF ( NNCHIT .GT. 0 ) THEN
19068 C                     IF ( ILCOPT .EQ. 1 ) THEN
19069 C                        SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
19070 C                        DO 1220 NCH = 1, 10
19071 C                           ETAETA = ( ONE - SKINRH**INUC(I)
19072 C     &                            - DBLE(INUC(I))* ( ONE - FRCFLL )
19073 C     &                            * ( ONE - SKINRH ) )
19074 C     &                            / ( SKINRH**INUC(I) - DBLE (INUC(I))
19075 C     &                            * ( ONE - FRCFLL) * SKINRH )
19076 C                           SKINRH = SKINRH * ( ONE + ETAETA )
19077 C 1220                   CONTINUE
19078 C                        PRSKIN = SKINRH**(NNCHIT-1)
19079 C                     ELSE IF ( ILCOPT .EQ. 2 ) THEN
19080 C                        PRSKIN = ONE - FRCFLL
19081 C                     END IF
19082                      REDCTN = ZERO
19083                      DO 1230 NCH = 1, NNCHIT
19084                         IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
19085                            PRFRMI = (( ONE - 2.D+00 * DLKPRH )
19086      &                            * DT_RNDM(PRFRMI))**0.333333333333D+00
19087                         ELSE
19088                            PRFRMI = ( ONE - 2.D+00 * DLKPRH
19089      &                            * DT_RNDM(PRFRMI))**0.333333333333D+00
19090                         END IF
19091                         REDCTN = REDCTN + PRFRMI**2
19092  1230                CONTINUE
19093                      REDCTN = REDCTN / DBLE (NNCHIT)
19094                   ELSE
19095                      REDCTN = 0.5D+00
19096                   END IF
19097                   EEXC  (I) = EEXC   (I) * REDCTN / REDORI
19098                   AMRCL (I) = AMRCL0 (I) + EEXC (I)
19099                   PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
19100                END IF
19101 **
19102                IF (ICASCA.EQ.0) THEN
19103                   EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
19104                   M = MIN(NTOT(I),260)
19105                   EXC(I,M)  = EXC(I,M)+EEXC(I)
19106                   NEXC(I,M) = NEXC(I,M)+1
19107                ENDIF
19108             ENDIF
19109          ELSEIF (NTOT(I).EQ.1) THEN
19110             WRITE(LOUT,1003) I
19111  1003       FORMAT(1X,'FICONF:   warning! NTOT(I)=1? (I=',I3,')')
19112             GOTO 9999
19113          ELSE
19114             AMRCL0(I) = ZERO
19115             AMRCL(I)  = ZERO
19116             EEXC(I)   = ZERO
19117             INORCL    = INORCL+I
19118          ENDIF
19119     7 CONTINUE
19120
19121       PRCLPR(5) = AMRCL(1)
19122       PRCLTA(5) = AMRCL(2)
19123
19124       IF (ICOR.GT.0) THEN
19125          IF (INORCL.EQ.0) THEN
19126 * one or both residual nuclei consist of one nucleon only, transform
19127 * this nucleon on mass shell
19128             DO 9 K=1,4
19129                P1IN(K) = PRCL(1,K)
19130                P2IN(K) = PRCL(2,K)
19131     9       CONTINUE
19132             XM1 = AMRCL(1)
19133             XM2 = AMRCL(2)
19134             CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
19135             IF (IREJ1.GT.0) THEN
19136                WRITE(LOUT,*) 'ficonf-mashel rejection'
19137                GOTO 9999
19138             ENDIF
19139             DO 10 K=1,4
19140                PRCL(1,K) = P1OUT(K)
19141                PRCL(2,K) = P2OUT(K)
19142                PRCLPR(K) = P1OUT(K)
19143                PRCLTA(K) = P2OUT(K)
19144    10       CONTINUE
19145             PRCLPR(5) = AMRCL(1)
19146             PRCLTA(5) = AMRCL(2)
19147          ELSE
19148             IF (IOULEV(3).GT.0)
19149      &      WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
19150      &                       INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
19151      &                       AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
19152      &                       AMRCL(2),AMRCL(2)-AMRCL0(2)
19153  1001       FORMAT(1X,'FICONF:   warning! no residual nucleus for',
19154      &             ' correction',/,11X,'at event',I8,
19155      &             ',  nucleon config. 1:',2I4,' 2:',2I4,
19156      &             2(/,11X,3E12.3))
19157             IF (NLOOP.LE.500) THEN
19158                GOTO 9998
19159             ELSE
19160                IREXCI(1) = IREXCI(1)+1
19161             ENDIF
19162          ENDIF
19163       ENDIF
19164
19165 * update counter
19166 C     IF (NRESEV(1).NE.NEVHKK) THEN
19167 C        NRESEV(1) = NEVHKK
19168 C        NRESEV(2) = NRESEV(2)+1
19169 C     ENDIF
19170       NRESEV(2) = NRESEV(2)+1
19171       DO 15 I=1,2
19172          EXCDPM(I)   = EXCDPM(I)+EEXC(I)
19173          EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
19174          NRESTO(I) = NRESTO(I)+NTOT(I)
19175          NRESPR(I) = NRESPR(I)+NPRO(I)
19176          NRESNU(I) = NRESNU(I)+NN(I)
19177          NRESBA(I) = NRESBA(I)+NH(I)
19178          NRESPB(I) = NRESPB(I)+NHPOS(I)
19179          NRESCH(I) = NRESCH(I)+NQ(I)
19180    15 CONTINUE
19181
19182 * evaporation
19183       IF (LEVPRT) THEN
19184          DO 13 I=1,2
19185 * initialize evaporation counter
19186             EEXCFI(I) = ZERO
19187             IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
19188      &          (EEXC(I).GT.ZERO)) THEN
19189 * put residual nuclei into DTEVT1
19190                IDRCL = 80000
19191                JMASS = INT( AIF(I))
19192                JCHAR = INT(AIZF(I))
19193 *  the following patch is required to transmit the correct excitation
19194 *   energy to Eventd
19195                IF (ITRSPT.EQ.1) THEN
19196                   IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
19197      &                (IOULEV(3).GT.0))
19198      &               WRITE(LOUT,*)
19199      &                  ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
19200      &                              AMRCL(I),AMRCL0(I),EEXC(I)
19201                   PRCL0 = PRCL(I,4)
19202                   PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
19203      &                                                    +PRCL(I,3)**2)
19204                   IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
19205                      WRITE(LOUT,*)
19206      &                  ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
19207                   ENDIF
19208                ENDIF
19209                CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
19210      &              PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
19211 **sr 22.6.97
19212                NOBAM(NHKK) = I
19213 **
19214                DO 14 J=1,4
19215                   VHKK(J,NHKK) = VRCL(I,J)
19216                   WHKK(J,NHKK) = WRCL(I,J)
19217    14          CONTINUE
19218 *  interface to evaporation module - fill final residual nucleus into
19219 *  common FKRESN
19220 *   fill resnuc only if code is not used as event generator in Fluka
19221                IF (ITRSPT.NE.1) THEN
19222                   PXRES  = PRCL(I,1)
19223                   PYRES  = PRCL(I,2)
19224                   PZRES  = PRCL(I,3)
19225                   IBRES  = NPRO(I)+NN(I)+NH(I)
19226                   ICRES  = NPRO(I)+NHPOS(I)
19227                   ANOW   = DBLE(IBRES)
19228                   ZNOW   = DBLE(ICRES)
19229                   PTRES  = SQRT(PXRES**2+PYRES**2+PZRES**2)
19230 *   ground state mass of the residual nucleus (should be equal to AM0T)
19231                   AMMRES = AMRCL0(I)
19232                   AMNRES = AMMRES-ZNOW*AMELEC+ELBNDE(ICRES)
19233 *  common FKFINU
19234                   TV = ZERO
19235 *   kinetic energy of residual nucleus
19236                   TVRECL = PRCL(I,4)-AMRCL(I)
19237 *   excitation energy of residual nucleus
19238                   TVCMS  = EEXC(I)
19239                   PTOLD  = PTRES
19240                   PTRES  = SQRT(ABS(TVRECL*(TVRECL+
19241      &                          2.0D0*(AMMRES+TVCMS))))
19242                   IF (PTOLD.LT.ANGLGB) THEN
19243                      CALL DT_RACO(PXRES,PYRES,PZRES)
19244                      PTOLD = ONE
19245                   ENDIF
19246                   PXRES = PXRES*PTRES/PTOLD
19247                   PYRES = PYRES*PTRES/PTOLD
19248                   PZRES = PZRES*PTRES/PTOLD
19249 * zero counter of secondaries from evaporation
19250                   NP = 0
19251 * evaporation
19252                   WE = ONE
19253                   CALL DT_EVEVAP(WE)
19254 * put evaporated particles and residual nuclei to DTEVT1
19255                   MO = NHKK
19256                   CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
19257                ENDIF
19258                EEXCFI(I) = EXCITF
19259                EXCEVA(I) = EXCEVA(I)+EXCITF
19260             ENDIF
19261    13    CONTINUE
19262       ENDIF
19263
19264       RETURN
19265
19266 C9998 IREXCI(1) = IREXCI(1)+1
19267  9998 IREJ   = IREJ+1
19268  9999 CONTINUE
19269       LRCLPR = .TRUE.
19270       LRCLTA = .TRUE.
19271       IREJ   = IREJ+1
19272       RETURN
19273       END
19274
19275 *$ CREATE DT_EVA2HE.FOR
19276 *COPY DT_EVA2HE
19277 *                                                                      *
19278 *====eva2he============================================================*
19279 *                                                                      *
19280       SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
19281
19282 ************************************************************************
19283 * Interface between common's of evaporation module (FKFINU,FKFHVY)     *
19284 * and DTEVT1.                                                          *
19285 *    MO    DTEVT1-index of "mother" (residual) nucleus before evap.    *
19286 *    EEXCF exitation energy of residual nucleus after evaporation      *
19287 *    IRCL  = 1 projectile residual nucleus                             *
19288 *          = 2 target     residual nucleus                             *
19289 * This version dated 19.04.95 is written by S. Roesler.                *
19290 *                                                                      *
19291 * Last change 27.12.2006 by S. Roesler.                                *
19292 ************************************************************************
19293
19294       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19295       SAVE
19296       PARAMETER ( LINP = 10 ,
19297      &            LOUT = 6 ,
19298      &            LDAT = 9 )
19299       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
19300
19301 * event history
19302       PARAMETER (NMXHKK=200000)
19303       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19304      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19305      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19306 * Note: DTEVT2 - special use for heavy fragments !
19307 *       (IDRES(I) = mass number, IDXRES(I) = charge)
19308 * extended event history
19309       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19310      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19311      &                IHIST(2,NMXHKK)
19312 * particle properties (BAMJET index convention)
19313       CHARACTER*8  ANAME
19314       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19315      &                IICH(210),IIBAR(210),K1(210),K2(210)
19316 * flags for input different options
19317       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19318       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19319      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19320 * statistics: residual nuclei
19321       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19322      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19323      &                NINCST(2,4),NINCEV(2),
19324      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19325      &                NRESPB(2),NRESCH(2),NRESEV(4),
19326      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19327      &                NEVAFI(2,2)
19328 * treatment of residual nuclei: properties of residual nuclei
19329       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19330      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19331      &                NTOTFI(2),NPROFI(2)
19332 * (original name: FINUC)
19333       PARAMETER (MXP=999)
19334       COMMON /FKFINU/ CXR    (MXP), CYR    (MXP), CZR    (MXP),
19335      &                CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
19336      &                TKI    (MXP), PLR    (MXP), WEI    (MXP),
19337      &                TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
19338      &                KPART  (MXP)
19339 * (original name: FHEAVY,FHEAVC)
19340       PARAMETER ( MXHEAV = 100 )
19341       CHARACTER*8 ANHEAV
19342       COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19343      &                CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19344      &                PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19345      &                AMHEAV  ( 12 ) , AMNHEA  ( 12 ) ,
19346      &                KHEAVY (MXHEAV), ICHEAV  ( 12 ) ,
19347      &                IBHEAV  ( 12 ) , NPHEAV
19348       COMMON /FKFHVC/ ANHEAV  ( 12 )
19349 * (original name: RESNUC)
19350       LOGICAL LRNFSS, LFRAGM
19351       COMMON /FKRESN/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19352      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19353      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
19354      &                  PYRES,  PZRES, PTRES2,  KTARP,  KTARN, IGREYP,
19355      &                 IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
19356      &                  ICRES,  IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
19357      &                 IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
19358      &                  IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
19359      &                 LFRAGM
19360
19361       DIMENSION IPTOKP(39)
19362       DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
19363      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
19364      & 100, 101, 97, 102, 98, 103, 109, 115 /
19365
19366       IREJ = 0
19367
19368 * skip if evaporation package is not included
19369       IF (.NOT.LEVAPO) RETURN
19370
19371 * update counter
19372       IF (NRESEV(3).NE.NEVHKK) THEN
19373          NRESEV(3) = NEVHKK
19374          NRESEV(4) = NRESEV(4)+1
19375       ENDIF
19376
19377       IF (LEMCCK)
19378      &   CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
19379      &                                                   IDUM,IDUM)
19380 * mass number/charge of residual nucleus before evaporation
19381       IBTOT = IDRES(MO)
19382       IZTOT = IDXRES(MO)
19383
19384 * protons/neutrons/gammas
19385       DO 1 I=1,NP
19386          PX    = CXR(I)*PLR(I)
19387          PY    = CYR(I)*PLR(I)
19388          PZ    = CZR(I)*PLR(I)
19389          ID    = IPTOKP(KPART(I))
19390          IDPDG = IDT_IPDGHA(ID)
19391          AM    = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
19392      &           (2.0D0*MAX(TKI(I),TINY10))
19393          IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
19394             WRITE(LOUT,1000) ID,AM,AAM(ID)
19395  1000       FORMAT(1X,'EVA2HE:  inconsistent mass of evap. ',
19396      &             'particle',I3,2E10.3)
19397          ENDIF
19398          PE = TKI(I)+AM
19399          CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
19400          NOBAM(NHKK) = IRCL
19401          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19402          IBTOT = IBTOT-IIBAR(ID)
19403          IZTOT = IZTOT-IICH(ID)
19404     1 CONTINUE
19405
19406 * heavy fragments
19407       DO 2 I=1,NPHEAV
19408          PX     = CXHEAV(I)*PHEAVY(I)
19409          PY     = CYHEAV(I)*PHEAVY(I)
19410          PZ     = CZHEAV(I)*PHEAVY(I)
19411          IDHEAV = 80000
19412          AM     = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
19413      &            (2.0D0*MAX(TKHEAV(I),TINY10))
19414          PE     = TKHEAV(I)+AM
19415          CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
19416      &                  IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
19417          NOBAM(NHKK) = IRCL
19418          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19419          IBTOT = IBTOT-IBHEAV(KHEAVY(I))
19420          IZTOT = IZTOT-ICHEAV(KHEAVY(I))
19421     2 CONTINUE
19422
19423       IF (IBRES.GT.0) THEN
19424 * residual nucleus after evaporation
19425          IDNUC = 80000
19426          CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
19427      &                                        IBRES,ICRES,0)
19428          NOBAM(NHKK) = IRCL
19429       ENDIF
19430       EEXCF = TVCMS
19431       NTOTFI(IRCL) = IBRES
19432       NPROFI(IRCL) = ICRES
19433       IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
19434       IBTOT = IBTOT-IBRES
19435       IZTOT = IZTOT-ICRES
19436
19437 * count events with fission
19438       NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
19439       IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
19440
19441 * energy-momentum conservation check
19442       IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
19443 C     IF (IREJ.GT.0) THEN
19444 C        CALL DT_EVTOUT(4)
19445 C        WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
19446 C     ENDIF
19447 * baryon-number/charge conservation check
19448       IF (IBTOT+IZTOT.NE.0) THEN
19449          WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
19450  1001    FORMAT(1X,'EVA2HE:   baryon-number/charge conservation ',
19451      &          'failure at event ',I8,' :  IBTOT,IZTOT = ',2I3)
19452       ENDIF
19453
19454       RETURN
19455       END
19456
19457 *$ CREATE DT_EBIND.FOR
19458 *COPY DT_EBIND
19459 *
19460 *===ebind==============================================================*
19461 *
19462       DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
19463
19464 ************************************************************************
19465 * Binding energy for nuclei.                                           *
19466 * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972)                  *
19467 *                 IA        mass number                                *
19468 *                 IZ        atomic number                              *
19469 * This version dated 5.5.95   is updated by S. Roesler.                *
19470 ************************************************************************
19471
19472       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19473       SAVE
19474       PARAMETER ( LINP = 10 ,
19475      &            LOUT = 6 ,
19476      &            LDAT = 9 )
19477       PARAMETER (ZERO=0.0D0)
19478
19479       DATA       A1,       A2,        A3,        A4,      A5
19480      &     / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
19481
19482       IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
19483          WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0.  ',IA,IZ
19484          DT_EBIND = ZERO
19485          RETURN
19486       ENDIF
19487       AA = IA
19488       DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
19489      &        -A4*(IA-2*IZ)**2/AA
19490       IF (MOD(IA,2).EQ.1) THEN
19491          IA5 = 0
19492       ELSEIF (MOD(IZ,2).EQ.1) THEN
19493          IA5 = 1
19494       ELSE
19495          IA5 = -1
19496       ENDIF
19497       DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
19498
19499       RETURN
19500       END
19501
19502 **sr 30.6. routine replaced completely
19503 *$ CREATE DT_ENERGY.FOR
19504 *COPY DT_ENERGY
19505 *                                                                      *
19506 *=== energy ===========================================================*
19507 *                                                                      *
19508       DOUBLE PRECISION FUNCTION DT_ENERGY( A, Z )
19509
19510 C     INCLUDE '(DBLPRC)'
19511 * DBLPRC.ADD
19512       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19513       SAVE
19514 * (original name: GLOBAL)
19515       PARAMETER ( KALGNM = 2 )
19516       PARAMETER ( ANGLGB = 5.0D-16 )
19517       PARAMETER ( ANGLSQ = 2.5D-31 )
19518       PARAMETER ( AXCSSV = 0.2D+16 )
19519       PARAMETER ( ANDRFL = 1.0D-38 )
19520       PARAMETER ( AVRFLW = 1.0D+38 )
19521       PARAMETER ( AINFNT = 1.0D+30 )
19522       PARAMETER ( AZRZRZ = 1.0D-30 )
19523       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
19524       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
19525       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
19526       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
19527       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
19528       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
19529       PARAMETER ( CSNNRM = 2.0D-15 )
19530       PARAMETER ( DMXTRN = 1.0D+08 )
19531       PARAMETER ( ZERZER = 0.D+00 )
19532       PARAMETER ( ONEONE = 1.D+00 )
19533       PARAMETER ( TWOTWO = 2.D+00 )
19534       PARAMETER ( THRTHR = 3.D+00 )
19535       PARAMETER ( FOUFOU = 4.D+00 )
19536       PARAMETER ( FIVFIV = 5.D+00 )
19537       PARAMETER ( SIXSIX = 6.D+00 )
19538       PARAMETER ( SEVSEV = 7.D+00 )
19539       PARAMETER ( EIGEIG = 8.D+00 )
19540       PARAMETER ( ANINEN = 9.D+00 )
19541       PARAMETER ( TENTEN = 10.D+00 )
19542       PARAMETER ( HLFHLF = 0.5D+00 )
19543       PARAMETER ( ONETHI = ONEONE / THRTHR )
19544       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
19545       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
19546       PARAMETER ( THRTWO = THRTHR / TWOTWO )
19547       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
19548       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
19549       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
19550       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
19551       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
19552       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
19553       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
19554       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
19555       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
19556       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
19557       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
19558       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
19559       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
19560       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
19561       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
19562       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
19563       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
19564       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
19565       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
19566       PARAMETER ( CLIGHT = 2.99792458         D+10 )
19567       PARAMETER ( AVOGAD = 6.0221367          D+23 )
19568       PARAMETER ( BOLTZM = 1.380658           D-23 )
19569       PARAMETER ( AMELGR = 9.1093897          D-28 )
19570       PARAMETER ( PLCKBR = 1.05457266         D-27 )
19571       PARAMETER ( ELCCGS = 4.8032068          D-10 )
19572       PARAMETER ( ELCMKS = 1.60217733         D-19 )
19573       PARAMETER ( AMUGRM = 1.6605402          D-24 )
19574       PARAMETER ( AMMUMU = 0.113428913        D+00 )
19575       PARAMETER ( AMPRMU = 1.007276470        D+00 )
19576       PARAMETER ( AMNEMU = 1.008664904        D+00 )
19577       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
19578       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
19579       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
19580       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
19581       PARAMETER ( PLABRC = 0.197327053        D+00 )
19582       PARAMETER ( AMELCT = 0.51099906         D-03 )
19583       PARAMETER ( AMUGEV = 0.93149432         D+00 )
19584       PARAMETER ( AMMUON = 0.105658389        D+00 )
19585       PARAMETER ( AMPRTN = 0.93827231         D+00 )
19586       PARAMETER ( AMNTRN = 0.93956563         D+00 )
19587       PARAMETER ( AMDEUT = 1.87561339         D+00 )
19588       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19589      &                   * 1.D-09 )
19590       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
19591       PARAMETER ( BLTZMN = 8.617385           D-14 )
19592       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
19593       PARAMETER ( GFOHB3 = 1.16639            D-05 )
19594       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
19595       PARAMETER ( SIN2TW = 0.2319             D+00 )
19596       PARAMETER ( GEVMEV = 1.0                D+03 )
19597       PARAMETER ( EMVGEV = 1.0                D-03 )
19598       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
19599       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
19600       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
19601       LOGICAL LGBIAS, LGBANA
19602       COMMON /FKGLOB/ LGBIAS, LGBANA
19603 C     INCLUDE '(DIMPAR)'
19604 * DIMPAR.ADD
19605       PARAMETER ( MXXRGN = 5000 )
19606       PARAMETER ( MXXMDF = 82   )
19607       PARAMETER ( MXXMDE = 54   )
19608       PARAMETER ( MFSTCK = 1000 )
19609       PARAMETER ( MESTCK = 100  )
19610       PARAMETER ( NALLWP = 39   )
19611       PARAMETER ( NELEMX = 80   )
19612       PARAMETER ( MPDPDX = 8    )
19613       PARAMETER ( ICOMAX = 180  )
19614       PARAMETER ( NSTBIS = 304  )
19615       PARAMETER ( IDMAXP = 220  )
19616       PARAMETER ( IDMXDC = 640  )
19617       PARAMETER ( MKBMX1 = 1    )
19618       PARAMETER ( MKBMX2 = 1    )
19619 C     INCLUDE '(IOUNIT)'
19620 * IOUNIT.ADD
19621       PARAMETER ( LUNIN  =  5 )
19622       PARAMETER ( LUNOUT =  6 )
19623 **sr 19.5. set error output-unit from 15 to 6
19624       PARAMETER ( LUNERR = 6  )
19625       PARAMETER ( LUNBER = 14 )
19626       PARAMETER ( LUNECH =  8 )
19627       PARAMETER ( LUNFLU = 13 )
19628       PARAMETER ( LUNGEO = 16 )
19629       PARAMETER ( LUNPMF = 12 )
19630       PARAMETER ( LUNRAN =  2 )
19631       PARAMETER ( LUNXSC =  9 )
19632       PARAMETER ( LUNDET = 17 )
19633       PARAMETER ( LUNRAY = 10 )
19634       PARAMETER ( LUNRDB =  1 )
19635       PARAMETER ( LUNPGO =  7 )
19636       PARAMETER ( LUNPGS =  4 )
19637       PARAMETER ( LUNSCR =  3 )
19638 *
19639 *----------------------------------------------------------------------*
19640 *                                                                      *
19641 *     Revised version of the original routine from EVAP:               *
19642 *                                                                      *
19643 *     Created on   15 may 1990     by    Alfredo Ferrari & Paola Sala  *
19644 *                                                   Infn - Milan       *
19645 *                                                                      *
19646 *     Last change on 19-sep-95     by    Alfredo Ferrari               *
19647 *                                                                      *
19648 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
19649 *     !!!  It is supposed to be used with the updated atomic   !!!     *
19650 *     !!!                    mass data file                    !!!     *
19651 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
19652 *                                                                      *
19653 *----------------------------------------------------------------------*
19654 *
19655 *  Mass number below which "unknown" isotopes out of the Z-interval
19656 *  reported in the mass tabulations are completely unstable and made
19657 *  up by Z proton masses + N neutron masses:
19658       PARAMETER ( KAFREE =  4 )
19659 *  Mass number below which "unknown" isotopes out of the Z-interval
19660 *  reported in the mass tabulations are supposed to be particle unstable
19661       PARAMETER ( KAPUNS = 12 )
19662 *  Minimum energy required for particle unstable isotopes
19663       PARAMETER ( DEPUNS = 0.5D+00 )
19664 *
19665 * (original name: EVA0)
19666       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
19667      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
19668      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
19669      *                T (4,7), RMASS (297), ALPH (297), BET (297),
19670      *                APRIME (250), IA (6), IZ (6)
19671 * (original name: ISOTOP)
19672       PARAMETER ( NAMSMX = 270 )
19673       PARAMETER ( NZGVAX =  15 )
19674       PARAMETER ( NISMMX = 574 )
19675       COMMON /FKISOT/ WAPS   (NAMSMX,NZGVAX),  T12NUC (NAMSMX,NZGVAX),
19676      &                WAPISM (NISMMX), T12ISM (NISMMX),
19677      &                ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
19678      &                AMSSST (100)  , ISOMNM (NSTBIS), ISONDX (2,100),
19679      &                JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
19680      &                INWAPS (NAMSMX), JSPISM (NISMMX),
19681      &                JPTISM (NISMMX), IZWISM (NISMMX),
19682      &                INWISM (0:NAMSMX)
19683 *
19684 CPH      SAVE KA0, KZ0, IZ0
19685       DATA KA0, KZ0, IZ0 / -1, -1, -1 /
19686 *
19687       IFLAG = 1
19688       GO TO 10
19689 *======================================================================*
19690 *                                                                      *
19691 *     Entry ENergy - KNOWn                                             *
19692 *                                                                      *
19693 *======================================================================*
19694       ENTRY DT_ENKNOW ( A, Z, IZZ0 )
19695       IZZ0  =-1
19696       IFLAG = 2
19697    10 CONTINUE
19698 *
19699       KA0 = NINT ( A )
19700       KZ0 = NINT ( Z )
19701       N   = KA0 - KZ0
19702 *  +-------------------------------------------------------------------*
19703 *  |  Null residual nucleus:
19704       IF ( KA0 .EQ. 0 .AND. KZ0 .LE. 0 ) THEN
19705          IF ( IFLAG .EQ. 1 ) THEN
19706             DT_ENERGY = ZERZER
19707          ELSE
19708             DT_ENKNOW = ZERZER
19709             IZZ0   = -1
19710          END IF
19711          RETURN
19712 *  |
19713 *  +-------------------------------------------------------------------*
19714 *  |  Only protons:
19715       ELSE IF ( N .LE. 0 ) THEN
19716          IF ( N .LT. 0 ) THEN
19717             WRITE ( LUNOUT, * )
19718      &     ' DPMJET stopped in energy: mass number =< atomic number !!',
19719      &       KA0, KZ0
19720             WRITE ( LUNOUT, * )
19721      &     ' DPMJET stopped in energy: mass number =< atomic number !!',
19722      &       KA0, KZ0
19723                WRITE ( 77, * )
19724      &  ' ^^^DPMJET stopped in energy: mass number =< atomic number !!',
19725      &       KA0, KZ0
19726             STOP 'DT_ENERGY:KA0-KZ0'
19727          END IF
19728          IZ0    = -1
19729          IF ( IFLAG .EQ. 1 ) THEN
19730             DT_ENERGY = Z * WAPS ( 1, 2 )
19731          ELSE
19732             DT_ENKNOW = Z * WAPS ( 1, 2 )
19733             IZZ0   = -1
19734          END IF
19735          RETURN
19736 *  |
19737 *  +-------------------------------------------------------------------*
19738 *  |  Only neutrons:
19739       ELSE IF ( KZ0 .LE. 0 ) THEN
19740          IF ( KZ0 .LT. 0 ) THEN
19741             WRITE ( LUNOUT, * )
19742      &   ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19743             WRITE ( LUNOUT, * )
19744      &   ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19745             WRITE ( 77, * )
19746      &' ^^^DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19747             STOP 'DT_ENERGY:KZ0<0'
19748          END IF
19749          IZ0    = -1
19750          IF ( IFLAG .EQ. 1 ) THEN
19751             DT_ENERGY = A * WAPS ( 1, 1 )
19752          ELSE
19753             DT_ENKNOW = A * WAPS ( 1, 1 )
19754             IZZ0   = -1
19755          END IF
19756          RETURN
19757       END IF
19758 *  |
19759 *  +-------------------------------------------------------------------*
19760 *  +-------------------------------------------------------------------*
19761 *  |  No actual nucleus
19762 *  |
19763 *  +-------------------------------------------------------------------*
19764 *  +-------------------------------------------------------------------*
19765 *  |  A larger than maximum allowed:
19766       IF ( KA0 .GT. NAMSMX ) THEN
19767          IZ0    = -1
19768          IF ( IFLAG .EQ. 1 ) THEN
19769             DT_ENERGY = DT_ENRG( A, Z )
19770          ELSE
19771             DT_ENKNOW = DT_ENRG( A, Z )
19772             IZZ0   = -1
19773          END IF
19774          RETURN
19775       END IF
19776 *  |
19777 *  +-------------------------------------------------------------------*
19778       IZZ = INWAPS ( KA0 )
19779 *  +-------------------------------------------------------------------*
19780 *  |  Too much neutron rich with respect to the stability line:
19781       IF ( KZ0 .LT. IZZ ) THEN
19782 *  |  +----------------------------------------------------------------*
19783 *  |  |  Up to A=Kafree all "bound" masses are known, set it unbound:
19784          IF ( KA0 .LE. KAFREE ) THEN
19785             DT_ENERGY = AINFNT
19786 *  |  |
19787 *  |  +----------------------------------------------------------------*
19788 *  |  |  Up to Kapuns: be sure it is particle unstable
19789          ELSE IF ( KA0 .LE. KAPUNS ) THEN
19790 *  |  |  Exp. excess mass for A,IZZ
19791             ENEEXP = WAPS ( KA0, 1 )
19792 *  |  |  Cameron excess mass for A, IZZ
19793             ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19794 *  |  |  Cameron excess mass for A, Z
19795             DT_ENERGY = DT_ENRG( A, Z )
19796 *  |  |  Use just the difference according to Cameron!!!
19797             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19798             JZZ    = INWAPS ( KA0 - 1 )
19799             LZZ    = INWAPS ( KA0 - 2 )
19800 *  |  |  +-------------------------------------------------------------*
19801 *  |  |  |  Residual mass for n-decay known:
19802             IF ( KZ0 .GE. JZZ .AND. KZ0 .LE. JZZ + NZGVAX - 1 ) THEN
19803                IZ0    = KZ0 - JZZ + 1
19804                DT_ENERGY = MAX(DT_ENERGY,WAPS (KA0-1,IZ0) + WAPS (1,1)
19805      &                      + DEPUNS )
19806 *  |  |  |
19807 *  |  |  +-------------------------------------------------------------*
19808 *  |  |  |  Residual mass for 2n-decay known:
19809             ELSE IF ( KZ0 .GE. LZZ .AND. KZ0 .LE. LZZ + NZGVAX - 1 )THEN
19810                IZ0    = KZ0 - LZZ + 1
19811                DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19812      &                      ( WAPS (1,1) + DEPUNS ) )
19813 *  |  |  |
19814 *  |  |  +-------------------------------------------------------------*
19815 *  |  |  |  Set it unbound:
19816             ELSE
19817                DT_ENERGY = AINFNT
19818             END IF
19819 *  |  |  |
19820 *  |  |  +-------------------------------------------------------------*
19821 *  |  |
19822 *  |  +----------------------------------------------------------------*
19823 *  |  |  Proceed as usual:
19824          ELSE
19825 *  |  |  Exp. excess mass for A,IZZ
19826             ENEEXP = WAPS ( KA0, 1 )
19827 *  |  |  Cameron excess mass for A, IZZ
19828             ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19829 *  |  |  Cameron excess mass for A, Z
19830             DT_ENERGY = DT_ENRG( A, Z )
19831 *  |  |  Use just the difference according to Cameron!!!
19832             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19833          END IF
19834 *  |  |
19835 *  |  +----------------------------------------------------------------*
19836 *  |  Be sure not to have a positive energy state:
19837          DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19838          IZ0    = -1
19839          IF ( IFLAG .EQ. 2 ) THEN
19840             DT_ENKNOW = DT_ENERGY
19841             IZZ0   = -1
19842          END IF
19843          RETURN
19844 *  |
19845 *  +-------------------------------------------------------------------*
19846 *  |  Too much proton rich with respect to the stability line:
19847       ELSE IF ( KZ0 .GT. IZZ + NZGVAX - 1 ) THEN
19848 *  |  +----------------------------------------------------------------*
19849 *  |  |  Up to A=Kafree all "bound" masses are known, set it unbound:
19850          IF ( KA0 .LE. KAFREE ) THEN
19851             DT_ENERGY = AINFNT
19852 *  |  |
19853 *  |  +----------------------------------------------------------------*
19854 *  |  |  Up to Kapuns: be sure it is particle unstable
19855          ELSE IF ( KA0 .LE. KAPUNS ) THEN
19856 *  |  |  Exp. excess mass for A,IZZ+NZGVAX-1
19857             ENEEXP = WAPS ( KA0, NZGVAX )
19858 *  |  |  Cameron excess mass for A, IZZ+NZGVAX-1
19859             ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19860 *  |  |  Cameron excess mass for A, Z
19861             DT_ENERGY = DT_ENRG( A, Z )
19862 *  |  |  Use just the difference according to Cameron!!!
19863             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19864             JZZ    = INWAPS ( KA0 - 1 )
19865             LZZ    = INWAPS ( KA0 - 2 )
19866 *  |  |  +-------------------------------------------------------------*
19867 *  |  |  |  Residual mass for p-decay known:
19868             IF ( KZ0-1 .GE. JZZ .AND. KZ0-1 .LE. JZZ + NZGVAX - 1 ) THEN
19869                IZ0    = KZ0 - 1 - JZZ + 1
19870                DT_ENERGY = MAX (DT_ENERGY, WAPS (KA0-1,IZ0) + WAPS (1,2)
19871      &                      + DEPUNS )
19872 *  |  |  |
19873 *  |  |  +-------------------------------------------------------------*
19874 *  |  |  |  Residual mass for 2p-decay known:
19875             ELSE IF ( KZ0-2 .GE. LZZ .AND. KZ0-2 .LE. LZZ + NZGVAX - 1 )
19876      &         THEN
19877                IZ0    = KZ0 - 2 - LZZ + 1
19878                DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19879      &                      ( WAPS (1,2) + DEPUNS ) )
19880 *  |  |  |
19881 *  |  |  +-------------------------------------------------------------*
19882 *  |  |  |  Set it unbound:
19883             ELSE
19884                DT_ENERGY = AINFNT
19885             END IF
19886 *  |  |  |
19887 *  |  |  +-------------------------------------------------------------*
19888 *  |  |
19889 *  |  +----------------------------------------------------------------*
19890 *  |  |  Proceed as usual:
19891          ELSE
19892 *  |  |  Exp. excess mass for A,IZZ+NZGVAX-1
19893             ENEEXP = WAPS ( KA0, NZGVAX )
19894 *  |  |  Cameron excess mass for A, IZZ+NZGVAX-1
19895             ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19896 *  |  |  Cameron excess mass for A, Z
19897             DT_ENERGY = DT_ENRG( A, Z )
19898 *  |  |  Use just the difference according to Cameron!!!
19899             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19900          END IF
19901 *  |  |
19902 *  |  +----------------------------------------------------------------*
19903 *  |  Be sure not to have a positive energy state:
19904          DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19905          IZ0    = -1
19906          IF ( IFLAG .EQ. 2 ) THEN
19907             DT_ENKNOW = DT_ENERGY
19908             IZZ0   = -1
19909          END IF
19910          RETURN
19911 *  |
19912 *  +-------------------------------------------------------------------*
19913 *  |  Known isotope or anyway isotope "inside" the stability zone
19914       ELSE
19915          IZ0    = KZ0 - IZZ + 1
19916          DT_ENERGY = WAPS ( KA0, IZ0 )
19917          IF ( IFLAG .EQ. 2 ) IZZ0 = IZ0
19918 *  |  +----------------------------------------------------------------*
19919 *  |  |  Mass not known
19920          IF ( ABS (DT_ENERGY) .LT. ANGLGB .AND. (KA0 .NE. 12 .OR. KZ0
19921      &        .NE. 6) ) THEN
19922             IF ( IFLAG .EQ. 2 ) IZZ0 = -1
19923 *  |  |  +-------------------------------------------------------------*
19924 *  |  |  |  Set it unbound:
19925             IF ( KA0 .LE. KAFREE ) THEN
19926                DT_ENERGY = AINFNT
19927 *  |  |  |
19928 *  |  |  +-------------------------------------------------------------*
19929 *  |  |  |  Try to get a reasonable excess mass:
19930             ELSE
19931                JZ0 = -100
19932 *  |  |  |  +----------------------------------------------------------*
19933 *  |  |  |  |  Check the closest one known:
19934                DO 500 JZZ = 1, NZGVAX
19935                   IF ( ABS ( WAPS (KA0,JZZ) ) .GT. ANGLGB .AND.
19936      &                 ABS (JZZ-IZ0) .LT. ABS (JZ0-IZ0) ) JZ0 = JZZ
19937                   IF ( ABS (JZ0-IZ0) .EQ. 1 ) GO TO 550
19938   500          CONTINUE
19939 *  |  |  |  |
19940 *  |  |  |  +----------------------------------------------------------*
19941   550          CONTINUE
19942 *  |  |  |  Exp. excess mass for A,IZZ+JZ0-1
19943                ENEEXP = WAPS ( KA0, JZ0 )
19944 *  |  |  |  Cameron excess mass for A, IZZ+JZ0-1
19945                ENECA1 = DT_ENRG( A, DBLE (IZZ+JZ0-1) )
19946 *  |  |  |  Cameron excess mass for A, Z
19947                DT_ENERGY = DT_ENRG( A, Z )
19948 *  |  |  |  Use just the difference according to Cameron!!!
19949                DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19950                IZ0    = -1
19951             END IF
19952 *  |  |  |
19953 *  |  |  +-------------------------------------------------------------*
19954 *  |  |  Be sure not to have a positive energy state:
19955             DT_ENERGY = MIN(DT_ENERGY,(A-Z)*WAPS(1,1)+Z*WAPS (1,2) )
19956          END IF
19957 *  |  |
19958 *  |  +----------------------------------------------------------------*
19959          IF ( IFLAG .EQ. 2 ) DT_ENKNOW = DT_ENERGY
19960          RETURN
19961       END IF
19962 *  |
19963 *  +-------------------------------------------------------------------*
19964 *=== End of Function Energy ===========================================*
19965 *     RETURN
19966       END
19967 **
19968
19969 *$ CREATE DT_ENRG.FOR
19970 *COPY DT_ENRG
19971 *                                                                      *
19972 *=== enrg =============================================================*
19973 *                                                                      *
19974       DOUBLE PRECISION FUNCTION DT_ENRG(A,Z)
19975
19976       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19977       SAVE
19978
19979       PARAMETER ( ZERZER = 0.D+00 )
19980       PARAMETER ( ONEONE = 1.D+00 )
19981       PARAMETER ( LUNIN  = 5  )
19982       PARAMETER ( LUNOUT = 6  )
19983 *
19984 *----------------------------------------------------------------------*
19985 *                                                                      *
19986 *     Revised version of the original routine from EVAP:               *
19987 *                                                                      *
19988 *     Created on   15 may 1990     by    Alfredo Ferrari & Paola Sala  *
19989 *                                                   Infn - Milan       *
19990 *                                                                      *
19991 *     Last change on 01-oct-94     by    Alfredo Ferrari               *
19992 *                                                                      *
19993 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
19994 *     !!!  It is supposed to be used with the updated atomic   !!!     *
19995 *     !!!                    mass data file                    !!!     *
19996 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
19997 *                                                                      *
19998 *----------------------------------------------------------------------*
19999 *
20000       PARAMETER ( O16OLD = 931.145  D+00 )
20001       PARAMETER ( O16NEW = 931.19826D+00 )
20002       PARAMETER ( O16RAT = O16NEW / O16OLD )
20003       PARAMETER ( C12NEW = 931.49432D+00 )
20004       PARAMETER ( ADJUST = -8.322737768178909D-02 )
20005       PARAMETER ( AINFNT = 1.0D+30 )
20006 * (original name: EVA0)
20007       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
20008      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
20009      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
20010      *                T (4,7), RMASS (297), ALPH (297), BET (297),
20011      *                APRIME (250), IA (6), IZ (6)
20012       LOGICAL LFIRST
20013 CPH      SAVE LFIRST, EXHYDR, EXNEUT
20014       DATA LFIRST / .TRUE. /
20015 *
20016       IF ( LFIRST ) THEN
20017          LFIRST = .FALSE.
20018 **sr 30.6.
20019 C        EXHYDR = DT_ENERGY( ONEONE, ONEONE )
20020 C        EXNEUT = DT_ENERGY( ONEONE, ZERZER )
20021          EXHYDR = A
20022          EXNEUT = Z
20023          DT_ENRG   = -AINFNT
20024          RETURN
20025 **
20026       END IF
20027       IZ0 = NINT (Z)
20028       IF ( IZ0 .LE. 0 ) THEN
20029          DT_ENRG = A * EXNEUT
20030          RETURN
20031       END IF
20032       N   = NINT (A-Z)
20033       IF ( N .LE. 0 ) THEN
20034          DT_ENRG = Z * EXHYDR
20035          RETURN
20036       END IF
20037       AM2ZOA= (A-Z-Z)/A
20038       AM2ZOA=AM2ZOA*AM2ZOA
20039       A13 = RMASS(NINT(A))
20040 *     A13 = A**.3333333333333333D+00
20041       AM13 = 1.D+00/A13
20042       EV=-17.0354D+00*(1.D+00 -1.84619 D+00*AM2ZOA)*A
20043       ES= 25.8357D+00*(1.D+00 -1.712185D+00*AM2ZOA)*
20044      &    (1.D+00 -0.62025D+00*AM13*AM13)*
20045      &    (A13*A13 -.62025D+00)
20046       EC= 0.799D+00*Z*(Z-1.D+00)*AM13*(((1.5772D+00*AM13 +1.2273D+00)*
20047      &    AM13-1.5849D+00)*
20048      &    AM13*AM13 +1.D+00)
20049       EEX= -0.4323D+00*AM13*Z**1.3333333D+00*
20050      &   (((0.49597D+00*AM13 -0.14518D+00)*AM13 -0.57811D+00) * AM13
20051      &   + 1.D+00)
20052       DT_ENRG=8.367D+00*A-0.783D+00*Z +EV +ES +EC +EEX+CAM2(IZ0)+CAM3(N)
20053       DT_ENRG=(DT_ENRG + A * O16OLD ) * O16RAT - A * ( C12NEW - ADJUST )
20054       DT_ENRG  = MIN ( DT_ENRG, Z * EXHYDR + ( A - Z ) * EXNEUT )
20055       RETURN
20056 *=== End of function Enrg =============================================*
20057       END
20058
20059 *$ CREATE DT_INCINI.FOR
20060 *COPY DT_INCINI
20061 *                                                                      *
20062 *=== incini ===========================================================*
20063 *                                                                      *
20064       SUBROUTINE DT_INCINI
20065
20066       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20067       SAVE
20068
20069       PARAMETER ( ZERZER = 0.D+00 )
20070       PARAMETER ( ONEONE = 1.D+00 )
20071       PARAMETER ( TWOTWO = 2.D+00 )
20072       PARAMETER ( THRTHR = 3.D+00 )
20073       PARAMETER ( FOUFOU = 4.D+00 )
20074       PARAMETER ( EIGEIG = 8.D+00 )
20075       PARAMETER ( ANINEN = 9.D+00 )
20076       PARAMETER ( HLFHLF = 0.5D+00 )
20077       PARAMETER ( ONETHI = ONEONE / THRTHR )
20078       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20079       PARAMETER ( PLABRC = 0.197327053        D+00 )
20080       PARAMETER ( AMELCT = 0.51099906         D-03 )
20081       PARAMETER ( AMUGEV = 0.93149432         D+00 )
20082       PARAMETER ( AMPRTN = 0.93827231         D+00 )
20083       PARAMETER ( AMNTRN = 0.93956563         D+00 )
20084       PARAMETER ( AMDEUT = 1.87561339         D+00 )
20085       PARAMETER ( EMVGEV = 1.0                D-03 )
20086
20087       PARAMETER ( LUNOUT = 6  )
20088 *
20089 *----------------------------------------------------------------------*
20090 *                                                                      *
20091 *     Created on  10  june  1990   by    Alfredo Ferrari & Paola Sala  *
20092 *                                                   Infn - Milan       *
20093 *                                                                      *
20094 *     Last change on 02-may-95     by    Alfredo Ferrari               *
20095 *                                                                      *
20096 *                                                                      *
20097 *----------------------------------------------------------------------*
20098 *
20099 * (original name: FHEAVY,FHEAVC)
20100       PARAMETER ( MXHEAV = 100 )
20101       CHARACTER*8 ANHEAV
20102       COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20103      &                CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20104      &                PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20105      &                AMHEAV  ( 12 ) , AMNHEA  ( 12 ) ,
20106      &                KHEAVY (MXHEAV), ICHEAV  ( 12 ) ,
20107      &                IBHEAV  ( 12 ) , NPHEAV
20108       COMMON /FKFHVC/ ANHEAV  ( 12 )
20109 * (original name: INPFLG)
20110       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20111 * (original name: FRBKCM)
20112       PARAMETER ( MXFFBK =     6 )
20113       PARAMETER ( MXZFBK =     9 )
20114       PARAMETER ( MXNFBK =    10 )
20115       PARAMETER ( MXAFBK =    16 )
20116       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20117       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20118       PARAMETER ( NXAFBK = MXAFBK + 1 )
20119       PARAMETER ( MXPSST =   300 )
20120       PARAMETER ( MXPSFB = 41000 )
20121       LOGICAL LFRMBK, LNCMSS
20122       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20123      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20124      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20125      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
20126      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20127      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20128      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20129      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20130      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
20131 * (original name: NUCDAT)
20132       PARAMETER ( AMUAMU = AMUGEV )
20133       PARAMETER ( AMPROT = AMPRTN )
20134       PARAMETER ( AMNEUT = AMNTRN )
20135       PARAMETER ( AMELEC = AMELCT )
20136       PARAMETER ( R0NUCL = 1.12        D+00 )
20137       PARAMETER ( RCCOUL = 1.7         D+00 )
20138       PARAMETER ( FERTHO = 14.33       D-09 )
20139       PARAMETER ( EXPEBN = 2.39        D+00 )
20140       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
20141       PARAMETER ( AMUC12 = AMUGEV - HLFHLF * AMELCT + BEXC12 / 12.D+00 )
20142       PARAMETER ( AMHYDR = AMPRTN + AMELCT  )
20143       PARAMETER ( AMHTON = AMHYDR - AMNTRN  )
20144       PARAMETER ( AMNTOU = AMNTRN - AMUC12  )
20145       PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
20146       PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
20147       PARAMETER ( GAMMIN = 1.0D-06 )
20148       PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
20149       PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
20150       COMMON /FKNDAT/ AV0WEL,     APFRMX,     AEFRMX,     AEFRMA,
20151      &                RDSNUC,     V0WELL (2), PFRMMX (2), EFRMMX (2),
20152      &                EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
20153      &                VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
20154      &                PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
20155      &                EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
20156      &                ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV    ,
20157      &                AMRCSQ    , ATO1O3    , ZTO1O3    , ELBNDE (0:100)
20158 * (original name: PAREVT)
20159       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20160      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20161       PARAMETER ( NALLWP = 39   )
20162       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20163      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20164      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20165      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20166 * (original name: NUCOLD)
20167       COMMON /FKNOLD/ HELP (2), HHLP (2), FTVTH (2), FINCX (2),
20168      &                EKPOLD (2), BBOLD, ZZOLD, SQROLD, ASEASQ,
20169      &                FSPRED, FEX0RD
20170 *
20171       BBOLD  = - 1.D+10
20172       ZZOLD  = - 1.D+10
20173       SQROLD = - 1.D+10
20174       APFRMX = PLABRC * ( ANINEN * PIPIPI / EIGEIG )**ONETHI / R0NUCL
20175       AMNUCL (1) = AMPROT
20176       AMNUCL (2) = AMNEUT
20177       AMNUSQ (1) = AMPROT * AMPROT
20178       AMNUSQ (2) = AMNEUT * AMNEUT
20179       AMNHLP = HLFHLF * ( AMNUCL (1) + AMNUCL (2) )
20180       ASQHLP = AMNHLP**2
20181 *     ASQHLP = HLFHLF * ( AMNUSQ (1) + AMNUSQ (2) )
20182       AEFRMX = SQRT ( ASQHLP + APFRMX**2 ) - AMNHLP
20183       AEFRMA = 0.3D+00 * APFRMX**2 / AMNHLP * ( ONEONE - APFRMX**2 /
20184      &         ( 5.6D+00 * ASQHLP ) )
20185       AV0WEL = AEFRMX + EBNDAV
20186       EBNDNG (1) = EBNDAV
20187       EBNDNG (2) = EBNDAV
20188       AEXC12 = EMVGEV * DT_ENERGY( 12.D+00, 6.D+00 )
20189       CEXC12 = EMVGEV * DT_ENRG( 12.D+00, 6.D+00 )
20190       AMMC12 = 12.D+00 * AMUGEV + AEXC12
20191       AMNC12 = AMMC12 - 6.D+00 * AMELCT + FERTHO * 6.D+00**EXPEBN
20192       AEXO16 = EMVGEV * DT_ENERGY( 16.D+00, 8.D+00 )
20193       CEXO16 = EMVGEV * DT_ENRG( 16.D+00, 8.D+00 )
20194       AMMO16 = 16.D+00 * AMUGEV + AEXO16
20195       AMNO16 = AMMO16 - 8.D+00 * AMELCT + FERTHO * 8.D+00**EXPEBN
20196       AEXS28 = EMVGEV * DT_ENERGY( 28.D+00, 14.D+00 )
20197       CEXS28 = EMVGEV * DT_ENRG( 28.D+00, 14.D+00 )
20198       AMMS28 = 28.D+00 * AMUGEV + AEXS28
20199       AMNS28 = AMMS28 - 14.D+00 * AMELCT + FERTHO * 14.D+00**EXPEBN
20200       AEXC40 = EMVGEV * DT_ENERGY( 40.D+00, 20.D+00 )
20201       CEXC40 = EMVGEV * DT_ENRG( 40.D+00, 20.D+00 )
20202       AMMC40 = 40.D+00 * AMUGEV + AEXC40
20203       AMNC40 = AMMC40 - 20.D+00 * AMELCT + FERTHO * 20.D+00**EXPEBN
20204       AEXF56 = EMVGEV * DT_ENERGY( 56.D+00, 26.D+00 )
20205       CEXF56 = EMVGEV * DT_ENRG( 56.D+00, 26.D+00 )
20206       AMMF56 = 56.D+00 * AMUGEV + AEXF56
20207       AMNF56 = AMMF56 - 26.D+00 * AMELCT + FERTHO * 26.D+00**EXPEBN
20208       AEX107 = EMVGEV * DT_ENERGY( 107.D+00, 47.D+00 )
20209       CEX107 = EMVGEV * DT_ENRG( 107.D+00, 47.D+00 )
20210       AMM107 = 107.D+00 * AMUGEV + AEX107
20211       AMN107 = AMM107 - 47.D+00 * AMELCT + FERTHO * 47.D+00**EXPEBN
20212       AEX132 = EMVGEV * DT_ENERGY( 132.D+00, 54.D+00 )
20213       CEX132 = EMVGEV * DT_ENRG( 132.D+00, 54.D+00 )
20214       AMM132 = 132.D+00 * AMUGEV + AEX132
20215       AMN132 = AMM132 - 54.D+00 * AMELCT + FERTHO * 54.D+00**EXPEBN
20216       AEX181 = EMVGEV * DT_ENERGY( 181.D+00, 73.D+00 )
20217       CEX181 = EMVGEV * DT_ENRG( 181.D+00, 73.D+00 )
20218       AMM181 = 181.D+00 * AMUGEV + AEX181
20219       AMN181 = AMM181 - 73.D+00 * AMELCT + FERTHO * 73.D+00**EXPEBN
20220       AEX208 = EMVGEV * DT_ENERGY( 208.D+00, 82.D+00 )
20221       CEX208 = EMVGEV * DT_ENRG( 208.D+00, 82.D+00 )
20222       AMM208 = 208.D+00 * AMUGEV + AEX208
20223       AMN208 = AMM208 - 82.D+00 * AMELCT + FERTHO * 82.D+00**EXPEBN
20224       AEX238 = EMVGEV * DT_ENERGY( 238.D+00, 92.D+00 )
20225       CEX238 = EMVGEV * DT_ENRG( 238.D+00, 92.D+00 )
20226       AMM238 = 238.D+00 * AMUGEV + AEX238
20227       AMN238 = AMM238 - 92.D+00 * AMELCT + FERTHO * 92.D+00**EXPEBN
20228
20229       AMHEAV (1) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ZERZER )
20230       AMHEAV (2) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ONEONE )
20231       AMHEAV (3) = TWOTWO * AMUGEV
20232      &             + EMVGEV * DT_ENERGY( TWOTWO, ONEONE )
20233       AMHEAV (4) = THRTHR * AMUGEV
20234      &             + EMVGEV * DT_ENERGY( THRTHR, ONEONE )
20235       AMHEAV (5) = THRTHR * AMUGEV
20236      &             + EMVGEV * DT_ENERGY( THRTHR, TWOTWO )
20237       AMHEAV (6) = FOUFOU * AMUGEV
20238      &             + EMVGEV * DT_ENERGY( FOUFOU, TWOTWO )
20239       ELBNDE (0) = ZERZER
20240       ELBNDE (1) = 13.6D-09
20241       DO 2000 IZ = 2, 100
20242          ELBNDE ( IZ ) = FERTHO * DBLE ( IZ )**EXPEBN
20243 2000  CONTINUE
20244       AMNHEA (1) = AMHEAV (1) + ELBNDE (0)
20245       AMNHEA (2) = AMHEAV (2) - AMELCT + ELBNDE (1)
20246       AMNHEA (3) = AMHEAV (3) - AMELCT + ELBNDE (1)
20247       AMNHEA (4) = AMHEAV (4) - AMELCT + ELBNDE (1)
20248       AMNHEA (5) = AMHEAV (5) - TWOTWO * AMELCT + ELBNDE (2)
20249       AMNHEA (6) = AMHEAV (6) - TWOTWO * AMELCT + ELBNDE (2)
20250       IF ( LEVPRT ) THEN
20251          WRITE ( LUNOUT, * )' **** Evaporation from residual nucleus',
20252      &                      ' activated **** '
20253          IF ( LDEEXG ) WRITE ( LUNOUT, * )' **** Deexcitation gamma',
20254      &                      ' production activated **** '
20255 **sr 18.5.95
20256 * commented, since obsolete
20257 C        IF ( LHEAVY ) WRITE ( LUNOUT, * )' **** Evaporated "heavies"',
20258 C    &                      ' transport activated **** '
20259          IF ( IFISS .GT. 0 )
20260      &                 WRITE ( LUNOUT, * )' **** High Energy fission ',
20261      &                      ' requested & activated **** '
20262          IF ( LFRMBK )
20263      &                 WRITE ( LUNOUT, * )' **** Fermi Break Up ',
20264      &                      ' requested & activated **** '
20265          IF ( LFRMBK ) CALL DT_FRBKIN(.FALSE.,.FALSE.)
20266       ELSE
20267          LDEEXG = .FALSE.
20268          LHEAVY = .FALSE.
20269          LFRMBK = .FALSE.
20270          IFISS  = 0
20271       END IF
20272       RETURN
20273 *=== End of subroutine incini =========================================*
20274       END
20275
20276 *$ CREATE DT_STALIN.FOR
20277 *COPY DT_STALIN
20278 *                                                                      *
20279 *=== stalin ===========================================================*
20280 *                                                                      *
20281       SUBROUTINE DT_STALIN
20282
20283       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20284       SAVE
20285       PARAMETER ( ANGLGB = 5.0D-16 )
20286       PARAMETER ( ZERZER = 0.D+00 )
20287       PARAMETER ( ONEONE = 1.D+00 )
20288       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20289       PARAMETER ( AMUGEV = 0.93149432         D+00 )
20290       PARAMETER ( EMVGEV = 1.0                D-03 )
20291       PARAMETER ( NSTBIS = 304  )
20292       PARAMETER ( LUNIN  = 5  )
20293       PARAMETER ( LUNOUT = 6  )
20294 *
20295 *----------------------------------------------------------------------*
20296 *                                                                      *
20297 *     STAbility LINe calculation:                                      *
20298 *                                                                      *
20299 *     Created on 04 december 1992  by    Alfredo Ferrari & Paola Sala  *
20300 *                                                   Infn - Milan       *
20301 *                                                                      *
20302 *     Last change on 04-dec-92     by    Alfredo Ferrari               *
20303 *                                                                      *
20304 *                                                                      *
20305 *----------------------------------------------------------------------*
20306 *
20307 * (original name: ISOTOP)
20308       PARAMETER ( NAMSMX = 270 )
20309       PARAMETER ( NZGVAX =  15 )
20310       PARAMETER ( NISMMX = 574 )
20311       COMMON /FKISOT/ WAPS   (NAMSMX,NZGVAX),  T12NUC (NAMSMX,NZGVAX),
20312      &                WAPISM (NISMMX), T12ISM (NISMMX),
20313      &                ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20314      &                AMSSST (100)  , ISOMNM (NSTBIS), ISONDX (2,100),
20315      &                JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20316      &                INWAPS (NAMSMX), JSPISM (NISMMX),
20317      &                JPTISM (NISMMX), IZWISM (NISMMX),
20318      &                INWISM (0:NAMSMX)
20319 *
20320       DIMENSION ZNORM (260)
20321 *  +-------------------------------------------------------------------*
20322 *  |
20323       DO 1000 IZ=1,100
20324          DO 500 J=1,2
20325             ASTLIN (J,IZ) = ZERZER
20326   500    CONTINUE
20327  1000 CONTINUE
20328 *  |
20329 *  +-------------------------------------------------------------------*
20330 *  +-------------------------------------------------------------------*
20331 *  |
20332       DO 2000 IA=1,260
20333          ZNORM (IA) = ZERZER
20334          DO 1500 J=1,2
20335             ZSTLIN (J,IA) = ZERZER
20336  1500    CONTINUE
20337  2000 CONTINUE
20338 *  |
20339 *  +-------------------------------------------------------------------*
20340 *  +-------------------------------------------------------------------*
20341 *  |  Loop on the Atomic Number
20342       DO 3000 IZ=1,100
20343          AMSSST (IZ) = ZERZER
20344          ANORM       = ONEONE
20345          ZTAR        = IZ
20346 *  |  +----------------------------------------------------------------*
20347 *  |  |    Loop on the stable isotopes
20348          DO 2500 IS = ISONDX (1,IZ), ISONDX (2,IZ)
20349             IA = ISOMNM (IS)
20350             ASTLIN (1,IZ) = ASTLIN (1,IZ) + ABUISO (IS) * IA
20351             ASTLIN (2,IZ) = ASTLIN (2,IZ) + ABUISO (IS) * IA**2
20352             ZNORM    (IA) = ZNORM (IA) + ABUISO (IS)
20353             ZSTLIN (1,IA) = ZSTLIN (1,IA) + ABUISO (IS) * IZ
20354             ZSTLIN (2,IA) = ZSTLIN (2,IA) + ABUISO (IS) * IZ**2
20355             AHELP  = IA
20356             IF ( AHELP .LE. 1.00001D+00 ) THEN
20357                ANORM = ONEONE / ( ONEONE - ABUISO (IS) )
20358                GO TO 2500
20359             END IF
20360             AMSSST (IZ) = ABUISO (IS) * ( AHELP * AMUGEV
20361      &                  + EMVGEV * DT_ENERGY(AHELP,ZTAR) ) + AMSSST (IZ)
20362  2500    CONTINUE
20363 *  |  |
20364 *  |  +----------------------------------------------------------------*
20365          AMSSST (IZ) = ANORM * AMSSST (IZ) / AMUGEV
20366 *  |  Normalize and print A_stab versus Z data:
20367          ASTLIN (2,IZ) = MAX ( SQRT (ASTLIN(2,IZ)-ASTLIN(1,IZ)**2),
20368      &                         0.5D+00 )
20369 *        WRITE (LUNOUT,*)'  Z:',IZ,' A_stab:',SNGL(ASTLIN(1,IZ)),
20370 *    &                   '  Sigma_st',SNGL(ASTLIN(2,IZ))
20371  3000 CONTINUE
20372 *  |
20373 *  +-------------------------------------------------------------------*
20374 *  +-------------------------------------------------------------------*
20375 *  |  Normalize and print Z_stab versus A data:
20376       DO 4000 IA=1,260
20377          ZSTLIN (1,IA) = ZSTLIN (1,IA) / MAX ( ZNORM (IA), 1.D-10 )
20378          ZSTLIN (2,IA) = ZSTLIN (2,IA) / MAX ( ZNORM (IA), 1.D-10 )
20379          ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ZSTLIN (1,IA)**2 )
20380          IF ( ZNORM (IA) .GT. ANGLGB )
20381 **sr 2.11. avoid underflows at Pentium
20382      &      ZSTLIN (2,IA) =
20383      &               MAX ( SQRT ( ABS(ZSTLIN(2,IA)-ZSTLIN(1,IA)**2) ),
20384 C    &      ZSTLIN (2,IA) = MAX ( SQRT (ZSTLIN(2,IA)-ZSTLIN(1,IA)**2),
20385      &                            0.3D+00 )
20386  4000 CONTINUE
20387 *  |
20388 *  +-------------------------------------------------------------------*
20389 *  +-------------------------------------------------------------------*
20390 *  |  Normalize and print Z_stab versus A data:
20391       DO 5000 IA=1,260
20392          IF ( ZNORM (IA) .LE. ANGLGB ) THEN
20393             DO 4200 JA = IA-1,1,-1
20394                IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20395                   IA1 = JA
20396                   GO TO 4300
20397                END IF
20398  4200       CONTINUE
20399  4300       CONTINUE
20400             DO 4400 JA = IA+1,260
20401                IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20402                   IA2 = JA
20403                   GO TO 4500
20404                END IF
20405  4400       CONTINUE
20406             IA2 = IA1
20407             IA1 = IA1 - 1
20408  4500       CONTINUE
20409             ZSTLIN (1,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20410      &                    * ( ZSTLIN (1,IA2) - ZSTLIN (1,IA1) )
20411      &                    + ZSTLIN (1,IA1)
20412             ZSTLIN (2,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20413      &                    * ( ZSTLIN (2,IA2) - ZSTLIN (2,IA1) )
20414      &                    + ZSTLIN (2,IA1)
20415          END IF
20416          IZ = MIN ( 100, NINT (ZSTLIN(1,IA)) )
20417          ATOZ = IZ / ASTLIN (1,IZ)
20418          ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ATOZ * ASTLIN (2,IZ) )
20419 *        WRITE (LUNOUT,*)'  A:',IA,' Z_stab:',SNGL(ZSTLIN(1,IA)),
20420 *    &                   '  Sigma_st',SNGL(ZSTLIN(2,IA))
20421  5000 CONTINUE
20422 *  |
20423 *  +-------------------------------------------------------------------*
20424       RETURN
20425       END
20426
20427 *$ CREATE DT_BERTTP.FOR
20428 *COPY DT_BERTTP
20429 *
20430 *=== berttp ===========================================================*
20431 *                                                                      *
20432       SUBROUTINE DT_BERTTP
20433
20434       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20435       SAVE
20436
20437       PARAMETER ( CSNNRM = 2.0D-15 )
20438       PARAMETER ( ZERZER = 0.D+00 )
20439       PARAMETER ( ONEONE = 1.D+00 )
20440       PARAMETER ( THRTHR = 3.D+00 )
20441       PARAMETER ( SIXSIX = 6.D+00 )
20442       PARAMETER ( ONETHI = ONEONE / THRTHR )
20443       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20444       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
20445       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
20446       PARAMETER ( EMVGEV = 1.0                D-03 )
20447
20448       PARAMETER ( NSTBIS = 304  )
20449
20450       PARAMETER ( LUNIN  = 5  )
20451       PARAMETER ( LUNOUT = 6  )
20452 **sr 19.5. set error output-unit from 15 to 6
20453       PARAMETER ( LUNERR = 6  )
20454 C---------------------------------------------------------------------
20455 C SUBNAME = DT_BERTTP --- READ BERTINI DATA
20456 C---------------------------------------------------------------------
20457 C     ---------------------------------- I-N-C DATA
20458 C     COMMON R8(2127),R4(64),CRSC(600,4),R8B(336),CS(29849)
20459 C     REAL*8 R8,R8B,CRSC,CS
20460 C     REAL*4 R4
20461 C     --------------------------------- EVAPORATION DATA
20462 * (original name: COOKCM)
20463       PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
20464       LOGICAL LDEFOZ, LDEFON
20465       PARAMETER ( INCOOK = 150, IZCOOK = 98 )
20466       COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
20467      &                SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
20468      &                PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
20469 * (original name: EVA0)
20470       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
20471      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
20472      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
20473      *                T (4,7), RMASS (297), ALPH (297), BET (297),
20474      *                APRIME (250), IA (6), IZ (6)
20475 * (original name: FRBKCM)
20476       PARAMETER ( MXFFBK =     6 )
20477       PARAMETER ( MXZFBK =     9 )
20478       PARAMETER ( MXNFBK =    10 )
20479       PARAMETER ( MXAFBK =    16 )
20480       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20481       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20482       PARAMETER ( NXAFBK = MXAFBK + 1 )
20483       PARAMETER ( MXPSST =   300 )
20484       PARAMETER ( MXPSFB = 41000 )
20485       LOGICAL LFRMBK, LNCMSS
20486       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20487      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20488      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20489      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
20490      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20491      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20492      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20493      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20494      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
20495 * (original name: HETTP)
20496       COMMON /FKHETP/  NHSTP,NBERTP,IOSUB,INSRS
20497 * (original name: INPFLG)
20498       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20499 * (original name: ISOTOP)
20500       PARAMETER ( NAMSMX = 270 )
20501       PARAMETER ( NZGVAX =  15 )
20502       PARAMETER ( NISMMX = 574 )
20503       COMMON /FKISOT/ WAPS   (NAMSMX,NZGVAX),  T12NUC (NAMSMX,NZGVAX),
20504      &                WAPISM (NISMMX), T12ISM (NISMMX),
20505      &                ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20506      &                AMSSST (100)  , ISOMNM (NSTBIS), ISONDX (2,100),
20507      &                JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20508      &                INWAPS (NAMSMX), JSPISM (NISMMX),
20509      &                JPTISM (NISMMX), IZWISM (NISMMX),
20510      &                INWISM (0:NAMSMX)
20511 * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
20512       PARAMETER ( PI     = PIPIPI )
20513       PARAMETER ( PISQ   = PIPISQ )
20514       PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
20515       PARAMETER ( RZNUCL = 1.12        D+00 )
20516       PARAMETER ( RMSPRO = 0.8         D+00 )
20517       PARAMETER ( R0PROT = RMSPRO / SQRT12  )
20518       PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
20519      &          / R0PROT )
20520       PARAMETER ( RLLE04 = RZNUCL )
20521       PARAMETER ( RLLE16 = RZNUCL )
20522       PARAMETER ( RLGT16 = RZNUCL )
20523       PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
20524       PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
20525       PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
20526       PARAMETER ( SKLE04 = 1.4D+00 )
20527       PARAMETER ( SKLE16 = 1.9D+00 )
20528       PARAMETER ( SKGT16 = 2.4D+00 )
20529       PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
20530       PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
20531       PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
20532       PARAMETER ( ALPHA0 = 0.1D+00 )
20533       PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
20534       PARAMETER ( GAMSK0 = 0.9D+00 )
20535       PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
20536       PARAMETER ( POTME0 = 0.6666666666666667D+00 )
20537       PARAMETER ( POTBA0 = 1.D+00 )
20538       PARAMETER ( PNFRAT = 1.533D+00 )
20539       PARAMETER ( RADPIM = 0.035D+00 )
20540       PARAMETER ( RDPMHL = 14.D+00   )
20541       PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
20542       PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
20543       PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
20544       PARAMETER ( AP0PFS = 0.5D+00 )
20545       PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
20546       PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
20547       PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
20548       PARAMETER ( MXSCIN = 50     )
20549       LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
20550      &        LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
20551       COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
20552      &                RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
20553      &                SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
20554      &                CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
20555      &                PFRTAB (2:260)
20556       COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
20557      &                ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
20558      &                RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
20559      &                YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
20560      &                RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
20561      &                PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
20562      &                PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
20563      &                BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
20564      &                YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
20565      &                XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
20566      &                SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
20567      &                R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
20568      &                PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
20569      &                EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
20570      &                PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
20571      &                EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
20572      &                PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
20573      &                BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
20574       COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
20575      &                RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
20576      &                EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
20577      &                BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
20578      &                WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
20579      &                POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
20580      &                BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
20581      &                SIGPAB (3), SIGNAB (3), HHLP   (2), FORTOT (2),
20582      &                FPNBLC, DPNBLC, FFTFLG, IFTFLG,
20583      &                IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
20584      &                KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
20585      &                NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
20586      &                IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
20587      &                LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
20588       COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
20589       COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
20590      &                YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
20591      &                AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
20592      &                NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
20593      &                NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
20594      &                ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
20595      &                LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
20596      &                LNCDCY, LNUSCT
20597       DIMENSION AWSTAB (2:260), SIGMAB (3)
20598       EQUIVALENCE ( DEFPRO, DEFNUC (1) )
20599       EQUIVALENCE ( DEFNEU, DEFNUC (2) )
20600       EQUIVALENCE ( RHOIPP, RHONCP (1) )
20601       EQUIVALENCE ( RHOINP, RHONCP (2) )
20602       EQUIVALENCE ( RHOIP2, RHONC2 (1) )
20603       EQUIVALENCE ( RHOIN2, RHONC2 (2) )
20604       EQUIVALENCE ( RHOIP3, RHONC3 (1) )
20605       EQUIVALENCE ( RHOIN3, RHONC3 (2) )
20606       EQUIVALENCE ( RHOIPT, RHONCT (1) )
20607       EQUIVALENCE ( RHOINT, RHONCT (2) )
20608       EQUIVALENCE ( OMALHL, SK3PAR )
20609       EQUIVALENCE ( ALPHAL, HABPAR )
20610       EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
20611       EQUIVALENCE ( SIGMPE, SIGMPR (1) )
20612       EQUIVALENCE ( SIGMPC, SIGMPR (2) )
20613       EQUIVALENCE ( SIGMPI, SIGMPR (3) )
20614       EQUIVALENCE ( SIGMPA, SIGMPR (4) )
20615       EQUIVALENCE ( SIGMNE, SIGMNU (1) )
20616       EQUIVALENCE ( SIGMNC, SIGMNU (2) )
20617       EQUIVALENCE ( SIGMNI, SIGMNU (3) )
20618       EQUIVALENCE ( SIGMNA, SIGMNU (4) )
20619       EQUIVALENCE ( SIGMA2, SIGPAB (1) )
20620       EQUIVALENCE ( SIGMA3, SIGPAB (2) )
20621       EQUIVALENCE ( SIGMAS, SIGPAB (3) )
20622       EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
20623 * (original name: NUCLEV)
20624       LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
20625       COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
20626      &                DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
20627      &                CUMRAD (0:160,2), RUSNUC (2),
20628      &                ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
20629      &                NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
20630      &                NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
20631      &                JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
20632      &                MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
20633      &                NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
20634      &                LFLVSL, LRLVSL, LEQSBL
20635       DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
20636      &          MGSSPR (19) , MGSSNE (25)
20637       EQUIVALENCE ( RUSNUC (1), RUSPRO )
20638       EQUIVALENCE ( RUSNUC (2), RUSNEU )
20639       EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
20640       EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
20641       EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
20642       EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
20643       EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
20644       EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
20645       EQUIVALENCE ( NTANUC (1), NTAPRO )
20646       EQUIVALENCE ( NTANUC (2), NTANEU )
20647       EQUIVALENCE ( NAVNUC (1), NAVPRO )
20648       EQUIVALENCE ( NAVNUC (2), NAVNEU )
20649       EQUIVALENCE ( NLSNUC (1), NLSPRO )
20650       EQUIVALENCE ( NLSNUC (2), NLSNEU )
20651       EQUIVALENCE ( NCONUC (1), NCOPRO )
20652       EQUIVALENCE ( NCONUC (2), NCONEU )
20653       EQUIVALENCE ( NSKNUC (1), NSKPRO )
20654       EQUIVALENCE ( NSKNUC (2), NSKNEU )
20655       EQUIVALENCE ( NHANUC (1), NHAPRO )
20656       EQUIVALENCE ( NHANUC (2), NHANEU )
20657       EQUIVALENCE ( NUSNUC (1), NUSPRO )
20658       EQUIVALENCE ( NUSNUC (2), NUSNEU )
20659       EQUIVALENCE ( NACNUC (1), NACPRO )
20660       EQUIVALENCE ( NACNUC (2), NACNEU )
20661       EQUIVALENCE ( JMXNUC (1), JMXPRO )
20662       EQUIVALENCE ( JMXNUC (2), JMXNEU )
20663       EQUIVALENCE ( MAGNUC (1), MAGPRO )
20664       EQUIVALENCE ( MAGNUC (2), MAGNEU )
20665 * (original name: PAREVT)
20666       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20667      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20668       PARAMETER ( NALLWP = 39   )
20669       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20670      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20671      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20672      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20673 * (original name: XSEPAR)
20674       COMMON /FKXSEP/ AANXSE (100), BBNXSE (100), CCNXSE (100),
20675      &                DDNXSE (100), EENXSE (100), ZZNXSE (100),
20676      &                EMNXSE (100), XMNXSE (100),
20677      &                AAPXSE (100), BBPXSE (100), CCPXSE (100),
20678      &                DDPXSE (100), EEPXSE (100), FFPXSE (100),
20679      &                ZZPXSE (100), EMPXSE (100), XMPXSE (100)
20680
20681 C---------------------------------------------------------------------
20682 **sr 17.5.95
20683 * modified for use in DPMJET
20684 C     WRITE( LUNOUT,'(A,I2)')
20685 C    & ' *** Reading evaporation and nuclear data from unit: ', NBERTP
20686 C     REWIND NBERTP
20687       IF (LEVPRT) WRITE(LUNOUT,1000)
20688  1000 FORMAT(/,1X,'BERTTP:',4X,'Initialization of evaporation module',
20689      &       /,12X,'------------------------------------',/)
20690       NBERNW = 23
20691 CPH      OPEN (UNIT=NBERNW,FILE='dpmjet.dat',STATUS='UNKNOWN')
20692
20693 **sr 17.5.
20694 *!!!! changed to be able to read the ASCII !!!!
20695 **
20696 C A. Ferrari: first of all read isotopic data
20697       READ (NBERNW,*) ISONDX
20698       READ (NBERNW,*) ISOMNM
20699       READ (NBERNW,*) ABUISO
20700 C     READ (NBERTP) ISONDX
20701 C     READ (NBERTP) ISOMNM
20702 C     READ (NBERTP) ABUISO
20703       DO 1 I=1,4
20704 C        READ  (NBERTP) (CRSC(J,I),J=1,600)
20705 C A. Ferrari: commented also the dummy read to save disk space
20706 C        READ  (NBERTP)
20707     1 CONTINUE
20708 C     READ  (NBERTP) CS
20709 C A. Ferrari: commented also the dummy read to save disk space
20710 C     READ  (NBERTP)
20711 C---------------------------------------------------------------------
20712       READ (NBERNW,*) (P0(I),P1(I),P2(I),I=1,1001)
20713       READ (NBERNW,*) IA,IZ
20714       DO 2 I=1,6
20715          FLA(I)=IA(I)
20716          FLZ(I)=IZ(I)
20717     2 CONTINUE
20718       READ (NBERNW,*) RHO,OMEGA
20719       READ (NBERNW,*) EXMASS
20720       READ (NBERNW,*) CAM2
20721       READ (NBERNW,*) CAM3
20722       READ (NBERNW,*) CAM4
20723       READ (NBERNW,*) CAM5
20724       READ (NBERNW,*) ((T(I,J),J=1,7),I=1,3)
20725       DO 3 I=1,7
20726          T(4,I) = ZERZER
20727     3 CONTINUE
20728       READ (NBERNW,*) RMASS
20729       READ (NBERNW,*) ALPH
20730       READ (NBERNW,*) BET
20731       READ (NBERNW,*) INWAPS
20732       READ (NBERNW,*) WAPS
20733       READ (NBERNW,*) T12NUC
20734       READ (NBERNW,*) JSPNUC
20735       READ (NBERNW,*) JPTNUC
20736       READ (NBERNW,*) INWISM
20737       READ (NBERNW,*) IZWISM
20738       READ (NBERNW,*) WAPISM
20739       READ (NBERNW,*) T12ISM
20740       READ (NBERNW,*) JSPISM
20741       READ (NBERNW,*) JPTISM
20742       READ (NBERNW,*) APRIME
20743       IF (LEVPRT)
20744      &WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20745       READ (NBERNW,*) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20746       IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20747      &     ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20748          WRITE (LUNOUT,*)
20749      &         ' *** Inconsistent Nuclear Geometry data on file ***'
20750          STOP
20751       END IF
20752       READ (NBERNW,*) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20753      &              EKATAB, PFATAB, PFRTAB
20754       READ (NBERNW,*) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20755      &              EMNXSE, XMNXSE
20756       READ (NBERNW,*) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20757      &              ZZPXSE, EMPXSE, XMPXSE
20758 *  Data about Fermi-breakup:
20759       READ (NBERNW,*) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20760       IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20761      &     MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20762          WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20763      &                   ' in the Nuclear Data file ***'
20764          STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20765       END IF
20766       READ (NBERNW,*) IFRBKN
20767       READ (NBERNW,*) IFRBKZ
20768       READ (NBERNW,*) IFBKSP
20769       READ (NBERNW,*) IFBKST
20770       READ (NBERNW,*) EEXFBK
20771
20772       CLOSE (UNIT=NBERNW)
20773
20774 C     READ (NBERTP) (P0(I),P1(I),P2(I),I=1,1001)
20775 C     READ (NBERTP) IA,IZ
20776 C     DO 2 I=1,6
20777 C        FLA(I)=IA(I)
20778 C        FLZ(I)=IZ(I)
20779 C   2 CONTINUE
20780 C     READ (NBERTP) RHO,OMEGA
20781 C     READ (NBERTP) EXMASS
20782 C     READ (NBERTP) CAM2
20783 C     READ (NBERTP) CAM3
20784 C     READ (NBERTP) CAM4
20785 C     READ (NBERTP) CAM5
20786 C     READ (NBERTP) ((T(I,J),J=1,7),I=1,3)
20787 C     DO 3 I=1,7
20788 C        T(4,I) = ZERZER
20789 C   3 CONTINUE
20790 C     READ (NBERTP) RMASS
20791 C     READ (NBERTP) ALPH
20792 C     READ (NBERTP) BET
20793 C     READ (NBERTP) INWAPS
20794 C     READ (NBERTP) WAPS
20795 C     READ (NBERTP) T12NUC
20796 C     READ (NBERTP) JSPNUC
20797 C     READ (NBERTP) JPTNUC
20798 C     READ (NBERTP) INWISM
20799 C     READ (NBERTP) IZWISM
20800 C     READ (NBERTP) WAPISM
20801 C     READ (NBERTP) T12ISM
20802 C     READ (NBERTP) JSPISM
20803 C     READ (NBERTP) JPTISM
20804 C     READ (NBERTP) APRIME
20805 C     WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20806 C     READ (NBERTP) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20807 C     IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20808 C    &     ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20809 C        WRITE (LUNOUT,*)
20810 C    &         ' *** Inconsistent Nuclear Geometry data on file ***'
20811 C        STOP
20812 C     END IF
20813 C     READ (NBERTP) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20814 C    &              EKATAB, PFATAB, PFRTAB
20815 C     READ (NBERTP) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20816 C    &              EMNXSE, XMNXSE
20817 C     READ (NBERTP) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20818 C    &              ZZPXSE, EMPXSE, XMPXSE
20819 *  Data about Fermi-breakup:
20820 C     READ (NBERTP) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20821 C     IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20822 C    &     MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20823 C        WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20824 C    &                   ' in the Nuclear Data file ***'
20825 C        STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20826 C     END IF
20827 C     READ (NBERTP) IFRBKN
20828 C     READ (NBERTP) IFRBKZ
20829 C     READ (NBERTP) IFBKSP
20830 C     READ (NBERTP) IFBKST
20831 C     READ (NBERTP) EEXFBK
20832 C     CLOSE (UNIT=NBERTP)
20833       DO 100 JZ = 1, 130
20834          SHENUC ( JZ, 1 ) = EMVGEV * ( CAM2 (JZ) + CAM4 (JZ) )
20835   100 CONTINUE
20836       DO 200 JA = 1, 200
20837          SHENUC ( JA, 2 ) = EMVGEV * ( CAM3 (JA) + CAM5 (JA) )
20838   200 CONTINUE
20839       CALL DT_STALIN
20840       IF ( ILVMOD .LE. 0 ) THEN
20841          ILVMOD = IB0
20842       ELSE
20843          IB0 = ILVMOD
20844       END IF
20845       IF ( LLVMOD ) THEN
20846          DO 300 JZ = 1, IZCOOK
20847             CAM4 (JZ) = PZCOOK (JZ)
20848   300    CONTINUE
20849          DO 400 JN = 1, INCOOK
20850             CAM5 (JN) = PNCOOK (JZ)
20851   400    CONTINUE
20852       END IF
20853 **sr
20854       IF (LEVPRT) THEN
20855          WRITE (LUNOUT,*)
20856          IF ( ILVMOD .EQ. 1 ) THEN
20857             WRITE (LUNOUT,*)
20858      &   ' **** Standard EVAP T=0 level density used ****'
20859          ELSE IF ( ILVMOD .EQ. 2 ) THEN
20860             WRITE (LUNOUT,*)
20861      &   ' **** Gilbert & Cameron T=0 N,Z-dep. level density used ****'
20862          ELSE IF ( ILVMOD .EQ. 3 ) THEN
20863             WRITE (LUNOUT,*)
20864      &      ' **** Julich A-dependent level density used ****'
20865          ELSE IF ( ILVMOD .EQ. 4 ) THEN
20866             WRITE (LUNOUT,*)
20867      &   ' **** Brancazio & Cameron T=0 N,Z-dep. level density used',
20868      &                                                          ' ****'
20869          ELSE
20870             WRITE (LUNOUT,*)
20871      &   ' **** Unknown T=0 level density option requested ****'
20872             STOP 'BERTTP-ILVMOD'
20873          END IF
20874          IF ( JLVMOD .LE. 0 ) THEN
20875             GAMIGN = ZERZER
20876             WRITE (LUNOUT,*)
20877      &   ' **** No Excitation en. dependence for level densities ****'
20878          ELSE IF ( JLVMOD .EQ. 1 ) THEN
20879             WRITE (LUNOUT,*)
20880      &   ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20881             WRITE (LUNOUT,*)
20882      &   ' **** with Ignyatuk (1975, 1st) set of parameters for T=oo',
20883      &                                                        ' ****'
20884             GAMIGN = 0.054D+00
20885             BETIGN = -6.3 D-05
20886             ALPIGN = 0.154D+00
20887             POWIGN = ZERZER
20888          ELSE IF ( JLVMOD .EQ. 2 ) THEN
20889             WRITE (LUNOUT,*)
20890      &   ' ****   Ignyatuk (1975, 1st) level density en. dep. used ****'
20891             WRITE (LUNOUT,*)
20892      &   ' **** with UNKNOWN set of parameters for T=oo ****'
20893             STOP 'BERTTP-JLVMOD'
20894          ELSE IF ( JLVMOD .EQ. 3 ) THEN
20895             WRITE (LUNOUT,*)
20896      &   ' ****   Ignyatuk (1975, 1st) level density en. dep. used ****'
20897             WRITE (LUNOUT,*)
20898      &   ' **** with UNKNOWN set of parameters for T=oo ****'
20899             STOP 'BERTTP-JLVMOD'
20900          ELSE IF ( JLVMOD .EQ. 4 ) THEN
20901             WRITE (LUNOUT,*)
20902      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20903             WRITE (LUNOUT,*)
20904      &   ' **** with Ignyatuk (1975, 2nd) set of parameters for T=oo',
20905      &                                                        ' ****'
20906             GAMIGN = 0.054D+00
20907             BETIGN = 0.162D+00
20908             ALPIGN = 0.114D+00
20909             POWIGN = -ONETHI
20910          ELSE IF ( JLVMOD .EQ. 5 ) THEN
20911             WRITE (LUNOUT,*)
20912      &   ' ****  Ignyatuk (1975, 2nd) level density en. dep. used  ****'
20913             WRITE (LUNOUT,*)
20914      &   ' **** with Iljinov & Mebel 1st set of parameters for T=oo****'
20915             GAMIGN = 0.051D+00
20916             BETIGN = 0.098D+00
20917             ALPIGN = 0.114D+00
20918             POWIGN = -ONETHI
20919          ELSE IF ( JLVMOD .EQ. 6 ) THEN
20920             WRITE (LUNOUT,*)
20921      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20922             WRITE (LUNOUT,*)
20923      &   ' **** with Iljinov & Mebel 2nd set of parameters for T=oo****'
20924             GAMIGN = -0.46D+00
20925             BETIGN = 0.107D+00
20926             ALPIGN = 0.111D+00
20927             POWIGN = -ONETHI
20928          ELSE IF ( JLVMOD .EQ. 7 ) THEN
20929             WRITE (LUNOUT,*)
20930      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20931             WRITE (LUNOUT,*)
20932      &   ' **** with Iljinov & Mebel 3rd set of parameters for T=oo****'
20933             GAMIGN = 0.059D+00
20934             BETIGN = 0.257D+00
20935             ALPIGN = 0.072D+00
20936             POWIGN = -ONETHI
20937          ELSE IF ( JLVMOD .EQ. 8 ) THEN
20938             WRITE (LUNOUT,*)
20939      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20940             WRITE (LUNOUT,*)
20941      &   ' **** with Iljinov & Mebel 4th set of parameters for T=oo****'
20942             GAMIGN = -0.37D+00
20943             BETIGN = 0.229D+00
20944             ALPIGN = 0.077D+00
20945             POWIGN = -ONETHI
20946          ELSE
20947             WRITE (LUNOUT,*)
20948      &   ' **** Unknown T=oo level density option requested ****'
20949             STOP 'BERTTP-JLVMOD'
20950          END IF
20951          IF ( LLVMOD ) THEN
20952             WRITE (LUNOUT,*)
20953      &      ' **** Cook''s modified pairing energy used ****'
20954          ELSE
20955             WRITE (LUNOUT,*)
20956      &      ' **** Original Gilbert/Cameron pairing energy used ****'
20957          END IF
20958       ENDIF
20959 **
20960
20961       ILVMOD = IB0
20962       DO 500 JZ = 1, 130
20963          PAENUC ( JZ, 1 ) = EMVGEV * CAM4 (JZ)
20964   500 CONTINUE
20965       DO 600 JA = 1, 200
20966          PAENUC ( JA, 2 ) = EMVGEV * CAM5 (JA)
20967   600 CONTINUE
20968       RETURN
20969       END
20970
20971 *$ CREATE DT_EVEVAP.FOR
20972 *COPY DT_EVEVAP
20973 *
20974 *====evevap============================================================*
20975 *
20976       SUBROUTINE DT_EVEVAP(WE)
20977
20978       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20979       SAVE
20980       PARAMETER ( LINP = 10 ,
20981      &            LOUT = 6 ,
20982      &            LDAT = 9 )
20983
20984 * flags for input different options
20985       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
20986       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
20987      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
20988
20989       LEVAPO = .FALSE.
20990
20991       RETURN
20992       END
20993
20994 *$ CREATE DT_FRBKIN.FOR
20995 *COPY DT_FRBKIN
20996 *
20997 *====frbkin============================================================*
20998 *
20999       SUBROUTINE DT_FRBKIN(LDUM1,LDUM2)
21000
21001       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21002       SAVE
21003       PARAMETER ( LINP = 10 ,
21004      &            LOUT = 6 ,
21005      &            LDAT = 9 )
21006
21007       LOGICAL LDUM1,LDUM2
21008
21009       RETURN
21010       END
21011
21012 *$ CREATE DT_EXPLOD.FOR
21013 *COPY DT_EXPLOD
21014 *
21015 *=== explod ===========================================================*
21016 *
21017       SUBROUTINE DT_EXPLOD( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
21018      &                    PYEXPL, PZEXPL )
21019
21020       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21021       SAVE
21022
21023       DIMENSION PXEXPL (NPEXPL), PYEXPL (NPEXPL), PZEXPL (NPEXPL),
21024      &          ETEXPL (NPEXPL), AMEXPL (NPEXPL)
21025
21026       RETURN
21027       END
21028
21029 ************************************************************************
21030 *                                                                      *
21031 *  DPMJET 3.0:   cross section routines                                *
21032 *                                                                      *
21033 ************************************************************************
21034 *
21035 *
21036 *     SUBROUTINE DT_SHNDIF
21037 *         diffractive cross sections (all energies)
21038 *     SUBROUTINE DT_PHOXS
21039 *         total and inel. cross sections from PHOJET interpol. tables
21040 *     SUBROUTINE DT_XSHN
21041 *         total and el. cross sections for all energies
21042 *     SUBROUTINE DT_SIHNAB
21043 *         pion 2-nucleon absorption cross sections
21044 *     SUBROUTINE DT_SIGEMU
21045 *         cross section for target "compounds"
21046 *     SUBROUTINE DT_SIGGA
21047 *         photon nucleus cross sections
21048 *     SUBROUTINE DT_SIGGAT
21049 *         photon nucleus cross sections from tables
21050 *     SUBROUTINE DT_SANO
21051 *         anomalous hard photon-nucleon cross sections from tables
21052 *     SUBROUTINE DT_SIGGP
21053 *         photon nucleon cross sections
21054 *     SUBROUTINE DT_SIGVEL
21055 *         quasi-elastic vector meson prod. cross sections
21056 *     DOUBLE PRECISION FUNCTION DT_SIGVP
21057 *         sigma_VN(tilde)
21058 *     DOUBLE PRECISION FUNCTION DT_RRM2
21059 *     DOUBLE PRECISION FUNCTION DT_RM2
21060 *     DOUBLE PRECISION FUNCTION DT_SAM2
21061 *     SUBROUTINE DT_CKMT
21062 *     SUBROUTINE DT_CKMTX
21063 *     SUBROUTINE DT_PDF0
21064 *     SUBROUTINE DT_CKMTQ0
21065 *     SUBROUTINE DT_CKMTDE
21066 *     SUBROUTINE DT_CKMTPR
21067 *     FUNCTION DT_CKMTFF
21068 *
21069 *     SUBROUTINE DT_FLUINI
21070 *         total nucleon cross section fluctuation treatment
21071 *
21072 *     SUBROUTINE DT_SIGTBL
21073 *         pre-tabulation of low-energy elastic x-sec. using SIHNEL
21074 *     SUBROUTINE DT_XSTABL
21075 *         service routines
21076 *
21077 *
21078 *$ CREATE DT_SHNDIF.FOR
21079 *COPY DT_SHNDIF
21080 *
21081 *===shndif===============================================================*
21082 *
21083       SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
21084
21085 **********************************************************************
21086 *   Single diffractive hadron-nucleon cross sections                 *
21087 *                                              S.Roesler 14/1/93     *
21088 *                                                                    *
21089 *   The cross sections are calculated from extrapolated single       *
21090 *   diffractive antiproton-proton cross sections (DTUJET92) using    *
21091 *   scaling relations between total and single diffractive cross     *
21092 *   sections.                                                        *
21093 **********************************************************************
21094
21095       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21096       SAVE
21097       PARAMETER (ZERO=0.0D0)
21098
21099 * particle properties (BAMJET index convention)
21100       CHARACTER*8  ANAME
21101       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21102      &                IICH(210),IIBAR(210),K1(210),K2(210)
21103 *
21104       CSD1   =   4.201483727D0
21105       CSD4   = -0.4763103556D-02
21106       CSD5   =  0.4324148297D0
21107 *
21108       CHMSD1 =  0.8519297242D0
21109       CHMSD4 = -0.1443076599D-01
21110       CHMSD5 =  0.4014954567D0
21111 *
21112       EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
21113       PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
21114 *
21115       SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21116       SHMSD  = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
21117       FRAC   = SHMSD/SDIAPP
21118 *
21119       GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
21120      &     999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
21121      &      10, 10, 20, 20, 20) KPROJ
21122 *
21123    10 CONTINUE
21124 *---------------------------- p - p , n - p , sigma0+- - p ,
21125 *                             Lambda - p
21126       CSD1   =  6.004476070D0
21127       CSD4   = -0.1257784606D-03
21128       CSD5   =  0.2447335720D0
21129       SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21130       SIGDIH = FRAC*SIGDIF
21131       RETURN
21132 *
21133    20 CONTINUE
21134 *
21135       KPSCAL = 2
21136       KTSCAL = 1
21137 C     F      = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
21138       DUMZER = ZERO
21139       CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
21140       F      = SDIAPP/SIGTO
21141       KT     = 1
21142 C     SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
21143       CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
21144       SIGDIF = SIGTO*F
21145       SIGDIH = FRAC*SIGDIF
21146       RETURN
21147 *
21148   999 CONTINUE
21149 *-------------------------- leptons..
21150       SIGDIF = 1.D-10
21151       SIGDIH = 1.D-10
21152       RETURN
21153       END
21154
21155 *$ CREATE DT_PHOXS.FOR
21156 *COPY DT_PHOXS
21157 *
21158 *===phoxs================================================================*
21159 *
21160       SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
21161
21162 ************************************************************************
21163 * Total/inelastic proton-nucleon cross sections taken from PHOJET-     *
21164 * interpolation tables.                                                *
21165 * This version dated 05.11.97 is written by S. Roesler                 *
21166 ************************************************************************
21167
21168       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21169       SAVE
21170
21171       PARAMETER ( LINP = 10 ,
21172      &            LOUT = 6 ,
21173      &            LDAT = 9 )
21174       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21175       PARAMETER (TWOPI  = 6.283185307179586454D+00,
21176      &           PI     = TWOPI/TWO,
21177      &           GEV2MB = 0.38938D0)
21178
21179       LOGICAL LFIRST
21180       DATA LFIRST /.TRUE./
21181
21182 * nucleon-nucleon event-generator
21183       CHARACTER*8 CMODEL
21184       LOGICAL LPHOIN
21185       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21186 * particle properties (BAMJET index convention)
21187       CHARACTER*8  ANAME
21188       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21189      &                IICH(210),IIBAR(210),K1(210),K2(210)
21190
21191 **PHOJET105a
21192 C     PARAMETER (IEETAB=10)
21193 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21194 **PHOJET110
21195 C  energy-interpolation table
21196       INTEGER IEETA2
21197       PARAMETER ( IEETA2 = 20 )
21198       INTEGER ISIMAX
21199       DOUBLE PRECISION SIGTAB,SIGECM
21200       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21201 **
21202
21203       IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
21204          WRITE(LOUT,*) MCGENE
21205  1000    FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
21206          STOP
21207       ENDIF
21208
21209       IF (ECM.LE.ZERO) THEN
21210          EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
21211          ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
21212       ENDIF
21213
21214       IF (MODE.EQ.1) THEN
21215 * DL
21216          DELDL = 0.0808D0
21217          EPSDL = -0.4525D0
21218          S     = ECM*ECM
21219          STOT  = 21.7D0*S**DELDL+56.08D0*S**EPSDL
21220          ALPHAP= 0.25D0
21221          BEL   = 8.5D0+2.D0*ALPHAP*LOG(S)
21222          SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
21223          SINE  = STOT-SIGEL
21224          SDIF1 = ZERO
21225       ELSE
21226 * Phojet
21227          IP = 1
21228          IF(ECM.LE.SIGECM(IP,1)) THEN
21229            I1 = 1
21230            I2 = 1
21231          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21232            DO 1 I=2,ISIMAX
21233               IF (ECM.LE.SIGECM(IP,I)) GOTO 2
21234     1      CONTINUE
21235     2      CONTINUE
21236            I1 = I-1
21237            I2 = I
21238          ELSE
21239            IF (LFIRST) THEN
21240               WRITE(LOUT,'(/1X,A,2E12.3)')
21241      &          'PHOXS: warning! energy above initialization limit (',
21242      &          ECM,SIGECM(IP,ISIMAX)
21243              LFIRST = .FALSE.
21244            ENDIF
21245            I1 = ISIMAX
21246            I2 = ISIMAX
21247          ENDIF
21248          FAC2 = ZERO
21249          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21250      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21251          FAC1  = ONE-FAC2
21252          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21253          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21254          SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
21255      &           FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
21256          BEL   = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
21257       ENDIF
21258
21259       RETURN
21260       END
21261
21262 *$ CREATE DT_XSHN.FOR
21263 *COPY DT_XSHN
21264 *
21265 *===xshn===============================================================*
21266 *
21267       SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
21268
21269 ************************************************************************
21270 * Total and elastic hadron-nucleon cross section.                      *
21271 * Below 500GeV cross sections are based on the '98 data compilation    *
21272 * of the PDG. At higher energies PHOJET results are used (patched to   *
21273 * the low energy data at 500GeV).                                      *
21274 *     IP      projectile index (BAMJET numbering scheme)               *
21275 *             (should be in the range 1..25)                           *
21276 *     IT      target index (BAMJET numbering scheme)                   *
21277 *             (1 = proton, 8 = neutron)                                *
21278 *     PL      laboratory momentum                                      *
21279 *     ECM     cm. energy (ignored if PL>0)                             *
21280 *     STOT    total cross section                                      *
21281 *     SELA    elastic cross section                                    *
21282 * Last change: 24.4.99 by S. Roesler                                   *
21283 ************************************************************************
21284
21285       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21286       SAVE
21287
21288       PARAMETER ( LINP = 10 ,
21289      &            LOUT = 6 ,
21290      &            LDAT = 9 )
21291       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
21292
21293       PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
21294      &           PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
21295       PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
21296
21297       LOGICAL LFIRST
21298 * particle properties (BAMJET index convention)
21299       CHARACTER*8  ANAME
21300       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21301      &                IICH(210),IIBAR(210),K1(210),K2(210)
21302 * nucleon-nucleon event-generator
21303       CHARACTER*8 CMODEL
21304       LOGICAL LPHOIN
21305       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21306 **PHOJET105a
21307 C     PARAMETER (IEETAB=10)
21308 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21309 **PHOJET110
21310 C  energy-interpolation table
21311       INTEGER IEETA2
21312       PARAMETER ( IEETA2 = 20 )
21313       INTEGER ISIMAX
21314       DOUBLE PRECISION SIGTAB,SIGECM
21315       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21316
21317       DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
21318       DIMENSION IDXDAT(25,2)
21319 *
21320       DATA APL /
21321      &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
21322      &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
21323      &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
21324      &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
21325      & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
21326      & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
21327      & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
21328 *
21329 * total cross sections:
21330 * p p
21331       DATA (ASIGTO(1,K),K=1,NPOINT) /
21332      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21333      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21334      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
21335      & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
21336      & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
21337      & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
21338      & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
21339 * pbar p
21340       DATA (ASIGTO(2,K),K=1,NPOINT) /
21341      & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
21342      & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
21343      & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
21344      & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
21345      & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
21346      & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
21347      & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
21348 * n p
21349       DATA (ASIGTO(3,K),K=1,NPOINT) /
21350      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21351      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21352      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21353      & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
21354      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21355      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21356      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21357 * pi+ p
21358       DATA (ASIGTO(4,K),K=1,NPOINT) /
21359      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21360      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21361      & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
21362      & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
21363      & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
21364      & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
21365      & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
21366 * pi- p
21367       DATA (ASIGTO(5,K),K=1,NPOINT) /
21368      & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
21369      & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
21370      & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
21371      & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
21372      & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
21373      & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
21374      & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
21375 * K+ p
21376       DATA (ASIGTO(6,K),K=1,NPOINT) /
21377      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21378      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21379      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
21380      & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
21381      & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
21382      & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
21383      & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
21384 * K- p
21385       DATA (ASIGTO(7,K),K=1,NPOINT) /
21386      & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
21387      & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
21388      & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
21389      & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
21390      & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
21391      & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
21392      & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21393 * K+ n
21394       DATA (ASIGTO(8,K),K=1,NPOINT) /
21395      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21396      & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21397      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21398      & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21399      & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21400      & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21401      & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21402 * K- n
21403       DATA (ASIGTO(9,K),K=1,NPOINT) /
21404      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21405      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21406      & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21407      & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21408      & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21409      & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21410      & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21411 * Lambda p
21412       DATA (ASIGTO(10,K),K=1,NPOINT) /
21413      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21414      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21415      & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21416      & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21417      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21418      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21419      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21420 *
21421 * elastic cross sections:
21422 * p p
21423       DATA (ASIGEL(1,K),K=1,NPOINT) /
21424      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21425      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21426      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21427      & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21428      & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21429      & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21430      & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21431 * pbar p
21432       DATA (ASIGEL(2,K),K=1,NPOINT) /
21433      & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21434      & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21435      & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21436      & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21437      & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21438      & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21439      & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21440 * n p
21441       DATA (ASIGEL(3,K),K=1,NPOINT) /
21442      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21443      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21444      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21445      & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21446      & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21447      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21448      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21449 * pi+ p
21450       DATA (ASIGEL(4,K),K=1,NPOINT) /
21451      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21452      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21453      & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21454      & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21455      & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21456      & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21457      & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21458 * pi- p
21459       DATA (ASIGEL(5,K),K=1,NPOINT) /
21460      & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21461      & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21462      & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21463      & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21464      & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21465      & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21466      & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21467 * K+ p
21468       DATA (ASIGEL(6,K),K=1,NPOINT) /
21469      & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21470      & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21471      & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21472      & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21473      & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21474      & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21475      & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21476 * K- p
21477       DATA (ASIGEL(7,K),K=1,NPOINT) /
21478      & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21479      & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21480      & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21481      & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21482      & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21483      & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21484      & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21485 * K+ n
21486       DATA (ASIGEL(8,K),K=1,NPOINT) /
21487      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21488      & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21489      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21490      & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21491      & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21492      & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21493      & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21494 * K- n
21495       DATA (ASIGEL(9,K),K=1,NPOINT) /
21496      & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21497      & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21498      & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21499      & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21500      & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21501      & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21502      & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21503 * Lambda p
21504       DATA (ASIGEL(10,K),K=1,NPOINT) /
21505      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21506      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21507      & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21508      & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21509      & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21510      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21511      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21512
21513       DATA (IDXDAT(K,1),K=1,25) /
21514      &  1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21515      &  1, 3,45, 8, 9/
21516       DATA (IDXDAT(K,2),K=1,25) /
21517      &  3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21518      &  3, 1,45, 6, 7/
21519
21520       DATA LFIRST /.TRUE./
21521
21522       IF (LFIRST) THEN
21523          APLABL = LOG10(PLABLO)
21524          APLABH = LOG10(PLABHI)
21525          APTHRE = LOG10(PTHRE)
21526          ADP1   = (APTHRE-APLABL)/DBLE(NPOIN1)
21527          ADP2   = (APLABH-APTHRE)/DBLE(NPOIN2)
21528          DUM0   = ZERO
21529          PHOPLA = PLABHI
21530          PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21531          ECMS   = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21532          IF (MCGENE.EQ.2) THEN
21533             IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21534                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21535             ELSE
21536                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21537             ENDIF
21538          ELSE
21539             CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21540          ENDIF
21541          PHOSEL = PHOSTO-PHOSIN
21542          APHOST = LOG10(PHOSTO)
21543          APHOSE = LOG10(PHOSEL)
21544          LFIRST = .FALSE.
21545       ENDIF
21546       STOT = ZERO
21547       SELA = ZERO
21548       PLAB = PL
21549       ECMS = ECM
21550       IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21551          WRITE(LOUT,1000) IP,IT
21552  1000    FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21553      &          'proj/target',2I4)
21554          STOP
21555       ENDIF
21556
21557       IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21558          ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21559          PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21560       ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21561          WRITE(LOUT,1001) PLAB,ECMS
21562  1001    FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21563          STOP
21564       ENDIF
21565
21566 * index of spectrum
21567       IDXP = IP
21568       IF (IP.GT.25) THEN
21569          IF (AAM(IP).GT.ZERO) THEN
21570             IF (ABS(IIBAR(IP)).GT.0) THEN
21571                IDXP = 1
21572             ELSE
21573                IDXP = 13
21574             ENDIF
21575          ELSE
21576             IDXP = 7
21577          ENDIF
21578       ENDIF
21579       IDXT = 1
21580       IF (IT.EQ.8) IDXT = 2
21581       IDXS = IDXDAT(IDXP,IDXT)
21582       IF (IDXS.EQ.0) RETURN
21583
21584 * compute momentum bin indices
21585       IF (PLAB.LT.PLABLO) THEN
21586          IDX0 = 1
21587          IDX1 = 1
21588       ELSEIF (PLAB.GE.PLABHI) THEN
21589          IDX0 = NPOINT
21590          IDX1 = NPOINT
21591       ELSE
21592          APLAB = LOG10(PLAB)
21593          IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21594             IDX0 = INT((APLAB-APLABL)/ADP1)+1
21595          ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21596             IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21597          ENDIF
21598          IDX1 = IDX0+1
21599       ENDIF
21600
21601 * interpolate cross section
21602       IF (IDXS.GT.10) THEN
21603          IDXS1 = IDXS/10
21604          IDXS2 = IDXS-10*IDXS1
21605          IF (IDX0.EQ.IDX1) THEN
21606             IF (IDX0.EQ.1) THEN
21607                ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21608                ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21609             ELSE
21610                DUM0   = ZERO
21611                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21612                PHOSEL = PHOSTO-PHOSIN
21613                ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21614                ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21615                ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21616                ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21617                ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
21618                ASELA  = 0.5D0*(ASELA1+ASELA2)
21619             ENDIF
21620          ELSE
21621             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21622             ASTOT1 = ASIGTO(IDXS1,IDX0)+
21623      &               FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21624             ASTOT2 = ASIGTO(IDXS2,IDX0)+
21625      &               FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21626             ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
21627             ASELA1 = ASIGEL(IDXS1,IDX0)+
21628      &               FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21629             ASELA2 = ASIGEL(IDXS2,IDX0)+
21630      &               FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21631             ASELA  = 0.5D0*(ASELA1+ASELA2)
21632          ENDIF
21633       ELSE
21634          IF (IDX0.EQ.IDX1) THEN
21635             IF (IDX0.EQ.1) THEN
21636                ASTOT = ASIGTO(IDXS,IDX0)
21637                ASELA = ASIGEL(IDXS,IDX0)
21638             ELSE
21639                DUM0   = ZERO
21640                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21641                PHOSEL = PHOSTO-PHOSIN
21642                ASTOT  = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21643                ASELA  = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21644             ENDIF
21645          ELSE
21646             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21647             ASTOT = ASIGTO(IDXS,IDX0)+
21648      &              FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21649             ASELA = ASIGEL(IDXS,IDX0)+
21650      &              FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21651          ENDIF
21652       ENDIF
21653       STOT = 10.0D0**ASTOT
21654       SELA = 10.0D0**ASELA
21655
21656       RETURN
21657       END
21658
21659 *$ CREATE DT_SIHNAB.FOR
21660 *COPY DT_SIHNAB
21661 *
21662 *===sihnab===============================================================*
21663 *
21664       SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21665
21666 **********************************************************************
21667 * Pion 2-nucleon absorption cross sections.                          *
21668 * (sigma_tot for pi+ d --> p p, pi- d --> n n                        *
21669 *  taken from Ritchie PRC 28 (1983) 926 )                            *
21670 * This version dated 18.05.96 is written by S. Roesler               *
21671 **********************************************************************
21672
21673       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21674       SAVE
21675       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21676       PARAMETER (AMPR = 938.0D0,
21677      &           AMPI = 140.0D0,
21678      &           AMDE = TWO*AMPR,
21679      &           A    = -1.2D0,
21680      &           B    = 3.5D0,
21681      &           C    = 7.4D0,
21682      &           D    = 5600.0D0,
21683      &           ER   = 2136.0D0)
21684
21685       SIGABS = ZERO
21686       IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21687      &                   .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21688       PTOT = PLAB*1.0D3
21689       EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21690       IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21691       ECM  = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21692       SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21693 * approximate 3N-abs., I=1-abs. etc.
21694       SIGABS = SIGABS/0.40D0
21695 * pi0-absorption (rough approximation!!)
21696       IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21697
21698       RETURN
21699       END
21700
21701 *$ CREATE DT_SIGEMU.FOR
21702 *COPY DT_SIGEMU
21703 *
21704 *===sigemu=============================================================*
21705 *
21706       SUBROUTINE DT_SIGEMU
21707
21708 ************************************************************************
21709 * Combined cross section for target compounds.                         *
21710 * This version dated 6.4.98   is written by S. Roesler                 *
21711 ************************************************************************
21712
21713       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21714       SAVE
21715       PARAMETER ( LINP = 10 ,
21716      &            LOUT = 6 ,
21717      &            LDAT = 9 )
21718       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21719      &           OHALF=0.5D0,ONE=1.0D0)
21720
21721       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21722 * Glauber formalism: cross sections
21723       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21724      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21725      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21726      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21727      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21728      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21729      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21730      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21731      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21732      &                BSLOPE,NEBINI,NQBINI
21733 * emulsion treatment
21734       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21735      &                NCOMPO,IEMUL
21736 * nucleon-nucleon event-generator
21737       CHARACTER*8 CMODEL
21738       LOGICAL LPHOIN
21739       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21740
21741       IF (MCGENE.NE.4) THEN
21742          WRITE(LOUT,'(A)') ' DT_SIGEMU:    Combined cross sections'
21743          WRITE(LOUT,'(15X,A)') '-----------------------'
21744       ENDIF
21745       DO 1 IE=1,NEBINI
21746          DO 2 IQ=1,NQBINI
21747             SIGTOT = ZERO
21748             SIGELA = ZERO
21749             SIGQEP = ZERO
21750             SIGQET = ZERO
21751             SIGQE2 = ZERO
21752             SIGPRO = ZERO
21753             SIGDEL = ZERO
21754             SIGDQE = ZERO
21755             ERRTOT = ZERO
21756             ERRELA = ZERO
21757             ERRQEP = ZERO
21758             ERRQET = ZERO
21759             ERRQE2 = ZERO
21760             ERRPRO = ZERO
21761             ERRDEL = ZERO
21762             ERRDQE = ZERO
21763             IF (NCOMPO.GT.0) THEN
21764                DO 3 IC=1,NCOMPO
21765                   SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21766                   SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21767                   SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21768                   SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21769                   SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21770                   SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21771                   SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21772                   SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21773                   ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21774                   ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21775                   ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21776                   ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21777                   ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21778                   ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21779                   ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21780                   ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21781     3          CONTINUE
21782                ERRTOT = SQRT(ERRTOT)
21783                ERRELA = SQRT(ERRELA)
21784                ERRQEP = SQRT(ERRQEP)
21785                ERRQET = SQRT(ERRQET)
21786                ERRQE2 = SQRT(ERRQE2)
21787                ERRPRO = SQRT(ERRPRO)
21788                ERRDEL = SQRT(ERRDEL)
21789                ERRDQE = SQRT(ERRDQE)
21790             ELSE
21791                SIGTOT = XSTOT(IE,IQ,1)
21792                SIGELA = XSELA(IE,IQ,1)
21793                SIGQEP = XSQEP(IE,IQ,1)
21794                SIGQET = XSQET(IE,IQ,1)
21795                SIGQE2 = XSQE2(IE,IQ,1)
21796                SIGPRO = XSPRO(IE,IQ,1)
21797                SIGDEL = XSDEL(IE,IQ,1)
21798                SIGDQE = XSDQE(IE,IQ,1)
21799                ERRTOT = XETOT(IE,IQ,1)
21800                ERRELA = XEELA(IE,IQ,1)
21801                ERRQEP = XEQEP(IE,IQ,1)
21802                ERRQET = XEQET(IE,IQ,1)
21803                ERRQE2 = XEQE2(IE,IQ,1)
21804                ERRPRO = XEPRO(IE,IQ,1)
21805                ERRDEL = XEDEL(IE,IQ,1)
21806                ERRDQE = XEDQE(IE,IQ,1)
21807             ENDIF
21808             IF (MCGENE.NE.4) THEN
21809                WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21810  1000         FORMAT(/,1X,'E_cm =',F9.1,' GeV  Q^2 =',F6.1,' GeV^2 :',/)
21811                WRITE(LOUT,1001) SIGTOT,ERRTOT
21812  1001          FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21813                WRITE(LOUT,1002) SIGELA,ERRELA
21814  1002          FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21815                WRITE(LOUT,1003) SIGQEP,ERRQEP
21816  1003          FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21817      &                F11.5,' mb')
21818                WRITE(LOUT,1004) SIGQET,ERRQET
21819  1004          FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21820      &                F11.5,' mb')
21821                WRITE(LOUT,1005) SIGQE2,ERRQE2
21822  1005          FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21823      &                ' +-',F11.5,' mb')
21824                WRITE(LOUT,1006) SIGPRO,ERRPRO
21825  1006          FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21826                WRITE(LOUT,1007) SIGDEL,ERRDEL
21827  1007          FORMAT(1X,'diff-el   ',27X,F10.4,' +-',F11.5,' mb')
21828                WRITE(LOUT,1008) SIGDQE,ERRDQE
21829  1008          FORMAT(1X,'diff-qel  ',27X,F10.4,' +-',F11.5,' mb')
21830             ENDIF
21831
21832     2    CONTINUE
21833     1 CONTINUE
21834
21835       RETURN
21836       END
21837
21838 *$ CREATE DT_SIGGA.FOR
21839 *COPY DT_SIGGA
21840 *
21841 *===sigga==============================================================*
21842 *
21843       SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21844
21845 ************************************************************************
21846 * Total/inelastic photon-nucleus cross sections.                       *
21847 *     !!!! Overwrites SHMAKI-initialization. Do not use it during      *
21848 *          production runs !!!!                                        *
21849 * This version dated 27.03.96 is written by S. Roesler                 *
21850 ************************************************************************
21851
21852       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21853       SAVE
21854       PARAMETER ( LINP = 10 ,
21855      &            LOUT = 6 ,
21856      &            LDAT = 9 )
21857       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21858      &           OHALF=0.5D0,ONE=1.0D0)
21859       PARAMETER (AMPROT = 0.938D0)
21860
21861       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21862 * Glauber formalism: cross sections
21863       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21864      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21865      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21866      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21867      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21868      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21869      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21870      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21871      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21872      &                BSLOPE,NEBINI,NQBINI
21873
21874       NT  = NTI
21875       X   = XI
21876       Q2  = Q2I
21877       ECM = ECMI
21878       XNU = XNUI
21879       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21880      &   ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21881       CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21882       STOT  = XSTOT(1,1,1)
21883       ETOT  = XETOT(1,1,1)
21884       SIN   = XSPRO(1,1,1)
21885       EIN   = XEPRO(1,1,1)
21886
21887       RETURN
21888       END
21889
21890 *$ CREATE DT_SIGGAT.FOR
21891 *COPY DT_SIGGAT
21892 *
21893 *===siggat=============================================================*
21894 *
21895       SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21896
21897 ************************************************************************
21898 * Total/inelastic photon-nucleus cross sections.                       *
21899 * Uses pre-tabulated cross section.                                    *
21900 * This version dated 29.07.96 is written by S. Roesler                 *
21901 ************************************************************************
21902
21903       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21904       SAVE
21905       PARAMETER ( LINP = 10 ,
21906      &            LOUT = 6 ,
21907      &            LDAT = 9 )
21908       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21909      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21910
21911       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21912 * Glauber formalism: cross sections
21913       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21914      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21915      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21916      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21917      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21918      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21919      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21920      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21921      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21922      &                BSLOPE,NEBINI,NQBINI
21923
21924       NTARG = ABS(NT)
21925       I1   = 1
21926       I2   = 1
21927       RATE = ONE
21928       IF (NEBINI.GT.1) THEN
21929          IF (ECMI.GE.ECMNN(NEBINI)) THEN
21930             I1   = NEBINI
21931             I2   = NEBINI
21932             RATE = ONE
21933          ELSEIF (ECMI.GT.ECMNN(1)) THEN
21934             DO 1 I=2,NEBINI
21935                IF (ECMI.LT.ECMNN(I)) THEN
21936                   I1   = I-1
21937                   I2   = I
21938                   RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21939                   GOTO 2
21940                ENDIF
21941     1       CONTINUE
21942     2       CONTINUE
21943          ENDIF
21944       ENDIF
21945       J1   = 1
21946       J2   = 1
21947       RATQ = ONE
21948       IF (NQBINI.GT.1) THEN
21949          IF (Q2I.GE.Q2G(NQBINI)) THEN
21950             J1   = NQBINI
21951             J2   = NQBINI
21952             RATQ = ONE
21953          ELSEIF (Q2I.GT.Q2G(1)) THEN
21954             DO 3 I=2,NQBINI
21955                IF (Q2I.LT.Q2G(I)) THEN
21956                   J1   = I-1
21957                   J2   = I
21958                   RATQ = LOG10(    Q2I/MAX(Q2G(J1),TINY14))/
21959      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21960 C                 RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21961                   GOTO 4
21962                ENDIF
21963     3       CONTINUE
21964     4       CONTINUE
21965          ENDIF
21966       ENDIF
21967
21968       STOT = XSTOT(I1,J1,NTARG)+
21969      &   RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21970      &   RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21971      &   RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21972      &              XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21973
21974       RETURN
21975       END
21976
21977 *$ CREATE DT_SANO.FOR
21978 *COPY DT_SANO
21979 *
21980 *===sigano=============================================================*
21981 *
21982       DOUBLE PRECISION FUNCTION DT_SANO(ECM)
21983
21984 ************************************************************************
21985 * This version dated 31.07.96 is written by S. Roesler                 *
21986 ************************************************************************
21987
21988       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21989       SAVE
21990       PARAMETER ( LINP = 10 ,
21991      &            LOUT = 6 ,
21992      &            LDAT = 9 )
21993       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21994      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21995       PARAMETER (NE = 8)
21996
21997 * VDM parameter for photon-nucleus interactions
21998       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21999 * properties of interacting particles
22000       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
22001
22002       DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
22003       DATA ECMANO /
22004      &             0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
22005      &             0.100D+04,0.200D+04,0.500D+04
22006      &            /
22007 * fixed cut (3 GeV/c)
22008       DATA FRAANO /
22009      &             0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
22010      &             0.062D+00,0.054D+00,0.042D+00
22011      &            /
22012       DATA SIGHRD /
22013      &           4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
22014      &           3.3086D-01,7.6255D-01,2.1319D+00
22015      &            /
22016 * running cut (based on obsolete Phojet-caluclations, bugs..)
22017 C     DATA FRAANO /
22018 C    &             0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
22019 C    &             0.167E+00,0.150E+00,0.131E+00
22020 C    &            /
22021 C     DATA SIGHRD /
22022 C    &           6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
22023 C    &           2.5736E-01,4.5593E-01,8.2550E-01
22024 C    &            /
22025
22026       DT_SANO = ZERO
22027       IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
22028       J1   = 0
22029       J2   = 0
22030       RATE = ONE
22031       IF (ECM.GE.ECMANO(NE)) THEN
22032          J1 = NE
22033          J2 = NE
22034       ELSEIF (ECM.GT.ECMANO(1)) THEN
22035          DO 1 IE=2,NE
22036             IF (ECM.LT.ECMANO(IE)) THEN
22037                J1   = IE-1
22038                J2   = IE
22039                RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
22040                GOTO 2
22041             ENDIF
22042     1    CONTINUE
22043     2    CONTINUE
22044       ENDIF
22045       IF ((J1.GT.0).AND.(J2.GT.0)) THEN
22046          AFRA1  = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
22047          AFRA2  = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
22048          DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
22049       ENDIF
22050
22051       RETURN
22052       END
22053
22054 *$ CREATE DT_SIGGP.FOR
22055 *COPY DT_SIGGP
22056 *
22057 *===siggp==============================================================*
22058 *
22059       SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
22060
22061 ************************************************************************
22062 * Total/inelastic photon-nucleon cross sections.                       *
22063 * This version dated 30.04.96 is written by S. Roesler                 *
22064 ************************************************************************
22065
22066       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22067       SAVE
22068       PARAMETER ( LINP = 10 ,
22069      &            LOUT = 6 ,
22070      &            LDAT = 9 )
22071       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22072       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
22073      &           PI     = TWOPI/TWO,
22074      &           GEV2MB = 0.38938D0,
22075      &           ALPHEM = ONE/137.0D0)
22076
22077 * particle properties (BAMJET index convention)
22078       CHARACTER*8  ANAME
22079       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22080      &                IICH(210),IIBAR(210),K1(210),K2(210)
22081 * VDM parameter for photon-nucleus interactions
22082       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22083
22084 **PHOJET105a
22085 C     CHARACTER*8 MDLNA
22086 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
22087 C     PARAMETER (IEETAB=10)
22088 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
22089 **PHOJET110
22090 C  model switches and parameters
22091       CHARACTER*8 MDLNA
22092       INTEGER ISWMDL,IPAMDL
22093       DOUBLE PRECISION PARMDL
22094       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
22095 C  energy-interpolation table
22096       INTEGER IEETA2
22097       PARAMETER ( IEETA2 = 20 )
22098       INTEGER ISIMAX
22099       DOUBLE PRECISION SIGTAB,SIGECM
22100       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
22101 **
22102
22103 C     PARAMETER (NPOINT=80)
22104       PARAMETER (NPOINT=16)
22105       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22106
22107       STOT = ZERO
22108       SINE = ZERO
22109       SDIR = ZERO
22110
22111       W2 = ECMI**2
22112       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22113      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22114       Q2 = Q2I
22115       X  = XI
22116 * photoprod.
22117       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22118          Q2 = 0.0001D0
22119          X  = Q2/(W2+Q2-AAM(1)**2)
22120 * DIS
22121       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22122          X  = Q2/(W2+Q2-AAM(1)**2)
22123       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22124          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22125       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22126          W2 = Q2*(ONE-X)/X+AAM(1)**2
22127       ELSE
22128          WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
22129          STOP
22130       ENDIF
22131       ECM = SQRT(W2)
22132
22133       IF (MODEGA.EQ.1) THEN
22134          SCALE = SQRT(Q2)
22135          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22136      &                                                       IDPDF)
22137 C        W = SQRT(W2)
22138 C        ALLMF2 = PHO_ALLM97(Q2,W)
22139 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22140          STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22141          SINE = ZERO
22142          SDIR = ZERO
22143       ELSEIF (MODEGA.EQ.2) THEN
22144          IF (INTRGE(1).EQ.1) THEN
22145             AMLO2 = (3.0D0*AAM(13))**2
22146          ELSEIF (INTRGE(1).EQ.2) THEN
22147             AMLO2 = AAM(33)**2
22148          ELSE
22149             AMLO2 = AAM(96)**2
22150          ENDIF
22151          IF (INTRGE(2).EQ.1) THEN
22152             AMHI2 = W2/TWO
22153          ELSEIF (INTRGE(2).EQ.2) THEN
22154             AMHI2 = W2/4.0D0
22155          ELSE
22156             AMHI2 = W2
22157          ENDIF
22158          AMHI20 = (ECM-AAM(1))**2
22159          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22160          XAMLO  = LOG( AMLO2+Q2 )
22161          XAMHI  = LOG( AMHI2+Q2 )
22162 **PHOJET105a
22163 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22164 **PHOJET112
22165          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22166 **
22167          SUM  = ZERO
22168          DO 1 J=1,NPOINT
22169             AM2 = EXP(ABSZX(J))-Q2
22170             IF (AM2.LT.16.0D0) THEN
22171                R = TWO
22172             ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
22173                R = 10.0D0/3.0D0
22174             ELSE
22175                R = 11.0D0/3.0D0
22176             ENDIF
22177 C           FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22178             FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22179      &            * (ONE+EPSPOL*Q2/AM2)
22180             SUM = SUM+WEIGHT(J)*FAC
22181     1    CONTINUE
22182          SINE = SUM
22183          SDIR = DT_SIGVP(X,Q2)
22184          STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
22185          SDIR = SDIR/(0.588D0+RL2+Q2)
22186 C        STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
22187       ELSEIF (MODEGA.EQ.3) THEN
22188          CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
22189       ELSEIF (MODEGA.EQ.4) THEN
22190 *  load cross sections from PHOJET interpolation table
22191          IP = 1
22192          IF(ECM.LE.SIGECM(IP,1)) THEN
22193            I1 = 1
22194            I2 = 1
22195          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
22196            DO 2 I=2,ISIMAX
22197               IF (ECM.LE.SIGECM(IP,I)) GOTO 3
22198     2      CONTINUE
22199     3      CONTINUE
22200            I1 = I-1
22201            I2 = I
22202          ELSE
22203            WRITE(LOUT,'(/1X,A,2E12.3)')
22204      &       'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
22205            I1 = ISIMAX
22206            I2 = ISIMAX
22207          ENDIF
22208          FAC2 = ZERO
22209          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
22210      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
22211          FAC1 = ONE-FAC2
22212 *  cross section dependence on photon virtuality
22213          FSUP1 = ZERO
22214          DO 4 I=1,3
22215             FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
22216      &                                /(1.D0+Q2/PARMDL(30+I))**2
22217     4    CONTINUE
22218          FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
22219          FAC1  = FAC1*FSUP1
22220          FAC2  = FAC2*FSUP1
22221          FSUP2 = 1.0D0
22222          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
22223          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
22224          SDIR  = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
22225 **re:
22226          STOT  = STOT-SDIR
22227 **
22228          SDIR  = SDIR/(FSUP1*FSUP2)
22229 **re:
22230          STOT  = STOT+SDIR
22231 **
22232       ENDIF
22233
22234       RETURN
22235       END
22236
22237 *$ CREATE DT_SIGVEL.FOR
22238 *COPY DT_SIGVEL
22239 *
22240 *===sigvel=============================================================*
22241 *
22242       SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
22243
22244 ************************************************************************
22245 * Cross section for elastic vector meson production                    *
22246 * This version dated 10.05.96 is written by S. Roesler                 *
22247 ************************************************************************
22248
22249       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22250       SAVE
22251       PARAMETER ( LINP = 10 ,
22252      &            LOUT = 6 ,
22253      &            LDAT = 9 )
22254       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22255       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
22256      &           PI     = TWOPI/TWO,
22257      &           GEV2MB = 0.38938D0,
22258      &           ALPHEM = ONE/137.0D0)
22259
22260 * particle properties (BAMJET index convention)
22261       CHARACTER*8  ANAME
22262       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22263      &                IICH(210),IIBAR(210),K1(210),K2(210)
22264 * VDM parameter for photon-nucleus interactions
22265       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22266
22267       W2 = ECMI**2
22268       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22269      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22270       Q2 = Q2I
22271       X  = XI
22272 * photoprod.
22273       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22274          Q2 = 0.0001D0
22275          X  = Q2/(W2+Q2-AAM(1)**2)
22276 * DIS
22277       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22278          X  = Q2/(W2+Q2-AAM(1)**2)
22279       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22280          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22281       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22282          W2 = Q2*(ONE-X)/X+AAM(1)**2
22283       ELSE
22284          WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
22285          STOP
22286       ENDIF
22287       ECM = SQRT(W2)
22288
22289       AMV  = AAM(IDXV)
22290       AMV2 = AMV**2
22291
22292       BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
22293      &        +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
22294       ROSH   = 0.1D0
22295       STOVP  = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
22296       SELVP  = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
22297
22298       IF (IDXV.EQ.33) THEN
22299          COUPL = 0.00365D0
22300       ELSE
22301          STOP
22302       ENDIF
22303       SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
22304       SIG2 = SELVP
22305       SVEL  = COUPL * (AMV2/(AMV2+Q2))**2
22306      &              * (ONE+EPSPOL*Q2/AMV2) * SELVP
22307
22308       RETURN
22309       END
22310
22311 *$ CREATE DT_SIGVP.FOR
22312 *COPY DT_SIGVP
22313 *
22314 *===sigvp==============================================================*
22315 *
22316       DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
22317
22318 ************************************************************************
22319 * sigma_Vp                                                             *
22320 ************************************************************************
22321
22322       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22323       SAVE
22324
22325       PARAMETER ( LINP = 10 ,
22326      &            LOUT = 6 ,
22327      &            LDAT = 9 )
22328       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22329       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22330      &           PI    = TWOPI/TWO,
22331      &           GEV2MB = 0.38938D0,
22332      &           AMPROT = 0.938D0,
22333      &           ALPHEM = ONE/137.0D0)
22334 * VDM parameter for photon-nucleus interactions
22335       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22336
22337       X  = XI
22338       Q2 = Q2I
22339       IF (XI.LE.ZERO)  X  = 0.0001D0
22340       IF (Q2I.LE.ZERO) Q2 = 0.0001D0
22341
22342       ECM    = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
22343
22344       SCALE = SQRT(Q2)
22345       IF (MODEGA.EQ.1) THEN
22346          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22347      &                                                       IDPDF)
22348 C        W = ECM
22349 C        ALLMF2 = PHO_ALLM97(Q2,W)
22350 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22351 C        STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22352 C        DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
22353          DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
22354       ELSEIF (MODEGA.EQ.4) THEN
22355          CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
22356 C        F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
22357          DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
22358       ELSE
22359          STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
22360       ENDIF
22361
22362       RETURN
22363
22364       END
22365
22366 *$ CREATE DT_RRM2.FOR
22367 *COPY DT_RRM2
22368 *
22369 *===RRM2===============================================================*
22370 *
22371       DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22372
22373       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22374       SAVE
22375       PARAMETER ( LINP = 10 ,
22376      &            LOUT = 6 ,
22377      &            LDAT = 9 )
22378       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22379       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22380      &           PI    = TWOPI/TWO,
22381      &           GEV2MB = 0.38938D0)
22382
22383 * particle properties (BAMJET index convention)
22384       CHARACTER*8  ANAME
22385       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22386      &                IICH(210),IIBAR(210),K1(210),K2(210)
22387 * VDM parameter for photon-nucleus interactions
22388       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22389
22390       S   = Q2*(ONE-X)/X+AAM(1)**2
22391       ECM = SQRT(S)
22392
22393       IF (INTRGE(1).EQ.1) THEN
22394          AMLO2 = (3.0D0*AAM(13))**2
22395       ELSEIF (INTRGE(1).EQ.2) THEN
22396          AMLO2 = AAM(33)**2
22397       ELSE
22398          AMLO2 = AAM(96)**2
22399       ENDIF
22400       IF (INTRGE(2).EQ.1) THEN
22401          AMHI2 = S/TWO
22402       ELSEIF (INTRGE(2).EQ.2) THEN
22403          AMHI2 = S/4.0D0
22404       ELSE
22405          AMHI2 = S
22406       ENDIF
22407       AMHI20 = (ECM-AAM(1))**2
22408       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22409
22410       AM1C2 = 16.0D0
22411       AM2C2 = 121.0D0
22412       IF (AMHI2.LE.AM1C2) THEN
22413          DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22414       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22415          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22416      &          10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22417       ELSE
22418          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22419      &          10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22420      &          11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22421       ENDIF
22422
22423       RETURN
22424       END
22425
22426 *$ CREATE DT_RM2.FOR
22427 *COPY DT_RM2
22428 *
22429 *===RM2================================================================*
22430 *
22431       DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22432
22433       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22434       SAVE
22435       PARAMETER ( LINP = 10 ,
22436      &            LOUT = 6 ,
22437      &            LDAT = 9 )
22438       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22439       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22440      &           PI    = TWOPI/TWO,
22441      &           GEV2MB = 0.38938D0)
22442 * VDM parameter for photon-nucleus interactions
22443       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22444
22445       IF (RL2.LE.ZERO) THEN
22446          DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22447      &        (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22448      &         +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22449       ELSE
22450          TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22451          TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22452          DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22453      &       -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22454      &       +EPSPOL*(
22455      &         -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22456      &       -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22457       ENDIF
22458
22459       RETURN
22460       END
22461
22462 *$ CREATE DT_SAM2.FOR
22463 *COPY DT_SAM2
22464 *
22465 *===SAM2===============================================================*
22466 *
22467       DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22468
22469       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22470       SAVE
22471       PARAMETER ( LINP = 10 ,
22472      &            LOUT = 6 ,
22473      &            LDAT = 9 )
22474       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22475      &           TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22476       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22477      &           PI    = TWOPI/TWO,
22478      &           GEV2MB = 0.38938D0)
22479
22480 * particle properties (BAMJET index convention)
22481       CHARACTER*8  ANAME
22482       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22483      &                IICH(210),IIBAR(210),K1(210),K2(210)
22484 * VDM parameter for photon-nucleus interactions
22485       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22486
22487       S = ECM**2
22488       IF (INTRGE(1).EQ.1) THEN
22489          AMLO2 = (3.0D0*AAM(13))**2
22490       ELSEIF (INTRGE(1).EQ.2) THEN
22491          AMLO2 = AAM(33)**2
22492       ELSE
22493          AMLO2 = AAM(96)**2
22494       ENDIF
22495       IF (INTRGE(2).EQ.1) THEN
22496          AMHI2 = S/TWO
22497       ELSEIF (INTRGE(2).EQ.2) THEN
22498          AMHI2 = S/4.0D0
22499       ELSE
22500          AMHI2 = S
22501       ENDIF
22502       AMHI20 = (ECM-AAM(1))**2
22503       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22504
22505       AM1C2 = 16.0D0
22506       AM2C2 = 121.0D0
22507       YLO   = LOG(AMLO2+Q2)
22508       YC1   = LOG(AM1C2+Q2)
22509       YC2   = LOG(AM2C2+Q2)
22510       YHI   = LOG(AMHI2+Q2)
22511       IF (AMHI2.LE.AM1C2) THEN
22512          FACHI = TWO
22513       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22514          FACHI = TENTRD
22515       ELSE
22516          FACHI = ELVTRD
22517       ENDIF
22518
22519     1 CONTINUE
22520       YSAM2  = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22521       IF (YSAM2.LE.YC1) THEN
22522          FAC = TWO
22523       ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22524          FAC = TENTRD
22525       ELSE
22526          FAC = ELVTRD
22527       ENDIF
22528       WEIGMX = FACHI*(ONE-Q2*EXP(  -YHI))
22529       XSAM2  = FAC  *(ONE-Q2*EXP(-YSAM2))
22530       IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22531
22532       DT_SAM2   = EXP(YSAM2)-Q2
22533
22534       RETURN
22535       END
22536
22537 *$ CREATE DT_CKMT.FOR
22538 *COPY DT_CKMT
22539 *
22540 *===ckmt===============================================================*
22541 *
22542       SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22543      &                F2,IPAR)
22544
22545 ************************************************************************
22546 * This version dated 31.01.96 is written by S. Roesler                 *
22547 ************************************************************************
22548
22549       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22550       SAVE
22551       PARAMETER ( LINP = 10 ,
22552      &            LOUT = 6 ,
22553      &            LDAT = 9 )
22554       PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22555
22556       PARAMETER (Q02 = 2.0D0,
22557      &           DQ2 = 10.05D0,
22558      &           Q12 = Q02+DQ2)
22559
22560       DIMENSION PD(-6:6),SEA(3),VAL(2)
22561
22562       CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22563       CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22564       ADQ2 = LOG10(Q12)-LOG10(Q02)
22565       F2P  = (F2Q1-F2Q0)/ADQ2
22566       CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22567       CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22568       F2PP = (F2PQ1-F2PQ0)/ADQ2
22569       FX   = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22570
22571       Q2     = MAX(SCALE**2.0D0,TINY10)
22572       SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22573       IF (Q2.LT.Q02) THEN
22574          CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22575          UPV  = VAL(1)
22576          DNV  = VAL(2)
22577          USEA = SEA(1)
22578          DSEA = SEA(2)
22579          STR  = SEA(3)
22580          CHM  = 0.0D0
22581          BOT  = 0.0D0
22582          TOP  = 0.0D0
22583          GL   = GLU
22584       ELSE
22585          CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22586          F2 = F2*SMOOTH
22587          UPV  = PD(2)-PD(3)
22588          DNV  = PD(1)-PD(3)
22589          USEA = PD(3)
22590          DSEA = PD(3)
22591          STR  = PD(3)
22592          CHM  = PD(4)
22593          BOT  = PD(5)
22594          TOP  = PD(6)
22595          GL   = PD(0)
22596 C        UPV  = UPV*SMOOTH
22597 C        DNV  = DNV*SMOOTH
22598 C        USEA = USEA*SMOOTH
22599 C        DSEA = DSEA*SMOOTH
22600 C        STR  = STR*SMOOTH
22601 C        CHM  = CHM*SMOOTH
22602 C        GL   = GL*SMOOTH
22603       ENDIF
22604
22605       RETURN
22606       END
22607 C
22608
22609 *$ CREATE DT_CKMTX.FOR
22610 *COPY DT_CKMTX
22611       SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22612 C**********************************************************************
22613 C
22614 C     PDF based on Regge theory, evolved with .... by ....
22615 C
22616 C     input: IPAR     2212   proton (not installed)
22617 C                       45   Pomeron
22618 C                      100   Deuteron
22619 C
22620 C     output: PD(-6:6) x*f(x)  parton distribution functions
22621 C            (PDFLIB convention: d = PD(1), u = PD(2) )
22622 C
22623 C**********************************************************************
22624
22625       SAVE
22626       DOUBLE PRECISION  X,SCALE2,PD(-6:6),CDN,CUP,F2
22627       PARAMETER ( LINP = 10 ,
22628      &            LOUT = 6 ,
22629      &            LDAT = 9 )
22630       DIMENSION QQ(7)
22631 C
22632       Q2=SNGL(SCALE2)
22633       Q1S=Q2
22634       XX=SNGL(X)
22635 C  QCD lambda for evolution
22636       OWLAM = 0.23D0
22637       OWLAM2=OWLAM**2
22638 C  Q0**2 for evolution
22639       Q02 = 2.D0
22640 C
22641 C
22642 C  the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22643 C                        q(6)=x*charm, q(7)=x*gluon
22644 C
22645       SB=0.
22646       IF(Q2-Q02) 1,1,2
22647     2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22648     1 CONTINUE
22649       IF(IPAR.EQ.2212) THEN
22650         CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22651         CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22652         CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22653         CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22654         CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22655         CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22656         CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22657 C     ELSEIF (IPAR.EQ.45) THEN
22658 C       CALL CKMTPO(1,0,XX,SB,QQ(1))
22659 C       CALL CKMTPO(2,0,XX,SB,QQ(2))
22660 C       CALL CKMTPO(3,0,XX,SB,QQ(3))
22661 C       CALL CKMTPO(4,0,XX,SB,QQ(4))
22662 C       CALL CKMTPO(5,0,XX,SB,QQ(5))
22663 C       CALL CKMTPO(8,0,XX,SB,QQ(6))
22664 C       CALL CKMTPO(7,0,XX,SB,QQ(7))
22665       ELSEIF (IPAR.EQ.100) THEN
22666         CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22667         CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22668         CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22669         CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22670         CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22671         CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22672         CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22673       ELSE
22674         WRITE(LOUT,'(1X,A,I4,A)')
22675      &     'CKMTX:   IPAR =',IPAR,' not implemented!'
22676         STOP
22677       ENDIF
22678 C
22679       PD(-6) = 0.D0
22680       PD(-5) = 0.D0
22681       PD(-4) = DBLE(QQ(6))
22682       PD(-3) = DBLE(QQ(3))
22683       PD(-2) = DBLE(QQ(4))
22684       PD(-1) = DBLE(QQ(5))
22685       PD(0)  = DBLE(QQ(7))
22686       PD(1)  = DBLE(QQ(2))
22687       PD(2)  = DBLE(QQ(1))
22688       PD(3)  = DBLE(QQ(3))
22689       PD(4)  = DBLE(QQ(6))
22690       PD(5)  = 0.D0
22691       PD(6)  = 0.D0
22692       IF(IPAR.EQ.45) THEN
22693         CDN = (PD(1)-PD(-1))/2.D0
22694         CUP = (PD(2)-PD(-2))/2.D0
22695         PD(-1) = PD(-1) + CDN
22696         PD(-2) = PD(-2) + CUP
22697         PD(1) = PD(-1)
22698         PD(2) = PD(-2)
22699       ENDIF
22700       F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22701      &     1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22702      &     1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22703       END
22704 C
22705
22706 *$ CREATE DT_PDF0.FOR
22707 *COPY DT_PDF0
22708 *
22709 *===pdf0===============================================================*
22710 *
22711       SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22712
22713 ************************************************************************
22714 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
22715 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
22716 *                   IPAR  = 2212   proton                              *
22717 *                         =  100   deuteron                            *
22718 * This version dated 31.01.96 is written by S. Roesler                 *
22719 ************************************************************************
22720
22721       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22722       SAVE
22723       PARAMETER ( LINP = 10 ,
22724      &            LOUT = 6 ,
22725      &            LDAT = 9 )
22726       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22727
22728       PARAMETER (
22729      &              AA     = 0.1502D0,
22730      &              BBDEU  = 1.2D0,
22731      &              BUD    = 0.754D0,
22732      &              BDD    = 0.4495D0,
22733      &              BUP    = 1.2064D0,
22734      &              BDP    = 0.1798D0,
22735      &              DELTA0 = 0.07684D0,
22736      &              D      = 1.117D0,
22737      &              C      = 3.5489D0,
22738      &              A      = 0.2631D0,
22739      &              B      = 0.6452D0,
22740      &              ALPHAR = 0.415D0,
22741      &              E      = 0.1D0
22742      &          )
22743
22744       PARAMETER (NPOINT=16)
22745 C     DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22746       DIMENSION SEA(3),VAL(2)
22747
22748       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22749       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
22750 * proton, deuteron
22751       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22752          CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22753          SEA(1) = 0.75D0*SEA0
22754          SEA(2) = SEA(1)
22755          SEA(3) = SEA(1)
22756          VAL(1) = 9.0D0/4.0D0*VALU0
22757          VAL(2) = 9.0D0*VALD0
22758          GLU0   = SEA(1)/(1.0D0-X)
22759          F2     = SEA0+VALU0+VALD0
22760          F2PDF  = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22761      &            1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22762      &            1.0D0/9.0D0*(2.0D0*SEA(3))
22763          IF (ABS(F2-F2PDF).GT.TINY9) THEN
22764             WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22765             STOP
22766          ENDIF
22767 **PHOJET105a
22768 C        CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22769 **PHOJET112
22770 C        CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22771 **
22772 C        SUMQ = ZERO
22773 C        SUMG = ZERO
22774 C        DO 1 J=1,NPOINT
22775 C           CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22776 C           VALU0 = 9.0D0/4.0D0*VALU0
22777 C           VALD0 = 9.0D0*VALD0
22778 C           SEA0  = 0.75D0*SEA0
22779 C           SUMQ  = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22780 C           SUMG  = SUMG+ (SEA0/(1.0D0-ABSZX(J)))  *WEIGHT(J)
22781 C   1    CONTINUE
22782 C        GLU = GLU0*(1.0D0-SUMQ)/SUMG
22783       ELSE
22784          WRITE(LOUT,'(1X,A,I4,A)')
22785      &      'PDF0:   IPAR =',IPAR,' not implemented!'
22786          STOP
22787       ENDIF
22788
22789       RETURN
22790       END
22791
22792 *$ CREATE DT_CKMTQ0.FOR
22793 *COPY DT_CKMTQ0
22794 *
22795 *===ckmtq0=============================================================*
22796 *
22797       SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22798
22799 ************************************************************************
22800 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
22801 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
22802 *                   IPAR  = 2212   proton                              *
22803 *                         =  100   deuteron                            *
22804 * This version dated 31.01.96 is written by S. Roesler                 *
22805 ************************************************************************
22806
22807       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22808       SAVE
22809       PARAMETER ( LINP = 10 ,
22810      &            LOUT = 6 ,
22811      &            LDAT = 9 )
22812       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22813
22814       PARAMETER (
22815      &              AA     = 0.1502D0,
22816      &              BBDEU  = 1.2D0,
22817      &              BUD    = 0.754D0,
22818      &              BDD    = 0.4495D0,
22819      &              BUP    = 1.2064D0,
22820      &              BDP    = 0.1798D0,
22821      &              DELTA0 = 0.07684D0,
22822      &              D      = 1.117D0,
22823      &              C      = 3.5489D0,
22824      &              A      = 0.2631D0,
22825      &              B      = 0.6452D0,
22826      &              ALPHAR = 0.415D0,
22827      &              E      = 0.1D0
22828      &          )
22829
22830       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22831       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
22832 * proton, deuteron
22833       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22834          IF (IPAR.EQ.2212) THEN
22835             BU = BUP
22836             BD = BDP
22837          ELSE
22838             BU = BUD
22839             BD = BDD
22840          ENDIF
22841          SEA0  = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22842      &          (Q2/(Q2+A))**(1.0D0+DELTA)
22843          VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22844      &           (Q2/(Q2+B))**(ALPHAR)
22845          VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22846      &           (Q2/(Q2+B))**(ALPHAR)
22847       ELSE
22848          WRITE(LOUT,'(1X,A,I4,A)')
22849      &      'CKMTQ0: IPAR =',IPAR,' not implemented!'
22850          STOP
22851       ENDIF
22852       RETURN
22853       END
22854 C
22855 C
22856
22857 *$ CREATE DT_CKMTDE.FOR
22858 *COPY DT_CKMTDE
22859       SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22860 C
22861 C**********************************************************************
22862 C    Deuteron - PDFs
22863 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22864 C    ANS = PDF(I)
22865 C    This version by S. Roesler, 30.01.96
22866 C**********************************************************************
22867
22868       SAVE
22869       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22870       EQUIVALENCE (GF(1,1,1),DL(1))
22871       DATA DELTA/.13/
22872 C
22873       DATA (DL(K),K=    1,   85) /
22874      &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22875      &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22876      &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22877      &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22878      &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22879      &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22880      &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22881      &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22882      &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22883      &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22884      &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22885      &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22886      &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22887      &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22888      &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22889      &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22890      &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22891       DATA (DL(K),K=   86,  170) /
22892      &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22893      &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22894      &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22895      &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22896      &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22897      &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22898      &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
22899      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22900      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22901      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22902      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22903      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22904      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22905      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22906      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22907      &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22908      &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22909       DATA (DL(K),K=  171,  255) /
22910      &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22911      &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22912      &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22913      &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22914      &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22915      &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22916      &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22917      &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22918      &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22919      &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22920      &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22921      &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22922      &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22923      &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22924      &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22925      &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22926      &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22927       DATA (DL(K),K=  256,  340) /
22928      &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22929      &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22930      &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22931      &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22932      &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
22933      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22934      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22935      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22936      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22937      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22938      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22939      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22940      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22941      &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22942      &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22943      &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22944      &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22945       DATA (DL(K),K=  341,  425) /
22946      &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22947      &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22948      &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22949      &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22950      &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22951      &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22952      &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22953      &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22954      &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22955      &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22956      &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22957      &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22958      &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22959      &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22960      &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22961      &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22962      &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22963       DATA (DL(K),K=  426,  510) /
22964      &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22965      &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22966      &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
22967      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22968      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22969      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22970      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22971      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22972      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22973      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22974      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22975      &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22976      &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22977      &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22978      &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22979      &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22980      &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22981       DATA (DL(K),K=  511,  595) /
22982      &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
22983      &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
22984      &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
22985      &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
22986      &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
22987      &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
22988      &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
22989      &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
22990      &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
22991      &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
22992      &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
22993      &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
22994      &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
22995      &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
22996      &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
22997      &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
22998      &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
22999       DATA (DL(K),K=  596,  680) /
23000      &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
23001      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23002      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23003      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23004      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23005      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23006      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23007      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23008      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23009      &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23010      &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
23011      &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
23012      &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
23013      &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
23014      &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
23015      &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
23016      &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
23017       DATA (DL(K),K=  681,  765) /
23018      &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
23019      &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
23020      &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
23021      &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
23022      &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
23023      &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
23024      &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
23025      &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
23026      &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
23027      &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
23028      &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
23029      &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
23030      &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
23031      &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
23032      &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
23033      &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
23034      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23035       DATA (DL(K),K=  766,  850) /
23036      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23037      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23038      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23039      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23040      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23041      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23042      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23043      &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23044      &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
23045      &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
23046      &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
23047      &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
23048      &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
23049      &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
23050      &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
23051      &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
23052      &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
23053       DATA (DL(K),K=  851,  935) /
23054      &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
23055      &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
23056      &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
23057      &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
23058      &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
23059      &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
23060      &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
23061      &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
23062      &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
23063      &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
23064      &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
23065      &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
23066      &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
23067      &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
23068      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23069      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23070      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23071       DATA (DL(K),K=  936, 1020) /
23072      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23073      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23074      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23075      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23076      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23077      &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23078      &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
23079      &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
23080      &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
23081      &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
23082      &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
23083      &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
23084      &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
23085      &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
23086      &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
23087      &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
23088      &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
23089       DATA (DL(K),K= 1021, 1105) /
23090      &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
23091      &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
23092      &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
23093      &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
23094      &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
23095      &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
23096      &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
23097      &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
23098      &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
23099      &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
23100      &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
23101      &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
23102      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23103      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23104      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23105      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23106      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23107       DATA (DL(K),K= 1106, 1190) /
23108      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23109      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23110      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23111      &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23112      &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
23113      &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
23114      &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
23115      &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
23116      &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
23117      &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
23118      &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
23119      &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
23120      &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
23121      &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
23122      &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
23123      &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
23124      &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
23125       DATA (DL(K),K= 1191, 1275) /
23126      &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
23127      &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
23128      &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
23129      &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
23130      &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
23131      &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
23132      &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
23133      &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
23134      &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
23135      &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
23136      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23137      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23138      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23139      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23140      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23141      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23142      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23143       DATA (DL(K),K= 1276, 1360) /
23144      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23145      &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23146      &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
23147      &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
23148      &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
23149      &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
23150      &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
23151      &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
23152      &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
23153      &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
23154      &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
23155      &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
23156      &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
23157      &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
23158      &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
23159      &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
23160      &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
23161       DATA (DL(K),K= 1361, 1445) /
23162      &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
23163      &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
23164      &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
23165      &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
23166      &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
23167      &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
23168      &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
23169      &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
23170      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23171      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23172      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23173      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23174      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23175      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23176      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23177      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23178      &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23179       DATA (DL(K),K= 1446, 1530) /
23180      &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
23181      &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
23182      &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
23183      &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
23184      &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
23185      &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
23186      &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
23187      &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
23188      &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
23189      &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
23190      &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
23191      &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
23192      &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
23193      &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
23194      &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
23195      &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
23196      &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
23197       DATA (DL(K),K= 1531, 1615) /
23198      &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
23199      &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
23200      &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
23201      &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
23202      &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
23203      &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
23204      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23205      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23206      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23207      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23208      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23209      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23210      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23211      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23212      &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23213      &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
23214      &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
23215       DATA (DL(K),K= 1616, 1700) /
23216      &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
23217      &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
23218      &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
23219      &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
23220      &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
23221      &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
23222      &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
23223      &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
23224      &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
23225      &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
23226      &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
23227      &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
23228      &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
23229      &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
23230      &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
23231      &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
23232      &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
23233       DATA (DL(K),K= 1701, 1785) /
23234      &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
23235      &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
23236      &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
23237      &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
23238      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23239      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23240      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23241      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23242      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23243      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23244      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23245      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23246      &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23247      &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
23248      &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
23249      &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
23250      &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
23251       DATA (DL(K),K= 1786, 1870) /
23252      &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
23253      &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
23254      &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
23255      &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
23256      &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
23257      &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
23258      &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
23259      &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
23260      &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
23261      &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
23262      &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
23263      &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
23264      &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
23265      &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
23266      &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
23267      &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
23268      &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
23269       DATA (DL(K),K= 1871, 1955) /
23270      &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
23271      &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
23272      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23273      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23274      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23275      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23276      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23277      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23278      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23279      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23280      &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23281      &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
23282      &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
23283      &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
23284      &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
23285      &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
23286      &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
23287       DATA (DL(K),K= 1956, 2040) /
23288      &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
23289      &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
23290      &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
23291      &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
23292      &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
23293      &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
23294      &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
23295      &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
23296      &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
23297      &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
23298      &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
23299      &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
23300      &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
23301      &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
23302      &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
23303      &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
23304      &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
23305       DATA (DL(K),K= 2041, 2125) /
23306      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23307      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23308      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23309      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23310      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23311      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23312      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23313      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23314      &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23315      &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
23316      &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
23317      &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
23318      &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
23319      &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
23320      &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
23321      &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
23322      &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
23323       DATA (DL(K),K= 2126, 2210) /
23324      &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
23325      &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
23326      &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
23327      &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
23328      &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
23329      &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
23330      &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
23331      &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
23332      &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
23333      &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
23334      &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
23335      &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
23336      &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
23337      &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
23338      &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
23339      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23340      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23341       DATA (DL(K),K= 2211, 2295) /
23342      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23343      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23344      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23345      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23346      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23347      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23348      &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23349      &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23350      &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23351      &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23352      &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23353      &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23354      &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23355      &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23356      &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23357      &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23358      &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23359       DATA (DL(K),K= 2296, 2380) /
23360      &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23361      &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23362      &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23363      &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23364      &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23365      &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23366      &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23367      &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23368      &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23369      &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23370      &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23371      &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23372      &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
23373      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23374      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23375      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23376      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23377       DATA (DL(K),K= 2381, 2465) /
23378      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23379      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23380      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23381      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23382      &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23383      &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23384      &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23385      &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23386      &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23387      &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23388      &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23389      &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23390      &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23391      &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23392      &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23393      &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23394      &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23395       DATA (DL(K),K= 2466, 2550) /
23396      &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23397      &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23398      &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23399      &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23400      &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23401      &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23402      &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23403      &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23404      &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23405      &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23406      &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
23407      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23408      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23409      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23410      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23411      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23412      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23413       DATA (DL(K),K= 2551, 2635) /
23414      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23415      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23416      &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23417      &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23418      &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23419      &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23420      &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23421      &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23422      &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23423      &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23424      &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23425      &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23426      &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23427      &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23428      &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23429      &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23430      &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23431       DATA (DL(K),K= 2636, 2720) /
23432      &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23433      &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23434      &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23435      &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23436      &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23437      &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23438      &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23439      &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23440      &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
23441      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23442      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23443      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23444      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23445      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23446      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23447      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23448      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23449       DATA (DL(K),K= 2721, 2805) /
23450      &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23451      &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23452      &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23453      &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23454      &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23455      &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23456      &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23457      &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23458      &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23459      &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23460      &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23461      &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23462      &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23463      &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23464      &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23465      &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23466      &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23467       DATA (DL(K),K= 2806, 2890) /
23468      &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23469      &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23470      &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23471      &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23472      &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23473      &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23474      &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
23475      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23476      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23477      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23478      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23479      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23480      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23481      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23482      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23483      &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23484      &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23485       DATA (DL(K),K= 2891, 2975) /
23486      &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23487      &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23488      &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23489      &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23490      &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23491      &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23492      &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23493      &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23494      &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23495      &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23496      &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23497      &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23498      &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23499      &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23500      &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23501      &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23502      &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23503       DATA (DL(K),K= 2976, 3060) /
23504      &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23505      &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23506      &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23507      &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23508      &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
23509      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23510      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23511      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23512      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23513      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23514      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23515      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23516      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23517      &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23518      &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23519      &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23520      &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23521       DATA (DL(K),K= 3061, 3145) /
23522      &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23523      &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23524      &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23525      &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23526      &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23527      &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23528      &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23529      &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23530      &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23531      &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23532      &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23533      &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23534      &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23535      &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23536      &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23537      &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23538      &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23539       DATA (DL(K),K= 3146, 3230) /
23540      &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23541      &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23542      &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
23543      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23544      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23545      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23546      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23547      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23548      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23549      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23550      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23551      &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23552      &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23553      &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23554      &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23555      &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23556      &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23557       DATA (DL(K),K= 3231, 3315) /
23558      &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23559      &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23560      &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23561      &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23562      &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23563      &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23564      &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23565      &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23566      &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23567      &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23568      &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23569      &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23570      &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23571      &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23572      &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23573      &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23574      &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23575       DATA (DL(K),K= 3316, 3400) /
23576      &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
23577      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23578      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23579      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23580      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23581      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23582      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23583      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23584      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23585      &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23586      &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23587      &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23588      &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23589      &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23590      &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23591      &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23592      &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23593       DATA (DL(K),K= 3401, 3485) /
23594      &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23595      &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23596      &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23597      &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23598      &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23599      &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23600      &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23601      &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23602      &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23603      &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23604      &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23605      &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23606      &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23607      &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23608      &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23609      &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23610      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23611       DATA (DL(K),K= 3486, 3570) /
23612      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23613      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23614      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23615      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23616      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23617      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23618      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23619      &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23620      &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23621      &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23622      &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23623      &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23624      &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23625      &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23626      &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23627      &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23628      &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23629       DATA (DL(K),K= 3571, 3655) /
23630      &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23631      &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23632      &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23633      &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23634      &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23635      &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23636      &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23637      &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23638      &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23639      &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23640      &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23641      &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23642      &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23643      &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
23644      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23645      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23646      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23647       DATA (DL(K),K= 3656, 3740) /
23648      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23649      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23650      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23651      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23652      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23653      &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23654      &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23655      &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23656      &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23657      &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23658      &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23659      &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23660      &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23661      &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23662      &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23663      &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23664      &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23665       DATA (DL(K),K= 3741, 3825) /
23666      &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23667      &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23668      &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23669      &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23670      &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23671      &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23672      &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23673      &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23674      &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23675      &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23676      &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23677      &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
23678      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23679      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23680      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23681      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23682      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23683       DATA (DL(K),K= 3826, 3910) /
23684      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23685      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23686      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23687      &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23688      &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23689      &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23690      &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23691      &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23692      &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23693      &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23694      &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23695      &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23696      &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23697      &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23698      &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23699      &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23700      &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23701       DATA (DL(K),K= 3911, 3995) /
23702      &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23703      &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23704      &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23705      &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23706      &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23707      &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23708      &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23709      &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23710      &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23711      &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
23712      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23713      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23714      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23715      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23716      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23717      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23718      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23719       DATA (DL(K),K= 3996, 4000) /
23720      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23721 C
23722       ANS = 0.
23723       IF (X.GT.0.9985) RETURN
23724       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23725 C
23726       IS  = S/DELTA+1
23727       IS1 = IS+1
23728       DO 1 L=1,25
23729          KL    = L+NDRV*25
23730          F1(L) = GF(I,IS,KL)
23731          F2(L) = GF(I,IS1,KL)
23732     1 CONTINUE
23733       A1 = DT_CKMTFF(X,F1)
23734       A2 = DT_CKMTFF(X,F2)
23735 C      A1=ALOG(A1)
23736 C      A2=ALOG(A2)
23737       S1  = (IS-1)*DELTA
23738       S2  = S1+DELTA
23739       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23740 C      ANS=EXP(ANS)
23741       RETURN
23742       END
23743 C
23744 C
23745
23746 *$ CREATE DT_CKMTPR.FOR
23747 *COPY DT_CKMTPR
23748       SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23749 C
23750 C**********************************************************************
23751 C    Proton   - PDFs
23752 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23753 C    ANS = PDF(I)
23754 C    This version by S. Roesler, 31.01.96
23755 C**********************************************************************
23756
23757       SAVE
23758       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23759       EQUIVALENCE (GF(1,1,1),DL(1))
23760       DATA DELTA/.10/
23761 C
23762       DATA (DL(K),K=    1,   85) /
23763      &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23764      &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23765      &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23766      &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23767      &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23768      &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23769      &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23770      &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23771      &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23772      &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23773      &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23774      &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23775      &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23776      &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23777      &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23778      &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23779      &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23780       DATA (DL(K),K=   86,  170) /
23781      &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23782      &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23783      &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23784      &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23785      &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23786      &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23787      &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23788      &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23789      &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23790      &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23791      &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23792      &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23793      &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23794      &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23795      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23796      &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23797      &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23798       DATA (DL(K),K=  171,  255) /
23799      &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23800      &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23801      &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23802      &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23803      &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23804      &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23805      &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23806      &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23807      &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23808      &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23809      &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23810      &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23811      &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23812      &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23813      &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23814      &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23815      &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23816       DATA (DL(K),K=  256,  340) /
23817      &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23818      &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23819      &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23820      &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23821      &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23822      &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23823      &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23824      &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23825      &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23826      &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23827      &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23828      &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23829      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23830      &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23831      &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23832      &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23833      &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23834       DATA (DL(K),K=  341,  425) /
23835      &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23836      &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23837      &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23838      &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23839      &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23840      &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23841      &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23842      &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23843      &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23844      &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23845      &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23846      &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23847      &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23848      &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23849      &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23850      &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23851      &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23852       DATA (DL(K),K=  426,  510) /
23853      &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23854      &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23855      &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23856      &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23857      &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23858      &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23859      &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23860      &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23861      &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23862      &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23863      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23864      &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23865      &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23866      &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23867      &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23868      &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23869      &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23870       DATA (DL(K),K=  511,  595) /
23871      &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23872      &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23873      &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23874      &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23875      &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23876      &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23877      &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23878      &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23879      &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23880      &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23881      &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23882      &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23883      &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23884      &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23885      &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23886      &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23887      &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23888       DATA (DL(K),K=  596,  680) /
23889      &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23890      &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23891      &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23892      &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23893      &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23894      &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23895      &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23896      &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23897      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23898      &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23899      &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23900      &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23901      &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23902      &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23903      &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23904      &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23905      &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23906       DATA (DL(K),K=  681,  765) /
23907      &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23908      &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23909      &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23910      &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23911      &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23912      &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23913      &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23914      &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23915      &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23916      &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23917      &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23918      &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23919      &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23920      &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23921      &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23922      &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23923      &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23924       DATA (DL(K),K=  766,  850) /
23925      &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23926      &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23927      &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23928      &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23929      &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23930      &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23931      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23932      &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23933      &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23934      &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23935      &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23936      &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23937      &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23938      &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23939      &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23940      &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23941      &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23942       DATA (DL(K),K=  851,  935) /
23943      &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23944      &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23945      &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23946      &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23947      &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23948      &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23949      &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23950      &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23951      &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23952      &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23953      &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23954      &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23955      &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23956      &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23957      &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23958      &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23959      &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23960       DATA (DL(K),K=  936, 1020) /
23961      &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23962      &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23963      &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23964      &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23965      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23966      &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23967      &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23968      &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23969      &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23970      &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23971      &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23972      &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23973      &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23974      &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23975      &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23976      &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23977      &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23978       DATA (DL(K),K= 1021, 1105) /
23979      &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23980      &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23981      &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23982      &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
23983      &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
23984      &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
23985      &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
23986      &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
23987      &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
23988      &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
23989      &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
23990      &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
23991      &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
23992      &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
23993      &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
23994      &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
23995      &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
23996       DATA (DL(K),K= 1106, 1190) /
23997      &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
23998      &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23999      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24000      &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
24001      &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
24002      &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
24003      &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
24004      &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
24005      &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
24006      &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
24007      &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
24008      &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
24009      &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
24010      &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
24011      &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
24012      &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
24013      &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
24014       DATA (DL(K),K= 1191, 1275) /
24015      &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
24016      &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
24017      &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
24018      &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
24019      &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
24020      &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
24021      &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
24022      &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
24023      &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
24024      &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
24025      &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
24026      &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
24027      &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
24028      &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
24029      &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
24030      &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
24031      &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
24032       DATA (DL(K),K= 1276, 1360) /
24033      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24034      &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
24035      &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
24036      &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
24037      &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
24038      &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
24039      &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
24040      &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
24041      &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
24042      &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
24043      &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
24044      &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
24045      &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
24046      &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
24047      &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
24048      &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
24049      &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
24050       DATA (DL(K),K= 1361, 1445) /
24051      &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
24052      &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
24053      &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
24054      &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
24055      &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
24056      &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
24057      &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
24058      &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
24059      &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
24060      &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
24061      &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
24062      &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
24063      &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
24064      &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
24065      &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
24066      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24067      &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
24068       DATA (DL(K),K= 1446, 1530) /
24069      &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
24070      &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
24071      &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
24072      &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
24073      &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
24074      &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
24075      &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
24076      &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
24077      &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
24078      &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
24079      &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
24080      &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
24081      &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
24082      &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
24083      &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
24084      &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
24085      &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
24086       DATA (DL(K),K= 1531, 1615) /
24087      &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
24088      &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
24089      &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
24090      &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
24091      &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
24092      &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
24093      &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
24094      &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
24095      &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
24096      &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
24097      &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
24098      &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
24099      &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24100      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24101      &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
24102      &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
24103      &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
24104       DATA (DL(K),K= 1616, 1700) /
24105      &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
24106      &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
24107      &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
24108      &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
24109      &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
24110      &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
24111      &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
24112      &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
24113      &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
24114      &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
24115      &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
24116      &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
24117      &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
24118      &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
24119      &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
24120      &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
24121      &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
24122       DATA (DL(K),K= 1701, 1785) /
24123      &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
24124      &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
24125      &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
24126      &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
24127      &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
24128      &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
24129      &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
24130      &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
24131      &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
24132      &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
24133      &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24134      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24135      &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
24136      &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
24137      &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
24138      &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
24139      &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
24140       DATA (DL(K),K= 1786, 1870) /
24141      &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
24142      &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
24143      &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
24144      &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
24145      &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
24146      &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
24147      &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
24148      &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
24149      &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
24150      &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
24151      &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
24152      &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
24153      &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
24154      &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
24155      &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
24156      &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
24157      &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
24158       DATA (DL(K),K= 1871, 1955) /
24159      &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
24160      &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
24161      &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
24162      &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
24163      &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
24164      &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
24165      &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
24166      &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
24167      &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24168      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24169      &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
24170      &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
24171      &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
24172      &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
24173      &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
24174      &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
24175      &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
24176       DATA (DL(K),K= 1956, 2040) /
24177      &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
24178      &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
24179      &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
24180      &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
24181      &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
24182      &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
24183      &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
24184      &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
24185      &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
24186      &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
24187      &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
24188      &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
24189      &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
24190      &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
24191      &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
24192      &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
24193      &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
24194       DATA (DL(K),K= 2041, 2125) /
24195      &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
24196      &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
24197      &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
24198      &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
24199      &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
24200      &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
24201      &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24202      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24203      &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
24204      &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
24205      &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
24206      &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
24207      &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
24208      &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
24209      &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
24210      &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
24211      &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
24212       DATA (DL(K),K= 2126, 2210) /
24213      &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
24214      &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
24215      &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
24216      &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
24217      &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
24218      &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
24219      &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
24220      &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
24221      &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
24222      &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
24223      &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
24224      &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
24225      &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
24226      &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
24227      &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
24228      &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
24229      &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
24230       DATA (DL(K),K= 2211, 2295) /
24231      &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
24232      &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
24233      &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
24234      &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
24235      &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24236      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24237      &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
24238      &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
24239      &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
24240      &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
24241      &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
24242      &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
24243      &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
24244      &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
24245      &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
24246      &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
24247      &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
24248       DATA (DL(K),K= 2296, 2380) /
24249      &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
24250      &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
24251      &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
24252      &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
24253      &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
24254      &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
24255      &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
24256      &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
24257      &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
24258      &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
24259      &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
24260      &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
24261      &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
24262      &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
24263      &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
24264      &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
24265      &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
24266       DATA (DL(K),K= 2381, 2465) /
24267      &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
24268      &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
24269      &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24270      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24271      &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
24272      &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
24273      &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
24274      &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
24275      &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
24276      &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
24277      &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
24278      &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
24279      &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
24280      &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
24281      &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
24282      &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
24283      &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
24284       DATA (DL(K),K= 2466, 2550) /
24285      &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
24286      &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
24287      &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
24288      &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
24289      &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
24290      &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
24291      &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
24292      &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
24293      &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
24294      &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
24295      &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
24296      &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
24297      &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
24298      &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
24299      &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
24300      &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
24301      &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
24302       DATA (DL(K),K= 2551, 2635) /
24303      &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24304      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24305      &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
24306      &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
24307      &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
24308      &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
24309      &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
24310      &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
24311      &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
24312      &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
24313      &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
24314      &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
24315      &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
24316      &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
24317      &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
24318      &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
24319      &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
24320       DATA (DL(K),K= 2636, 2720) /
24321      &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
24322      &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
24323      &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
24324      &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
24325      &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
24326      &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
24327      &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
24328      &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
24329      &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
24330      &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
24331      &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
24332      &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
24333      &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
24334      &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
24335      &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
24336      &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24337      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24338       DATA (DL(K),K= 2721, 2805) /
24339      &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
24340      &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
24341      &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
24342      &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
24343      &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24344      &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24345      &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24346      &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24347      &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24348      &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24349      &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24350      &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24351      &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24352      &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24353      &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24354      &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24355      &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24356       DATA (DL(K),K= 2806, 2890) /
24357      &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24358      &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24359      &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24360      &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24361      &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24362      &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24363      &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24364      &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24365      &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24366      &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24367      &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24368      &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24369      &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24370      &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24371      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24372      &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24373      &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24374       DATA (DL(K),K= 2891, 2975) /
24375      &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24376      &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24377      &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24378      &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24379      &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24380      &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24381      &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24382      &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24383      &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24384      &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24385      &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24386      &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24387      &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24388      &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24389      &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24390      &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24391      &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24392       DATA (DL(K),K= 2976, 3060) /
24393      &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24394      &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24395      &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24396      &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24397      &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24398      &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24399      &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24400      &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24401      &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24402      &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24403      &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24404      &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24405      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24406      &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24407      &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24408      &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24409      &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24410       DATA (DL(K),K= 3061, 3145) /
24411      &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24412      &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24413      &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24414      &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24415      &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24416      &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24417      &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24418      &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24419      &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24420      &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24421      &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24422      &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24423      &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24424      &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24425      &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24426      &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24427      &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24428       DATA (DL(K),K= 3146, 3230) /
24429      &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24430      &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24431      &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24432      &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24433      &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24434      &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24435      &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24436      &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24437      &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24438      &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24439      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24440      &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24441      &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24442      &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24443      &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24444      &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24445      &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24446       DATA (DL(K),K= 3231, 3315) /
24447      &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24448      &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24449      &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24450      &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24451      &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24452      &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24453      &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24454      &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24455      &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24456      &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24457      &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24458      &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24459      &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24460      &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24461      &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24462      &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24463      &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24464       DATA (DL(K),K= 3316, 3400) /
24465      &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24466      &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24467      &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24468      &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24469      &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24470      &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24471      &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24472      &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24473      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24474      &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24475      &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24476      &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24477      &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24478      &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24479      &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24480      &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24481      &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24482       DATA (DL(K),K= 3401, 3485) /
24483      &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24484      &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24485      &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24486      &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24487      &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24488      &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24489      &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24490      &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24491      &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24492      &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24493      &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24494      &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24495      &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24496      &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24497      &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24498      &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24499      &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24500       DATA (DL(K),K= 3486, 3570) /
24501      &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24502      &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24503      &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24504      &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24505      &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24506      &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24507      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24508      &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24509      &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24510      &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24511      &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24512      &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24513      &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24514      &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24515      &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24516      &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24517      &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24518       DATA (DL(K),K= 3571, 3655) /
24519      &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24520      &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24521      &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24522      &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24523      &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24524      &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24525      &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24526      &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24527      &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24528      &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24529      &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24530      &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24531      &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24532      &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24533      &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24534      &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24535      &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24536       DATA (DL(K),K= 3656, 3740) /
24537      &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24538      &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24539      &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24540      &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24541      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24542      &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24543      &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24544      &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24545      &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24546      &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24547      &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24548      &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24549      &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24550      &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24551      &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24552      &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24553      &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24554       DATA (DL(K),K= 3741, 3825) /
24555      &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24556      &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24557      &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24558      &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24559      &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24560      &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24561      &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24562      &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24563      &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24564      &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24565      &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24566      &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24567      &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24568      &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24569      &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24570      &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24571      &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24572       DATA (DL(K),K= 3826, 3910) /
24573      &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24574      &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24575      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24576      &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24577      &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24578      &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24579      &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24580      &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24581      &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24582      &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24583      &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24584      &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24585      &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24586      &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24587      &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24588      &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24589      &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24590       DATA (DL(K),K= 3911, 3995) /
24591      &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24592      &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24593      &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24594      &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24595      &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24596      &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24597      &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24598      &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24599      &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24600      &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24601      &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24602      &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24603      &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24604      &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24605      &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24606      &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24607      &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24608       DATA (DL(K),K= 3996, 4000) /
24609      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24610 C
24611       ANS = 0.
24612       IF (X.GT.0.9985) RETURN
24613       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24614 C
24615       IS  = S/DELTA+1
24616       IS1 = IS+1
24617       DO 1 L=1,25
24618          KL    = L+NDRV*25
24619          F1(L) = GF(I,IS,KL)
24620          F2(L) = GF(I,IS1,KL)
24621     1 CONTINUE
24622       A1 = DT_CKMTFF(X,F1)
24623       A2 = DT_CKMTFF(X,F2)
24624 C      A1=ALOG(A1)
24625 C      A2=ALOG(A2)
24626       S1  = (IS-1)*DELTA
24627       S2  = S1+DELTA
24628       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24629 C      ANS=EXP(ANS)
24630       RETURN
24631       END
24632 C
24633
24634 *$ CREATE DT_CKMTFF.FOR
24635 *COPY DT_CKMTFF
24636       FUNCTION DT_CKMTFF(X,FVL)
24637 C**********************************************************************
24638 C
24639 C     LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24640 C     FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24641 C     NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24642 C     IN MAIN ROUTINE.
24643 C
24644 C**********************************************************************
24645
24646       SAVE
24647       DIMENSION FVL(25),XGRID(25)
24648       DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24649      *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24650 C
24651       DT_CKMTFF=0.
24652       DO 1 I=1,NX
24653       IF(X.LT.XGRID(I)) GO TO 2
24654     1 CONTINUE
24655     2 I=I-1
24656       IF(I.EQ.0) THEN
24657          I=I+1
24658       ELSE IF(I.GT.23) THEN
24659          I=23
24660       ENDIF
24661       J=I+1
24662       K=J+1
24663       AXI=LOG(XGRID(I))
24664       BXI=LOG(1.-XGRID(I))
24665       AXJ=LOG(XGRID(J))
24666       BXJ=LOG(1.-XGRID(J))
24667       AXK=LOG(XGRID(K))
24668       BXK=LOG(1.-XGRID(K))
24669       FI=LOG(ABS(FVL(I)) +1.E-15)
24670       FJ=LOG(ABS(FVL(J)) +1.E-16)
24671       FK=LOG(ABS(FVL(K)) +1.E-17)
24672       DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24673       ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24674      $ BXI))/DET
24675       ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24676       BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24677       IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24678      1RETURN
24679 C      IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24680 C         WRITE(6,2001) X,FVL
24681 C 2001    FORMAT(8E12.4)
24682 C         WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24683 C      ENDIF
24684       DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24685       RETURN
24686       END
24687
24688 *$ CREATE DT_FLUINI.FOR
24689 *COPY DT_FLUINI
24690 *
24691 *===fluini=============================================================*
24692 *
24693       SUBROUTINE DT_FLUINI
24694
24695 ************************************************************************
24696 * Initialisation of the nucleon-nucleon cross section fluctuation      *
24697 * treatment. The original version by J. Ranft.                         *
24698 * This version dated 21.04.95 is revised by S. Roesler.                *
24699 ************************************************************************
24700
24701       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24702       SAVE
24703       PARAMETER ( LINP = 10 ,
24704      &            LOUT = 6 ,
24705      &            LDAT = 9 )
24706       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24707
24708       PARAMETER ( A     = 0.1D0,
24709      &            B     = 0.893D0,
24710      &            OM    = 1.1D0,
24711      &            N     = 6,
24712      &            DX    = 0.003D0)
24713
24714 * n-n cross section fluctuations
24715       PARAMETER (NBINS = 1000)
24716       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24717       DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24718
24719       WRITE(LOUT,1000)
24720  1000 FORMAT(/,1X,'FLUINI:  hadronic cross section fluctuations ',
24721      &       'treated')
24722
24723       FLUSU  = ZERO
24724       FLUSUU = ZERO
24725
24726       DO 1 I=1,NBINS
24727          X        = DBLE(I)*DX
24728          FLUIX(I) = X
24729          FLUS     = ((X-B)/(OM*B))**N
24730          IF (FLUS.LE.20.0D0) THEN
24731             FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24732          ELSE
24733             FLUSI(I) = ZERO
24734          ENDIF
24735          FLUSU = FLUSU+FLUSI(I)
24736     1 CONTINUE
24737       DO 2 I=1,NBINS
24738          FLUSUU   = FLUSUU+FLUSI(I)/FLUSU
24739          FLUSI(I) = FLUSUU
24740     2 CONTINUE
24741
24742 C     WRITE(LOUT,1001)
24743 C1001 FORMAT(1X,'FLUCTUATIONS')
24744 C     CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24745
24746       DO 3 I=1,NBINS
24747          AF = DBLE(I)*0.001D0
24748          DO 4 J=1,NBINS
24749             IF (AF.LE.FLUSI(J)) THEN
24750                FLUIXX(I) = FLUIX(J)
24751                GOTO 5
24752             ENDIF
24753     4    CONTINUE
24754     5    CONTINUE
24755     3 CONTINUE
24756       FLUIXX(1)     = FLUIX(1)
24757       FLUIXX(NBINS) = FLUIX(NBINS)
24758
24759       RETURN
24760       END
24761
24762 *$ CREATE DT_SIGTBL.FOR
24763 *COPY DT_SIGTBL
24764 *
24765 *===sigtab=============================================================*
24766 *
24767       SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24768
24769 ************************************************************************
24770 * This version dated 18.11.95 is written by S. Roesler                 *
24771 ************************************************************************
24772
24773       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24774       SAVE
24775       PARAMETER ( LINP = 10 ,
24776      &            LOUT = 6 ,
24777      &            LDAT = 9 )
24778
24779       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24780      &           OHALF=0.5D0,ONE=1.0D0)
24781       PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24782
24783       LOGICAL LINIT
24784
24785 * particle properties (BAMJET index convention)
24786       CHARACTER*8  ANAME
24787       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24788      &                IICH(210),IIBAR(210),K1(210),K2(210)
24789
24790       DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24791       DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24792      &             0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24793      &             0, 0, 5/
24794       DATA LINIT /.FALSE./
24795
24796 * precalculation and tabulation of elastic cross sections
24797       IF (ABS(MODE).EQ.1) THEN
24798          IF (MODE.EQ.1)
24799      &      OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24800          PLABLX = LOG10(PLO)
24801          PLABHX = LOG10(PHI)
24802          DPLAB  = (PLABHX-PLABLX)/DBLE(NBINS)
24803          DO 1 I=1,NBINS+1
24804             PLAB = PLABLX+DBLE(I-1)*DPLAB
24805             PLAB = 10**PLAB
24806             DO 2 IPROJ=1,23
24807                IDX = IDSIG(IPROJ)
24808                IF (IDX.GT.0) THEN
24809 C                 CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24810 C                 CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24811                   DUMZER = ZERO
24812                   CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24813                   CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24814                ENDIF
24815     2       CONTINUE
24816             IF (MODE.EQ.1) THEN
24817                WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24818      &                                (SIGEN(IDX,I),IDX=1,5)
24819  1000          FORMAT(F5.1,10F7.2)
24820             ENDIF
24821     1    CONTINUE
24822          IF (MODE.EQ.1) CLOSE(LDAT)
24823          LINIT = .TRUE.
24824       ELSE
24825          SIGE = -ONE
24826          IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24827      &                           .AND.(PTOT.LE.PHI) ) THEN
24828             IDX = IDSIG(JP)
24829             IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24830                PLABX = LOG10(PTOT)
24831                IF (PLABX.LE.PLABLX) THEN
24832                   I1 = 1
24833                   I2 = 1
24834                ELSEIF (PLABX.GE.PLABHX) THEN
24835                   I1 = NBINS+1
24836                   I2 = NBINS+1
24837                ELSE
24838                   I1 = INT((PLABX-PLABLX)/DPLAB)+1
24839                   I2 = I1+1
24840                ENDIF
24841                PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24842                PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24843                PBIN   = PLAB2X-PLAB1X
24844                IF (PBIN.GT.TINY10) THEN
24845                   RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24846                ELSE
24847                   RATX = ZERO
24848                ENDIF
24849                IF (JT.EQ.1) THEN
24850                   SIG1 = SIGEP(IDX,I1)
24851                   SIG2 = SIGEP(IDX,I2)
24852                ELSE
24853                   SIG1 = SIGEN(IDX,I1)
24854                   SIG2 = SIGEN(IDX,I2)
24855                ENDIF
24856                SIGE = SIG1+RATX*(SIG2-SIG1)
24857             ENDIF
24858          ENDIF
24859       ENDIF
24860
24861       RETURN
24862       END
24863
24864 *$ CREATE DT_XSTABL.FOR
24865 *COPY DT_XSTABL
24866 *
24867 *===xstabl=============================================================*
24868 *
24869       SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24870
24871       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24872       SAVE
24873       PARAMETER ( LINP = 10 ,
24874      &            LOUT = 6 ,
24875      &            LDAT = 9 )
24876       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24877      &           OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24878       LOGICAL LLAB,LELOG,LQLOG
24879
24880 * particle properties (BAMJET index convention)
24881       CHARACTER*8  ANAME
24882       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24883      &                IICH(210),IIBAR(210),K1(210),K2(210)
24884 * properties of interacting particles
24885       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24886       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24887 * Glauber formalism: cross sections
24888       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24889      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24890      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24891      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24892      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24893      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24894      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24895      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24896      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24897      &                BSLOPE,NEBINI,NQBINI
24898 * emulsion treatment
24899       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24900      &                NCOMPO,IEMUL
24901
24902       DIMENSION WHAT(6)
24903
24904       LLAB   = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24905       ELO    = ABS(WHAT(1))
24906       EHI    = ABS(WHAT(2))
24907       IF (ELO.GT.EHI) ELO = EHI
24908       LELOG  = WHAT(3).LT.ZERO
24909       NEBINS = MAX(INT(ABS(WHAT(3))),1)
24910       DEBINS = (EHI-ELO)/DBLE(NEBINS)
24911       IF (LELOG) THEN
24912          AELO   = LOG10(ELO)
24913          AEHI   = LOG10(EHI)
24914          ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24915       ENDIF
24916       Q2LO   = WHAT(4)
24917       Q2HI   = WHAT(5)
24918       IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24919       LQLOG  = WHAT(6).LT.ZERO
24920       NQBINS = MAX(INT(ABS(WHAT(6))),1)
24921       DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24922       IF (LQLOG) THEN
24923          AQ2LO  = LOG10(Q2LO)
24924          AQ2HI  = LOG10(Q2HI)
24925          ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24926       ENDIF
24927
24928       IF ( ELO.EQ. EHI) NEBINS = 0
24929       IF (Q2LO.EQ.Q2HI) NQBINS = 0
24930
24931       WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24932  1000 FORMAT(/,1X,'XSTABL:  E_lo  =',E10.3,' GeV  E_hi  =',E10.3,
24933      &       ' GeV     Lab = ',L1,'  qel: ',I2,/,10X,'Q2_lo =',F10.5,
24934      &       ' GeV^2  Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24935      &       '   A_p = ',I3,'   A_t = ',I3,/)
24936
24937 C     IF (IJPROJ.NE.7) THEN
24938          WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24939 * normalize fractions of emulsion components
24940          IF (NCOMPO.GT.0) THEN
24941             SUMFRA = ZERO
24942             DO 10 I=1,NCOMPO
24943                SUMFRA = SUMFRA+EMUFRA(I)
24944    10       CONTINUE
24945             IF (SUMFRA.GT.ZERO) THEN
24946                DO 11 I=1,NCOMPO
24947                   EMUFRA(I) = EMUFRA(I)/SUMFRA
24948    11          CONTINUE
24949             ENDIF
24950          ENDIF
24951 C     ELSE
24952 C        WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24953 C     ENDIF
24954       DO 1 I=1,NEBINS+1
24955          IF (LELOG) THEN
24956             E = 10**(AELO+DBLE(I-1)*ADEBIN)
24957          ELSE
24958             E = ELO+DBLE(I-1)*DEBINS
24959          ENDIF
24960          DO 2 J=1,NQBINS+1
24961             IF (LQLOG) THEN
24962                Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24963             ELSE
24964                Q2 = Q2LO+DBLE(J-1)*DQBINS
24965             ENDIF
24966 c            IF (IJPROJ.NE.7) THEN
24967                IF (LLAB) THEN
24968                   PLAB = ZERO
24969                   ECM  = ZERO
24970                   CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24971                ELSE
24972                   ECM = E
24973                ENDIF
24974                XI  = ZERO
24975                Q2I = ZERO
24976                IF (IJPROJ.EQ.7) Q2I = Q2
24977                IF (NCOMPO.GT.0) THEN
24978                   DO 20 IC=1,NCOMPO
24979                      IIT = IEMUMA(IC)
24980                      CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
24981    20             CONTINUE
24982                ELSE
24983                   CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
24984 C                 CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
24985                ENDIF
24986                IF (NCOMPO.GT.0) THEN
24987                   XTOT = ZERO
24988                   ETOT = ZERO
24989                   XELA = ZERO
24990                   EELA = ZERO
24991                   XQEP = ZERO
24992                   EQEP = ZERO
24993                   XQET = ZERO
24994                   EQET = ZERO
24995                   XQE2 = ZERO
24996                   EQE2 = ZERO
24997                   XPRO = ZERO
24998                   EPRO = ZERO
24999                   XPRO1= ZERO
25000                   XDEL = ZERO
25001                   EDEL = ZERO
25002                   XDQE = ZERO
25003                   EDQE = ZERO
25004                   DO 21 IC=1,NCOMPO
25005                      XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
25006                      ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
25007                      XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
25008                      EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
25009                      XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
25010                      EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
25011                      XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
25012                      EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
25013                      XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
25014                      EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
25015                      XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
25016                      EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
25017                      XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
25018                      EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
25019                      XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
25020                      EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
25021                      YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
25022      &                     -XSQEP(1,1,IC)-XSQET(1,1,IC)
25023      &                     -XSQE2(1,1,IC)
25024                      XPRO1= XPRO1+EMUFRA(IC)*YPRO
25025    21             CONTINUE
25026                   ETOT = SQRT(ETOT)
25027                   EELA = SQRT(EELA)
25028                   EQEP = SQRT(EQEP)
25029                   EQET = SQRT(EQET)
25030                   EQE2 = SQRT(EQE2)
25031                   EPRO = SQRT(EPRO)
25032                   EDEL = SQRT(EDEL)
25033                   EDQE = SQRT(EDQE)
25034                   WRITE(LOUT,'(8E9.3)')
25035      &               E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
25036 C                 WRITE(LOUT,'(4E9.3)')
25037 C    &               E,XDEL,XDQE,XDEL+XDQE
25038                ELSE
25039                   WRITE(LOUT,'(11E10.3)')
25040      &              E,
25041      &              XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
25042      &              XSQE2(1,1,1),XSPRO(1,1,1),
25043      &              XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
25044      &             -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
25045      &              XSDEL(1,1,1)+XSDQE(1,1,1)
25046 C                 WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
25047 C    &                                    XSDEL(1,1,1)+XSDQE(1,1,1)
25048                ENDIF
25049 c            ELSE
25050 c               IF (LLAB) THEN
25051 c                  IF (IT.GT.1) THEN
25052 c                     IF (IXSQEL.EQ.0) THEN
25053 cC                       CALL DT_SIGGA(IT,  Q2, E,ZERO,ZERO,
25054 cC                       CALL DT_SIGGA(IT,   E,Q2,ZERO,ZERO,
25055 c                        CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
25056 c     &                             STOT,ETOT,SIN,EIN,STOT0)
25057 c                        IF (IRATIO.EQ.1) THEN
25058 c                           CALL DT_SIGGP(  Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
25059 cC                          CALL DT_SIGGP(   E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
25060 cC                          CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
25061 c*!! save cross sections
25062 c                           STOTA = STOT
25063 c                           ETOTA = ETOT
25064 c                           STOTP = STGP
25065 c*!!
25066 c                           STOT  = STOT/(DBLE(IT)*STGP)
25067 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
25068 c                           STOT0 = STGP
25069 c                           ETOT  = ZERO
25070 c                           EIN   = ZERO
25071 c                        ENDIF
25072 c                     ELSE
25073 c                        WRITE(LOUT,*)
25074 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
25075 c                        STOP
25076 c                     ENDIF
25077 c                  ELSE
25078 c                     ETOT = ZERO
25079 c                     EIN  = ZERO
25080 c                     STOT0= ZERO
25081 c                     IF (IXSQEL.EQ.0) THEN
25082 c                        CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
25083 c                     ELSE
25084 c                       SIN = ZERO
25085 c                       CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
25086 c                     ENDIF
25087 c                  ENDIF
25088 c               ELSE
25089 c                  IF (IT.GT.1) THEN
25090 c                     IF (IXSQEL.EQ.0) THEN
25091 c                        CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
25092 c     &                             STOT,ETOT,SIN,EIN,STOT0)
25093 c                        IF (IRATIO.EQ.1) THEN
25094 c                           CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
25095 c*!! save cross sections
25096 c                           STOTA = STOT
25097 c                           ETOTA = ETOT
25098 c                           STOTP = STGP
25099 c*!!
25100 c                           STOT  = STOT/(DBLE(IT)*STGP)
25101 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
25102 c                           STOT0 = STGP
25103 c                           ETOT  = ZERO
25104 c                           EIN   = ZERO
25105 c                        ENDIF
25106 c                     ELSE
25107 c                        WRITE(LOUT,*)
25108 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
25109 c                        STOP
25110 c                     ENDIF
25111 c                  ELSE
25112 c                     ETOT = ZERO
25113 c                     EIN  = ZERO
25114 c                     STOT0= ZERO
25115 c                     IF (IXSQEL.EQ.0) THEN
25116 c                        CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
25117 c                     ELSE
25118 c                       SIN = ZERO
25119 c                       CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
25120 c                     ENDIF
25121 c                  ENDIF
25122 c               ENDIF
25123 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
25124 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
25125 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
25126 c               WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
25127 c            ENDIF
25128     2    CONTINUE
25129     1 CONTINUE
25130
25131       RETURN
25132       END
25133
25134 *$ CREATE DT_TESTXS.FOR
25135 *COPY DT_TESTXS
25136 *
25137 *===testxs=============================================================*
25138 *
25139       SUBROUTINE DT_TESTXS
25140
25141       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25142       SAVE
25143
25144       DIMENSION XSTOT(26,2),XSELA(26,2)
25145
25146       OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
25147       OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
25148       OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
25149       OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
25150       DUMECM = 0.0D0
25151       PLABL = 0.01D0
25152       PLABH = 10000.0D0
25153       NBINS = 120
25154       APLABL = LOG10(PLABL)
25155       APLABH = LOG10(PLABH)
25156       ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
25157       DO 1 I=1,NBINS+1
25158          ADP = APLABL+DBLE(I-1)*ADPLAB
25159          P = 10.0D0**ADP
25160          DO 2 J=1,26
25161             CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
25162             CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
25163     2    CONTINUE
25164          WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
25165          WRITE(11,1000) P,(XSELA(K,1),K=1,26)
25166          WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
25167          WRITE(13,1000) P,(XSELA(K,2),K=1,26)
25168     1 CONTINUE
25169  1000 FORMAT(F8.3,26F9.3)
25170
25171       RETURN
25172       END
25173
25174 ************************************************************************
25175 *                                                                      *
25176 *  DTUNUC 2.0:   library routines                                      *
25177 *                                   processed by S. Roesler, 6.5.95    *
25178 *                                                                      *
25179 ************************************************************************
25180 *
25181 *     1) Handling of parton momenta
25182 *          SUBROUTINE MASHEL
25183 *          SUBROUTINE DFERMI
25184 *
25185 *     2) Handling of parton flavors and particle indices
25186 *          INTEGER FUNCTION IPDG2B
25187 *          INTEGER FUNCTION IB2PDG
25188 *          INTEGER FUNCTION IQUARK
25189 *          INTEGER FUNCTION IBJQUA
25190 *          INTEGER FUNCTION ICIHAD
25191 *          INTEGER FUNCTION IPDGHA
25192 *          INTEGER FUNCTION MCHAD
25193 *          SUBROUTINE FLAHAD
25194 *
25195 *     3) Energy-momentum and quantum number conservation check routines
25196 *          SUBROUTINE EMC1
25197 *          SUBROUTINE EMC2
25198 *          SUBROUTINE EVTEMC
25199 *          SUBROUTINE EVTFLC
25200 *          SUBROUTINE EVTCHG
25201 *
25202 *     4) Transformations
25203 *          SUBROUTINE LTINI
25204 *          SUBROUTINE LTRANS
25205 *          SUBROUTINE LTNUC
25206 *          SUBROUTINE DALTRA
25207 *          SUBROUTINE DTRAFO
25208 *          SUBROUTINE STTRAN
25209 *          SUBROUTINE MYTRAN
25210 *          SUBROUTINE LT2LAO
25211 *          SUBROUTINE LT2LAB
25212 *
25213 *     5) Sampling from distributions
25214 *          INTEGER FUNCTION NPOISS
25215 *          DOUBLE PRECISION FUNCTION SAMPXB
25216 *          DOUBLE PRECISION FUNCTION SAMPEX
25217 *          DOUBLE PRECISION FUNCTION SAMSQX
25218 *          DOUBLE PRECISION FUNCTION BETREJ
25219 *          DOUBLE PRECISION FUNCTION DGAMRN
25220 *          DOUBLE PRECISION FUNCTION DBETAR
25221 *          SUBROUTINE RANNOR
25222 *          SUBROUTINE DPOLI
25223 *          SUBROUTINE DSFECF
25224 *          SUBROUTINE RACO
25225 *
25226 *     6) Special functions, algorithms and service routines
25227 *          DOUBLE PRECISION FUNCTION YLAMB
25228 *          SUBROUTINE SORT
25229 *          SUBROUTINE SORT1
25230 *          SUBROUTINE DT_XTIME
25231 *
25232 *     7) Random number generator package
25233 *          DOUBLE PRECISION FUNCTION DT_RNDM
25234 *          SUBROUTINE DT_RNDMST
25235 *          SUBROUTINE DT_RNDMIN
25236 *          SUBROUTINE DT_RNDMOU
25237 *          SUBROUTINE DT_RNDMTE
25238 *
25239 ************************************************************************
25240 *                                                                      *
25241 *                 1) Handling of parton momenta                        *
25242 *                                                                      *
25243 ************************************************************************
25244 *$ CREATE DT_MASHEL.FOR
25245 *COPY DT_MASHEL
25246 *
25247 *===mashel=============================================================*
25248 *
25249       SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
25250
25251 ************************************************************************
25252 *                                                                      *
25253 *    rescaling of momenta of two partons to put both                   *
25254 *                                       on mass shell                  *
25255 *                                                                      *
25256 *    input:       PA1,PA2   input momentum vectors                     *
25257 *                 XM1,2     desired masses of particles afterwards     *
25258 *                 P1,P2     changed momentum vectors                   *
25259 *                                                                      *
25260 * The original version is written by R. Engel.                         *
25261 * This version dated 12.12.94 is modified by S. Roesler.               *
25262 ************************************************************************
25263
25264       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25265       SAVE
25266       PARAMETER ( LINP = 10 ,
25267      &            LOUT = 6 ,
25268      &            LDAT = 9 )
25269       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
25270
25271       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
25272
25273       IREJ = 0
25274
25275 * Lorentz transformation into system CMS
25276       PX  = PA1(1)+PA2(1)
25277       PY  = PA1(2)+PA2(2)
25278       PZ  = PA1(3)+PA2(3)
25279       EE  = PA1(4)+PA2(4)
25280       XPTOT = SQRT(PX**2+PY**2+PZ**2)
25281       XMS   = (EE-XPTOT)*(EE+XPTOT)
25282       IF(XMS.LT.(XM1+XM2)**2) THEN
25283 C        WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
25284          GOTO 9999
25285       ENDIF
25286       XMS = SQRT(XMS)
25287       BGX = PX/XMS
25288       BGY = PY/XMS
25289       BGZ = PZ/XMS
25290       GAM = EE/XMS
25291       CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
25292      &           PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
25293 * rotation angles
25294       COD = P1(3)/PTOT1
25295 C     SID = SQRT((ONE-COD)*(ONE+COD))
25296       PPT = SQRT(P1(1)**2+P1(2)**2)
25297       SID = PPT/PTOT1
25298       COF = ONE
25299       SIF = ZERO
25300       IF(PTOT1*SID.GT.TINY10) THEN
25301          COF   = P1(1)/(SID*PTOT1)
25302          SIF   = P1(2)/(SID*PTOT1)
25303          ANORF = SQRT(COF*COF+SIF*SIF)
25304          COF   = COF/ANORF
25305          SIF   = SIF/ANORF
25306       ENDIF
25307 * new CM momentum and energies (for masses XM1,XM2)
25308       XM12 = SIGN(XM1**2,XM1)
25309       XM22 = SIGN(XM2**2,XM2)
25310       SS   = XMS**2
25311       PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
25312       EE1  = SQRT(XM12+PCMP**2)
25313       EE2  = XMS-EE1
25314 * back rotation
25315       MODE = 1
25316       CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
25317       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
25318      &            PTOT1,P1(1),P1(2),P1(3),P1(4))
25319       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
25320      &            PTOT2,P2(1),P2(2),P2(3),P2(4))
25321 * check consistency
25322       DEL = XMS*0.0001D0
25323       IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
25324         IDEV = 1
25325       ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
25326         IDEV = 2
25327       ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
25328         IDEV = 3
25329       ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
25330         IDEV = 4
25331       ELSE
25332         IDEV = 0
25333       ENDIF
25334       IF (IDEV.NE.0) THEN
25335          WRITE(LOUT,'(/1X,A,I3)')
25336      &      'MASHEL: inconsistent transformation',IDEV
25337          WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25338          WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25339          WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25340          WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25341          WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25342          WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25343       ENDIF
25344       RETURN
25345
25346  9999 CONTINUE
25347       IREJ = 1
25348       RETURN
25349       END
25350
25351 *$ CREATE DT_DFERMI.FOR
25352 *COPY DT_DFERMI
25353 *
25354 *===dfermi=============================================================*
25355 *
25356       SUBROUTINE DT_DFERMI(GPART)
25357
25358 ************************************************************************
25359 * Find largest of three random numbers.                                *
25360 ************************************************************************
25361
25362       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25363       SAVE
25364
25365       DIMENSION G(3)
25366
25367       DO 10 I=1,3
25368         G(I)=DT_RNDM(GPART)
25369    10 CONTINUE
25370       IF (G(3).LT.G(2)) GOTO 40
25371       IF (G(3).LT.G(1)) GOTO 30
25372       GPART = G(3)
25373    20 RETURN
25374    30 GPART = G(1)
25375       GOTO 20
25376    40 IF (G(2).LT.G(1)) GOTO 30
25377       GPART = G(2)
25378       GOTO 20
25379
25380       END
25381
25382 ************************************************************************
25383 *                                                                      *
25384 *         2) Handling of parton flavors and particle indices           *
25385 *                                                                      *
25386 ************************************************************************
25387 *$ CREATE IDT_IPDG2B.FOR
25388 *COPY IDT_IPDG2B
25389 *
25390 *===ipdg2b=============================================================*
25391 *
25392       INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25393
25394 ************************************************************************
25395 *                                                                      *
25396 *     conversion of quark numbering scheme                             *
25397 *                                                                      *
25398 *     input:   PDG parton numbering                                    *
25399 *              for diquarks:  NN number of the constituent quark       *
25400 *                             (e.g. ID=2301,NN=1 -> ICONV2=1)          *
25401 *                                                                      *
25402 *     output:  BAMJET particle codes                                   *
25403 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
25404 *              2 d     8 a-d             -2 a-d                        *
25405 *              3 s     9 a-s             -3 a-s                        *
25406 *              4 c    10 a-c             -4 a-c                        *
25407 *                                                                      *
25408 * This is a modified version of ICONV2 written by R. Engel.            *
25409 * This version dated 13.12.94 is written by S. Roesler.                *
25410 ************************************************************************
25411
25412       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25413       SAVE
25414       PARAMETER ( LINP = 10 ,
25415      &            LOUT = 6 ,
25416      &            LDAT = 9 )
25417
25418       IDA = ABS(ID)
25419 * diquarks
25420       IF (IDA.GT.6) THEN
25421         KF  = 3
25422         IF (IDA.GE.1000) KF = 4
25423         IDA = IDA/(10**(KF-NN))
25424         IDA = MOD(IDA,10)
25425       ENDIF
25426 * exchange up and dn quarks
25427       IF (IDA.EQ.1) THEN
25428         IDA = 2
25429       ELSEIF (IDA.EQ.2) THEN
25430         IDA = 1
25431       ENDIF
25432 * antiquarks
25433       IF (ID.LT.0) THEN
25434          IF (MODE.EQ.1) THEN
25435             IDA = IDA+6
25436          ELSE
25437             IDA = -IDA
25438          ENDIF
25439       ENDIF
25440       IDT_IPDG2B = IDA
25441
25442       RETURN
25443       END
25444
25445 *$ CREATE IDT_IB2PDG.FOR
25446 *COPY IDT_IB2PDG
25447 *
25448 *===ib2pdg=============================================================*
25449 *
25450       INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25451
25452 ************************************************************************
25453 *                                                                      *
25454 *     conversion of quark numbering scheme                             *
25455 *                                                                      *
25456 *     input:   BAMJET particle codes                                   *
25457 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
25458 *              2 d     8 a-d             -2 a-d                        *
25459 *              3 s     9 a-s             -3 a-s                        *
25460 *              4 c    10 a-c             -4 a-c                        *
25461 *                                                                      *
25462 *     output:  PDG parton numbering                                    *
25463 *                                                                      *
25464 * This version dated 13.12.94 is written by S. Roesler.                *
25465 ************************************************************************
25466
25467       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25468       SAVE
25469       PARAMETER ( LINP = 10 ,
25470      &            LOUT = 6 ,
25471      &            LDAT = 9 )
25472
25473       DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25474       DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25475       DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25476      &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25477      &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25478
25479       IDA = ID1
25480       IDB = ID2
25481       IF (MODE.EQ.1) THEN
25482          IF (ID1.GT.6) IDA = -(ID1-6)
25483          IF (ID2.GT.6) IDB = -(ID2-6)
25484       ENDIF
25485       IF (ID2.EQ.0) THEN
25486          IDT_IB2PDG = IHKKQ(IDA)
25487       ELSE
25488          IDT_IB2PDG = IHKKQQ(IDA,IDB)
25489       ENDIF
25490
25491       RETURN
25492       END
25493
25494 *$ CREATE IDT_IQUARK.FOR
25495 *COPY IDT_IQUARK
25496 *
25497 *===ipdgqu=============================================================*
25498 *
25499       INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25500
25501 ************************************************************************
25502 *                                                                      *
25503 *     quark contents according to PDG conventions                      *
25504 *     (random selection in case of quark mixing)                       *
25505 *                                                                      *
25506 *     input:   IDBAMJ BAMJET particle code                             *
25507 *              K      1..3   quark number                              *
25508 *                                                                      *
25509 *     output:  1   d  (anti --> neg.)                                  *
25510 *              2   u                                                   *
25511 *              3   s                                                   *
25512 *              4   c                                                   *
25513 *                                                                      *
25514 * This version written by R. Engel.                                    *
25515 ************************************************************************
25516
25517       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25518       SAVE
25519
25520       IQ = IDT_IBJQUA(K,IDBAMJ)
25521 * quark-antiquark
25522       IF (IQ.GT.6) THEN
25523          IQ = 6-IQ
25524       ENDIF
25525 * exchange of up and down
25526       IF (ABS(IQ).EQ.1) THEN
25527          IQ = SIGN(2,IQ)
25528       ELSEIF (ABS(IQ).EQ.2) THEN
25529          IQ = SIGN(1,IQ)
25530       ENDIF
25531       IDT_IQUARK = IQ
25532
25533       RETURN
25534       END
25535
25536 *$ CREATE IDT_IBJQUA.FOR
25537 *COPY IDT_IBJQUA
25538 *
25539 *===ibamq==============================================================*
25540 *
25541       INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25542
25543 ************************************************************************
25544 *                                                                      *
25545 *     quark contents according to BAMJET conventions                   *
25546 *     (random selection in case of quark mixing)                       *
25547 *                                                                      *
25548 *     input:   IDBAMJ BAMJET particle code                             *
25549 *              K      1..3   quark number                              *
25550 *                                                                      *
25551 *     output:  1   u      7   u bar                                    *
25552 *              2   d      8   d bar                                    *
25553 *              3   s      9   s bar                                    *
25554 *              4   c     10   c bar                                    *
25555 *                                                                      *
25556 * This version written by R. Engel.                                    *
25557 ************************************************************************
25558
25559       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25560       SAVE
25561
25562       DIMENSION ITAB(3,210)
25563       DATA ((ITAB(I,K),I=1,3),K=1,30) /
25564      &    1,  1,  2,   7,  7,  8,   0,  0,  0,
25565      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25566      &    0,  0,  0,   1,  2,  2,   7,  8,  8,
25567 *sr 10.1.94
25568 C    &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25569      &    0,  0,  0,   0,  0,  0,   3,  8,  0,
25570 *
25571      &    1,  8,  0,   2,  7,  0,   1,  9,  0,
25572 *sr 10.1.94
25573 C    &    3,  7,  0,   0,  0,  0,   0,  0,  0,
25574      &    3,  7,  0,   3,  1,  2,   9,  7,  8,
25575 *sr 10.1.94
25576 C    &    0,  0,  0,   2,  2,  3,   1,  1,  3,
25577      &    2,  9,  0,   2,  2,  3,   1,  1,  3,
25578 *
25579      &    1,  2,  3, 201,202,  0,   2,  9,  0,
25580      &    3,  8,  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=31,60) /
25583      &    3,  9,  0,   1,  8,  0, 203,204,  0,
25584      &    2,  7,  0,   0,  0,  0,   1,  9,  0,
25585      &    2,  9,  0,   3,  7,  0,   3,  8,  0,
25586      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25587      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25588      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25589      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25590      &    0,  0,  0,   1,  1,  1,   1,  1,  2,
25591      &    1,  2,  2,   2,  2,  2,   0,  0,  0,
25592      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25593       DATA ((ITAB(I,K),I=1,3),K=61,90) /
25594      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25595      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25596      &    7,  7,  7,   7,  7,  8,   7,  8,  8,
25597      &    8,  8,  8,   0,  0,  0,   0,  0,  0,
25598      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25599      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25600      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25601      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25602      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25603      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25604       DATA ((ITAB(I,K),I=1,3),K=91,120) /
25605      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25606      &    0,  0,  0,   0,  0,  0,   3,  9,  0,
25607      &    1,  3,  3,   2,  3,  3,   7,  7,  9,
25608      &    7,  8,  9,   8,  8,  9,   7,  9,  9,
25609      &    8,  9,  9,   1,  1,  3,   1,  2,  3,
25610      &    2,  2,  3,   1,  3,  3,   2,  3,  3,
25611      &    3,  3,  3,   7,  7,  9,   7,  8,  9,
25612      &    8,  8,  9,   7,  9,  9,   8,  9,  9,
25613      &    9,  9,  9,   4,  7,  0,   4,  8,  0,
25614      &    2, 10,  0,   1, 10,  0,   4,  9,  0 /
25615       DATA ((ITAB(I,K),I=1,3),K=121,150) /
25616      &    3, 10,  0,   4, 10,  0,   4,  7,  0,
25617      &    4,  8,  0,   2, 10,  0,   1, 10,  0,
25618      &    4,  9,  0,   3, 10,  0,   4, 10,  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,   1,  2,  4,   1,  3,  4,
25622      &    2,  3,  4,   1,  1,  4,   0,  0,  0,
25623      &    2,  2,  4,   0,  0,  0,   0,  0,  0,
25624      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
25625      &    3,  4,  4,   7,  8, 10,   7,  9, 10 /
25626       DATA ((ITAB(I,K),I=1,3),K=151,180) /
25627      &    8,  9, 10,   7,  7, 10,   0,  0,  0,
25628      &    8,  8, 10,   0,  0,  0,   0,  0,  0,
25629      &    9,  9, 10,   7, 10, 10,   8, 10, 10,
25630      &    9, 10, 10,   1,  1,  4,   1,  2,  4,
25631      &    2,  2,  4,   1,  3,  4,   2,  3,  4,
25632      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
25633      &    3,  4,  4,   4,  4,  4,   7,  7, 10,
25634      &    7,  8, 10,   8,  8, 10,   7,  9, 10,
25635      &    8,  9, 10,   9,  9, 10,   7, 10, 10,
25636      &    8, 10, 10,   9, 10, 10,  10, 10, 10 /
25637       DATA ((ITAB(I,K),I=1,3),K=181,210) /
25638      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25639      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25640      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25641      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25642      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25643      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25644      &    0,  0,  0,   0,  0,  0,   1,  7,  0,
25645      &    2,  8,  0,   1,  7,  0,   2,  8,  0,
25646      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25647      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25648       DATA IDOLD /0/
25649
25650       ONE = 1.0D0
25651       IF (ITAB(1,IDBAMJ).LE.200) THEN
25652          ID = ITAB(K,IDBAMJ)
25653       ELSE
25654          IF(IDOLD.NE.IDBAMJ) THEN
25655             IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25656      &           DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25657         ELSE
25658            IDOLD = 0
25659         ENDIF
25660         ID = ITAB(K,IT)
25661       ENDIF
25662       IDOLD  = IDBAMJ
25663       IDT_IBJQUA = ID
25664
25665       RETURN
25666       END
25667
25668 *$ CREATE IDT_ICIHAD.FOR
25669 *COPY IDT_ICIHAD
25670 *
25671 *===icihad=============================================================*
25672 *
25673       INTEGER FUNCTION IDT_ICIHAD(MCIND)
25674
25675 ************************************************************************
25676 * Conversion of particle index PDG proposal --> BAMJET-index scheme    *
25677 * This is a completely new version dated 25.10.95.                     *
25678 * Renamed to be not in conflict with the modified PHOJET-version       *
25679 ************************************************************************
25680
25681       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25682       SAVE
25683
25684 * hadron index conversion (BAMJET <--> PDG)
25685       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25686      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25687      &                IAMCIN(210)
25688
25689       IDT_ICIHAD = 0
25690       KPDG   = ABS(MCIND)
25691       IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25692       IF (MCIND.LT.0) THEN
25693          JSIGN = 1
25694       ELSE
25695          JSIGN = 2
25696       ENDIF
25697       IF (KPDG.GE.10000) THEN
25698          DO 1 I=1,19
25699             IDT_ICIHAD = IBAM5(JSIGN,I)
25700             IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25701             IDT_ICIHAD = 0
25702     1    CONTINUE
25703       ELSEIF (KPDG.GE.1000) THEN
25704          DO 2 I=1,29
25705             IDT_ICIHAD = IBAM4(JSIGN,I)
25706             IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25707             IDT_ICIHAD = 0
25708     2    CONTINUE
25709       ELSEIF (KPDG.GE.100) THEN
25710          DO 3 I=1,22
25711             IDT_ICIHAD = IBAM3(JSIGN,I)
25712             IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25713             IDT_ICIHAD = 0
25714     3    CONTINUE
25715       ELSEIF (KPDG.GE.10) THEN
25716          DO 4 I=1,7
25717             IDT_ICIHAD = IBAM2(JSIGN,I)
25718             IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25719             IDT_ICIHAD = 0
25720     4    CONTINUE
25721       ENDIF
25722     5 CONTINUE
25723
25724       RETURN
25725       END
25726
25727 *$ CREATE IDT_IPDGHA.FOR
25728 *COPY IDT_IPDGHA
25729 *
25730 *===ipdgha=============================================================*
25731 *
25732       INTEGER FUNCTION IDT_IPDGHA(MCIND)
25733
25734 ************************************************************************
25735 * Conversion of particle index BAMJET-index scheme --> PDG proposal    *
25736 * Adopted from the original by S. Roesler. This version dated 12.5.95  *
25737 * Renamed to be not in conflict with the modified PHOJET-version       *
25738 ************************************************************************
25739
25740       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25741       SAVE
25742
25743 * hadron index conversion (BAMJET <--> PDG)
25744       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25745      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25746      &                IAMCIN(210)
25747
25748       IDT_IPDGHA = IAMCIN(MCIND)
25749
25750       RETURN
25751       END
25752
25753 *$ CREATE DT_FLAHAD.FOR
25754 *COPY DT_FLAHAD
25755 *
25756 *===flahad=============================================================*
25757 *
25758       SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25759
25760 ************************************************************************
25761 * sampling of FLAvor composition for HADrons/photons                   *
25762 *              ID         BAMJET-id of hadron                          *
25763 *              IF1,2,3    flavor content                               *
25764 *                         (u,d,s: 1,2,3;  au,ad,as: -1,-1,-3)          *
25765 * Note:  -  u,d numbering as in BAMJET                                 *
25766 *        -  ID .le. 30 !!                                              *
25767 * This version dated 12.03.96 is written by S. Roesler                 *
25768 ************************************************************************
25769
25770       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25771       SAVE
25772
25773 * auxiliary common for reggeon exchange (DTUNUC 1.x)
25774       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25775      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25776      &                IQTCHR(-6:6),MQUARK(3,39)
25777
25778       DIMENSION JSEL(3,6)
25779       DATA JSEL/ 1,2,3,  2,3,1,  3,1,2,  1,3,2,   2,1,3,   3,2,1/
25780
25781       ONE = 1.0D0
25782       IF (ID.EQ.7) THEN
25783 * photon (charge dependent flavour sampling)
25784          K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25785          IF (K.LE.4) THEN
25786             IF1 = 2
25787             IF2 = -2
25788          ELSE IF(K.EQ.5) THEN
25789             IF1 = 1
25790             IF2 = -1
25791          ELSE
25792             IF1 = 3
25793             IF2 = -3
25794          ENDIF
25795          IF(DT_RNDM(ONE).LT.0.5D0) THEN
25796             K   = IF1
25797             IF1 = IF2
25798             IF2 = K
25799          ENDIF
25800          IF3 = 0
25801       ELSE
25802 * hadron
25803          IX  = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25804          IF1 = MQUARK(JSEL(1,IX),ID)
25805          IF2 = MQUARK(JSEL(2,IX),ID)
25806          IF3 = MQUARK(JSEL(3,IX),ID)
25807          IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25808             IF1 = IF3
25809             IF3 = 0
25810          ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25811             IF2 = IF3
25812             IF3 = 0
25813          ENDIF
25814       ENDIF
25815
25816       RETURN
25817       END
25818
25819 *$ CREATE IDT_MCHAD.FOR
25820 *COPY IDT_MCHAD
25821 *
25822 *===mchad==============================================================*
25823 *
25824       INTEGER FUNCTION IDT_MCHAD(ITDTU)
25825
25826 ************************************************************************
25827 * Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25828 * Adopted from the original by S. Roesler. This version dated 6.5.95   *
25829 *                                                                      *
25830 * Last change 28.12.2006 by S. Roesler.                                *
25831 ************************************************************************
25832
25833       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25834       SAVE
25835
25836       DIMENSION ITRANS(210)
25837       DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25838      &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25839      &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25840      &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25841      &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25842      &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25843      &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25844
25845       IF ( ITDTU .GT. 0 ) THEN
25846          IDT_MCHAD = ITRANS(ITDTU)
25847       ELSE
25848          IDT_MCHAD = -1
25849       END IF
25850
25851       RETURN
25852       END
25853
25854 ************************************************************************
25855 *                                                                      *
25856 *   3) Energy-momentum and quantum number conservation check routines  *
25857 *                                                                      *
25858 ************************************************************************
25859 *$ CREATE DT_EMC1.FOR
25860 *COPY DT_EMC1
25861 *
25862 *===emc1===============================================================*
25863 *
25864       SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25865
25866 ************************************************************************
25867 * This version dated 15.12.94 is written by S. Roesler                 *
25868 ************************************************************************
25869
25870       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25871       SAVE
25872       PARAMETER ( LINP = 10 ,
25873      &            LOUT = 6 ,
25874      &            LDAT = 9 )
25875       PARAMETER (TINY10=1.0D-10)
25876
25877       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25878
25879       IREJ = 0
25880
25881       IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25882      &   WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25883
25884       IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25885          IF (MODE.EQ.1) THEN
25886             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25887          ELSEIF (MODE.EQ.2) THEN
25888             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25889          ENDIF
25890          CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25891          CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25892          CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25893       ELSEIF (MODE.LT.0) THEN
25894          IF (MODE.EQ.-1) THEN
25895             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
25896          ELSEIF (MODE.EQ.-2) THEN
25897             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
25898          ENDIF
25899          CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
25900          CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
25901          CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
25902       ENDIF
25903
25904       IF (ABS(MODE).EQ.3) THEN
25905          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25906          IF (IREJ1.NE.0) GOTO 9999
25907       ENDIF
25908       RETURN
25909
25910  9999 CONTINUE
25911       IREJ = 1
25912       RETURN
25913       END
25914
25915 *$ CREATE DT_EMC2.FOR
25916 *COPY DT_EMC2
25917 *
25918 *===emc2===============================================================*
25919 *
25920       SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25921      &                                                MODE,IPOS,IREJ)
25922
25923 ************************************************************************
25924 *             MODE = 1   energy-momentum cons. check                   *
25925 *                  = 2   flavor-cons. check                            *
25926 *                  = 3   energy-momentum & flavor cons. check          *
25927 *                  = 4   energy-momentum & charge cons. check          *
25928 *                  = 5   energy-momentum & flavor & charge cons. check *
25929 * This version dated 16.01.95 is written by S. Roesler                 *
25930 ************************************************************************
25931
25932       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25933       SAVE
25934       PARAMETER ( LINP = 10 ,
25935      &            LOUT = 6 ,
25936      &            LDAT = 9 )
25937       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25938
25939 * event history
25940       PARAMETER (NMXHKK=200000)
25941       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25942      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25943      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25944 * extended event history
25945       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25946      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25947      &                IHIST(2,NMXHKK)
25948
25949       IREJ  = 0
25950       IREJ1 = 0
25951       IREJ2 = 0
25952       IREJ3 = 0
25953
25954       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25955      &                CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25956       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25957      &                                CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25958       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25959       DO 1 I=1,NHKK
25960          IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25961      &       (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25962      &       (ISTHKK(I).EQ.IP5))                          THEN
25963             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25964      &                                    .OR.(MODE.EQ.5))
25965      &      CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25966      &                                               2,IDUM,IDUM)
25967             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25968      &         CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25969             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25970      &                            CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25971          ENDIF
25972          IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25973      &       (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25974      &       (ISTHKK(I).EQ.IN5))                          THEN
25975             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25976      &                                    .OR.(MODE.EQ.5))
25977      &      CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25978      &                                                   2,IDUM,IDUM)
25979             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25980      &         CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25981             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25982      &                            CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
25983          ENDIF
25984     1 CONTINUE
25985       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25986      &   CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
25987       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25988      &   CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
25989       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
25990       IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
25991
25992       RETURN
25993
25994  9999 CONTINUE
25995       IREJ = 1
25996       RETURN
25997       END
25998
25999 *$ CREATE DT_EVTEMC.FOR
26000 *COPY DT_EVTEMC
26001 *
26002 *===evtemc=============================================================*
26003 *
26004       SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
26005
26006 ************************************************************************
26007 * This version dated 13.12.94 is written by S. Roesler                 *
26008 ************************************************************************
26009
26010       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26011       SAVE
26012       PARAMETER ( LINP = 10 ,
26013      &            LOUT = 6 ,
26014      &            LDAT = 9 )
26015       PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
26016      &           ZERO=0.0D0)
26017
26018 * event history
26019       PARAMETER (NMXHKK=200000)
26020       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26021      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26022      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26023 * flags for input different options
26024       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
26025       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
26026      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
26027
26028       IREJ = 0
26029
26030       MODE = IMODE
26031       CHKLEV = TINY10
26032       IF (MODE.EQ.4) THEN
26033          CHKLEV = TINY2
26034          MODE   = 3
26035       ELSEIF (MODE.EQ.5) THEN
26036          CHKLEV = TINY1
26037          MODE   = 3
26038       ELSEIF (MODE.EQ.-1) THEN
26039          CHKLEV = EIO
26040          MODE   = 3
26041       ENDIF
26042
26043       IF (ABS(MODE).EQ.3) THEN
26044          PXDEV = PX
26045          PYDEV = PY
26046          PZDEV = PZ
26047          EDEV  = E
26048          IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
26049          IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
26050      &       (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
26051             IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
26052      &         'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
26053      &         '  event  ',NEVHKK,
26054      &         ' ! ',PXDEV,PYDEV,PZDEV,EDEV
26055             PX   = 0.0D0
26056             PY   = 0.0D0
26057             PZ   = 0.0D0
26058             E    = 0.0D0
26059             GOTO 9999
26060          ENDIF
26061          PX   = 0.0D0
26062          PY   = 0.0D0
26063          PZ   = 0.0D0
26064          E    = 0.0D0
26065          RETURN
26066       ENDIF
26067
26068       IF (MODE.EQ.1) THEN
26069          PX = 0.0D0
26070          PY = 0.0D0
26071          PZ = 0.0D0
26072          E  = 0.0D0
26073       ENDIF
26074
26075       PX = PX+PXIO
26076       PY = PY+PYIO
26077       PZ = PZ+PZIO
26078       E  = E+EIO
26079
26080       RETURN
26081
26082  9999 CONTINUE
26083       IREJ = 1
26084       RETURN
26085       END
26086
26087 *$ CREATE DT_EVTFLC.FOR
26088 *COPY DT_EVTFLC
26089 *
26090 *===evtflc=============================================================*
26091 *
26092       SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
26093
26094 ************************************************************************
26095 * Flavor conservation check.                                           *
26096 *        ID       identity of particle                                 *
26097 *        ID1 = 1  ID for q,aq,qq,aqaq in PDG-numbering scheme          *
26098 *            = 2  ID for particle/resonance in BAMJET numbering scheme *
26099 *            = 3  ID for particle/resonance in PDG    numbering scheme *
26100 *        MODE = 1 initialization and add ID                            *
26101 *             =-1 initialization and subtract ID                       *
26102 *             = 2 add ID                                               *
26103 *             =-2 subtract ID                                          *
26104 *             = 3 check flavor cons.                                   *
26105 *        IPOS     flag to give position of call of EVTFLC to output    *
26106 *                 unit in case of violation                            *
26107 * This version dated 10.01.95 is written by S. Roesler                 *
26108 ************************************************************************
26109
26110       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26111       SAVE
26112       PARAMETER ( LINP = 10 ,
26113      &            LOUT = 6 ,
26114      &            LDAT = 9 )
26115       PARAMETER (TINY10=1.0D-10)
26116
26117       IREJ = 0
26118
26119       IF (MODE.EQ.3) THEN
26120          IF (IFL.NE.0) THEN
26121             WRITE(LOUT,'(1X,A,I3,A,I3)')
26122      &         'EVTFLC: flavor-conservation failure at pos. ',IPOS,
26123      &         ' !  IFL = ',IFL
26124             IFL = 0
26125             GOTO 9999
26126          ENDIF
26127          IFL = 0
26128          RETURN
26129       ENDIF
26130
26131       IF (MODE.EQ.1) IFL = 0
26132       IF (ID.EQ.0)   RETURN
26133
26134       IF (ID1.EQ.1) THEN
26135          IDD = ABS(ID)
26136          NQ  = 1
26137          IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
26138          IF (IDD.GE.1000) NQ = 3
26139          DO 1 I=1,NQ
26140             IFBAM = IDT_IPDG2B(ID,I,2)
26141             IF (ABS(IFBAM).EQ.1) THEN
26142                IFBAM = SIGN(2,IFBAM)
26143             ELSEIF (ABS(IFBAM).EQ.2) THEN
26144                IFBAM = SIGN(1,IFBAM)
26145             ENDIF
26146             IF (MODE.GT.0) THEN
26147                IFL = IFL+IFBAM
26148             ELSE
26149                IFL = IFL-IFBAM
26150             ENDIF
26151     1    CONTINUE
26152          RETURN
26153       ENDIF
26154
26155       IDD = ID
26156       IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
26157       IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
26158          DO 2 I=1,3
26159             IF (MODE.GT.0) THEN
26160                IFL = IFL+IDT_IQUARK(I,IDD)
26161             ELSE
26162                IFL = IFL-IDT_IQUARK(I,IDD)
26163             ENDIF
26164     2    CONTINUE
26165       ENDIF
26166       RETURN
26167
26168  9999 CONTINUE
26169       IREJ = 1
26170       RETURN
26171       END
26172
26173 *$ CREATE DT_EVTCHG.FOR
26174 *COPY DT_EVTCHG
26175 *
26176 *===evtchg=============================================================*
26177 *
26178       SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
26179
26180 ************************************************************************
26181 * Charge conservation check.                                           *
26182 *        ID       identity of particle (PDG-numbering scheme)          *
26183 *        MODE = 1 initialization                                       *
26184 *             =-2 subtract ID-charge                                   *
26185 *             = 2 add ID-charge                                        *
26186 *             = 3 check charge cons.                                   *
26187 *        IPOS     flag to give position of call of EVTCHG to output    *
26188 *                 unit in case of violation                            *
26189 * This version dated 10.01.95 is written by S. Roesler                 *
26190 * Last change: s.r. 21.01.01                                           *
26191 ************************************************************************
26192
26193       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26194       SAVE
26195       PARAMETER ( LINP = 10 ,
26196      &            LOUT = 6 ,
26197      &            LDAT = 9 )
26198
26199 * event history
26200       PARAMETER (NMXHKK=200000)
26201       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26202      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26203      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26204 * particle properties (BAMJET index convention)
26205       CHARACTER*8  ANAME
26206       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26207      &                IICH(210),IIBAR(210),K1(210),K2(210)
26208
26209       IREJ = 0
26210
26211       IF (MODE.EQ.1) THEN
26212          ICH  = 0
26213          IBAR = 0
26214          RETURN
26215       ENDIF
26216
26217       IF (MODE.EQ.3) THEN
26218          IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
26219             WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
26220      &         'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
26221      &         '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
26222             ICH  = 0
26223             IBAR = 0
26224             GOTO 9999
26225          ENDIF
26226          ICH  = 0
26227          IBAR = 0
26228          RETURN
26229       ENDIF
26230
26231       IF (ID.EQ.0)   RETURN
26232
26233       IDD = IDT_ICIHAD(ID)
26234 * modification 21.1.01: use intrinsic phojet-functions to determine charge
26235 * and baryon number
26236 C     IF (IDD.GT.0) THEN
26237 C        IF (MODE.EQ.2) THEN
26238 C           ICH  = ICH+IICH(IDD)
26239 C           IBAR = IBAR+IIBAR(IDD)
26240 C        ELSEIF (MODE.EQ.-2) THEN
26241 C           ICH  = ICH-IICH(IDD)
26242 C           IBAR = IBAR-IIBAR(IDD)
26243 C        ENDIF
26244 C     ELSE
26245 C        WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
26246 C        CALL DT_EVTOUT(4)
26247 C        STOP
26248 C     ENDIF
26249       IF (MODE.EQ.2) THEN
26250          ICH  = ICH+IPHO_CHR3(ID,1)/3
26251          IBAR = IBAR+IPHO_BAR3(ID,1)/3
26252       ELSEIF (MODE.EQ.-2) THEN
26253          ICH  = ICH-IPHO_CHR3(ID,1)/3
26254          IBAR = IBAR-IPHO_BAR3(ID,1)/3
26255       ENDIF
26256
26257       RETURN
26258
26259  9999 CONTINUE
26260       IREJ = 1
26261       RETURN
26262       END
26263
26264 ************************************************************************
26265 *                                                                      *
26266 *                 4) Transformations                                   *
26267 *                                                                      *
26268 ************************************************************************
26269 *$ CREATE DT_LTINI.FOR
26270 *COPY DT_LTINI
26271 *
26272 *===ltini==============================================================*
26273 *
26274       SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
26275
26276 ************************************************************************
26277 * Initializations of Lorentz-transformations, calculation of Lorentz-  *
26278 * parameters.                                                          *
26279 * This version dated 13.11.95 is written by  S. Roesler.               *
26280 ************************************************************************
26281
26282       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26283       SAVE
26284       PARAMETER ( LINP = 10 ,
26285      &            LOUT = 6 ,
26286      &            LDAT = 9 )
26287       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
26288      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
26289
26290 * Lorentz-parameters of the current interaction
26291       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26292      &                UMO,PPCM,EPROJ,PPROJ
26293 * properties of photon/lepton projectiles
26294       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
26295 * particle properties (BAMJET index convention)
26296       CHARACTER*8  ANAME
26297       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26298      &                IICH(210),IIBAR(210),K1(210),K2(210)
26299 * nucleon-nucleon event-generator
26300       CHARACTER*8 CMODEL
26301       LOGICAL LPHOIN
26302       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26303
26304       Q2   = VIRT
26305       IDP  = IDPR
26306       IF (MCGENE.NE.3) THEN
26307 * lepton-projectiles and PHOJET: initialize real photon instead
26308          IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26309      &       (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26310      &       (IDPR.EQ. 5).OR.(IDPR.EQ. 6))   THEN
26311             IDP = 7
26312             Q2  = ZERO
26313          ENDIF
26314       ENDIF
26315       IDT  = IDTA
26316       EPN  = EPN0
26317       PPN  = PPN0
26318       ECM  = ECM0
26319       AMP  = AAM(IDP)-SQRT(ABS(Q2))
26320       AMT  = AAM(IDT)
26321       AMP2 = SIGN(AMP**2,AMP)
26322       AMT2 = AMT**2
26323       IF (ECM0.GT.ZERO) THEN
26324          EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26325          IF (AMP2.GT.ZERO) THEN
26326             PPN = SQRT((EPN+AMP)*(EPN-AMP))
26327          ELSE
26328             PPN = SQRT(EPN**2-AMP2)
26329          ENDIF
26330       ELSE
26331          IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26332             IF (IDP.EQ.7) EPN = ABS(EPN)
26333             IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26334             IF (AMP2.GT.ZERO) THEN
26335                PPN = SQRT((EPN+AMP)*(EPN-AMP))
26336             ELSE
26337                PPN = SQRT(EPN**2-AMP2)
26338             ENDIF
26339          ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26340             IF (AMP2.GT.ZERO) THEN
26341                EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26342             ELSE
26343                EPN = SQRT(PPN**2+AMP2)
26344             ENDIF
26345          ENDIF
26346          ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26347       ENDIF
26348       UMO   = ECM
26349       EPROJ = EPN
26350       PPROJ = PPN
26351       IF (AMP2.GT.ZERO) THEN
26352          ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26353          PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26354       ELSE
26355          ETARG = TINY10
26356          PTARG = TINY10
26357       ENDIF
26358 * photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26359       IF (IDP.EQ.7) THEN
26360          PGAMM(1) = ZERO
26361          PGAMM(2) = ZERO
26362          AMGAM  = AMP
26363          AMGAM2 = AMP2
26364          IF (ECM0.GT.ZERO) THEN
26365             S = ECM0**2
26366          ELSE
26367             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26368                S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26369             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26370                S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26371             ENDIF
26372          ENDIF
26373          PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26374      &                     +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26375          PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26376          IF (MODE.EQ.1) THEN
26377             PNUCL(1) = ZERO
26378             PNUCL(2) = ZERO
26379             PNUCL(3) = -PGAMM(3)
26380             PNUCL(4) = SQRT(S)-PGAMM(4)
26381          ENDIF
26382       ENDIF
26383       IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26384      &    (IDPR.EQ.10).OR.(IDPR.EQ.11))   THEN
26385          PLEPT0(1) = ZERO
26386          PLEPT0(2) = ZERO
26387 * neglect lepton masses
26388 C        AMLPT2   = AAM(IDPR)**2
26389          AMLPT2   = ZERO
26390 *
26391          IF (ECM0.GT.ZERO) THEN
26392             S = ECM0**2
26393          ELSE
26394             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26395                S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26396             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26397                S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26398             ENDIF
26399          ENDIF
26400          PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26401      &                     +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26402          PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26403          PNUCL(1) = ZERO
26404          PNUCL(2) = ZERO
26405          PNUCL(3) = -PLEPT0(3)
26406          PNUCL(4) = SQRT(S)-PLEPT0(4)
26407       ENDIF
26408 * Lorentz-parameter for transformation Lab. - projectile rest system
26409       IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26410          GALAB = TINY10
26411          BGLAB = TINY10
26412          BLAB  = TINY10
26413       ELSE
26414          GALAB = EPROJ/AMP
26415          BGLAB = PPROJ/AMP
26416          BLAB  = BGLAB/GALAB
26417       ENDIF
26418 * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26419       IF (IDP.EQ.7) THEN
26420          GACMS(1) = TINY10
26421          BGCMS(1) = TINY10
26422       ELSE
26423          GACMS(1) = (ETARG+AMP)/UMO
26424          BGCMS(1) = PTARG/UMO
26425       ENDIF
26426 * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26427       GACMS(2) = (EPROJ+AMT)/UMO
26428       BGCMS(2) = PPROJ/UMO
26429       PPCM     = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26430
26431       EPN0 = EPN
26432       PPN0 = PPN
26433       ECM0 = ECM
26434
26435       RETURN
26436       END
26437
26438 *$ CREATE DT_LTRANS.FOR
26439 *COPY DT_LTRANS
26440 *
26441 *===ltrans=============================================================*
26442 *
26443       SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26444
26445 ************************************************************************
26446 * Lorentz-transformations.                                             *
26447 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
26448 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
26449 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
26450 * This version dated 01.11.95 is written by  S. Roesler.               *
26451 ************************************************************************
26452
26453       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26454       SAVE
26455       PARAMETER ( LINP = 10 ,
26456      &            LOUT = 6 ,
26457      &            LDAT = 9 )
26458       PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26459
26460       PARAMETER (SQTINF=1.0D+15)
26461
26462 * particle properties (BAMJET index convention)
26463       CHARACTER*8  ANAME
26464       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26465      &                IICH(210),IIBAR(210),K1(210),K2(210)
26466
26467       PXO = PXI
26468       PYO = PYI
26469       CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26470
26471 * check particle mass for consistency (numerical rounding errors)
26472       PO     = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26473       AMO2   = (PEO-PO)*(PEO+PO)
26474       AMORQ2 = AAM(ID)**2
26475       AMDIF2 = ABS(AMO2-AMORQ2)
26476       IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26477          DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26478          PEO   = PEO+DELTA
26479          PO1   = PO -DELTA
26480          PXO   = PXO*PO1/PO
26481          PYO   = PYO*PO1/PO
26482          PZO   = PZO*PO1/PO
26483 C        WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26484       ENDIF
26485
26486       RETURN
26487       END
26488
26489 *$ CREATE DT_LTNUC.FOR
26490 *COPY DT_LTNUC
26491 *
26492 *===ltnuc==============================================================*
26493 *
26494       SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26495
26496 ************************************************************************
26497 * Lorentz-transformations.                                             *
26498 *   PIN        longitudnal momentum       (input)                      *
26499 *   EIN        energy                     (input)                      *
26500 *   POUT       transformed long. momentum (output)                     *
26501 *   EOUT       transformed energy         (output)                     *
26502 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
26503 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
26504 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
26505 * This version dated 01.11.95 is written by  S. Roesler.               *
26506 ************************************************************************
26507
26508       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26509       SAVE
26510       PARAMETER ( LINP = 10 ,
26511      &            LOUT = 6 ,
26512      &            LDAT = 9 )
26513       PARAMETER (ZERO=0.0D0)
26514
26515 * Lorentz-parameters of the current interaction
26516       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26517      &                UMO,PPCM,EPROJ,PPROJ
26518
26519       BDUM1 = ZERO
26520       BDUM2 = ZERO
26521       PDUM1 = ZERO
26522       PDUM2 = ZERO
26523       IF (ABS(MODE).EQ.1) THEN
26524          BG = -SIGN(BGLAB,DBLE(MODE))
26525          CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26526      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26527       ELSEIF (ABS(MODE).EQ.2) THEN
26528          BG = SIGN(BGCMS(1),DBLE(MODE))
26529          CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26530      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26531       ELSEIF (ABS(MODE).EQ.3) THEN
26532          BG = -SIGN(BGCMS(2),DBLE(MODE))
26533          CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26534      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26535       ELSE
26536          WRITE(LOUT,1000) MODE
26537  1000    FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26538          EOUT = EIN
26539          POUT = PIN
26540       ENDIF
26541
26542       RETURN
26543       END
26544
26545 *$ CREATE DT_DALTRA.FOR
26546 *COPY DT_DALTRA
26547 *
26548 *===daltra=============================================================*
26549 *
26550       SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26551
26552 ************************************************************************
26553 * Arbitrary Lorentz-transformation.                                    *
26554 * Adopted from the original by S. Roesler. This version dated 15.01.95 *
26555 ************************************************************************
26556
26557       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26558       SAVE
26559       PARAMETER (ONE=1.0D0)
26560
26561       EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26562       PE = EP/(GA+ONE)+EC
26563       PX = PCX+BGX*PE
26564       PY = PCY+BGY*PE
26565       PZ = PCZ+BGZ*PE
26566       P  = SQRT(PX*PX+PY*PY+PZ*PZ)
26567       E  = GA*EC+EP
26568
26569       RETURN
26570       END
26571
26572 *$ CREATE DT_DTRAFO.FOR
26573 *COPY DT_DTRAFO
26574 *
26575 *====dtrafo============================================================*
26576 *
26577       SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26578      &                                    PL,CXL,CYL,CZL,EL)
26579
26580 C     LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26581
26582       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26583       SAVE
26584
26585       IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26586       SID  = SQRT(1.D0-COD*COD)
26587       PLX  = P*SID*COF
26588       PLY  = P*SID*SIF
26589       PCMZ = P*COD
26590       PLZ  = GAM*PCMZ+BGAM*ECM
26591       PL   = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26592       EL   = GAM*ECM+BGAM*PCMZ
26593 C     ROTATION INTO THE ORIGINAL DIRECTION
26594       COZ  = PLZ/PL
26595       SIZ  = SQRT(1.D0-COZ**2)
26596       CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26597
26598       RETURN
26599       END
26600
26601 *$ CREATE DT_STTRAN.FOR
26602 *COPY DT_STTRAN
26603 *
26604 *====sttran============================================================*
26605 *
26606       SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26607
26608       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26609       SAVE
26610       DATA ANGLSQ/1.D-30/
26611 ************************************************************************
26612 *     VERSION BY                     J. RANFT                          *
26613 *                                    LEIPZIG                           *
26614 *                                                                      *
26615 *     THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES      *
26616 *                                                                      *
26617 *     INPUT VARIABLES:                                                 *
26618 *        XO,YO,ZO = ORIGINAL DIRECTION COSINES                         *
26619 *        CDE,SDE  = COSINE AND SINE OF THE POLAR (THETA)               *
26620 *                   ANGLE OF "SCATTERING"                              *
26621 *        SDE      = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING"    *
26622 *        SFE,CFE  = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE       *
26623 *                   OF "SCATTERING"                                    *
26624 *                                                                      *
26625 *     OUTPUT VARIABLES:                                                *
26626 *        X,Y,Z     = NEW DIRECTION COSINES                             *
26627 *                                                                      *
26628 *     ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 )                  *
26629 ************************************************************************
26630 *
26631 *
26632 *  Changed by A. Ferrari
26633 *
26634 *     IF (ABS(XO)-0.0001D0) 1,1,2
26635 *   1 IF (ABS(YO)-0.0001D0) 3,3,2
26636 *   3 CONTINUE
26637       A = XO**2 + YO**2
26638       IF ( A .LT. ANGLSQ ) THEN
26639          X=SDE*CFE
26640          Y=SDE*SFE
26641          Z=CDE*ZO
26642       ELSE
26643          XI=SDE*CFE
26644          YI=SDE*SFE
26645          ZI=CDE
26646          A=SQRT(A)
26647          X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26648          Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26649          Z=A*YI+ZO*ZI
26650       ENDIF
26651
26652       RETURN
26653       END
26654
26655 *$ CREATE DT_MYTRAN.FOR
26656 *COPY DT_MYTRAN
26657 *
26658 *===mytran=============================================================*
26659 *
26660       SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26661
26662 ************************************************************************
26663 * This subroutine rotates the coordinate frame                         *
26664 *    a) theta  around y                                                *
26665 *    b) phi    around z      if IMODE = 1                              *
26666 *                                                                      *
26667 *     x'          cos(ph) -sin(ph) 0      cos(th)  0  sin(th)   x      *
26668 *     y' = A B =  sin(ph) cos(ph)  0  .   0        1        0   y      *
26669 *     z'          0       0        1     -sin(th)  0  cos(th)   z      *
26670 *                                                                      *
26671 * and vice versa if IMODE = 0.                                         *
26672 * This version dated 5.4.94 is based on the original version DTRAN     *
26673 * by J. Ranft and is written by S. Roesler.                            *
26674 ************************************************************************
26675
26676       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26677       SAVE
26678       PARAMETER ( LINP = 10 ,
26679      &            LOUT = 6 ,
26680      &            LDAT = 9 )
26681
26682       IF (IMODE.EQ.1) THEN
26683          X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26684          Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26685          Z=-SDE    *XO       +CDE    *ZO
26686       ELSE
26687          X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26688          Y= -SFE*XO+CFE*YO
26689          Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26690       ENDIF
26691       RETURN
26692       END
26693
26694 *$ CREATE DT_LT2LAO.FOR
26695 *COPY DT_LT2LAO
26696 *
26697 *===lt2lab=============================================================*
26698 *
26699       SUBROUTINE DT_LT2LAO
26700
26701 ************************************************************************
26702 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
26703 * for final state particles/fragments defined in nucleon-nucleon-cms   *
26704 * and transforms them back to the lab.                                 *
26705 * This version dated 16.11.95 is written by S. Roesler                 *
26706 ************************************************************************
26707
26708       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26709       SAVE
26710       PARAMETER ( LINP = 10 ,
26711      &            LOUT = 6 ,
26712      &            LDAT = 9 )
26713
26714 * event history
26715       PARAMETER (NMXHKK=200000)
26716       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26717      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26718      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26719 * extended event history
26720       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26721      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26722      &                IHIST(2,NMXHKK)
26723
26724       NEND      = NHKK
26725       NPOINT(5) = NHKK+1
26726       IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26727       DO 1 I=NPOINT(4),NEND
26728 C     DO 1 I=1,NEND
26729          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26730      &                                (ISTHKK(I).EQ.1001)) THEN
26731             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26732             NOB = NOBAM(I)
26733             CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26734      &                            PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26735             IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26736                ISTHKK(I) = 3*ISTHKK(I)
26737                NOBAM(NHKK)  = NOB
26738             ELSE
26739                IF (ISTHKK(I).EQ.-1) NOBAM(NHKK)  = NOB
26740                ISTHKK(I) = SIGN(3,ISTHKK(I))
26741             ENDIF
26742             JDAHKK(1,I) = NHKK
26743          ENDIF
26744     1 CONTINUE
26745
26746       RETURN
26747       END
26748
26749 *$ CREATE DT_LT2LAB.FOR
26750 *COPY DT_LT2LAB
26751 *
26752 *===lt2lab=============================================================*
26753 *
26754       SUBROUTINE DT_LT2LAB
26755
26756 ************************************************************************
26757 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
26758 * for final state particles/fragments defined in nucleon-nucleon-cms   *
26759 * and transforms them to the lab.                                      *
26760 * This version dated 07.01.96 is written by S. Roesler                 *
26761 ************************************************************************
26762
26763       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26764       SAVE
26765       PARAMETER ( LINP = 10 ,
26766      &            LOUT = 6 ,
26767      &            LDAT = 9 )
26768
26769 * event history
26770       PARAMETER (NMXHKK=200000)
26771       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26772      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26773      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26774 * extended event history
26775       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26776      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26777      &                IHIST(2,NMXHKK)
26778
26779       IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26780       DO 1 I=NPOINT(4),NHKK
26781          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26782      &                                (ISTHKK(I).EQ.1001)) THEN
26783             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26784             PHKK(3,I) = PZ
26785             PHKK(4,I) = PE
26786          ENDIF
26787     1 CONTINUE
26788
26789       RETURN
26790       END
26791
26792 ************************************************************************
26793 *                                                                      *
26794 *                 5) Sampling from distributions                       *
26795 *                                                                      *
26796 ************************************************************************
26797 *$ CREATE IDT_NPOISS.FOR
26798 *COPY IDT_NPOISS
26799 *
26800 *===npoiss=============================================================*
26801 *
26802       INTEGER FUNCTION IDT_NPOISS(AVN)
26803
26804 ************************************************************************
26805 * Sample according to Poisson distribution with Poisson parameter AVN. *
26806 * The original version written by J. Ranft.                            *
26807 * This version dated 11.1.95 is written by S. Roesler.                 *
26808 ************************************************************************
26809
26810       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26811       SAVE
26812       PARAMETER ( LINP = 10 ,
26813      &            LOUT = 6 ,
26814      &            LDAT = 9 )
26815
26816       EXPAVN = EXP(-AVN)
26817       K = 1
26818       A = 1.0D0
26819
26820    10 CONTINUE
26821       A = DT_RNDM(A)*A
26822       IF (A.GE.EXPAVN) THEN
26823          K = K+1
26824          GOTO 10
26825       ENDIF
26826       IDT_NPOISS = K-1
26827
26828       RETURN
26829       END
26830
26831 *$ CREATE DT_SAMPXB.FOR
26832 *COPY DT_SAMPXB
26833 *
26834 *===sampxb=============================================================*
26835 *
26836       DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26837
26838 ************************************************************************
26839 * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2.             *
26840 * Processed by S. Roesler, 6.5.95                                      *
26841 ************************************************************************
26842
26843       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26844       SAVE
26845       PARAMETER (TWO=2.0D0)
26846
26847       A1 = LOG(X1+SQRT(X1**2+B**2))
26848       A2 = LOG(X2+SQRT(X2**2+B**2))
26849       AN = A2-A1
26850       A  = AN*DT_RNDM(A1)+A1
26851       BB = EXP(A)
26852       DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26853
26854       RETURN
26855       END
26856
26857 *$ CREATE DT_SAMPEX.FOR
26858 *COPY DT_SAMPEX
26859 *
26860 *===sampex=============================================================*
26861 *
26862       DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26863
26864 ************************************************************************
26865 * Sampling from f(x)=1./x between x1 and x2.                           *
26866 * Processed by S. Roesler, 6.5.95                                      *
26867 ************************************************************************
26868
26869       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26870       SAVE
26871       PARAMETER (ONE=1.0D0)
26872
26873       R   = DT_RNDM(X1)
26874       AL1 = LOG(X1)
26875       AL2 = LOG(X2)
26876       DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26877
26878       RETURN
26879       END
26880
26881 *$ CREATE DT_SAMSQX.FOR
26882 *COPY DT_SAMSQX
26883 *
26884 *===samsqx=============================================================*
26885 *
26886       DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26887
26888 ************************************************************************
26889 * Sampling from f(x)=1./x^0.5 between x1 and x2.                       *
26890 * Processed by S. Roesler, 6.5.95                                      *
26891 ************************************************************************
26892
26893       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26894       SAVE
26895       PARAMETER (ONE=1.0D0)
26896
26897       R = DT_RNDM(X1)
26898       DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26899
26900       RETURN
26901       END
26902
26903 *$ CREATE DT_SAMPLW.FOR
26904 *COPY DT_SAMPLW
26905 *
26906 *===samplw=============================================================*
26907 *
26908       DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26909
26910 ************************************************************************
26911 * Sampling from f(x)=1/x^b between x_min and x_max.                    *
26912 * S. Roesler, 18.4.98                                                  *
26913 ************************************************************************
26914
26915       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26916       SAVE
26917       PARAMETER (ONE=1.0D0)
26918
26919       R = DT_RNDM(B)
26920       IF (B.EQ.ONE) THEN
26921          DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26922       ELSE
26923          ONEMB  = ONE-B
26924          DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26925       ENDIF
26926
26927       RETURN
26928       END
26929
26930 *$ CREATE DT_BETREJ.FOR
26931 *COPY DT_BETREJ
26932 *
26933 *===betrej=============================================================*
26934 *
26935       DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26936
26937       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26938       SAVE
26939
26940       PARAMETER ( LINP = 10 ,
26941      &            LOUT = 6 ,
26942      &            LDAT = 9 )
26943       PARAMETER (ONE=1.0D0)
26944
26945       IF (XMIN.GE.XMAX)THEN
26946          WRITE (LOUT,500) XMIN,XMAX
26947   500    FORMAT(1X,'DT_BETREJ:  XMIN<XMAX execution stopped ',2F10.5)
26948          STOP
26949       ENDIF
26950
26951    10 CONTINUE
26952       XX     = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26953       BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26954       YY     = BETMAX*DT_RNDM(XX)
26955       BETXX  = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26956       IF (YY.GT.BETXX) GOTO 10
26957       DT_BETREJ = XX
26958
26959       RETURN
26960       END
26961
26962 *$ CREATE DT_DGAMRN.FOR
26963 *COPY DT_DGAMRN
26964 *
26965 *===dgamrn=============================================================*
26966 *
26967       DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26968
26969 ************************************************************************
26970 * Sampling from Gamma-distribution.                                    *
26971 *       F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)            *
26972 * Processed by S. Roesler, 6.5.95                                      *
26973 ************************************************************************
26974
26975       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26976       SAVE
26977       PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
26978
26979       NCOU = 0
26980       N    = INT(ETA)
26981       F    = ETA-DBLE(N)
26982       IF (F.EQ.ZERO) GOTO 20
26983    10 R = DT_RNDM(F)
26984       NCOU = NCOU+1
26985       IF (NCOU.GE.11) GOTO 20
26986       IF (R.LT.F/(F+2.71828D0)) GOTO 30
26987       YYY = LOG(DT_RNDM(R)+TINY9)/F
26988       IF (ABS(YYY).GT.50.0D0) GOTO 20
26989       Y = EXP(YYY)
26990       IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
26991       GOTO 40
26992    20 Y = 0.0D0
26993       GOTO 50
26994    30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
26995       IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
26996    40 IF (N.EQ.0) GOTO 70
26997    50 Z = 1.0D0
26998       DO 60 I = 1,N
26999    60 Z = Z*DT_RNDM(Z)
27000       Y = Y-LOG(Z+TINY9)
27001    70 DT_DGAMRN = Y/ALAM
27002
27003       RETURN
27004       END
27005
27006 *$ CREATE DT_DBETAR.FOR
27007 *COPY DT_DBETAR
27008 *
27009 *===dbetar=============================================================*
27010 *
27011       DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
27012
27013 ************************************************************************
27014 * Sampling from Beta -distribution between 0.0 and 1.0                 *
27015 *  F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
27016 * Processed by S. Roesler, 6.5.95                                      *
27017 ************************************************************************
27018
27019       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27020       SAVE
27021
27022       Y = DT_DGAMRN(1.0D0,GAM)
27023       Z = DT_DGAMRN(1.0D0,ETA)
27024       DT_DBETAR = Y/(Y+Z)
27025
27026       RETURN
27027       END
27028
27029 *$ CREATE DT_RANNOR.FOR
27030 *COPY DT_RANNOR
27031 *
27032 *===rannor=============================================================*
27033 *
27034       SUBROUTINE DT_RANNOR(X,Y)
27035
27036 ************************************************************************
27037 * Sampling from Gaussian distribution.                                 *
27038 * Processed by S. Roesler, 6.5.95                                      *
27039 ************************************************************************
27040
27041       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27042       SAVE
27043       PARAMETER (TINY10=1.0D-10)
27044
27045       CALL DT_DSFECF(SFE,CFE)
27046       V = MAX(TINY10,DT_RNDM(X))
27047       A = SQRT(-2.D0*LOG(V))
27048       X = A*SFE
27049       Y = A*CFE
27050
27051       RETURN
27052       END
27053
27054 *$ CREATE DT_DPOLI.FOR
27055 *COPY DT_DPOLI
27056 *
27057 *===dpoli==============================================================*
27058 *
27059       SUBROUTINE DT_DPOLI(CS,SI)
27060
27061       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27062       SAVE
27063
27064       U  = DT_RNDM(CS)
27065       CS = DT_RNDM(U)
27066       IF (U.LT.0.5D0) CS=-CS
27067       SI = SQRT(1.0D0-CS*CS+1.0D-10)
27068
27069       RETURN
27070       END
27071
27072 *$ CREATE DT_DSFECF.FOR
27073 *COPY DT_DSFECF
27074 *
27075 *===dsfecf=============================================================*
27076 *
27077       SUBROUTINE DT_DSFECF(SFE,CFE)
27078
27079       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27080       SAVE
27081       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27082
27083     1 CONTINUE
27084       X  = DT_RNDM(SFE)
27085       Y  = DT_RNDM(X)
27086       XX = X*X
27087       YY = Y*Y
27088       XY = XX+YY
27089       IF (XY.GT.ONE) GOTO 1
27090       CFE = (XX-YY)/XY
27091       SFE = TWO*X*Y/XY
27092       IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
27093       RETURN
27094       END
27095
27096 *$ CREATE DT_RACO.FOR
27097 *COPY DT_RACO
27098 *
27099 *===raco===============================================================*
27100 *
27101       SUBROUTINE DT_RACO(WX,WY,WZ)
27102
27103 ************************************************************************
27104 * Direction cosines of random uniform (isotropic) direction in three   *
27105 * dimensional space                                                    *
27106 * Processed by S. Roesler, 20.11.95                                    *
27107 ************************************************************************
27108
27109       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27110       SAVE
27111       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27112
27113   10  CONTINUE
27114       X  = TWO*DT_RNDM(WX)-ONE
27115       Y  = DT_RNDM(X)
27116       X2 = X*X
27117       Y2 = Y*Y
27118       IF (X2+Y2.GT.ONE) GOTO 10
27119
27120       CFE = (X2-Y2)/(X2+Y2)
27121       SFE = TWO*X*Y/(X2+Y2)
27122 * z = 1/2 [ 1 + cos (theta) ]
27123       Z   = DT_RNDM(X)
27124 * 1/2 sin (theta)
27125       WZ = SQRT(Z*(ONE-Z))
27126       WX = TWO*WZ*CFE
27127       WY = TWO*WZ*SFE
27128       WZ = TWO*Z-ONE
27129
27130       RETURN
27131       END
27132
27133 ************************************************************************
27134 *                                                                      *
27135 *           6) Special functions, algorithms and service routines      *
27136 *                                                                      *
27137 ************************************************************************
27138 *$ CREATE DT_YLAMB.FOR
27139 *COPY DT_YLAMB
27140 *
27141 *===ylamb==============================================================*
27142 *
27143       DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
27144
27145 ************************************************************************
27146 *                                                                      *
27147 *     auxiliary function for three particle decay mode                 *
27148 *     (standard LAMBDA**(1/2) function)                                *
27149 *                                                                      *
27150 * Adopted from an original version written by R. Engel.                *
27151 * This version dated 12.12.94 is written by S. Roesler.                *
27152 ************************************************************************
27153
27154       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27155       SAVE
27156
27157       YZ   = Y-Z
27158       XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
27159       IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
27160       DT_YLAMB = SQRT(XLAM)
27161
27162       RETURN
27163       END
27164
27165 *$ CREATE DT_SORT.FOR
27166 *COPY DT_SORT
27167 *
27168 *===sort1==============================================================*
27169 *
27170       SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
27171
27172 ************************************************************************
27173 * This subroutine sorts entries in A in increasing/decreasing order    *
27174 * of A(3,i).                                                           *
27175 *              MODE  = 1     increasing in A(3,i=1..N)                 *
27176 *                    = 2     decreasing in A(3,i=1..N)                 *
27177 * This version dated 21.04.95 is revised by S. Roesler                 *
27178 ************************************************************************
27179
27180       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27181       SAVE
27182
27183       DIMENSION A(3,N)
27184
27185       M = I1
27186    10 CONTINUE
27187       M = I1-1
27188       IF (M.LE.0) RETURN
27189       L = 0
27190       DO 20 I=I0,M
27191          J = I+1
27192          IF (MODE.EQ.1) THEN
27193             IF (A(3,I).LE.A(3,J)) GOTO 20
27194          ELSE
27195             IF (A(3,I).GE.A(3,J)) GOTO 20
27196          ENDIF
27197          B = A(3,I)
27198          C = A(1,I)
27199          D = A(2,I)
27200          A(3,I) = A(3,J)
27201          A(2,I) = A(2,J)
27202          A(1,I) = A(1,J)
27203          A(3,J) = B
27204          A(1,J) = C
27205          A(2,J) = D
27206          L = 1
27207    20 CONTINUE
27208       IF (L.EQ.1) GOTO 10
27209
27210       RETURN
27211       END
27212
27213 *$ CREATE DT_SORT1.FOR
27214 *COPY DT_SORT1
27215 *
27216 *===sort1==============================================================*
27217 *
27218       SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
27219
27220 ************************************************************************
27221 * This subroutine sorts entries in A in increasing/decreasing order    *
27222 * of A(i).                                                             *
27223 *              MODE  = 1     increasing in A(i=1..N)                   *
27224 *                    = 2     decreasing in A(i=1..N)                   *
27225 * This version dated 21.04.95 is revised by S. Roesler                 *
27226 ************************************************************************
27227
27228       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27229       SAVE
27230
27231       DIMENSION A(N),IDX(N)
27232
27233       M = I1
27234    10 CONTINUE
27235       M = I1-1
27236       IF (M.LE.0) RETURN
27237       L = 0
27238       DO 20 I=I0,M
27239          J = I+1
27240          IF (MODE.EQ.1) THEN
27241             IF (A(I).LE.A(J)) GOTO 20
27242          ELSE
27243             IF (A(I).GE.A(J)) GOTO 20
27244          ENDIF
27245          B    = A(I)
27246          A(I) = A(J)
27247          A(J) = B
27248          IX     = IDX(I)
27249          IDX(I) = IDX(J)
27250          IDX(J) = IX
27251          L = 1
27252    20 CONTINUE
27253       IF (L.EQ.1) GOTO 10
27254
27255       RETURN
27256       END
27257
27258 *$ CREATE DT_XTIME.FOR
27259 *COPY DT_XTIME
27260 *
27261 *===xtime==============================================================*
27262 *
27263       SUBROUTINE DT_XTIME
27264
27265       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27266       SAVE
27267       PARAMETER ( LINP = 10 ,
27268      &            LOUT = 6 ,
27269      &            LDAT = 9 )
27270
27271       CHARACTER DAT*9,TIM*11
27272
27273       DAT = '         '
27274       TIM = '           '
27275 C     CALL GETDAT(IYEAR,IMONTH,IDAY)
27276 C     CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
27277
27278 C     CALL DATE(DAT)
27279 C     CALL TIME(TIM)
27280 C     WRITE(LOUT,1000) DAT,TIM
27281  1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
27282
27283       RETURN
27284       END
27285
27286 ************************************************************************
27287 *                                                                      *
27288 *                 7) Random number generator package                   *
27289 *                                                                      *
27290 *    THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND        *
27291 *    SERVICE ROUTINES.                                                 *
27292 *    THE ALGORITHM IS FROM                                             *
27293 *      'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR'                     *
27294 *      G.MARSAGLIA, A.ZAMAN ;  FSU-SCRI-87-50                          *
27295 *    IMPLEMENTATION BY K. HAHN  DEC. 88,                               *
27296 *    THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27297 *    AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ),        *
27298 *    THE PERIOD IS ABOUT 2**144,                                       *
27299 *    TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS,            *
27300 *    THE PACKAGE CONTAINS                                              *
27301 *      FUNCTION DT_RNDM(I)                  : GENERATOR                *
27302 *      SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION           *
27303 *      SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)  : PUT SEED TO GENERATOR    *
27304 *      SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)  : TAKE SEED FROM GENERATOR *
27305 *      SUBROUTINE DT_RNDMTE(IO)             : TEST OF GENERATOR        *
27306 *---                                                                   *
27307 *    FUNCTION DT_RNDM(I)                                               *
27308 *       GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS  IN (0..1)          *
27309 *       I  - DUMMY VARIABLE, NOT USED                                  *
27310 *    SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)                             *
27311 *       INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27312 *       NA1,NA2,NA3,NB1  - VALUES FOR INITIALIZING THE GENERATOR       *
27313 *                          NA? MUST BE IN 1..178 AND NOT ALL 1         *
27314 *                          12,34,56  ARE THE STANDARD VALUES           *
27315 *                          NB1 MUST BE IN 1..168                       *
27316 *                          78  IS THE STANDARD VALUE                   *
27317 *    SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)                               *
27318 *       PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS   *
27319 *       AS AFTER THE LAST DT_RNDMOU CALL )                             *
27320 *       U(97),C,CD,CM,I,J  - SEED VALUES AS TAKEN FROM DT_RNDMOU       *
27321 *    SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)                               *
27322 *       TAKES SEED FROM GENERATOR                                      *
27323 *       U(97),C,CD,CM,I,J  - SEED VALUES                               *
27324 *    SUBROUTINE DT_RNDMTE(IO)                                          *
27325 *       TEST OF THE GENERATOR                                          *
27326 *       IO     - DEFINES OUTPUT                                        *
27327 *                  = 0  OUTPUT ONLY IF AN ERROR IS DETECTED            *
27328 *                  = 1  OUTPUT INDEPENDEND ON AN ERROR                 *
27329 *       DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO   *
27330 *       SAME STATUS                                                    *
27331 *       AS BEFORE CALL OF DT_RNDMTE                                    *
27332 ************************************************************************
27333 *$ CREATE DT_RNDM.FOR
27334 *COPY DT_RNDM
27335 *
27336 c$$$*===rndm===============================================================*
27337 c$$$*
27338 c$$$      DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27339 c$$$
27340 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27341 c$$$      SAVE
27342 c$$$
27343 c$$$* random number generator
27344 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27345 c$$$
27346 c$$$* counter of calls to random number generator
27347 c$$$* uncomment if needed
27348 c$$$C     COMMON /DTRNCT/ IRNCT0,IRNCT1
27349 c$$$C     LOGICAL LFIRST
27350 c$$$C     DATA LFIRST /.TRUE./
27351 c$$$
27352 c$$$* counter of calls to random number generator
27353 c$$$* uncomment if needed
27354 c$$$C     IF (LFIRST) THEN
27355 c$$$C        IRNCT0 = 0
27356 c$$$C        IRNCT1 = 0
27357 c$$$C        LFIRST = .FALSE.
27358 c$$$C     ENDIF
27359 c$$$ 100  CONTINUE
27360 c$$$      DT_RNDM = U(I)-U(J)
27361 c$$$      IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27362 c$$$      U(I) = DT_RNDM
27363 c$$$      I    = I-1
27364 c$$$      IF ( I.EQ.0 ) I = 97
27365 c$$$      J    = J-1
27366 c$$$      IF ( J.EQ.0 ) J = 97
27367 c$$$      C    = C-CD
27368 c$$$      IF ( C.LT.0.0D0 ) C = C+CM
27369 c$$$      DT_RNDM = DT_RNDM-C
27370 c$$$      IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27371 c$$$
27372 c$$$      IF ((DT_RNDM.EQ.0.D0).OR.(DT_RNDM.EQ.1.D0)) GOTO 100
27373 c$$$
27374 c$$$* counter of calls to random number generator
27375 c$$$* uncomment if needed
27376 c$$$C     IRNCT0 = IRNCT0+1
27377 c$$$
27378 c$$$      RETURN
27379 c$$$      END
27380 c$$$
27381 c$$$*$ CREATE DT_RNDMST.FOR
27382 c$$$*COPY DT_RNDMST
27383 c$$$*
27384 c$$$*===rndmst=============================================================*
27385 c$$$*
27386 c$$$      SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27387 c$$$
27388 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27389 c$$$      SAVE
27390 c$$$
27391 c$$$* random number generator
27392 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27393 c$$$
27394 c$$$      MA1 = NA1
27395 c$$$      MA2 = NA2
27396 c$$$      MA3 = NA3
27397 c$$$      MB1 = NB1
27398 c$$$      I   = 97
27399 c$$$      J   = 33
27400 c$$$      DO 20 II2 = 1,97
27401 c$$$        S = 0
27402 c$$$        T = 0.5D0
27403 c$$$        DO 10 II1 = 1,24
27404 c$$$          MAT  = MOD(MOD(MA1*MA2,179)*MA3,179)
27405 c$$$          MA1  = MA2
27406 c$$$          MA2  = MA3
27407 c$$$          MA3  = MAT
27408 c$$$          MB1  = MOD(53*MB1+1,169)
27409 c$$$          IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27410 c$$$   10   T = 0.5D0*T
27411 c$$$   20 U(II2) = S
27412 c$$$      C  =   362436.0D0/16777216.0D0
27413 c$$$      CD =  7654321.0D0/16777216.0D0
27414 c$$$      CM = 16777213.0D0/16777216.0D0
27415 c$$$      RETURN
27416 c$$$      END
27417 c$$$
27418 c$$$*$ CREATE DT_RNDMIN.FOR
27419 c$$$*COPY DT_RNDMIN
27420 c$$$*
27421 c$$$*===rndmin=============================================================*
27422 c$$$*
27423 c$$$      SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27424 c$$$
27425 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27426 c$$$      SAVE
27427 c$$$
27428 c$$$* random number generator
27429 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27430 c$$$
27431 c$$$      DIMENSION UIN(97)
27432 c$$$
27433 c$$$      DO 10 KKK = 1,97
27434 c$$$   10 U(KKK) = UIN(KKK)
27435 c$$$      C  = CIN
27436 c$$$      CD = CDIN
27437 c$$$      CM = CMIN
27438 c$$$      I  = IIN
27439 c$$$      J  = JIN
27440 c$$$
27441 c$$$      RETURN
27442 c$$$      END
27443 c$$$
27444 c$$$*$ CREATE DT_RNDMOU.FOR
27445 c$$$*COPY DT_RNDMOU
27446 c$$$*
27447 c$$$*===rndmou=============================================================*
27448 c$$$*
27449 c$$$      SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
27450 c$$$
27451 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27452 c$$$      SAVE
27453 c$$$
27454 c$$$* random number generator
27455 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27456 c$$$
27457 c$$$      DIMENSION UOUT(97)
27458 c$$$
27459 c$$$      DO 10 KKK = 1,97
27460 c$$$   10 UOUT(KKK) = U(KKK)
27461 c$$$      COUT  = C
27462 c$$$      CDOUT = CD
27463 c$$$      CMOUT = CM
27464 c$$$      IOUT  = I
27465 c$$$      JOUT  = J
27466 c$$$
27467 c$$$      RETURN
27468 c$$$      END
27469 c$$$
27470 c$$$*$ CREATE DT_RNDMTE.FOR
27471 c$$$*COPY DT_RNDMTE
27472 c$$$*
27473 c$$$*===rndmte=============================================================*
27474 c$$$*
27475 c$$$      SUBROUTINE DT_RNDMTE(IO)
27476 c$$$
27477 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27478 c$$$      SAVE
27479 c$$$
27480 c$$$      DIMENSION UU(97),U(6),X(6),D(6)
27481 c$$$      DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27482 c$$$     +8354498.D0, 10633180.D0/
27483 c$$$
27484 c$$$      CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27485 c$$$      CALL DT_RNDMST(12,34,56,78)
27486 c$$$      DO 10 II1 = 1,20000
27487 c$$$   10 XX = DT_RNDM(XX)
27488 c$$$      SD        = 0.0D0
27489 c$$$      DO 20 II2 = 1,6
27490 c$$$        X(II2)  = 4096.D0*(4096.D0*DT_RNDM(SD))
27491 c$$$        D(II2)  = X(II2)-U(II2)
27492 c$$$   20 SD = SD+D(II2)
27493 c$$$      CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27494 c$$$**sr 24.01.95
27495 c$$$C     IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27496 c$$$      IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27497 c$$$C        WRITE(6,1000)
27498 c$$$ 1000    FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27499 c$$$     &          ' passed')
27500 c$$$      ENDIF
27501 c$$$**
27502 c$$$      RETURN
27503 c$$$  500 FORMAT('  === TEST OF THE RANDOM-GENERATOR ===',/,
27504 c$$$     &'    EXPECTED VALUE    CALCULATED VALUE     DIFFERENCE',/, 6(F17.
27505 c$$$     &1,F20.1,F15.3,/), '  === END OF TEST ;',
27506 c$$$     &'  GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27507 c$$$      END
27508 *
27509 *$ CREATE PHO_RNDM.FOR
27510 *COPY PHO_RNDM
27511 *
27512 *===pho_rndm===========================================================*
27513 *
27514       DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27515
27516       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27517       SAVE
27518
27519       PHO_RNDM = DT_RNDM(DUMMY)
27520
27521       RETURN
27522       END
27523
27524 *$ CREATE PYR.FOR
27525 *COPY PYR
27526 *
27527 *===pyr================================================================*
27528 *
27529       DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27530
27531       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27532       SAVE
27533
27534       DUMMY = DBLE(IDUMMY)
27535       PYR = DT_RNDM(DUMMY)
27536
27537       RETURN
27538       END
27539
27540 *$ CREATE DT_TITLE.FOR
27541 *COPY DT_TITLE
27542 *
27543 *===title==============================================================*
27544 *
27545       SUBROUTINE DT_TITLE
27546
27547       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27548       SAVE
27549       PARAMETER ( LINP = 10 ,
27550      &            LOUT = 6 ,
27551      &            LDAT = 9 )
27552
27553       CHARACTER*6 CVERSI
27554       CHARACTER*11 CCHANG
27555       DATA CVERSI,CCHANG /'3.0-5 ','08 Jan 2007'/
27556
27557       CALL DT_XTIME
27558       WRITE(LOUT,1000) CVERSI,CCHANG
27559  1000 FORMAT(1X,'+-------------------------------------------------',
27560      &                  '----------------------+',/,
27561      &     1X,'|',71X,'|',/,
27562      &     1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27563      &     1X,'|',71X,'|',/,
27564      &     1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27565      &     1X,'|',71X,'|',/,
27566      &     1X,'|',12X,'Authors: Stefan Roesler   (CERN)',27X,'|',/,
27567      &     1X,'|',21X,'Ralph Engel      (FZ Karlsruhe)',19X,'|',/,
27568      &     1X,'|',21X,'Johannes Ranft   (Siegen Univ.)',19X,'|',/,
27569      &     1X,'|',71X,'|',/,
27570      &     1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27571      &                                              17X,'|',/,
27572      &     1X,'|',71X,'|',/,
27573      &     1X,'+-------------------------------------------------',
27574      &                '----------------------+',/,
27575      &     1X,'| Please send suggestions, bug reports, etc. to: ',
27576      &                                  'Stefan.Roesler@cern.ch |',/,
27577      &     1X,'+-------------------------------------------------',
27578      &                '----------------------+',/)
27579
27580       RETURN
27581       END
27582
27583 *$ CREATE DT_EVTINI.FOR
27584 *COPY DT_EVTINI
27585 *
27586 *===evtini=============================================================*
27587 *
27588       SUBROUTINE DT_EVTINI
27589
27590 ************************************************************************
27591 * Initialization of DTEVT1.                                            *
27592 * This version dated 15.01.94 is written by S. Roesler                 *
27593 ************************************************************************
27594
27595       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27596       SAVE
27597       PARAMETER ( LINP = 10 ,
27598      &            LOUT = 6 ,
27599      &            LDAT = 9 )
27600
27601 * event history
27602       PARAMETER (NMXHKK=200000)
27603       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27604      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27605      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27606 * extended event history
27607       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27608      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27609      &                IHIST(2,NMXHKK)
27610 * event flag
27611       COMMON /DTEVNO/ NEVENT,ICASCA
27612       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27613 * emulsion treatment
27614       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27615      &                NCOMPO,IEMUL
27616
27617 * initialization of DTEVT1/DTEVT2
27618       NEND = NHKK
27619       IF (NEVENT.EQ.1) NEND = NMXHKK
27620       NHKK   = 0
27621       NEVHKK = NEVENT
27622       DO 1 I=1,NEND
27623          ISTHKK(I)   = 0
27624          IDHKK(I)    = 0
27625          JMOHKK(1,I) = 0
27626          JMOHKK(2,I) = 0
27627          JDAHKK(1,I) = 0
27628          JDAHKK(2,I) = 0
27629          IDRES(I)    = 0
27630          IDXRES(I)   = 0
27631          NOBAM(I)    = 0
27632          IDCH(I)     = 0
27633          IHIST(1,I)  = 0
27634          IHIST(2,I)  = 0
27635          DO 2 J=1,4
27636             PHKK(J,I) = 0.0D0
27637             VHKK(J,I) = 0.0D0
27638             WHKK(J,I) = 0.0D0
27639     2    CONTINUE
27640          PHKK(5,I) = 0.0D0
27641     1 CONTINUE
27642       DO 3 I=1,10
27643          NPOINT(I) = 0
27644     3 CONTINUE
27645       CALL DT_CHASTA(-1)
27646
27647 C* initialization of DTLTRA
27648 C      IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27649
27650       RETURN
27651       END
27652
27653 *$ CREATE DT_STATIS.FOR
27654 *COPY DT_STATIS
27655 *
27656 *===statis=============================================================*
27657 *
27658       SUBROUTINE DT_STATIS(MODE)
27659
27660 ************************************************************************
27661 * Initialization and output of run-statistics.                         *
27662 *              MODE  = 1     initialization                            *
27663 *                    = 2     output                                    *
27664 * This version dated 23.01.94 is written by S. Roesler                 *
27665 ************************************************************************
27666
27667       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27668       SAVE
27669       PARAMETER ( LINP = 10 ,
27670      &            LOUT = 6 ,
27671      &            LDAT = 9 )
27672       PARAMETER (TINY3=1.0D-3)
27673
27674 * statistics
27675       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27676      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27677      &                ICEVTG(8,0:30)
27678 * rejection counter
27679       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27680      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27681      &                IREXCI(3),IRDIFF(2),IRINC
27682 * central particle production, impact parameter biasing
27683       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27684 * various options for treatment of partons (DTUNUC 1.x)
27685 * (chain recombination, Cronin,..)
27686       LOGICAL LCO2CR,LINTPT
27687       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27688      &                LCO2CR,LINTPT
27689 * nucleon-nucleon event-generator
27690       CHARACTER*8 CMODEL
27691       LOGICAL LPHOIN
27692       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27693 * flags for particle decays
27694       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27695      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27696      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27697 * diquark-breaking mechanism
27698       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27699
27700       DIMENSION PP(4),PT(4)
27701
27702       GOTO (1,2) MODE
27703
27704 * initialization
27705     1 CONTINUE
27706
27707 *   initialize statistics counter
27708       ICREQU = 0
27709       ICSAMP = 0
27710       ICCPRO = 0
27711       ICDPR  = 0
27712       ICDTA  = 0
27713       ICRJSS = 0
27714       ICVV2S = 0
27715       DO 10 I=1,9
27716          ICRES(I)    = 0
27717          ICCHAI(1,I) = 0
27718          ICCHAI(2,I) = 0
27719    10 CONTINUE
27720 *   initialize rejection counter
27721       IRPT      = 0
27722       IRHHA     = 0
27723       LOMRES    = 0
27724       LOBRES    = 0
27725       IRFRAG    = 0
27726       IREVT     = 0
27727       IRRES(1)  = 0
27728       IRRES(2)  = 0
27729       IRCHKI(1) = 0
27730       IRCHKI(2) = 0
27731       IRCRON(1) = 0
27732       IRCRON(2) = 0
27733       IRCRON(3) = 0
27734       IRDIFF(1) = 0
27735       IRDIFF(2) = 0
27736       IRINC     = 0
27737       DO 11 I=1,5
27738          ICDIFF(I) = 0
27739    11 CONTINUE
27740       DO 12 I=1,8
27741          DO 13 J=0,30
27742             ICEVTG(I,J) = 0
27743    13    CONTINUE
27744    12 CONTINUE
27745
27746       RETURN
27747
27748 * output
27749     2 CONTINUE
27750
27751 *   statistics counter
27752       WRITE(LOUT,1000)
27753  1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27754      &       28X,'---------------------')
27755       IF (ICREQU.GT.0) THEN
27756       WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27757  1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27758      &       I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27759      &       'event',11X,F9.1)
27760       ENDIF
27761       IF (ICDIFF(1).NE.0) THEN
27762          WRITE(LOUT,1009) ICDIFF
27763  1009    FORMAT(/,1X,'diffractive events:    total   ',I8,/,49X,
27764      &          'low mass   high mass',/,24X,'single diffraction',
27765      &          7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27766       ENDIF
27767       IF (ICENTR.GT.0.AND.ICSAMP.GT.0.AND.ICCPRO.GT.0) THEN
27768          WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27769      &                    DBLE(ICSAMP)/DBLE(ICCPRO)
27770  1002    FORMAT(/,1X,'central production:',/,2X,'mean number',
27771      &          ' of sampled Glauber-events per event',9X,F9.1,/,
27772      &          2X,'fraction of production cross section',21X,F10.6)
27773       ENDIF
27774       IF (ICSAMP.GT.0) THEN
27775       WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27776      &                 DBLE(ICDTA)/DBLE(ICSAMP)
27777  1003 FORMAT(/,54X,'proj.    targ.',/,1X,'average number of wounded',
27778      &       ' nucleons after x-sampling',2(4X,F6.2))
27779       ENDIF
27780
27781       IF (MCGENE.EQ.1) THEN
27782          IF (ICSAMP.GT.0) THEN
27783          WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27784  1004    FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27785      &          ' event',3X,F9.1)
27786          IF (ISICHA.EQ.1) THEN
27787             WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27788  1005       FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27789      &             'of single chains  per event',13X,F9.1)
27790          ENDIF
27791          ENDIF
27792          IF (ICSAMP.GT.0.AND.ICREQU.GT.0) THEN
27793          WRITE(LOUT,1006)
27794  1006    FORMAT(/,1X,'chain system statistics:  (per event)',/,
27795      &       23X,'mean number of chains      mean number of chains',/,
27796      &       23X,'sampled    hadronized      having mass of a reso.')
27797          WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27798      &                     DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27799      &                     DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27800      &                  DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27801  1007    FORMAT(1X,'sea     - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27802      &          1X,'disea   - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27803      &          1X,'sea     - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27804      &          1X,'sea     - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27805      &          1X,'disea   - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27806      &          1X,'valence - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27807      &          1X,'valence - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27808      &          1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27809      &          1X,'fused chains      ',18X,F4.1,17X,F4.1,/)
27810          WRITE(LOUT,1008)
27811      &     (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27812      &     DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27813      &     DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27814      &     (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27815      &     (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27816      &     DBLE(IRHHA)/DBLE(ICREQU),
27817      &     DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27818      &     (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27819  1008    FORMAT(/,1X,'Rejection counter:  (NEVT = no. of events)',/,/,
27820      &       1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27821      &       F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27822      &       'Intrins. p_t (GETSPT)',21X,'IRPT     /NEVT = ',F7.2,/,
27823      &       1X,'Chain mass corr. for resonances (EVTRES)',2X,
27824      &       'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES)  IRRES(2) /',
27825      &       'NEVT = ',F7.2,/,43X,'LOMRES   /NEVT = ',F7.2,/,
27826      &       43X,'LOBRES   /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27827      &       ' 2-chain systems (CHKINE)  IRCHKI(1)/NEVT = ',F7.2,/,
27828      &       43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27829      &       'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27830      &       F7.2,/,1X,'Total no. of rej.',
27831      &       ' in chain-systems treatment (GETCSY)',/,43X,
27832      &       'IRHHA    /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27833      &       ' (not yet used!)',4X,'IRFRAG   /NEVT = ',F7.2,/,
27834      &       1X,'Total no. of rej. in DPM-treatment of one event',
27835      &       ' (EVENTA)',/,43X,'IREVT    /NEVT = ',F7.2,/,1X,
27836      &       'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27837      &       ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27838      &       'IREXCI(3) = ',I5,/)
27839          ENDIF
27840       ELSEIF (MCGENE.EQ.2) THEN
27841          WRITE(LOUT,1010) ELOJET
27842  1010    FORMAT(/,/,1X,'PHOJET-treatment of chain systems above  ',
27843      &          F4.1,' GeV')
27844          WRITE(LOUT,1011)
27845  1011    FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27846      &          30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27847      &          5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27848          WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27849      &                    (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27850      &                    (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27851      &                    ((ICEVTG(I,J),I=1,8),J=3,7),
27852      &                    ((ICEVTG(I,J),I=1,8),J=19,21),
27853      &                    (ICEVTG(I,8),I=1,8),
27854      &                    ((ICEVTG(I,J),I=1,8),J=22,24),
27855      &                    (ICEVTG(I,9),I=1,8),
27856      &                    ((ICEVTG(I,J),I=1,8),J=25,28),
27857      &                    ((ICEVTG(I,J),I=1,8),J=10,18)
27858  1012    FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27859      &          8I8,/,/,1X,'PHOJET ',8I8,/,'   sngl ',8I8,/,/,
27860      &          ' no-dif.',8I8,/,
27861      &          ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27862      &          ' diff-1 ',8I8,/,'  low   ',8I8,/,'  high  ',8I8,/,
27863      &          '  h-diff',8I8,/,' diff-2 ',8I8,/,'  low   ',8I8,/,
27864      &          '  high  ',8I8,/,'  h-diff',8I8,/,' dbl-di.',8I8,/,
27865      &          '  lo-lo ',8I8,/,'  hi-hi ',8I8,/,'  lo-hi ',8I8,/,
27866      &          '  hi-lo ',8I8,/,
27867      &          ' dir-ga.',8I8,/,/,' dir-1  ',8I8,/,' dir-2  ',8I8,/,
27868      &          ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27869      &          ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27870          WRITE(LOUT,1013)
27871  1013    FORMAT(/,1X,'2. chain system statistics -',
27872      &          ' mean numbers per evt:',/,30X,'---------------------',
27873      &          /,/,16X,'s-s',7X,'d-s',7X,'s-d')
27874          IF (ICSAMP.GT.0) THEN
27875          WRITE(LOUT,1014)
27876      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27877      &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27878      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27879  1014    FORMAT(/,1X,'req.to.    ',3E10.2,/,/,1X,'low rq.    ',3E10.2,/,
27880      &          1X,'low ac.    ',3E10.2,/,/,1X,'PHOJET     ',3E10.2,/,/,
27881      &          ' no-dif.    ',3E10.2,/,' el-sca.    ',3E10.2,/,
27882      &          ' qel-sc.    ',3E10.2,/,' dbl-Po.    ',3E10.2,/,
27883      &          ' diff-1     ',3E10.2,/,' diff-2     ',3E10.2,/,
27884      &          ' dbl-di.    ',3E10.2,/,' dir-ga.    ',3E10.2,/,/,
27885      &          ' dir-1      ',3E10.2,/,' dir-2      ',3E10.2,/,
27886      &          ' dbl-dir    ',3E10.2,/,' s-Pom.     ',3E10.2,/,
27887      &          ' h-Pom.     ',3E10.2,/,' s-Reg.     ',3E10.2,/,
27888      &          ' enh-trg    ',3E10.2,/,' enh-log    ',3E10.2)
27889          ENDIF
27890          WRITE(LOUT,1015)
27891  1015    FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
27892          IF (ICSAMP.GT.0) THEN
27893          WRITE(LOUT,1016)
27894      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27895      &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27896      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27897  1016    FORMAT(/,1X,'req.to.    ',5E10.2,/,/,1X,'low rq.    ',5E10.2,/,
27898      &          1X,'low ac.    ',5E10.2,/,/,1X,'PHOJET     ',5E10.2,/,/,
27899      &          ' no-dif.    ',5E10.2,/,' el-sca.    ',5E10.2,/,
27900      &          ' qel-sc.    ',5E10.2,/,' dbl-Po.    ',5E10.2,/,
27901      &          ' diff-1     ',5E10.2,/,' diff-2     ',5E10.2,/,
27902      &          ' dbl-di.    ',5E10.2,/,' dir-ga.    ',5E10.2,/,/,
27903      &          ' dir-1      ',5E10.2,/,' dir-2      ',5E10.2,/,
27904      &          ' dbl-dir    ',5E10.2,/,' s-Pom.     ',5E10.2,/,
27905      &          ' h-Pom.     ',5E10.2,/,' s-Reg.     ',5E10.2,/,
27906      &          ' enh-trg    ',5E10.2,/,' enh-log    ',5E10.2)
27907          ENDIF
27908
27909       ENDIF
27910       CALL DT_CHASTA(1)
27911
27912       IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27913      &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
27914          WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27915      &    DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27916      &    DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27917          WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27918      &    DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27919      &    DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27920          WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27921      &    DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27922      &    DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27923          WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27924      &    DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27925      &    DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27926          WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27927      &    DBRKA(3,1),DBRKA(3,2),
27928      &    DBRKA(3,3),DBRKA(3,4)
27929          WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27930      &    DBRKR(3,1),DBRKR(3,2),
27931      &    DBRKR(3,3),DBRKR(3,4)
27932          WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27933      &    DBRKA(3,5),DBRKA(3,6),
27934      &    DBRKA(3,7),DBRKA(3,8)
27935          WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27936      &    DBRKR(3,5),DBRKR(3,6),
27937      &    DBRKR(3,7),DBRKR(3,8)
27938       ENDIF
27939
27940       FAC = 1.0D0
27941       IF (MCGENE.EQ.2) THEN
27942 C        CALL PHO_PHIST(-2,SIGMAX)
27943          CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27944       ENDIF
27945
27946       CALL DT_XTIME
27947
27948       RETURN
27949       END
27950
27951 *$ CREATE DT_EVTOUT.FOR
27952 *COPY DT_EVTOUT
27953 *
27954 *===evtout=============================================================*
27955 *
27956       SUBROUTINE DT_EVTOUT(MODE)
27957
27958 ************************************************************************
27959 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
27960 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
27961 *                    4  plot entries of DTEVT1 and DTEVT2              *
27962 * This version dated 11.12.94 is written by S. Roesler                 *
27963 ************************************************************************
27964
27965       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27966       SAVE
27967       PARAMETER ( LINP = 10 ,
27968      &            LOUT = 6 ,
27969      &            LDAT = 9 )
27970 * event history
27971       PARAMETER (NMXHKK=200000)
27972       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27973      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27974      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27975
27976       DIMENSION IRANGE(NMXHKK)
27977
27978       IF (MODE.EQ.2) RETURN
27979
27980       CALL DT_EVTPLO(IRANGE,MODE)
27981
27982       RETURN
27983       END
27984
27985 *$ CREATE DT_EVTPLO.FOR
27986 *COPY DT_EVTPLO
27987 *
27988 *===evtplo=============================================================*
27989 *
27990       SUBROUTINE DT_EVTPLO(IRANGE,MODE)
27991
27992 ************************************************************************
27993 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
27994 *                    2  plot entries of DTEVT1 given by IRANGE         *
27995 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
27996 *                    4  plot entries of DTEVT1 and DTEVT2              *
27997 *                    5  plot rejection counter                         *
27998 * This version dated 11.12.94 is written by S. Roesler                 *
27999 ************************************************************************
28000
28001       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28002       SAVE
28003       PARAMETER ( LINP = 10 ,
28004      &            LOUT = 6 ,
28005      &            LDAT = 9 )
28006
28007       CHARACTER*16 CHAU
28008
28009 * event history
28010       PARAMETER (NMXHKK=200000)
28011       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28012      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28013      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28014 * extended event history
28015       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28016      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28017      &                IHIST(2,NMXHKK)
28018 * rejection counter
28019       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
28020      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
28021      &                IREXCI(3),IRDIFF(2),IRINC
28022
28023       DIMENSION IRANGE(NMXHKK)
28024
28025       IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
28026          WRITE(LOUT,1000)
28027  1000    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTEVT1/',/,
28028      &         15X,'           --------------------------',/,/,
28029      &             '       ST    ID  M1   M2   D1   D2     PX     PY',
28030      &             '     PZ      E       M',/)
28031          DO 1 I=1,NHKK
28032             WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28033      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28034      &                       PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28035      &                       PHKK(5,I)
28036 C           WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28037 C    &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28038 C    &                       PHKK(3,I),PHKK(4,I)
28039 C           WRITE(LOUT,'(4E15.4)')
28040 C    &         VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
28041  1001       FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
28042  1011       FORMAT(I5,I5,I6,4I5,2E15.5)
28043     1    CONTINUE
28044          WRITE(LOUT,*)
28045 C        DO 4 I=1,NHKK
28046 C           WRITE(LOUT,1006) I,ISTHKK(I),
28047 C    &                    VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
28048 C    &                    WHKK(2,I),WHKK(3,I)
28049 C1006       FORMAT(1X,I4,I6,6E10.3)
28050 C   4    CONTINUE
28051       ENDIF
28052
28053       IF (MODE.EQ.2) THEN
28054          WRITE(LOUT,1000)
28055          NC = 0
28056     2    CONTINUE
28057          NC = NC+1
28058          IF (IRANGE(NC).EQ.-100) GOTO 9999
28059          I = IRANGE(NC)
28060          WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28061      &                    JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28062      &                    PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28063      &                    PHKK(5,I)
28064          GOTO 2
28065       ENDIF
28066
28067       IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
28068          WRITE(LOUT,1002)
28069  1002    FORMAT(/,1X,'EVTPLO:',14X,
28070      &         ' content of COMMON /DTEVT1/,/DTEVT2/',/,
28071      &         15X,'        -----------------------------------',/,/,
28072      &             '       ST    ID   M1   M2   D1   D2  IDR  IDXR',
28073      &             ' NOBAM IDCH    M',/)
28074          DO 3 I=1,NHKK
28075 C           IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
28076                KF    = IDHKK(I)
28077                IDCHK = KF/10000
28078                IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28079      &            (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
28080                CALL PYNAME(KF,CHAU)
28081                WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28082      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28083      &                       IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
28084      &                       PHKK(5,I),CHAU
28085  1003          FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
28086 C           ENDIF
28087     3    CONTINUE
28088       ENDIF
28089
28090       IF (MODE.EQ.5) THEN
28091          WRITE(LOUT,1004)
28092  1004    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTREJC/',/,
28093      &         15X,'           --------------------------',/)
28094          WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
28095      &                    IRSEA,IRCRON
28096  1005    FORMAT(1X,'IRPT   = ',I5,'  IRHHA = ',I5,/,
28097      &          1X,'IRRES  = ',2I5,'  LOMRES = ',I5,'  LOBRES = ',I5,/,
28098      &          1X,'IREMC  = ',10I5,/,
28099      &          1X,'IRFRAG = ',I5,'  IRSEA = ',I5,' IRCRON = ',I5,/)
28100       ENDIF
28101
28102  9999 RETURN
28103       END
28104
28105 *$ CREATE DT_EVTPUT.FOR
28106 *COPY DT_EVTPUT
28107 *
28108 *===evtput=============================================================*
28109 *
28110       SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
28111
28112       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28113       SAVE
28114       PARAMETER ( LINP = 10 ,
28115      &            LOUT = 6 ,
28116      &            LDAT = 9 )
28117       PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
28118      &           TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
28119
28120 * event history
28121       PARAMETER (NMXHKK=200000)
28122       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28123      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28124      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28125 * extended event history
28126       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28127      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28128      &                IHIST(2,NMXHKK)
28129 * Lorentz-parameters of the current interaction
28130       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28131      &                UMO,PPCM,EPROJ,PPROJ
28132 * particle properties (BAMJET index convention)
28133       CHARACTER*8  ANAME
28134       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28135      &                IICH(210),IIBAR(210),K1(210),K2(210)
28136
28137 C     IF (MODE.GT.100) THEN
28138 C        WRITE(LOUT,'(1X,A,I5,A,I5)')
28139 C    &        'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
28140 C        NHKK = NHKK-MODE+100
28141 C        RETURN
28142 C     ENDIF
28143       MO1  = M1
28144       MO2  = M2
28145       NHKK = NHKK+1
28146
28147       IF (NHKK.GT.NMXHKK) THEN
28148          WRITE(LOUT,1000) NHKK
28149  1000    FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
28150      &             '! program execution stopped..')
28151          STOP
28152       ENDIF
28153       IF (M1.LT.0) MO1 = NHKK+M1
28154       IF (M2.LT.0) MO2 = NHKK+M2
28155       ISTHKK(NHKK)   = IST
28156       IDHKK(NHKK)    = ID
28157       JMOHKK(1,NHKK) = MO1
28158       JMOHKK(2,NHKK) = MO2
28159       JDAHKK(1,NHKK) = 0
28160       JDAHKK(2,NHKK) = 0
28161       IDRES(NHKK)    = IDR
28162       IDXRES(NHKK)   = IDXR
28163       IDCH(NHKK)     = IDC
28164 ** here we need to do something..
28165       IF (ID.EQ.88888) THEN
28166          IDMO1 = ABS(IDHKK(MO1))
28167          IDMO2 = ABS(IDHKK(MO2))
28168          IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
28169          IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
28170          IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
28171          IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
28172       ELSE
28173          NOBAM(NHKK) = 0
28174       ENDIF
28175       IDBAM(NHKK) = IDT_ICIHAD(ID)
28176       IF (MO1.GT.0) THEN
28177          IF (JDAHKK(1,MO1).NE.0) THEN
28178             JDAHKK(2,MO1) = NHKK
28179          ELSE
28180             JDAHKK(1,MO1) = NHKK
28181          ENDIF
28182       ENDIF
28183       IF (MO2.GT.0) THEN
28184          IF (JDAHKK(1,MO2).NE.0) THEN
28185             JDAHKK(2,MO2) = NHKK
28186          ELSE
28187             JDAHKK(1,MO2) = NHKK
28188          ENDIF
28189       ENDIF
28190 C      IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
28191 C         PTOT   = SQRT(PX**2+PY**2+PZ**2)
28192 C         AM0    = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
28193 C         AMRQ   = AAM(IDBAM(NHKK))
28194 C         AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
28195 C         IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
28196 C     &       (PTOT.GT.ZERO)) THEN
28197 C            DELTA = -AMDIF2/(2.0D0*(E+PTOT))
28198 CC           DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
28199 C            E     = E+DELTA
28200 C            PTOT1 = PTOT-DELTA
28201 C            PX    = PX*PTOT1/PTOT
28202 C            PY    = PY*PTOT1/PTOT
28203 C            PZ    = PZ*PTOT1/PTOT
28204 C         ENDIF
28205 C      ENDIF
28206       PHKK(1,NHKK) = PX
28207       PHKK(2,NHKK) = PY
28208       PHKK(3,NHKK) = PZ
28209       PHKK(4,NHKK) = E
28210       PTOT = SQRT( PX**2+PY**2+PZ**2 )
28211       IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
28212          PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
28213          PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
28214       ELSE
28215          PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
28216 C        IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
28217 C    &      WRITE(LOUT,'(1X,A,G10.3)')
28218 C    &        'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
28219          PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
28220       ENDIF
28221       IDCHK = ID/10000
28222       IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
28223 * special treatment for chains:
28224 *    z coordinate of chain in Lab  = pos. of target nucleon
28225 *    time of chain-creation in Lab = time of passage of projectile
28226 *                                    nucleus at pos. of taget nucleus
28227 C        VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
28228 C        VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
28229          VHKK(1,NHKK) = VHKK(1,MO2)
28230          VHKK(2,NHKK) = VHKK(2,MO2)
28231          VHKK(3,NHKK) = VHKK(3,MO2)
28232          VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
28233 C        WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
28234 C        WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
28235          WHKK(1,NHKK) = WHKK(1,MO1)
28236          WHKK(2,NHKK) = WHKK(2,MO1)
28237          WHKK(3,NHKK) = WHKK(3,MO1)
28238          WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
28239       ELSE
28240          IF (MO1.GT.0) THEN
28241             DO 1 I=1,4
28242                VHKK(I,NHKK) = VHKK(I,MO1)
28243                WHKK(I,NHKK) = WHKK(I,MO1)
28244     1       CONTINUE
28245          ELSE
28246             DO 2 I=1,4
28247                VHKK(I,NHKK) = ZERO
28248                WHKK(I,NHKK) = ZERO
28249     2       CONTINUE
28250          ENDIF
28251       ENDIF
28252
28253       RETURN
28254       END
28255
28256 *$ CREATE DT_CHASTA.FOR
28257 *COPY DT_CHASTA
28258 *
28259 *===chasta=============================================================*
28260 *
28261       SUBROUTINE DT_CHASTA(MODE)
28262
28263 ************************************************************************
28264 * This subroutine performs CHAin STAtistics and checks sequence of     *
28265 * partons in dtevt1 and sorts them with projectile partons coming      *
28266 * first if necessary.                                                  *
28267 *                                                                      *
28268 * This version dated  8.5.00  is written by S. Roesler.                *
28269 ************************************************************************
28270
28271       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28272       SAVE
28273       PARAMETER ( LINP = 10 ,
28274      &            LOUT = 6 ,
28275      &            LDAT = 9 )
28276
28277       CHARACTER*5 CCHTYP
28278
28279 * event history
28280       PARAMETER (NMXHKK=200000)
28281       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28282      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28283      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28284 * extended event history
28285       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28286      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28287      &                IHIST(2,NMXHKK)
28288 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28289       PARAMETER (MAXCHN=10000)
28290       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28291
28292       DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28293      &          CCHTYP(9),ICHSTA(10),ITOT(10)
28294       DATA ICHCFG /1800*0/
28295       DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28296       DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28297       DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28298       DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28299       DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28300       DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28301       DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28302      &              'ad aq',' d ad','ad d ',' g g '/
28303 *
28304 * initialization
28305 *
28306       IF (MODE.EQ.-1) THEN
28307          NCHAIN = 0
28308 *
28309 * loop over DTEVT1 and analyse chain configurations
28310 *
28311       ELSEIF (MODE.EQ.0) THEN
28312          DO 21 IDX=NPOINT(3),NHKK
28313             IDCHK = IDHKK(IDX)/10000
28314             IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28315      &          (IDHKK(IDX).NE.80000).AND.
28316      &          (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28317                IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28318                   WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28319      &                          ' at entry ',IDX
28320                   GOTO 21
28321                ENDIF
28322 *
28323                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28324                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28325                IMO1 = IST1/10
28326                IMO1 = IST1-10*IMO1
28327                IMO2 = IST2/10
28328                IMO2 = IST2-10*IMO2
28329 *   swop parton entries if necessary since we need projectile partons
28330 *   to come first in the common
28331                IF (IMO1.GT.IMO2) THEN
28332                   NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28333                   DO 22 K=1,NPTN/2
28334                      I0 = JMOHKK(1,IDX)-1+K
28335                      I1 = JMOHKK(2,IDX)+1-K
28336                      ITMP = ISTHKK(I0)
28337                      ISTHKK(I0) = ISTHKK(I1)
28338                      ISTHKK(I1) = ITMP
28339                      ITMP = IDHKK(I0)
28340                      IDHKK(I0) = IDHKK(I1)
28341                      IDHKK(I1) = ITMP
28342                      IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28343      &                  JDAHKK(1,JMOHKK(1,I0)) = I1
28344                      IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28345      &                  JDAHKK(2,JMOHKK(1,I0)) = I1
28346                      IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28347      &                  JDAHKK(1,JMOHKK(2,I0)) = I1
28348                      IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28349      &                  JDAHKK(2,JMOHKK(2,I0)) = I1
28350                      IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28351      &                  JDAHKK(1,JMOHKK(1,I1)) = I0
28352                      IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28353      &                  JDAHKK(2,JMOHKK(1,I1)) = I0
28354                      IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28355      &                  JDAHKK(1,JMOHKK(2,I1)) = I0
28356                      IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28357      &                  JDAHKK(2,JMOHKK(2,I1)) = I0
28358                      ITMP = JMOHKK(1,I0)
28359                      JMOHKK(1,I0) = JMOHKK(1,I1)
28360                      JMOHKK(1,I1) = ITMP
28361                      ITMP = JMOHKK(2,I0)
28362                      JMOHKK(2,I0) = JMOHKK(2,I1)
28363                      JMOHKK(2,I1) = ITMP
28364                      ITMP = JDAHKK(1,I0)
28365                      JDAHKK(1,I0) = JDAHKK(1,I1)
28366                      JDAHKK(1,I1) = ITMP
28367                      ITMP = JDAHKK(2,I0)
28368                      JDAHKK(2,I0) = JDAHKK(2,I1)
28369                      JDAHKK(2,I1) = ITMP
28370                      DO 23 J=1,4
28371                         RTMP1 = PHKK(J,I0)
28372                         RTMP2 = VHKK(J,I0)
28373                         RTMP3 = WHKK(J,I0)
28374                         PHKK(J,I0) = PHKK(J,I1)
28375                         VHKK(J,I0) = VHKK(J,I1)
28376                         WHKK(J,I0) = WHKK(J,I1)
28377                         PHKK(J,I1) = RTMP1
28378                         VHKK(J,I1) = RTMP2
28379                         WHKK(J,I1) = RTMP3
28380    23                CONTINUE
28381                      RTMP1 = PHKK(5,I0)
28382                      PHKK(5,I0) = PHKK(5,I1)
28383                      PHKK(5,I1) = RTMP1
28384                      ITMP = IDRES(I0)
28385                      IDRES(I0) = IDRES(I1)
28386                      IDRES(I1) = ITMP
28387                      ITMP = IDXRES(I0)
28388                      IDXRES(I0) = IDXRES(I1)
28389                      IDXRES(I1) = ITMP
28390                      ITMP = NOBAM(I0)
28391                      NOBAM(I0) = NOBAM(I1)
28392                      NOBAM(I1) = ITMP
28393                      ITMP = IDBAM(I0)
28394                      IDBAM(I0) = IDBAM(I1)
28395                      IDBAM(I1) = ITMP
28396                      ITMP = IDCH(I0)
28397                      IDCH(I0) = IDCH(I1)
28398                      IDCH(I1) = ITMP
28399                      ITMP = IHIST(1,I0)
28400                      IHIST(1,I0) = IHIST(1,I1)
28401                      IHIST(1,I1) = ITMP
28402                      ITMP = IHIST(2,I0)
28403                      IHIST(2,I0) = IHIST(2,I1)
28404                      IHIST(2,I1) = ITMP
28405    22             CONTINUE
28406                ENDIF
28407                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28408                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28409 *
28410 *   parton 1 (projectile side)
28411                IF (IST1.EQ.21) THEN
28412                   IDX1 = 1
28413                ELSEIF (IST1.EQ.22) THEN
28414                   IDX1 = 2
28415                ELSEIF (IST1.EQ.31) THEN
28416                   IDX1 = 3
28417                ELSEIF (IST1.EQ.32) THEN
28418                   IDX1 = 4
28419                ELSEIF (IST1.EQ.41) THEN
28420                   IDX1 = 5
28421                ELSEIF (IST1.EQ.42) THEN
28422                   IDX1 = 6
28423                ELSEIF (IST1.EQ.51) THEN
28424                   IDX1 = 7
28425                ELSEIF (IST1.EQ.52) THEN
28426                   IDX1 = 8
28427                ELSEIF (IST1.EQ.61) THEN
28428                   IDX1 = 9
28429                ELSEIF (IST1.EQ.62) THEN
28430                   IDX1 = 10
28431                ELSE
28432 c                 WRITE(LOUT,*)
28433 c    &               ' CHASTA: unknown parton status flag (',
28434 c    &               IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28435                   GOTO 21
28436                ENDIF
28437                ID = IDHKK(JMOHKK(1,IDX))
28438                IF (ABS(ID).LE.4) THEN
28439                   IF (ID.GT.0) THEN
28440                      ITYP1 = 1
28441                   ELSE
28442                      ITYP1 = 2
28443                   ENDIF
28444                ELSEIF (ABS(ID).GE.1000) THEN
28445                   IF (ID.GT.0) THEN
28446                      ITYP1 = 3
28447                   ELSE
28448                      ITYP1 = 4
28449                   ENDIF
28450                ELSEIF (ID.EQ.21) THEN
28451                   ITYP1 = 5
28452                ELSE
28453                   WRITE(LOUT,*)
28454      &               ' CHASTA: inconsistent parton identity (',
28455      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28456                   GOTO 21
28457                ENDIF
28458 *
28459 *   parton 2 (target side)
28460                IF (IST2.EQ.21) THEN
28461                   IDX2 = 1
28462                ELSEIF (IST2.EQ.22) THEN
28463                   IDX2 = 2
28464                ELSEIF (IST2.EQ.31) THEN
28465                   IDX2 = 3
28466                ELSEIF (IST2.EQ.32) THEN
28467                   IDX2 = 4
28468                ELSEIF (IST2.EQ.41) THEN
28469                   IDX2 = 5
28470                ELSEIF (IST2.EQ.42) THEN
28471                   IDX2 = 6
28472                ELSEIF (IST2.EQ.51) THEN
28473                   IDX2 = 7
28474                ELSEIF (IST2.EQ.52) THEN
28475                   IDX2 = 8
28476                ELSEIF (IST2.EQ.61) THEN
28477                   IDX2 = 9
28478                ELSEIF (IST2.EQ.62) THEN
28479                   IDX2 = 10
28480                ELSE
28481 c                 WRITE(LOUT,*)
28482 c    &               ' CHASTA: unknown parton status flag (',
28483 c    &               IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28484                   GOTO 21
28485                ENDIF
28486                ID = IDHKK(JMOHKK(2,IDX))
28487                IF (ABS(ID).LE.4) THEN
28488                   IF (ID.GT.0) THEN
28489                      ITYP2 = 1
28490                   ELSE
28491                      ITYP2 = 2
28492                   ENDIF
28493                ELSEIF (ABS(ID).GE.1000) THEN
28494                   IF (ID.GT.0) THEN
28495                      ITYP2 = 3
28496                   ELSE
28497                      ITYP2 = 4
28498                   ENDIF
28499                ELSEIF (ID.EQ.21) THEN
28500                   ITYP2 = 5
28501                ELSE
28502                   WRITE(LOUT,*)
28503      &               ' CHASTA: inconsistent parton identity (',
28504      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28505                   GOTO 21
28506                ENDIF
28507 *
28508 *   fill counter
28509                ITYPE = ICHTYP(ITYP1,ITYP2)
28510                IF (ITYPE.NE.0) THEN
28511                   ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28512                   NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28513                   ICHCFG(IDX1,IDX2,ITYPE,2) =
28514      &               ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28515
28516                   NCHAIN = NCHAIN+1
28517                   IF (NCHAIN.GT.MAXCHN) THEN
28518                      WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28519      &                  NCHAIN,MAXCHN
28520                      STOP
28521                   ENDIF
28522                   IDXCHN(1,NCHAIN) = IDX
28523                   IDXCHN(2,NCHAIN) = ITYPE
28524                ELSE
28525                   WRITE(LOUT,*)
28526      &               ' CHASTA: inconsistent chain at entry ',IDX
28527                   GOTO 21
28528                ENDIF
28529             ENDIF
28530    21    CONTINUE
28531 *
28532 * write statistics to output unit
28533 *
28534       ELSEIF (MODE.EQ.1) THEN
28535          WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28536          DO 31 I=1,10
28537             WRITE(LOUT,'(/,2A)')
28538      &         ' -----------------------------------------',
28539      &         '------------------------------------'
28540             WRITE(LOUT,'(2A)')
28541      &         ' p\\t         21     22     31     32     41',
28542      &         '     42     51     52     61     62'
28543             WRITE(LOUT,'(2A)')
28544      &         ' -----------------------------------------',
28545      &         '------------------------------------'
28546             DO 32 J=1,10
28547                ITOT(J) = 0
28548                DO 33 K=1,9
28549                   ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28550    33          CONTINUE
28551    32       CONTINUE
28552             WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28553             DO 34 K=1,9
28554                ISUM = 0
28555                DO 35 J=1,10
28556                   ISUM = ISUM+ICHCFG(I,J,K,1)
28557    35          CONTINUE
28558                IF (ISUM.GT.0)
28559      &            WRITE(LOUT,'(1X,A5,2X,10I7)')
28560      &               CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28561    34       CONTINUE
28562 C           WRITE(LOUT,'(2A)')
28563 C    &         ' -----------------------------------------',
28564 C    &         '-------------------------------'
28565    31    CONTINUE
28566 *
28567       ELSE
28568          WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28569          STOP
28570       ENDIF
28571
28572       RETURN
28573       END
28574 *$ CREATE PHO_PHIST.FOR
28575 *COPY PHO_PHIST
28576 *
28577 *===pohist=============================================================*
28578 *
28579       SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28580
28581       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28582       SAVE
28583
28584       PARAMETER ( LINP = 10 ,
28585      &            LOUT = 6 ,
28586      &            LDAT = 9 )
28587       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28588 * Glauber formalism: cross sections
28589       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28590      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28591      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28592      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28593      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28594      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28595      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28596      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28597      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28598      &                BSLOPE,NEBINI,NQBINI
28599
28600       ILAB = 0
28601       IF (IMODE.EQ.10) THEN
28602          IMODE = 1
28603          ILAB  = 1
28604       ENDIF
28605       IF (ABS(IMODE).LT.1000) THEN
28606 * PHOJET-statistics
28607 C        CALL POHISX(IMODE,WEIGHT)
28608          IF (IMODE.EQ.-1) THEN
28609             MODE = 1
28610             XSTOT(1,1,1) = WEIGHT
28611          ENDIF
28612          IF (IMODE.EQ. 1) MODE = 2
28613          IF (IMODE.EQ.-2) MODE = 3
28614          IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28615 C        IF (MODE.EQ.3) WRITE(LOUT,*)
28616 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
28617          CALL DT_HISTOG(MODE)
28618          CALL DT_USRHIS(MODE)
28619       ELSE
28620 * DTUNUC-statistics
28621          MODE = IMODE/1000
28622 C        IF (MODE.EQ.3) WRITE(LOUT,*)
28623 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
28624          CALL DT_HISTOG(MODE)
28625          CALL DT_USRHIS(MODE)
28626       ENDIF
28627
28628       RETURN
28629       END
28630
28631 *$ CREATE DT_SWPPHO.FOR
28632 *COPY DT_SWPPHO
28633 *
28634 *===swppho=============================================================*
28635 *
28636       SUBROUTINE DT_SWPPHO(ILAB)
28637
28638       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28639       SAVE
28640       PARAMETER ( LINP = 10 ,
28641      &            LOUT = 6 ,
28642      &            LDAT = 9 )
28643       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28644
28645       LOGICAL LSTART
28646
28647 * event history
28648       PARAMETER (NMXHKK=200000)
28649       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28650      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28651      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28652 * extended event history
28653       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28654      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28655      &                IHIST(2,NMXHKK)
28656 * flags for input different options
28657       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28658       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28659      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28660 * properties of photon/lepton projectiles
28661       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28662
28663 **PHOJET105a
28664 C     PARAMETER (NMXHEP=2000)
28665 C     COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28666 C    &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28667 C     COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28668 C     COMMON /PLASAV/ PLAB
28669 **PHOJET110
28670 C  standard particle data interface
28671       INTEGER NMXHEP
28672       PARAMETER (NMXHEP=4000)
28673       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28674       DOUBLE PRECISION PHEP,VHEP
28675       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28676      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28677      &                VHEP(4,NMXHEP),NSD1, NSD2, NDD
28678 C  extension to standard particle data interface (PHOJET specific)
28679       INTEGER IMPART,IPHIST,ICOLOR
28680       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28681 C  global event kinematics and particle IDs
28682       INTEGER IFPAP,IFPAB
28683       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28684       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28685 **
28686       DATA ICOUNT/0/
28687
28688       DATA LSTART /.TRUE./
28689
28690 C     IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28691       IF ((IFRAME.EQ.1).AND.LSTART) THEN
28692          UMO  = ECM
28693          ELA  = ZERO
28694          PLA  = ZERO
28695          IDP  = IDT_ICIHAD(IFPAP(1))
28696          IDT  = IDT_ICIHAD(IFPAP(2))
28697          VIRT = PVIRT(1)
28698          CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28699          PLAB = PLA
28700          LSTART = .FALSE.
28701       ENDIF
28702
28703       NHKK   = 0
28704       ICOUNT = ICOUNT+1
28705 C     NEVHKK = NEVHEP
28706       NEVHKK = ICOUNT
28707       IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28708       DO 1 I=3,NHEP
28709          IF (ISTHEP(I).EQ.1) THEN
28710             NHKK = NHKK+1
28711             ISTHKK(NHKK) = 1
28712             IDHKK(NHKK)  = IDHEP(I)
28713             JMOHKK(1,NHKK) = 0
28714             JMOHKK(2,NHKK) = 0
28715             JDAHKK(1,NHKK) = 0
28716             JDAHKK(2,NHKK) = 0
28717             DO 2 K=1,4
28718                PHKK(K,NHKK) = PHEP(K,I)
28719                VHKK(K,NHKK) = ZERO
28720                WHKK(K,NHKK) = ZERO
28721     2       CONTINUE
28722             IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28723      &         CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28724      &                    PHKK(3,NHKK),PHKK(4,NHKK),-3)
28725             PHKK(5,NHKK) = PHEP(5,I)
28726             IDRES(NHKK)  = 0
28727             IDXRES(NHKK) = 0
28728             NOBAM(NHKK)  = 0
28729             IDBAM(NHKK)  = IDT_ICIHAD(IDHEP(I))
28730             IDCH(NHKK)   = 0
28731          ENDIF
28732     1 CONTINUE
28733
28734       RETURN
28735       END
28736
28737 *$ CREATE DT_HISTOG.FOR
28738 *COPY DT_HISTOG
28739 *
28740 *===histog=============================================================*
28741 *
28742       SUBROUTINE DT_HISTOG(MODE)
28743
28744 ************************************************************************
28745 * This version dated 25.03.96 is written by S. Roesler                 *
28746 ************************************************************************
28747
28748       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28749       SAVE
28750       PARAMETER ( LINP = 10 ,
28751      &            LOUT = 6 ,
28752      &            LDAT = 9 )
28753
28754       LOGICAL LFSP,LRNL
28755
28756 * event history
28757       PARAMETER (NMXHKK=200000)
28758       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28759      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28760      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28761 * extended event history
28762       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28763      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28764      &                IHIST(2,NMXHKK)
28765 * event flag used for histograms
28766       COMMON /DTNORM/ ICEVT,IEVHKK
28767 * flags for activated histograms
28768       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28769
28770       IEVHKK = NEVHKK
28771       GOTO (1,2,3) MODE
28772
28773 *------------------------------------------------------------------
28774 * initialization
28775     1 CONTINUE
28776       ICEVT = 0
28777       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28778       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28779
28780       RETURN
28781 *------------------------------------------------------------------
28782 * filling of histogram with event-record
28783     2 CONTINUE
28784       ICEVT = ICEVT+1
28785
28786       DO 20 I=1,NHKK
28787          CALL DT_SWPFSP(I,LFSP,LRNL)
28788          IF (LFSP) THEN
28789             IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28790             IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28791          ENDIF
28792          IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28793    20 CONTINUE
28794       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28795
28796       RETURN
28797 *------------------------------------------------------------------
28798 * output
28799     3 CONTINUE
28800       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28801       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28802
28803       RETURN
28804       END
28805
28806 *$ CREATE DT_SWPFSP.FOR
28807 *COPY DT_SWPFSP
28808 *
28809 *===swpfsp=============================================================*
28810 *
28811       SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28812
28813       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28814       SAVE
28815       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28816       PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28817      &           PI   =TWOPI/TWO,
28818      &           BOG  =TWOPI/360.0D0)
28819
28820 * event history
28821       PARAMETER (NMXHKK=200000)
28822       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28823      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28824      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28825 * extended event history
28826       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28827      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28828      &                IHIST(2,NMXHKK)
28829 * particle properties (BAMJET index convention)
28830       CHARACTER*8  ANAME
28831       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28832      &                IICH(210),IIBAR(210),K1(210),K2(210)
28833 * Lorentz-parameters of the current interaction
28834       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28835      &                UMO,PPCM,EPROJ,PPROJ
28836 * flags for input different options
28837       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28838       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28839      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28840 * (original name: PAREVT)
28841       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28842      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
28843       PARAMETER ( NALLWP = 39   )
28844       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
28845      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28846      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28847      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
28848 * temporary storage for one final state particle
28849       LOGICAL LFRAG,LGREY,LBLACK
28850       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28851      &                SINTHE,COSTHE,THETA,THECMS,
28852      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28853      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28854      &                LFRAG,LGREY,LBLACK
28855
28856       LOGICAL LFSP,LRNL
28857
28858       LFSP = .FALSE.
28859       LRNL = .FALSE.
28860       ISTRNL = 1000
28861       MULDEF = 1
28862       IF (LEVPRT) ISTRNL = 1001
28863
28864       IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28865          IST    = ISTHKK(IDX)
28866          IDPDG  = IDHKK(IDX)
28867          LFRAG  = .FALSE.
28868          IF (IDHKK(IDX).LT.80000) THEN
28869             IDBJT  = IDBAM(IDX)
28870             IBARY  = IIBAR(IDBJT)
28871             ICHAR  = IICH(IDBJT)
28872             AMASS  = AAM(IDBJT)
28873          ELSEIF (IDHKK(IDX).EQ.80000) THEN
28874             IDBJT  = 0
28875             IBARY  = IDRES(IDX)
28876             ICHAR  = IDXRES(IDX)
28877             AMASS  = PHKK(5,IDX)
28878             INUT   = IBARY-ICHAR
28879             IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28880             IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28881             IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28882             IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28883             IF (IDBJT.EQ.0) LFRAG = .TRUE.
28884          ELSE
28885             GOTO 9999
28886          ENDIF
28887          PE     = PHKK(4,IDX)
28888          PX     = PHKK(1,IDX)
28889          PY     = PHKK(2,IDX)
28890          PZ     = PHKK(3,IDX)
28891          PT2    = PX**2+PY**2
28892          PT     = SQRT(PT2)
28893          PTOT   = SQRT(PT2+PZ**2)
28894          SINTHE = PT/MAX(PTOT,TINY14)
28895          COSTHE = PZ/MAX(PTOT,TINY14)
28896          IF (COSTHE.GT.ONE) THEN
28897             THETA = ZERO
28898          ELSEIF (COSTHE.LT.-ONE) THEN
28899             THETA = TWOPI/2.0D0
28900          ELSE
28901             THETA = ACOS(COSTHE)
28902          ENDIF
28903          EKIN   = PE-AMASS
28904 **sr 15.4.96 new E_t-definition
28905          IF (IBARY.GT.0) THEN
28906             ET = EKIN*SINTHE
28907          ELSEIF (IBARY.LT.0) THEN
28908             ET = (EKIN+TWO*AMASS)*SINTHE
28909          ELSE
28910             ET = PE*SINTHE
28911          ENDIF
28912 **
28913          XLAB   = PZ/MAX(PPROJ,TINY14)
28914 C        XLAB   = PE/MAX(EPROJ,TINY14)
28915          BETA   = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28916      &                     *(ONE+AMASS/MAX(PE,TINY14)) ))
28917          PPLUS  = PE+PZ
28918          PMINUS = PE-PZ
28919          IF (PMINUS.GT.TINY14) THEN
28920             YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28921          ELSE
28922             YY = 100.0D0
28923          ENDIF
28924          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28925             ETA = -LOG(TAN(THETA/TWO))
28926          ELSE
28927             ETA = 100.0D0
28928          ENDIF
28929          IF (IFRAME.EQ.1) THEN
28930             CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28931             PPLUS  = EECMS+PZCMS
28932             PMINUS = EECMS-PZCMS
28933             IF ((PPLUS*PMINUS).GT.TINY14) THEN
28934                YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28935             ELSE
28936                YYCMS = 100.0D0
28937             ENDIF
28938             PTOTCM = SQRT(PT2+PZCMS**2)
28939             COSTH = PZCMS/MAX(PTOTCM,TINY14)
28940             IF (COSTH.GT.ONE) THEN
28941                THECMS = ZERO
28942             ELSEIF (COSTH.LT.-ONE) THEN
28943                THECMS = TWOPI/2.0D0
28944             ELSE
28945                THECMS = ACOS(COSTH)
28946             ENDIF
28947             IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28948                ETACMS = -LOG(TAN(THECMS/TWO))
28949             ELSE
28950                ETACMS = 100.0D0
28951             ENDIF
28952             XF = PZCMS/MAX(PPCM,TINY14)
28953             THECMS = THECMS/BOG
28954          ELSE
28955             PZCMS  = PZ
28956             EECMS  = PE
28957             YYCMS  = YY
28958             ETACMS = ETA
28959             XF     = XLAB
28960             THECMS = THETA/BOG
28961          ENDIF
28962          THETA  = THETA/BOG
28963
28964 * set flag for "grey/black"
28965          LGREY  = .FALSE.
28966          LBLACK = .FALSE.
28967          EK     = EKIN
28968          IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28969          IF (MULDEF.EQ.1) THEN
28970 *  EMU01-Def.
28971             IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28972      &                              (EK.LE.375.0D-3)      ).OR.
28973      &           ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28974      &                              (EK.LE. 56.0D-3)      ).OR.
28975      &           ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28976      &                              (EK.LE. 56.0D-3)      ).OR.
28977      &           ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28978      &                              (EK.LE.198.0D-3)      ).OR.
28979      &           ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28980      &                              (EK.LE.198.0D-3)      ).OR.
28981      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28982      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28983      &             (IDBJT.NE.16).AND.
28984      &             (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)    ) )
28985      &         LGREY = .TRUE.
28986             IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
28987      &           ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
28988      &           ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
28989      &           ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
28990      &           ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
28991      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28992      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28993      &             (IDBJT.NE.16).AND.(BETA.LE.0.23D0)  ) )
28994      &         LBLACK = .TRUE.
28995          ELSE
28996 *  common Def.
28997             IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
28998             IF (BETA.LE.0.23D0) LBLACK=.TRUE.
28999          ENDIF
29000          LFSP = .TRUE.
29001       ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
29002          IST    = ISTHKK(IDX)
29003          IDPDG  = IDHKK(IDX)
29004          LFRAG  = .TRUE.
29005          IDBJT  = 0
29006          IBARY  = IDRES(IDX)
29007          ICHAR  = IDXRES(IDX)
29008          AMASS  = PHKK(5,IDX)
29009          PE     = PHKK(4,IDX)
29010          PX     = PHKK(1,IDX)
29011          PY     = PHKK(2,IDX)
29012          PZ     = PHKK(3,IDX)
29013          PT2    = PX**2+PY**2
29014          PT     = SQRT(PT2)
29015          PTOT   = SQRT(PT2+PZ**2)
29016          SINTHE = PT/MAX(PTOT,TINY14)
29017          COSTHE = PZ/MAX(PTOT,TINY14)
29018          IF (COSTHE.GT.ONE) THEN
29019             THETA = ZERO
29020          ELSEIF (COSTHE.LT.-ONE) THEN
29021             THETA = TWOPI/2.0D0
29022          ELSE
29023             THETA  = ACOS(COSTHE)
29024          ENDIF
29025          EKIN   = PE-AMASS
29026 **sr 15.4.96 new E_t-definition
29027 C        ET     = PE*SINTHE
29028          ET     = EKIN*SINTHE
29029 **
29030          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
29031             ETA = -LOG(TAN(THETA/TWO))
29032          ELSE
29033             ETA = 100.0D0
29034          ENDIF
29035          THETA  = THETA/BOG
29036          LRNL   = .TRUE.
29037       ENDIF
29038
29039  9999 CONTINUE
29040       RETURN
29041       END
29042
29043 *$ CREATE DT_HIMULT.FOR
29044 *COPY DT_HIMULT
29045 *
29046 *===himult=============================================================*
29047 *
29048       SUBROUTINE DT_HIMULT(MODE)
29049
29050 ************************************************************************
29051 * Tables of average energies/multiplicities.                           *
29052 * This version dated 30.08.2000 is written by S. Roesler               *
29053 ************************************************************************
29054
29055       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29056       SAVE
29057       PARAMETER ( LINP = 10 ,
29058      &            LOUT = 6 ,
29059      &            LDAT = 9 )
29060       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29061
29062       PARAMETER (SWMEXP=1.7D0)
29063
29064       CHARACTER*8 ANAMEH(4)
29065
29066 * particle properties (BAMJET index convention)
29067       CHARACTER*8  ANAME
29068       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29069      &                IICH(210),IIBAR(210),K1(210),K2(210)
29070 * temporary storage for one final state particle
29071       LOGICAL LFRAG,LGREY,LBLACK
29072       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29073      &                SINTHE,COSTHE,THETA,THECMS,
29074      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29075      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29076      &                LFRAG,LGREY,LBLACK
29077 * event flag used for histograms
29078       COMMON /DTNORM/ ICEVT,IEVHKK
29079 * Lorentz-parameters of the current interaction
29080       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
29081      &                UMO,PPCM,EPROJ,PPROJ
29082
29083       PARAMETER (NOPART=210)
29084       DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
29085      &          AVPT(4,NOPART),IAVPT(4,NOPART)
29086       DATA ANAMEH /'DEUTERON','3-H     ','3-HE    ','4-HE    '/
29087
29088       GOTO (1,2,3) MODE
29089
29090 *------------------------------------------------------------------
29091 * initialization
29092     1 CONTINUE
29093       DO 10 I=1,NOPART
29094          DO 11 J=1,4
29095             AVMULT(J,I) = ZERO
29096             AVE(J,I)    = ZERO
29097             AVSWM(J,I)  = ZERO
29098             AVPT(J,I)   = ZERO
29099             IAVPT(J,I)  = 0
29100    11    CONTINUE
29101    10 CONTINUE
29102
29103       RETURN
29104
29105 *------------------------------------------------------------------
29106 * filling of histogram with event-record
29107     2 CONTINUE
29108       IF (PE.LT.0.0D0) THEN
29109          WRITE(LOUT,*) ' HIMULT:  PE < 0 ! ',PE
29110          RETURN
29111       ENDIF
29112       IF (.NOT.LFRAG) THEN
29113          IVEL = 2
29114          IF (LGREY)  IVEL = 3
29115          IF (LBLACK) IVEL = 4
29116          AVE(1,IDBJT)       = AVE(1,IDBJT)   +PE
29117          AVE(IVEL,IDBJT)    = AVE(IVEL,IDBJT)+PE
29118          AVPT(1,IDBJT)     = AVPT(1,IDBJT)   +PT
29119          AVPT(IVEL,IDBJT)  = AVPT(IVEL,IDBJT)+PT
29120          IAVPT(1,IDBJT)    = IAVPT(1,IDBJT)   +1
29121          IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
29122          AVSWM(1,IDBJT)     = AVSWM(1,IDBJT)   +PE**SWMEXP
29123          AVSWM(IVEL,IDBJT)  = AVSWM(IVEL,IDBJT)+PE**SWMEXP
29124          AVMULT(1,IDBJT)    = AVMULT(1,IDBJT)   +ONE
29125          AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
29126          IF (IDBJT.LT.116) THEN
29127 *   total energy, multiplicity
29128             AVE(1,30)       = AVE(1,30)   +PE
29129             AVE(IVEL,30)    = AVE(IVEL,30)+PE
29130             AVPT(1,30)     = AVPT(1,30)   +PT
29131             AVPT(IVEL,30)  = AVPT(IVEL,30)+PT
29132             IAVPT(1,30)    = IAVPT(1,30)   +1
29133             IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
29134             AVSWM(1,30)     = AVSWM(1,30)+PE**SWMEXP
29135             AVSWM(IVEL,30)  = AVSWM(IVEL,30)+PE**SWMEXP
29136             AVMULT(1,30)    = AVMULT(1,30)   +ONE
29137             AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
29138 *   charged energy, multiplicity
29139             IF (ICHAR.LT.0) THEN
29140                AVE(1,26)       = AVE(1,26)   +PE
29141                AVE(IVEL,26)    = AVE(IVEL,26)+PE
29142                AVPT(1,26)     = AVPT(1,26)   +PT
29143                AVPT(IVEL,26)  = AVPT(IVEL,26)+PT
29144                IAVPT(1,26)    = IAVPT(1,26)   +1
29145                IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
29146                AVSWM(1,26)     = AVSWM(1,26)   +PE**SWMEXP
29147                AVSWM(IVEL,26)  = AVSWM(IVEL,26)+PE**SWMEXP
29148                AVMULT(1,26)    = AVMULT(1,26)   +ONE
29149                AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
29150             ENDIF
29151             IF (ICHAR.NE.0) THEN
29152                AVE(1,27)       = AVE(1,27)   +PE
29153                AVE(IVEL,27)    = AVE(IVEL,27)+PE
29154                AVPT(1,27)     = AVPT(1,27)   +PT
29155                AVPT(IVEL,27)  = AVPT(IVEL,27)+PT
29156                IAVPT(1,27)    = IAVPT(1,27)   +1
29157                IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
29158                AVSWM(1,27)     = AVSWM(1,27)   +PE**SWMEXP
29159                AVSWM(IVEL,27)  = AVSWM(IVEL,27)+PE**SWMEXP
29160                AVMULT(1,27)    = AVMULT(1,27)   +ONE
29161                AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
29162             ENDIF
29163          ENDIF
29164       ENDIF
29165
29166       RETURN
29167
29168 *------------------------------------------------------------------
29169 * output
29170     3 CONTINUE
29171       WRITE(LOUT,3000)
29172  3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
29173      &       29X,'---------------------',/)
29174       IF (MULDEF.EQ.1) THEN
29175          WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
29176       ELSE
29177          BETGRE = 0.7D0
29178          BETBLC = 0.23D0
29179          WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
29180  3002    FORMAT(1X,'fast:  beta > ',F4.2,'    grey:  ',F4.2,' > beta > '
29181      &          ,F4.2,'    black:  beta < ',F4.2,/)
29182       ENDIF
29183       WRITE(LOUT,3003) SWMEXP
29184  3003 FORMAT(1X,'particle    |',12X,'average multiplicity',/,
29185      &      13X,'|     total         fast',
29186 C    &      '       grey     black      K      f(',F3.1,')',/,1X,
29187      &      '       grey     black    <pt>     f(',F3.1,')',/,1X,
29188      &      '------------+--------------',
29189      &      '-------------------------------------------------')
29190       DO 30 I=1,NOPART
29191          DO 31 J=1,4
29192             AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
29193             AVE(J,I)    = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
29194             AVPT(J,I)   = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
29195             AVSWM(J,I)  = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
29196    31    CONTINUE
29197          IF (I.LE.115) THEN
29198             WRITE(LOUT,3004) ANAME(I),I,
29199      &                       AVMULT(1,I),AVMULT(2,I),
29200      &                       AVMULT(3,I),AVMULT(4,I),
29201 C    &                       AVE(1,I),AVSWM(1,I)
29202      &                       AVPT(1,I),AVSWM(1,I)
29203          ELSEIF (I.LE.119) THEN
29204             WRITE(LOUT,3004) ANAMEH(I-115),I,
29205      &                       AVMULT(1,I),AVMULT(2,I),
29206      &                       AVMULT(3,I),AVMULT(4,I),
29207 C    &                       AVE(1,I),AVSWM(1,I)
29208      &                       AVPT(1,I),AVSWM(1,I)
29209          ENDIF
29210  3004    FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29211    30 CONTINUE
29212 **temporary
29213 C     WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29214 C    &               AVMULT(3,27)+AVMULT(4,27)
29215 **
29216
29217       RETURN
29218       END
29219
29220 *$ CREATE DT_HISTAT.FOR
29221 *COPY DT_HISTAT
29222 *
29223 *===histat=============================================================*
29224 *
29225       SUBROUTINE DT_HISTAT(IDX,MODE)
29226
29227 ************************************************************************
29228 * This version dated 26.02.96 is written by S. Roesler                 *
29229 *                                                                      *
29230 * Last change 27.12.2006 by S. Roesler.                                *
29231 ************************************************************************
29232
29233       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29234       SAVE
29235       PARAMETER ( LINP = 10 ,
29236      &            LOUT = 6 ,
29237      &            LDAT = 9 )
29238       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29239       PARAMETER (NDIM=199)
29240
29241 * event history
29242       PARAMETER (NMXHKK=200000)
29243       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29244      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29245      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29246 * extended event history
29247       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29248      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29249      &                IHIST(2,NMXHKK)
29250 * particle properties (BAMJET index convention)
29251       CHARACTER*8  ANAME
29252       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29253      &                IICH(210),IIBAR(210),K1(210),K2(210)
29254       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29255 * Glauber formalism: cross sections
29256       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29257      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29258      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29259      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29260      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29261      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29262      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29263      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29264      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29265      &                BSLOPE,NEBINI,NQBINI
29266 * emulsion treatment
29267       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29268      &                NCOMPO,IEMUL
29269 * properties of interacting particles
29270       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29271 * rejection counter
29272       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29273      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29274      &                IREXCI(3),IRDIFF(2),IRINC
29275 * statistics: residual nuclei
29276       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29277      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29278      &                NINCST(2,4),NINCEV(2),
29279      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29280      &                NRESPB(2),NRESCH(2),NRESEV(4),
29281      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29282      &                NEVAFI(2,2)
29283 * parameter for intranuclear cascade
29284       LOGICAL LPAULI
29285       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29286 * (original name: PAREVT)
29287       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29288      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
29289       PARAMETER ( NALLWP = 39   )
29290       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
29291      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29292      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29293      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
29294 * (original name: FRBKCM)
29295       PARAMETER ( MXFFBK =     6 )
29296       PARAMETER ( MXZFBK =     9 )
29297       PARAMETER ( MXNFBK =    10 )
29298       PARAMETER ( MXAFBK =    16 )
29299       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
29300       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
29301       PARAMETER ( NXAFBK = MXAFBK + 1 )
29302       PARAMETER ( MXPSST =   300 )
29303       PARAMETER ( MXPSFB = 41000 )
29304       LOGICAL LFRMBK, LNCMSS
29305       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29306      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
29307      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
29308      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
29309      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29310      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
29311      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29312      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
29313      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
29314 * (original name: INPFLG)
29315       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
29316 * temporary storage for one final state particle
29317       LOGICAL LFRAG,LGREY,LBLACK
29318       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29319      &                SINTHE,COSTHE,THETA,THECMS,
29320      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29321      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29322      &                LFRAG,LGREY,LBLACK
29323 * event flag used for histograms
29324       COMMON /DTNORM/ ICEVT,IEVHKK
29325 * statistics: double-Pomeron exchange
29326       COMMON /DTFLG2/ INTFLG,IPOPO
29327
29328       DIMENSION EMUSAM(NCOMPX)
29329
29330       CHARACTER*13 CMSG(3)
29331       DATA CMSG /'not requested','not requested','not requested'/
29332
29333       GOTO (1,2,3,4,5) MODE
29334
29335 *------------------------------------------------------------------
29336 * initialization
29337     1 CONTINUE
29338 *  emulsion treatment
29339       IF (NCOMPO.GT.0) THEN
29340          DO 10 I=1,NCOMPX
29341             EMUSAM(I) = ZERO
29342    10    CONTINUE
29343       ENDIF
29344 * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29345       NINCGE = 0
29346       DO 11 I=1,2
29347          EXCDPM(I)   = ZERO
29348          EXCDPM(I+2) = ZERO
29349          EXCEVA(I)   = ZERO
29350          NINCWO(I)   = 0
29351          NINCEV(I)   = 0
29352          NRESTO(I)   = 0
29353          NRESPR(I)   = 0
29354          NRESNU(I)   = 0
29355          NRESBA(I)   = 0
29356          NRESPB(I)   = 0
29357          NRESCH(I)   = 0
29358          NRESEV(I)   = 0
29359          NRESEV(I+2) = 0
29360          NEVAGA(I)   = 0
29361          NEVAHT(I)   = 0
29362          NEVAFI(1,I) = 0
29363          NEVAFI(2,I) = 0
29364          DO 12 J=1,6
29365             IF (J.LE.2) NINCHR(I,J) = 0
29366             IF (J.LE.3) NINCCO(I,J) = 0
29367             IF (J.LE.4) NINCST(I,J) = 0
29368             NEVA(I,J) = 0
29369    12    CONTINUE
29370          DO 13 J=1,210
29371             NEVAHY(1,I,J) = 0
29372             NEVAHY(2,I,J) = 0
29373    13    CONTINUE
29374    11 CONTINUE
29375       MAXGEN = 0
29376 **dble Po statistics.
29377       KPOPO = 0
29378
29379       RETURN
29380 *------------------------------------------------------------------
29381 * filling of histogram with event-record
29382     2 CONTINUE
29383       IF (IST.EQ.-1) THEN
29384          IF (.NOT.LFRAG) THEN
29385             IF (IDPDG.EQ.2212) THEN
29386                NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29387             ELSEIF (IDPDG.EQ.2112) THEN
29388                NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29389             ELSEIF (IDPDG.EQ.22) THEN
29390                NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29391             ELSEIF (IDPDG.EQ.80000) THEN
29392                IF (IDBJT.EQ.116) THEN
29393                   NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29394                ELSEIF (IDBJT.EQ.117) THEN
29395                   NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29396                ELSEIF (IDBJT.EQ.118) THEN
29397                   NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29398                ELSEIF (IDBJT.EQ.119) THEN
29399                   NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29400                ENDIF
29401             ENDIF
29402          ELSE
29403 *   heavy fragments (here: fission products only)
29404             NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29405             NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29406             NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29407          ENDIF
29408       ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29409          IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29410       ENDIF
29411
29412       RETURN
29413 *------------------------------------------------------------------
29414 * output
29415     3 CONTINUE
29416
29417 **dble Po statistics.
29418 C     WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29419 C    &   '# evts. / # dble-Po. evts / s_in / s_popo :',
29420 C    & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29421
29422 *  emulsion treatment
29423       IF (NCOMPO.GT.0) THEN
29424          WRITE(LOUT,3000)
29425  3000    FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29426      &          22X,'----------------------------',/,/,19X,
29427      &          'mass    charge          fraction',/,39X,
29428      &          'input     treated',/)
29429          DO 30 I=1,NCOMPO
29430             WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29431      &                       EMUSAM(I)/DBLE(ICEVT)
29432  3013       FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29433    30    CONTINUE
29434       ENDIF
29435
29436 *  i.n.c. statistics: output
29437       WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29438  3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29439      &       22X,'---------------------------------',/,/,1X,
29440      &       'no. of events for normalization: (accepted final events,',
29441      &       ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29442      &       /,1X,'no. of rejected events due to intranuclear',
29443      &       ' cascade',15X,I6,/)
29444       ICEV  = MAX(ICEVT,1)
29445       ICEV1 = ICEV
29446       IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29447       WRITE(LOUT,3002)
29448      &     (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29449      &     ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29450      &     KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29451      &    (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29452      &     (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29453      &     (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29454      &     (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29455  3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29456      &       5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29457      &       ' proj./ target (mean per evt)',/,8X,'baryons:  pos. ',
29458      &       F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,/,8X,
29459      &       'mesons:   pos. ',F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,
29460      &       /,1X,'maximum no. of generations treated (maximum allowed:'
29461      &       ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29462      &       ' interactions in proj./ target (mean per evt1)',
29463      &       F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29464      &       ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29465      &       'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29466      &       '(ap, K-, pi- only)     ',F7.3,' /',F7.3,/)
29467       WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29468      &                 IREXCI(1)+IREXCI(2)+IREXCI(3)
29469  3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29470      &       'evaporation',/,22X,'-----------------------------',
29471      &       '------------',/,/,1X,'no. of events for normal.: ',
29472      &       '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29473      &       ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29474      &       ' rejected events     (',I4,',',I4,',',I4,')',22X,I6,/)
29475
29476       WRITE(LOUT,3004)
29477  3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29478       ICEV  = MAX(NRESEV(2),1)
29479       WRITE(LOUT,3005)
29480      &     (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29481      &     (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29482      &     (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29483      &     (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29484      &     (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29485      &     (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29486      &     (EXCDPM(I)/DBLE(ICEV),I=1,2),
29487      &     (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29488  3005    FORMAT(1X,'residual nuclei:  (mean values per evt)',12X,
29489      &       'proj. / target',/,/,8X,'total number of particles',15X,
29490      &       2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29491      &       'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29492      &       'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29493      &       /,8X,'excitation energy (bef. evap.-step)   ',2E11.3,/,
29494      &       8X,'excitation energy per nucleon         ',2E11.3,/,/)
29495
29496 * evaporation / fission / fragmentation statistics: output
29497       ICEV  = MAX(NRESEV(2),1)
29498       ICEV1 = MAX(NRESEV(4),1)
29499       NTEVA1 =
29500      &   NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29501       NTEVA2 =
29502      &   NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29503       IF (LEVPRT) THEN
29504          IF (IFISS.EQ.1) CMSG(1) = 'requested    '
29505          IF (LFRMBK)     CMSG(2) = 'requested    '
29506          IF (LDEEXG)     CMSG(3) = 'requested    '
29507          WRITE(LOUT,3006)
29508      &        CMSG,
29509      &        DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29510      &        (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29511      &        (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29512      &        (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29513      &        (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29514      &        (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29515      &        (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29516      &        (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29517      &        (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29518  3006    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,'Fission:',
29519      &       13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29520      &       'deexcitation:',2X,A13,/,/,
29521      &       1X,'evaporation/deexcitation:  (mean values per evt1)  ',
29522      &       'proj. / target',/,/,8X,'total number of evap. particles',
29523      &       9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29524      &       'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29525      &       '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29526      &       2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29527      &       'heavy fragments',25X,2F9.3,/)
29528          IF (IFISS.EQ.1) THEN
29529             WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29530      &                       NEVAFI(2,1),NEVAFI(2,2),
29531      &             DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29532      &             DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29533  3007       FORMAT(1X,'Fission:   total number of events',14X,2I9,/
29534      &             12X,'out of which fission occured',8X,2I9,/,
29535      &             50X,'(',F5.2,'%) (',F5.2,'%)',/)
29536          ENDIF
29537 C        IF ((LFRMBK).OR.(IFISS.EQ.1)) THEN
29538 C           WRITE(LOUT,3008)
29539 C3008       FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29540 C    &             '       proj.   / target',/)
29541 C           DO 31 I=1,210
29542 C              IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29543 C                 WRITE(LOUT,3009) I,
29544 C    &            (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29545 C3009             FORMAT(38X,I3,3X,2E12.3)
29546 C              ENDIF
29547 C  31       CONTINUE
29548 C           WRITE(LOUT,3010)
29549 C3010       FORMAT(1X,'heavy fragments - statistics:',7X,'mass  ',
29550 C    &             '       proj.   / target',/)
29551 C           DO 32 I=1,210
29552 C              IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29553 C                 WRITE(LOUT,3011) I,
29554 C    &            (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29555 C3011             FORMAT(38X,I3,3X,2E12.3)
29556 C              ENDIF
29557 C  32       CONTINUE
29558 C           WRITE(LOUT,*)
29559 C        ENDIF
29560       ELSE
29561          WRITE(LOUT,3012)
29562  3012    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,
29563      &       'Evaporation:         not requested',/)
29564       ENDIF
29565
29566       RETURN
29567 *------------------------------------------------------------------
29568 * filling of histogram with event-record
29569     4 CONTINUE
29570 *  emulsion treatment
29571       IF (NCOMPO.GT.0) THEN
29572          DO 40 I=1,NCOMPO
29573             IF (IT.EQ.IEMUMA(I)) THEN
29574                EMUSAM(I) = EMUSAM(I)+ONE
29575             ENDIF
29576    40    CONTINUE
29577       ENDIF
29578       NINCGE = NINCGE+MAXGEN
29579       MAXGEN = 0
29580 **dble Po statistics.
29581       IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29582
29583       RETURN
29584 *------------------------------------------------------------------
29585 * filling of histogram with event-record
29586     5 CONTINUE
29587       IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29588          IB = IIBAR(IDBAM(IDX))
29589          IC = IICH(IDBAM(IDX))
29590          J  = ISTHKK(IDX)-14
29591          IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29592             NINCST(J,1) = NINCST(J,1)+1
29593          ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29594             NINCST(J,2) = NINCST(J,2)+1
29595          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29596             NINCST(J,3) = NINCST(J,3)+1
29597          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29598             NINCST(J,4) = NINCST(J,4)+1
29599          ENDIF
29600       ELSEIF (ISTHKK(IDX).EQ.17) THEN
29601          NINCWO(1) = NINCWO(1)+1
29602       ELSEIF (ISTHKK(IDX).EQ.18) THEN
29603          NINCWO(2) = NINCWO(2)+1
29604       ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29605          IB = IDRES(IDX)
29606          IC = IDXRES(IDX)
29607          IF (IC.GT.0) THEN
29608             NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29609             NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29610          ENDIF
29611          NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29612       ENDIF
29613
29614       RETURN
29615       END
29616
29617 *$ CREATE DT_NEWHGR.FOR
29618 *COPY DT_NEWHGR
29619 *
29620 *===newhgr=============================================================*
29621 *
29622       SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29623
29624 ************************************************************************
29625 *                                                                      *
29626 *     Histogram initialization.                                        *
29627 *                                                                      *
29628 *     input:  XLIM1/XLIM2  lower/upper edge of histogram-window        *
29629 *             XLIM3        bin size                                    *
29630 *             IBIN    > 0  number of bins in equidistant lin. binning  *
29631 *                     = -1 reset histograms                            *
29632 *                     < -1 |IBIN| number of bins in equidistant log.   *
29633 *                          binning or log. binning in user def. struc. *
29634 *             XLIMB(*)     user defined bin structure                  *
29635 *                                                                      *
29636 *     The bin structure is sensitive to                                *
29637 *             XLIM1, XLIM3, IBIN     if     XLIM3 > 0   (lin.)         *
29638 *             XLIM1, XLIM2, IBIN     if     XLIM3 = 0   (lin. & log.)  *
29639 *             XLIMB, IBIN            if     XLIM3 < 0                  *
29640 *                                                                      *
29641 *                                                                      *
29642 *     output: IREFN        histogram index                             *
29643 *                          (= -1 for inconsistent histogr. request)    *
29644 *                                                                      *
29645 * This subroutine is based on a original version by R. Engel.          *
29646 * This version dated 22.4.95 is written  by S. Roesler.                *
29647 ************************************************************************
29648
29649       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29650       SAVE
29651       PARAMETER ( LINP = 10 ,
29652      &            LOUT = 6 ,
29653      &            LDAT = 9 )
29654
29655       LOGICAL LSTART
29656
29657       PARAMETER (ZERO   =  0.0D0,
29658      &           TINY   =  1.0D-10)
29659
29660       DIMENSION XLIMB(*)
29661
29662 * histograms
29663       PARAMETER (NHIS=150, NDIM=250)
29664       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29665      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29666 * auxiliary common for histograms
29667       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29668
29669       DATA LSTART /.TRUE./
29670
29671 * reset histogram counter
29672       IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29673          IHISL  = 0
29674          IF (IBIN.EQ.-1) RETURN
29675          LSTART = .FALSE.
29676       ENDIF
29677
29678       IHIS  = IHISL+1
29679 * check for maximum number of allowed histograms
29680       IF (IHIS.GT.NHIS) THEN
29681          WRITE(LOUT,1003) IHIS,NHIS,IHIS
29682  1003    FORMAT(1X,'NEWHGR:   warning!  number of histograms (',
29683      &          I4,') exceeds array size (',I4,')',/,21X,
29684      &          'histogram',I3,' skipped!')
29685          GOTO 9999
29686       ENDIF
29687
29688       IREFN = IHIS
29689       IBINS(IHIS) = ABS(IBIN)
29690 * check requested number of bins
29691       IF (IBINS(IHIS).GE.NDIM) THEN
29692          WRITE(LOUT,1000) IBIN,NDIM,NDIM
29693  1000    FORMAT(1X,'NEWHGR:   warning!  number of bins (',
29694      &          I3,') exceeds array size (',I3,')',/,21X,
29695      &          'and will be reset to ',I3)
29696          IBINS(IHIS) = NDIM
29697       ENDIF
29698       IF (IBINS(IHIS).EQ.0) THEN
29699          WRITE(LOUT,1001) IBIN,IHIS
29700  1001    FORMAT(1X,'NEWHGR:   warning!  inconsistent number of',
29701      &          ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29702          GOTO 9999
29703       ENDIF
29704
29705 * initialize arrays
29706       DO 1 I=1,NDIM
29707          DO 2 K=1,3
29708             HIST(K,IHIS,I)   = ZERO
29709             HIST(K+3,IHIS,I) = ZERO
29710             TMPHIS(K,IHIS,I) = ZERO
29711     2    CONTINUE
29712          HIST(7,IHIS,I)   = ZERO
29713     1 CONTINUE
29714       DENTRY(1,IHIS)= ZERO
29715       DENTRY(2,IHIS)= ZERO
29716       OVERF(IHIS)   = ZERO
29717       UNDERF(IHIS)  = ZERO
29718       TMPUFL(IHIS)  = ZERO
29719       TMPOFL(IHIS)  = ZERO
29720
29721 * bin str. sensitive to lower edge, bin size, and numb. of bins
29722       IF (XLIM3.GT.ZERO) THEN
29723          DO 3 K=1,IBINS(IHIS)+1
29724             HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29725     3    CONTINUE
29726          ISWI(IHIS) = 1
29727 * bin str. sensitive to lower/upper edge and numb. of bins
29728       ELSEIF (XLIM3.EQ.ZERO) THEN
29729 *   linear binning
29730          IF (IBIN.GT.0) THEN
29731             XLOW = XLIM1
29732             XHI  = XLIM2
29733             IF (XLIM2.LE.XLIM1) THEN
29734                WRITE(LOUT,1002) XLIM1,XLIM2
29735  1002          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
29736      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29737                GOTO 9999
29738             ENDIF
29739             ISWI(IHIS) = 1
29740          ELSEIF (IBIN.LT.-1) THEN
29741 *   logarithmic binning
29742             IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29743                WRITE(LOUT,1004) XLIM1,XLIM2
29744  1004          FORMAT(1X,'NEWHGR:   warning!  inconsistent log. ',
29745      &                'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29746                GOTO 9999
29747             ENDIF
29748             IF (XLIM2.LE.XLIM1) THEN
29749                WRITE(LOUT,1005) XLIM1,XLIM2
29750  1005          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
29751      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29752                GOTO 9999
29753             ENDIF
29754             XLOW = LOG10(XLIM1)
29755             XHI  = LOG10(XLIM2)
29756             ISWI(IHIS) = 3
29757          ENDIF
29758          DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29759          DO 4 K=1,IBINS(IHIS)+1
29760             HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29761     4    CONTINUE
29762       ELSE
29763 * user defined bin structure
29764          DO 5 K=1,IBINS(IHIS)+1
29765             IF (IBIN.GT.0) THEN
29766                HIST(1,IHIS,K) = XLIMB(K)
29767                ISWI(IHIS) = 2
29768             ELSEIF (IBIN.LT.-1) THEN
29769                HIST(1,IHIS,K) = LOG10(XLIMB(K))
29770                ISWI(IHIS) = 4
29771             ENDIF
29772     5    CONTINUE
29773       ENDIF
29774
29775 * histogram accepted
29776       IHISL = IHIS
29777
29778       RETURN
29779
29780  9999 CONTINUE
29781       IREFN = -1
29782       RETURN
29783       END
29784
29785 *$ CREATE DT_FILHGR.FOR
29786 *COPY DT_FILHGR
29787 *
29788 *===filhgr=============================================================*
29789 *
29790       SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29791
29792 ************************************************************************
29793 *                                                                      *
29794 *     Scoring for histogram IHIS.                                      *
29795 *                                                                      *
29796 * This subroutine is based on a original version by R. Engel.          *
29797 * This version dated 23.4.95 is written  by S. Roesler.                *
29798 ************************************************************************
29799
29800       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29801       SAVE
29802       PARAMETER ( LINP = 10 ,
29803      &            LOUT = 6 ,
29804      &            LDAT = 9 )
29805
29806       PARAMETER (ZERO = 0.0D0,
29807      &           ONE  = 1.0D0,
29808      &           TINY = 1.0D-10)
29809
29810 * histograms
29811       PARAMETER (NHIS=150, NDIM=250)
29812       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29813      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29814 * auxiliary common for histograms
29815       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29816
29817       DATA NCEVT /1/
29818
29819       X = XI
29820       Y = YI
29821
29822 * dump content of temorary arrays into histograms
29823       IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29824          CALL DT_EVTHIS(IDUM)
29825          NCEVT = NEVT
29826       ENDIF
29827
29828 * check histogram index
29829       IF (IHIS.EQ.-1) RETURN
29830       IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29831 C        WRITE(LOUT,1000) IHIS,IHISL
29832  1000    FORMAT(1X,'FILHGR:   warning!  histogram index',I4,
29833      &          ' out of range (1..',I3,')')
29834          RETURN
29835       ENDIF
29836
29837       IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29838 * bin structure not explicitly given
29839          IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29840          DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29841          IF (X.LT.HIST(1,IHIS,1)) THEN
29842             I1 = 0
29843          ELSE
29844             I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29845          ENDIF
29846
29847       ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29848 * user defined bin structure
29849          IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29850          IF (X.LT.HIST(1,IHIS,1)) THEN
29851             I1 = 0
29852          ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29853             I1 = IBINS(IHIS)+1
29854          ELSE
29855 *   binary sort algorithm
29856             KMIN = 0
29857             KMAX = IBINS(IHIS)+1
29858     1       CONTINUE
29859             IF ((KMAX-KMIN).EQ.1) GOTO 2
29860             KK = (KMAX+KMIN)/2
29861             IF (X.LE.HIST(1,IHIS,KK)) THEN
29862                KMAX=KK
29863             ELSE
29864                KMIN=KK
29865             ENDIF
29866             GOTO 1
29867     2       CONTINUE
29868             I1 = KMIN
29869          ENDIF
29870
29871       ELSE
29872          WRITE(LOUT,1001)
29873  1001    FORMAT(1X,'FILHGR:   warning!  histogram not initialized')
29874          RETURN
29875       ENDIF
29876
29877 * scoring
29878       IF (I1.LE.0) THEN
29879          TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29880       ELSEIF (I1.LE.IBINS(IHIS)) THEN
29881          TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29882          IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29883             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29884          ELSE
29885             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29886          ENDIF
29887          TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29888       ELSE
29889          TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29890       ENDIF
29891
29892       RETURN
29893       END
29894
29895 *$ CREATE DT_EVTHIS.FOR
29896 *COPY DT_EVTHIS
29897 *
29898 *===evthis=============================================================*
29899 *
29900       SUBROUTINE DT_EVTHIS(NEVT)
29901
29902 ************************************************************************
29903 * Dump content of temorary histograms into /DTHIS1/. This subroutine   *
29904 * is called after each event and for the last event before any call    *
29905 * to OUTHGR.                                                           *
29906 *         NEVT   number of events dumped, this is only needed to       *
29907 *                get the normalization after the last event            *
29908 * This version dated 23.4.95 is written  by S. Roesler.                *
29909 ************************************************************************
29910
29911       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29912       SAVE
29913       PARAMETER ( LINP = 10 ,
29914      &            LOUT = 6 ,
29915      &            LDAT = 9 )
29916
29917       LOGICAL LNOETY
29918
29919       PARAMETER (ZERO = 0.0D0,
29920      &           ONE  = 1.0D0,
29921      &           TINY = 1.0D-10)
29922
29923 * histograms
29924       PARAMETER (NHIS=150, NDIM=250)
29925       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29926      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29927 * auxiliary common for histograms
29928       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29929
29930       DATA NCEVT /0/
29931
29932       NCEVT = NCEVT+1
29933       NEVT  = NCEVT
29934
29935       DO 1 I=1,IHISL
29936          LNOETY = .TRUE.
29937          DO 2 J=1,IBINS(I)
29938             IF (TMPHIS(1,I,J).GT.ZERO) THEN
29939                LNOETY = .FALSE.
29940                HIST(2,I,J)   = HIST(2,I,J)+ONE
29941                HIST(7,I,J)   = HIST(7,I,J)+TMPHIS(1,I,J)
29942                DENTRY(2,I)   = DENTRY(2,I)+TMPHIS(1,I,J)
29943                AVX           = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29944                HIST(3,I,J)   = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29945                HIST(4,I,J)   = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29946                HIST(5,I,J)   = HIST(5,I,J)+TMPHIS(3,I,J)
29947                HIST(6,I,J)   = HIST(6,I,J)+TMPHIS(3,I,J)**2
29948                TMPHIS(1,I,J) = ZERO
29949                TMPHIS(2,I,J) = ZERO
29950                TMPHIS(3,I,J) = ZERO
29951             ENDIF
29952     2    CONTINUE
29953          IF (LNOETY) THEN
29954             IF (TMPUFL(I).GT.ZERO) THEN
29955                UNDERF(I) = UNDERF(I)+ONE
29956                TMPUFL(I) = ZERO
29957             ELSEIF (TMPOFL(I).GT.ZERO) THEN
29958                OVERF(I)  = OVERF(I)+ONE
29959                TMPOFL(I) = ZERO
29960             ENDIF
29961          ELSE
29962             DENTRY(1,I) = DENTRY(1,I)+ONE
29963          ENDIF
29964     1 CONTINUE
29965
29966       RETURN
29967       END
29968
29969 *$ CREATE DT_OUTHGR.FOR
29970 *COPY DT_OUTHGR
29971 *
29972 *===outhgr=============================================================*
29973 *
29974       SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29975      &                  ILOGY,INORM,NMODE)
29976
29977 ************************************************************************
29978 *                                                                      *
29979 *     Plot histogram(s) to standard output unit                        *
29980 *                                                                      *
29981 *         I1..6         indices of histograms to be plotted            *
29982 *         CHEAD,IHEAD   header string,integer                          *
29983 *         NEVTS         number of events                               *
29984 *         FAC           scaling factor                                 *
29985 *         ILOGY   = 1   logarithmic y-axis                             *
29986 *         INORM         normalization                                  *
29987 *                 = 0   no further normalization (FAC is obsolete)     *
29988 *                 = 1   per event and bin width                        *
29989 *                 = 2   per entry and bin width                        *
29990 *                 = 3   per bin entry                                  *
29991 *                 = 4   per event and "bin width" x1^2...x2^2          *
29992 *                 = 5   per event and "log. bin width" ln x1..ln x2    *
29993 *                 = 6   per event                                      *
29994 *         MODE    = 0   no output but normalization applied            *
29995 *                 = 1   all valid histograms separately (small frame)  *
29996 *                       all valid histograms separately (small frame)  *
29997 *                 = -1  and tables as histograms                       *
29998 *                 = 2   all valid histograms (one plot, wide frame)    *
29999 *                       all valid histograms (one plot, wide frame)    *
30000 *                 = -2  and tables as histograms                       *
30001 *                                                                      *
30002 *                                                                      *
30003 *     Note: All histograms to be plotted with one call to this         *
30004 *           subroutine and |MODE|=2 must have the same bin structure!  *
30005 *           There is no test included ensuring this fact.              *
30006 *                                                                      *
30007 * This version dated 23.4.95 is written  by S. Roesler.                *
30008 ************************************************************************
30009
30010       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30011       SAVE
30012       PARAMETER ( LINP = 10 ,
30013      &            LOUT = 6 ,
30014      &            LDAT = 9 )
30015
30016       CHARACTER*72 CHEAD
30017
30018       PARAMETER (ZERO   =  0.0D0,
30019      &           IZERO  =  0,
30020      &           ONE    =  1.0D0,
30021      &           TWO    =  2.0D0,
30022      &           OHALF  =  0.5D0,
30023      &           EPS    =  1.0D-5,
30024      &           TINY   =  1.0D-8,
30025      &           SMALL  =  -1.0D8,
30026      &           RLARGE =  1.0D8 )
30027
30028 * histograms
30029       PARAMETER (NHIS=150, NDIM=250)
30030       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30031      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30032
30033       PARAMETER (NDIM2 = 2*NDIM)
30034       DIMENSION XX(NDIM2),YY(NDIM2)
30035
30036       PARAMETER (NHISTO = 6)
30037       DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
30038      &          IDX(NHISTO)
30039
30040       CHARACTER*43 CNORM(0:8)
30041       DATA CNORM /'no further normalization                   ',
30042      &            'per event and bin width                    ',
30043      &            'per entry1 and bin width                   ',
30044      &            'per bin entry                              ',
30045      &            'per event and "bin width" x1^2...x2^2      ',
30046      &            'per event and "log. bin width" ln x1..ln x2',
30047      &            'per event                                  ',
30048      &            'per bin entry1                             ',
30049      &            'per entry2 and bin width                   '/
30050
30051       IDX1(1) = I1
30052       IDX1(2) = I2
30053       IDX1(3) = I3
30054       IDX1(4) = I4
30055       IDX1(5) = I5
30056       IDX1(6) = I6
30057
30058       MODE = NMODE
30059
30060 * initialization if "wide frame" is requested
30061       IF (ABS(MODE).EQ.2) THEN
30062          DO 1 I=1,NHISTO
30063             DO 2 J=1,NDIM
30064                XX1(J,I) = ZERO
30065                YY1(J,I) = ZERO
30066     2       CONTINUE
30067     1    CONTINUE
30068       ENDIF
30069
30070 * plot header
30071       WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
30072
30073 * check histogram indices
30074       NHI = 0
30075       DO 3 I=1,NHISTO
30076          IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
30077             IF (ISWI(IDX1(I)).NE.0) THEN
30078                IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
30079                   WRITE(LOUT,1000)
30080      &                 IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
30081  1000             FORMAT(/,1X,'OUTHGR:   warning!  no entries in',
30082      &                   ' histogram ',I3,/,21X,'underflows:',F10.0,
30083      &                   '   overflows:  ',F10.0)
30084                ELSE
30085                   NHI = NHI+1
30086                   IDX(NHI) = IDX1(I)
30087                ENDIF
30088             ENDIF
30089          ENDIF
30090     3 CONTINUE
30091       IF (NHI.EQ.0) THEN
30092          WRITE(LOUT,1001)
30093  1001    FORMAT(/,1X,'OUTHGR:   warning!  histogram indices not valid')
30094          RETURN
30095       ENDIF
30096
30097 * check normalization request
30098       IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30099      &     ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30100      &                        (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30101      &     (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30102          WRITE(LOUT,1002) NEVTS,INORM,FAC
30103  1002    FORMAT(/,1X,'OUTHGR:   warning!  normalization request not ',
30104      &          'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30105      &          'FAC = ',E11.4)
30106          RETURN
30107       ENDIF
30108
30109       WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30110
30111 * apply normalization
30112       DO 4 N=1,NHI
30113
30114          I = IDX(N)
30115
30116          IF (ISWI(I).EQ.1) THEN
30117             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30118  1003       FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30119      &             ' to',2X,E10.4,',',2X,I3,' bins')
30120          ELSEIF (ISWI(I).EQ.2) THEN
30121             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30122             WRITE(LOUT,1007)
30123  1007       FORMAT(1X,'user defined bin structure')
30124          ELSEIF (ISWI(I).EQ.3) THEN
30125             WRITE(LOUT,1004)
30126      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30127  1004       FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30128      &             ' to',2X,E10.4,',',2X,I3,' bins')
30129          ELSEIF (ISWI(I).EQ.4) THEN
30130             WRITE(LOUT,1004)
30131      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30132             WRITE(LOUT,1007)
30133          ELSE
30134             WRITE(LOUT,1008) ISWI(I)
30135  1008       FORMAT(/,1X,'warning!  inconsistent bin structure flag ',I4)
30136          ENDIF
30137          WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30138  1005    FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30139      &          ' overfl.:',F8.0)
30140          WRITE(LOUT,1009) CNORM(INORM)
30141  1009    FORMAT(1X,'normalization: ',A,/)
30142
30143          DO 5 K=1,IBINS(I)
30144             CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30145             YMEAN = FAC*YMEAN
30146             YERR  = FAC*YERR
30147             WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30148             WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30149  1006       FORMAT(1X,5E11.3)
30150 *    small frame
30151             II = 2*K
30152             XX(II-1) = HIST(1,I,K)
30153             XX(II)   = HIST(1,I,K+1)
30154             YY(II-1) = YMEAN
30155             YY(II)   = YMEAN
30156 *    wide frame
30157             XX1(K,N) = XMEAN
30158             IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30159      &         XX1(K,N) = LOG10(XMEAN)
30160             YY1(K,N) = YMEAN
30161     5    CONTINUE
30162
30163 * plot small frame
30164          IF (ABS(MODE).EQ.1) THEN
30165             IBIN2 = 2*IBINS(I)
30166             WRITE(LOUT,'(/,1X,A)') 'Preview:'
30167             IF(ILOGY.EQ.1) THEN
30168               CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30169             ELSE
30170               CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30171             ENDIF
30172          ENDIF
30173
30174     4 CONTINUE
30175
30176 * plot wide frame
30177       IF (ABS(MODE).EQ.2) THEN
30178          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30179          NSIZE = NDIM*NHISTO
30180          DXLOW = HIST(1,IDX(1),1)
30181          DDX   = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30182          YLOW  = RLARGE
30183          YHI   = SMALL
30184          DO 6 I=1,NHISTO
30185             DO 7 J=1,NDIM
30186                IF (YY1(J,I).LT.YLOW) THEN
30187                   IF (ILOGY.EQ.1) THEN
30188                      IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30189                   ELSE
30190                      YLOW = YY1(J,I)
30191                   ENDIF
30192                ENDIF
30193                IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30194     7       CONTINUE
30195     6    CONTINUE
30196          DY = (YHI-YLOW)/DBLE(NDIM)
30197          IF (DY.LE.ZERO) THEN
30198             WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30199      &         'OUTHGR:   warning! zero bin width for histograms ',
30200      &         IDX,': ',YLOW,YHI
30201             RETURN
30202          ENDIF
30203          IF (ILOGY.EQ.1) THEN
30204             YLOW = LOG10(YLOW)
30205             DY   = (LOG10(YHI)-YLOW)/100.0D0
30206             DO 8 I=1,NHISTO
30207                DO 9 J=1,NDIM
30208                   IF (YY1(J,I).LE.ZERO) THEN
30209                      YY1(J,I) = YLOW
30210                   ELSE
30211                      YY1(J,I) = LOG10(YY1(J,I))
30212                   ENDIF
30213     9          CONTINUE
30214     8       CONTINUE
30215          ENDIF
30216          CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30217       ENDIF
30218
30219       RETURN
30220       END
30221
30222 *$ CREATE DT_GETBIN.FOR
30223 *COPY DT_GETBIN
30224 *
30225 *===getbin=============================================================*
30226 *
30227       SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30228      &                  XMEAN,YMEAN,YERR)
30229
30230 ************************************************************************
30231 * This version dated 23.4.95 is written  by S. Roesler.                *
30232 ************************************************************************
30233
30234       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30235       SAVE
30236       PARAMETER ( LINP = 10 ,
30237      &            LOUT = 6 ,
30238      &            LDAT = 9 )
30239
30240       PARAMETER (ZERO   = 0.0D0,
30241      &           ONE    = 1.0D0,
30242      &           TINY35 = 1.0D-35)
30243
30244 * histograms
30245       PARAMETER (NHIS=150, NDIM=250)
30246       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30247      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30248
30249       XLOW = HIST(1,IHIS,IBIN)
30250       XHI  = HIST(1,IHIS,IBIN+1)
30251       IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30252          XLOW = 10**XLOW
30253          XHI  = 10**XHI
30254       ENDIF
30255       IF (NORM.EQ.2) THEN
30256          DX   = XHI-XLOW
30257          NEVT = INT(DENTRY(1,IHIS))
30258       ELSEIF (NORM.EQ.3) THEN
30259          DX   = ONE
30260          NEVT = INT(HIST(2,IHIS,IBIN))
30261       ELSEIF (NORM.EQ.4) THEN
30262          DX   = XHI**2-XLOW**2
30263          NEVT = KEVT
30264       ELSEIF (NORM.EQ.5) THEN
30265          DX   = LOG(ABS(XHI))-LOG(ABS(XLOW))
30266          NEVT = KEVT
30267       ELSEIF (NORM.EQ.6) THEN
30268          DX   = ONE
30269          NEVT = KEVT
30270       ELSEIF (NORM.EQ.7) THEN
30271          DX   = ONE
30272          NEVT = INT(HIST(7,IHIS,IBIN))
30273       ELSEIF (NORM.EQ.8) THEN
30274          DX   = XHI-XLOW
30275          NEVT = INT(DENTRY(2,IHIS))
30276       ELSE
30277          DX   = ABS(XHI-XLOW)
30278          NEVT = KEVT
30279       ENDIF
30280       IF (ABS(DX).LT.TINY35) DX = ONE
30281       NEVT   = MAX(NEVT,1)
30282       YMEAN  = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30283       YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30284       YERR   = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30285       YSUM   = HIST(5,IHIS,IBIN)
30286       IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30287 C     XMEAN  = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30288       XMEAN  = HIST(3,IHIS,IBIN)/YSUM
30289       IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30290
30291       RETURN
30292       END
30293
30294 *$ CREATE DT_JOIHIS.FOR
30295 *COPY DT_JOIHIS
30296 *
30297 *===joihis=============================================================*
30298 *
30299       SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30300
30301 ************************************************************************
30302 *                                                                      *
30303 *     Operation on histograms.                                         *
30304 *                                                                      *
30305 *     input:  IH1,IH2      histogram indices to be joined              *
30306 *             COPER        character defining the requested operation, *
30307 *                          i.e. '+', '-', '*', '/'                     *
30308 *             FAC1,FAC2    factors for joining, i.e.                   *
30309 *                          FAC1*histo1 COPER FAC2*histo2               *
30310 *                                                                      *
30311 * This version dated 23.4.95 is written  by S. Roesler.                *
30312 ************************************************************************
30313
30314       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30315       SAVE
30316       PARAMETER ( LINP = 10 ,
30317      &            LOUT = 6 ,
30318      &            LDAT = 9 )
30319
30320       CHARACTER COPER*1
30321
30322       PARAMETER (ZERO   =  0.0D0,
30323      &           ONE    =  1.0D0,
30324      &           OHALF  =  0.5D0,
30325      &           TINY8  =  1.0D-8,
30326      &           SMALL  =  -1.0D8,
30327      &           RLARGE =  1.0D8 )
30328
30329 * histograms
30330       PARAMETER (NHIS=150, NDIM=250)
30331       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30332      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30333
30334       PARAMETER (NDIM2 = 2*NDIM)
30335       DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30336
30337       CHARACTER*43 CNORM(0:6)
30338       DATA CNORM /'no further normalization                   ',
30339      &            'per event and bin width                    ',
30340      &            'per entry and bin width                    ',
30341      &            'per bin entry                              ',
30342      &            'per event and "bin width" x1^2...x2^2      ',
30343      &            'per event and "log. bin width" ln x1..ln x2',
30344      &            'per event                                  '/
30345
30346 * check histogram indices
30347       IF ((IH1.LT.    1).OR.(IH2.LT.    1).OR.
30348      &    (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30349          WRITE(LOUT,1000) IH1,IH2,IHISL
30350  1000    FORMAT(1X,'JOIHIS:   warning!  inconsistent histogram ',
30351      &          'indices (',I3,',',I3,'),',/,21X,'valid range:  1,',I3)
30352          GOTO 9999
30353       ENDIF
30354
30355 * check bin structure of histograms to be joined
30356       IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30357          WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30358  1001    FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
30359      &          ' and ',I3,' failed',/,21X,
30360      &          'due to different numbers of bins (',I3,',',I3,')')
30361          GOTO 9999
30362       ENDIF
30363       DO 1 K=1,IBINS(IH1)+1
30364          IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30365             WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30366  1002       FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
30367      &             ' and ',I3,' failed at bin edge ',I3,/,21X,
30368      &             'X1,X2 = ',2E11.4)
30369             GOTO 9999
30370          ENDIF
30371     1 CONTINUE
30372
30373       WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30374  1003 FORMAT(1X,'JOIHIS:   joining histograms ',I3,',',I3,' with ',
30375      &       'operation ',A,/,11X,'and factors ',2E11.4)
30376       WRITE(LOUT,1004) CNORM(NORM)
30377  1004 FORMAT(1X,'normalization: ',A,/)
30378
30379       DO 2 K=1,IBINS(IH1)
30380          CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30381          CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30382          XLOW  = XLOW1
30383          XHI   = XHI1
30384          XMEAN = OHALF*(XMEAN1+XMEAN2)
30385          IF (COPER.EQ.'+') THEN
30386             YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30387          ELSEIF (COPER.EQ.'*') THEN
30388             YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30389          ELSEIF (COPER.EQ.'/') THEN
30390             IF (YMEAN2.EQ.ZERO) THEN
30391                YMEAN = ZERO
30392             ELSE
30393                IF (FAC2.EQ.ZERO) FAC2 = ONE
30394                YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30395             ENDIF
30396          ELSE
30397             GOTO 9998
30398          ENDIF
30399          WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30400          WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30401  1006    FORMAT(1X,5E11.3)
30402 *    small frame
30403          II = 2*K
30404          XX(II-1) = HIST(1,IH1,K)
30405          XX(II)   = HIST(1,IH1,K+1)
30406          YY(II-1) = YMEAN
30407          YY(II)   = YMEAN
30408 *    wide frame
30409          XX1(K) = XMEAN
30410          IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30411          YY1(K) = YMEAN
30412     2 CONTINUE
30413
30414 * plot small frame
30415       IF (ABS(MODE).EQ.1) THEN
30416          IBIN2 = 2*IBINS(IH1)
30417          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30418          IF(ILOGY.EQ.1) THEN
30419            CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30420          ELSE
30421            CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30422          ENDIF
30423       ENDIF
30424
30425 * plot wide frame
30426       IF (ABS(MODE).EQ.2) THEN
30427          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30428          NSIZE = NDIM
30429          DXLOW = HIST(1,IH1,1)
30430          DDX   = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30431          YLOW  = RLARGE
30432          YHI   = SMALL
30433          DO 3 I=1,NDIM
30434             IF (YY1(I).LT.YLOW) THEN
30435                IF (ILOGY.EQ.1) THEN
30436                   IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30437                ELSE
30438                   YLOW = YY1(I)
30439                ENDIF
30440             ENDIF
30441             IF (YY1(I).GT.YHI) YHI = YY1(I)
30442     3    CONTINUE
30443          DY = (YHI-YLOW)/DBLE(NDIM)
30444          IF (DY.LE.ZERO) THEN
30445             WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30446      &         'JOIHIS:   warning! zero bin width for histograms ',
30447      &         IH1,IH2,': ',YLOW,YHI
30448             RETURN
30449          ENDIF
30450          IF (ILOGY.EQ.1) THEN
30451             YLOW = LOG10(YLOW)
30452             DY   = (LOG10(YHI)-YLOW)/100.0D0
30453             DO 4 I=1,NDIM
30454                IF (YY1(I).LE.ZERO) THEN
30455                   YY1(I) = YLOW
30456                ELSE
30457                   YY1(I) = LOG10(YY1(I))
30458                ENDIF
30459     4       CONTINUE
30460          ENDIF
30461          CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30462       ENDIF
30463
30464       RETURN
30465
30466  9998 CONTINUE
30467       WRITE(LOUT,1005) COPER
30468  1005 FORMAT(1X,'JOIHIS:   unknown operation ',A)
30469
30470  9999 CONTINUE
30471       RETURN
30472       END
30473
30474 *$ CREATE DT_XGRAPH.FOR
30475 *COPY DT_XGRAPH
30476 *
30477 *===qgraph=============================================================*
30478 *
30479       SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30480 C***********************************************************************
30481 C
30482 C     calculate quasi graphic picture with 25 lines and 79 columns
30483 C     ranges will be chosen automatically
30484 C
30485 C     input     N          dimension of input fields
30486 C               IARG       number of curves (fields) to plot
30487 C               X          field of X
30488 C               Y1         field of Y1
30489 C               Y2         field of Y2
30490 C
30491 C This subroutine is written by R. Engel.
30492 C***********************************************************************
30493       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30494       SAVE
30495
30496       PARAMETER ( LINP = 10 ,
30497      &            LOUT = 6 ,
30498      &            LDAT = 9 )
30499 C
30500       DIMENSION X(N),Y1(N),Y2(N)
30501       PARAMETER (EPS=1.D-30)
30502       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30503       CHARACTER SYMB(5)
30504       CHARACTER COL(0:149,0:49)
30505 C
30506       DATA SYMB /'0','e','z','#','x'/
30507 C
30508       ISPALT=IBREIT-10
30509 C
30510 C***  automatic range fitting
30511 C
30512       XMAX=X(1)
30513       XMIN=X(1)
30514       DO 600 I=1,N
30515          XMAX=MAX(X(I),XMAX)
30516          XMIN=MIN(X(I),XMIN)
30517  600  CONTINUE
30518       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30519 C
30520       ITEST=0
30521       DO 1100 K=0,IZEIL-1
30522          ITEST=ITEST+1
30523          IF (ITEST.EQ.IYRAST) THEN
30524             DO 1010 L=1,ISPALT-1
30525                COL(L,K)='-'
30526 1010        CONTINUE
30527             COL(ISPALT,K)='+'
30528             ITEST=0
30529             DO 1020 L=0,ISPALT-1,IXRAST
30530                COL(L,K)='+'
30531 1020        CONTINUE
30532          ELSE
30533             DO 1030 L=1,ISPALT-1
30534                COL(L,K)=' '
30535 1030        CONTINUE
30536             DO 1040 L=0,ISPALT-1,IXRAST
30537                COL(L,K)='|'
30538 1040        CONTINUE
30539             COL(ISPALT,K)='|'
30540          ENDIF
30541 1100  CONTINUE
30542 C
30543 C***  plot curve Y1
30544 C
30545       YMAX=Y1(1)
30546       YMIN=Y1(1)
30547       DO 500 I=1,N
30548          YMAX=MAX(Y1(I),YMAX)
30549          YMIN=MIN(Y1(I),YMIN)
30550 500   CONTINUE
30551       IF(IARG.GT.1) THEN
30552         DO 550 I=1,N
30553            YMAX=MAX(Y2(I),YMAX)
30554            YMIN=MIN(Y2(I),YMIN)
30555 550     CONTINUE
30556       ENDIF
30557       YMAX=(YMAX-YMIN)/40.0D0+YMAX
30558       YMIN=YMIN-(YMAX-YMIN)/40.0D0
30559       YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30560       IF(YZOOM.LT.EPS) THEN
30561         WRITE(LOUT,'(1X,A)')
30562      &    'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30563         RETURN
30564       ENDIF
30565 C
30566 C***  plot curve Y1
30567 C
30568       ILAST=-1
30569       LLAST=-1
30570       DO 1200 K=1,N
30571          L=NINT((X(K)-XMIN)/XZOOM)
30572          I=NINT((YMAX-Y1(K))/YZOOM)
30573          IF(ILAST.GE.0) THEN
30574            LD = L-LLAST
30575            ID = I-ILAST
30576            DO 55 II=0,LD,SIGN(1,LD)
30577              DO 66 KK=0,ID,SIGN(1,ID)
30578                COL(II+LLAST,KK+ILAST)=SYMB(1)
30579  66          CONTINUE
30580  55        CONTINUE
30581          ELSE
30582            COL(L,I)=SYMB(1)
30583          ENDIF
30584          ILAST = I
30585          LLAST = L
30586 1200  CONTINUE
30587 C
30588       IF(IARG.GT.1) THEN
30589 C
30590 C***  plot curve Y2
30591 C
30592         DO 1250 K=1,N
30593            L=NINT((X(K)-XMIN)/XZOOM)
30594            I=NINT((YMAX-Y2(K))/YZOOM)
30595            COL(L,I)=SYMB(2)
30596 1250    CONTINUE
30597       ENDIF
30598 C
30599 C***  write it
30600 C
30601       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30602 C
30603 C***  write range of X
30604 C
30605       XZOOM = (XMAX-XMIN)/DBLE(7)
30606       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30607 C
30608       DO 1300 K=0,IZEIL-1
30609          YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30610          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30611  110     FORMAT(1X,1PE9.2,70A1)
30612 1300  CONTINUE
30613 C
30614 C***  write range of X
30615 C
30616       XZOOM = (XMAX-XMIN)/DBLE(7)
30617       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30618       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30619  120  FORMAT(6X,7(1PE10.3))
30620       END
30621
30622 *$ CREATE DT_XGLOGY.FOR
30623 *COPY DT_XGLOGY
30624 *
30625 *===qglogy=============================================================*
30626 *
30627       SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30628 C***********************************************************************
30629 C
30630 C     calculate quasi graphic picture with 25 lines and 79 columns
30631 C     logarithmic y axis
30632 C     ranges will be chosen automatically
30633 C
30634 C     input     N          dimension of input fields
30635 C               IARG       number of curves (fields) to plot
30636 C               X          field of X
30637 C               Y1         field of Y1
30638 C               Y2         field of Y2
30639 C
30640 C This subroutine is written by R. Engel.
30641 C***********************************************************************
30642 C
30643       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30644       SAVE
30645
30646       PARAMETER ( LINP = 10 ,
30647      &            LOUT = 6 ,
30648      &            LDAT = 9 )
30649       DIMENSION X(N),Y1(N),Y2(N)
30650       PARAMETER (EPS=1.D-30)
30651       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30652       CHARACTER SYMB(5)
30653       CHARACTER COL(0:149,0:49)
30654       PARAMETER (DEPS = 1.D-10)
30655 C
30656       DATA SYMB /'0','e','z','#','x'/
30657 C
30658       ISPALT=IBREIT-10
30659 C
30660 C***  automatic range fitting
30661 C
30662       XMAX=X(1)
30663       XMIN=X(1)
30664       DO 600 I=1,N
30665          XMAX=MAX(X(I),XMAX)
30666          XMIN=MIN(X(I),XMIN)
30667  600  CONTINUE
30668       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30669 C
30670       ITEST=0
30671       DO 1100 K=0,IZEIL-1
30672          ITEST=ITEST+1
30673          IF (ITEST.EQ.IYRAST) THEN
30674             DO 1010 L=1,ISPALT-1
30675                COL(L,K)='-'
30676 1010        CONTINUE
30677             COL(ISPALT,K)='+'
30678             ITEST=0
30679             DO 1020 L=0,ISPALT-1,IXRAST
30680                COL(L,K)='+'
30681 1020        CONTINUE
30682          ELSE
30683             DO 1030 L=1,ISPALT-1
30684                COL(L,K)=' '
30685 1030        CONTINUE
30686             DO 1040 L=0,ISPALT-1,IXRAST
30687                COL(L,K)='|'
30688 1040        CONTINUE
30689             COL(ISPALT,K)='|'
30690          ENDIF
30691 1100  CONTINUE
30692 C
30693 C***  plot curve Y1
30694 C
30695       YMAX=Y1(1)
30696       YMIN=MAX(Y1(1),EPS)
30697       DO 500 I=1,N
30698          YMAX =MAX(Y1(I),YMAX)
30699          IF(Y1(I).GT.EPS) THEN
30700            IF(YMIN.EQ.EPS) THEN
30701              YMIN = Y1(I)/10.D0
30702            ELSE
30703              YMIN = MIN(Y1(I),YMIN)
30704            ENDIF
30705          ENDIF
30706 500   CONTINUE
30707       IF(IARG.GT.1) THEN
30708         DO 550 I=1,N
30709            YMAX=MAX(Y2(I),YMAX)
30710            IF(Y2(I).GT.EPS) THEN
30711              IF(YMIN.EQ.EPS) THEN
30712                YMIN = Y2(I)
30713              ELSE
30714                YMIN = MIN(Y2(I),YMIN)
30715              ENDIF
30716            ENDIF
30717 550     CONTINUE
30718       ENDIF
30719 C
30720       DO 560 I=1,N
30721         Y1(I) = MAX(Y1(I),YMIN)
30722  560  CONTINUE
30723       IF(IARG.GT.1) THEN
30724         DO 570 I=1,N
30725           Y2(I) = MAX(Y2(I),YMIN)
30726  570    CONTINUE
30727       ENDIF
30728 C
30729       IF(YMAX.LE.YMIN) THEN
30730         WRITE(LOUT,'(/1X,A,2E12.3,/)')
30731      &     'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30732         WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30733         RETURN
30734       ENDIF
30735 C
30736       YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30737       YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30738       YZOOM=(YMA-YMI)/DBLE(IZEIL)
30739       IF(YZOOM.LT.EPS) THEN
30740         WRITE(LOUT,'(1X,A)')
30741      &    'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30742         RETURN
30743       ENDIF
30744 C
30745 C***  plot curve Y1
30746 C
30747       ILAST=-1
30748       LLAST=-1
30749       DO 1200 K=1,N
30750          L=NINT((X(K)-XMIN)/XZOOM)
30751          I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30752          IF(ILAST.GE.0) THEN
30753            LD = L-LLAST
30754            ID = I-ILAST
30755            DO 55 II=0,LD,SIGN(1,LD)
30756              DO 66 KK=0,ID,SIGN(1,ID)
30757                COL(II+LLAST,KK+ILAST)=SYMB(1)
30758  66          CONTINUE
30759  55        CONTINUE
30760          ELSE
30761            COL(L,I)=SYMB(1)
30762          ENDIF
30763          ILAST = I
30764          LLAST = L
30765 1200  CONTINUE
30766 C
30767       IF(IARG.GT.1) THEN
30768 C
30769 C***  plot curve Y2
30770 C
30771         DO 1250 K=1,N
30772            L=NINT((X(K)-XMIN)/XZOOM)
30773            I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30774            COL(L,I)=SYMB(2)
30775 1250    CONTINUE
30776       ENDIF
30777 C
30778 C***  write it
30779 C
30780       WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30781       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30782 C
30783 C***  write range of X
30784 C
30785       XZOOM1 = (XMAX-XMIN)/DBLE(7)
30786       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30787 C
30788       DO 1300 K=0,IZEIL-1
30789          YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30790          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30791  110     FORMAT(1X,1PE9.2,70A1)
30792 1300  CONTINUE
30793 C
30794 C***  write range of X
30795 C
30796       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30797       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30798  120  FORMAT(6X,7(1PE10.3))
30799 C
30800       END
30801
30802 *$ CREATE DT_SRPLOT.FOR
30803 *COPY DT_SRPLOT
30804 *
30805 *===plot===============================================================*
30806 *
30807       SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30808
30809       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30810       SAVE
30811
30812       PARAMETER ( LINP = 10 ,
30813      &            LOUT = 6 ,
30814      &            LDAT = 9 )
30815 *
30816 *     initial version
30817 *     J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30818 *     This is a subroutine of fluka to plot Y across the page
30819 *     as a function of X down the page. Up to 37 curves can be
30820 *     plotted in the same picture with different plotting characters.
30821 *     Output of first 10 overprinted characters addad by FB 88
30822 *  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30823 *
30824 *     Input Variables:
30825 *        X   = array containing the values of X
30826 *        Y   = array containing the values of Y
30827 *        N   = number of values in X and in Y
30828 *              can exceed the fixed number of lines
30829 *        M   = number of different curves X,Y are containing
30830 *        MM  = number of points in each curve i.e. N=M*MM
30831 *        XO  = smallest value of X to be plotted
30832 *        DX  = increment of X between subsequent lines
30833 *        YO  = smallest value of Y to be plotted
30834 *        DY  = increment of Y between subsequent character spaces
30835 *
30836 *        other variables used inside:
30837 *        XX  = numbers along the X-coordinate axis
30838 *        YY  = numbers along the Y-coordinate axis
30839 *        LL  = ten lines temporary storage for the plot
30840 *        L   = character set used to plot different curves
30841 *        LOV = memorizes overprinted symbols
30842 *              the first 10 overprinted symbols are printed on
30843 *              the end of the line to avoid ambiguities
30844 *              (added by FB as considered quite helpful)
30845 *
30846 *********************************************************************
30847 *
30848       DIMENSION XX(61),YY(61),LL(101,10)
30849       DIMENSION X(N),Y(N),L(40),LOV(40,10)
30850       INTEGER*4 LL, L, LOV
30851       DATA  L/
30852      11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30853      21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30854      31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30855      41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H  /
30856 *
30857 *
30858       MN=51
30859       DO 10 I=1,MN
30860         AI=I-1
30861    10 XX(I)=XO+AI*DX
30862       DO 20 I=1,11
30863         AI=I-1
30864    20 YY(I)=YO+10.0D0*AI*DY
30865       WRITE(LOUT, 500) (YY(I),I=1,11)
30866       MMN=MN-1
30867 *
30868 *
30869       DO 90 JJ=1,MMN,10
30870         JJJ=JJ-1
30871         DO 30 I=1,101
30872           DO 30 J=1,10
30873    30   LL(I,J)=L(40)
30874         DO 40 I=1,101
30875    40   LL(I,1)=L(39)
30876         DO 50 I=1,101,10
30877           DO 50 J=1,10
30878    50   LL(I,J)=L(38)
30879         DO 60 I=1,40
30880           DO 60 J=1,10
30881    60   LOV(I,J)=L(40)
30882 *
30883 *
30884         DO 70 I=1,M
30885           DO 70 J=1,MM
30886             II=J+(I-1)*MM
30887             AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30888             AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30889             AIX=AIX-DBLE(JJJ)
30890 *           changed Sept.88 by FB to avoid INTEGER OVERFLOW
30891             IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30892      +      . AIY .LT. 102.D0) THEN
30893               IX=INT(AIX)
30894               IY=INT(AIY)
30895               IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30896      +        THEN
30897                 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30898      +          =LL(IY,IX)
30899                 LL(IY,IX)=L(I)
30900               ENDIF
30901             ENDIF
30902    70   CONTINUE
30903 *
30904 *
30905         DO 80 I=1,10
30906           II=I+JJJ
30907           III=II+1
30908           WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30909      &                    (LOV(J,I),J=1,10)
30910    80   CONTINUE
30911    90 CONTINUE
30912 *
30913 *
30914       WRITE(LOUT, 520)
30915       WRITE(LOUT, 500) (YY(I),I=1,11)
30916       RETURN
30917 *
30918   500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30919   510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30920   520 FORMAT(20X,10('1---------'),'1')
30921       END
30922
30923 *$ CREATE DT_DEFSET.FOR
30924 *COPY DT_DEFSET
30925 *
30926 *===defset=============================================================*
30927 *
30928       BLOCK DATA DT_DEFSET
30929
30930       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30931       SAVE
30932
30933 * flags for input different options
30934       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30935       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30936      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30937       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30938 * emulsion treatment
30939       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30940      &                NCOMPO,IEMUL
30941
30942 * / DTFLG1 /
30943       DATA IFRAG  / 2, 1 /
30944       DATA IRESCO / 1 /
30945       DATA IMSHL  / 1 /
30946       DATA IRESRJ / 0 /
30947       DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30948       DATA LEMCCK / .FALSE. /
30949       DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30950      &              .TRUE.,.TRUE.,.TRUE./
30951       DATA LSEADI / .TRUE. /
30952       DATA LEVAPO / .TRUE. /
30953       DATA IFRAME / 1 /
30954       DATA ITRSPT / 0 /
30955
30956 * / DTCOMP /
30957       DATA EMUFRA / NCOMPX*0.0D0 /
30958       DATA IEMUMA / NCOMPX*1 /
30959       DATA IEMUCH / NCOMPX*1 /
30960       DATA NCOMPO / 0 /
30961       DATA IEMUL  / 0 /
30962
30963       END
30964
30965 *$ CREATE DT_HADPRP.FOR
30966 *COPY DT_HADPRP
30967 *
30968 *===hadprp=============================================================*
30969 *
30970       BLOCK DATA DT_HADPRP
30971
30972       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30973       SAVE
30974
30975 * auxiliary common for reggeon exchange (DTUNUC 1.x)
30976       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30977      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30978      &                IQTCHR(-6:6),MQUARK(3,39)
30979 * hadron index conversion (BAMJET <--> PDG)
30980       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30981      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
30982      &                IAMCIN(210)
30983 * names of hadrons used in input-cards
30984       CHARACTER*8 BTYPE
30985       COMMON /DTPAIN/ BTYPE(30)
30986
30987 * / DTQUAR /
30988 *----------------------------------------------------------------------*
30989 *                                                                      *
30990 *     Quark content of particles:                                      *
30991 *          index   quark   el. charge  bar. charge  isospin  isospin3  *
30992 *              1 = u          2/3          1/3        1/2       1/2    *
30993 *             -1 = ubar      -2/3         -1/3        1/2      -1/2    *
30994 *              2 = d         -1/3          1/3        1/2      -1/2    *
30995 *             -2 = dbar       1/3         -1/3        1/2       1/2    *
30996 *              3 = s         -1/3          1/3         0         0     *
30997 *             -3 = sbar       1/3         -1/3         0         0     *
30998 *              4 = c          2/3          1/3         0         0     *
30999 *             -4 = cbar      -2/3         -1/3         0         0     *
31000 *              5 = b         -1/3          1/3         0         0     *
31001 *             -5 = bbar       1/3         -1/3         0         0     *
31002 *              6 = t          2/3          1/3         0         0     *
31003 *             -6 = tbar      -2/3         -1/3         0         0     *
31004 *                                                                      *
31005 *         Mquark = particle quark composition (Paprop numbering)       *
31006 *         Iqechr = electric charge ( in 1/3 unit )                     *
31007 *         Iqbchr = baryonic charge ( in 1/3 unit )                     *
31008 *         Iqichr = isospin ( in 1/2 unit ), z component                *
31009 *         Iqschr = strangeness                                         *
31010 *         Iqcchr = charm                                               *
31011 *         Iquchr = beauty                                              *
31012 *         Iqtchr = ......                                              *
31013 *                                                                      *
31014 *----------------------------------------------------------------------*
31015       DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
31016       DATA IQBCHR / 6*-1, 0, 6*1 /
31017       DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
31018       DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
31019       DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
31020       DATA IQUCHR / 0, 1, 9*0, -1, 0 /
31021       DATA IQTCHR / -1, 11*0, 1 /
31022       DATA MQUARK /
31023      &   2, 1, 1,   -2,-1,-1,    0, 0, 0,    0, 0, 0,    0, 0, 0,
31024      &   0, 0, 0,    0, 0, 0,    2, 2, 1,   -2,-2,-1,    0, 0, 0,
31025      &   0, 0, 0,    0, 0, 0,    1,-2, 0,    2,-1, 0,    1,-3, 0,
31026      &   3,-1, 0,    1, 2, 3,   -1,-2,-3,    0, 0, 0,    2, 2, 3,
31027      &   1, 1, 3,    1, 2, 3,    1,-1, 0,    2,-3, 0,    3,-2, 0,
31028      &   2,-2, 0,    3,-3, 0,    0, 0, 0,    0, 0, 0,    0, 0, 0,
31029      &  -1,-1,-3,   -1,-2,-3,   -2,-2,-3,    1, 3, 3,   -1,-3,-3,
31030      &   2, 3, 3,   -2,-3,-3,    3, 3, 3,   -3,-3,-3 /
31031
31032 * / DTHAIC /
31033 * (renamed) (HAdron InDex COnversion)
31034 * translation table version filled up by r.e. 25.01.94                 *
31035       DATA IAMCIN /
31036      &2212,-2212,11,-11,12,              -12,22,2112,-2112,-13,
31037      &13,130,211,-211,321,               -321,3122,-3122,310,3112,
31038      &3222,3212,111,311,-311,            0,0,0,0,0,
31039      &221,213,113,-213,223,              323,313,-323,-313,10323,
31040      &10313,-10323,-10313,30323,30313,   -30323,-30313,3224,3214,3114,
31041      &3216,3218,2224,2214,2114,          1114,12224,12214,12114,11114,
31042      &99999,99999,22212,22112,32124,     31214,-2224,-2214,-2114,-1114,
31043      &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
31044      &5*99999,                           5*99999,
31045      &4*99999,331,                       333,3322,3312,-3222,-3212,
31046      &-3112,-3322,-3312,3224,3214,       3114,3324,3314,3334,-3224,
31047      &-3214,-3114,-3324,-3314,-3334,     421,411,-411,-421,431,
31048      &-431,441,423,413,-413,             -423,433,-433,20443,443,
31049      &-15,15,16,-16,14,                  -14,4122,4232,4132,4222,
31050      &4212,4112,3*99999,                 3*99999,-4122,-4232,
31051      &-4132,-4222,-4212,-4112,99999,     5*99999,
31052      &5*99999,                           5*99999,
31053      &10*99999,
31054      &5*99999 , 20211,20111,-20211,99999,20321,
31055      &-20321,20311,-20311,7*99999 ,
31056      &7*99999,12212,12112,99999/
31057
31058 * / DTHAIC /
31059 * (HAdron InDex COnversion)
31060       DATA (IPDG2(1,K),K=1,7)
31061      &   /   -11,   -12,   -13,   -15,   -16,   -14,     0/
31062       DATA (IBAM2(1,K),K=1,7)
31063      &   /     4,     6,    10,   131,   134,   136,     0/
31064       DATA (IPDG2(2,K),K=1,7)
31065      &   /    11,    12,    22,    13,    15,    16,    14/
31066       DATA (IBAM2(2,K),K=1,7)
31067      &   /     3,     5,     7,    11,   132,   133,   135/
31068       DATA (IPDG3(1,K),K=1,22)
31069      &   /  -211,  -321,  -311,  -213,  -323,  -313,  -411,  -421,
31070      &      -431,  -413,  -423,  -433,     0,     0,     0,     0,
31071      &         0,     0,     0,     0,     0,     0/
31072       DATA (IBAM3(1,K),K=1,22)
31073      &   /    14,    16,    25,    34,    38,    39,   118,   119,
31074      &       121,   125,   126,   128,     0,     0,     0,     0,
31075      &         0,     0,     0,     0,     0,     0/
31076       DATA (IPDG3(2,K),K=1,22)
31077      &   /   130,   211,   321,   310,   111,   311,   221,   213,
31078      &       113,   223,   323,   313,   331,   333,   421,   411,
31079      &       431,   441,   423,   413,   433,   443/
31080       DATA (IBAM3(2,K),K=1,22)
31081      &   /    12,    13,    15,    19,    23,    24,    31,    32,
31082      &        33,    35,    36,    37,    95,    96,   116,   117,
31083      &       120,   122,   123,   124,   127,   130/
31084       DATA (IPDG4(1,K),K=1,29)
31085      &   / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
31086      &     -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31087      &     -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31088      &     -4212, -4112,     0,     0,     0/
31089       DATA (IBAM4(1,K),K=1,29)
31090      &   /     2,     9,    18,    67,    68,    69,    70,    75,
31091      &        76,    99,   100,   101,   102,   103,   110,   111,
31092      &       112,   113,   114,   115,   149,   150,   151,   152,
31093      &       153,   154,     0,     0,     0/
31094       DATA (IPDG4(2,K),K=1,29)
31095      &   /  2212,  2112,  3122,  3112,  3222,  3212,  3224,  3214,
31096      &      3114,  3216,  3218,  2224,  2214,  2114,  1114,  3322,
31097      &      3312,  3224,  3214,  3114,  3324,  3314,  3334,  4122,
31098      &      4232,  4132,  4222,  4212,  4112/
31099       DATA (IBAM4(2,K),K=1,29)
31100      &   /     1,     8,    17,    20,    21,    22,    48,    49,
31101      &        50,    51,    52,    53,    54,    55,    56,    97,
31102      &        98,   104,   105,   106,   107,   108,   109,   137,
31103      &       138,   139,   140,   141,   142/
31104       DATA (IPDG5(1,K),K=1,19)
31105      &   /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31106      &    -20211,-20321,-20311,     0,     0,     0,     0,     0,
31107      &         0,     0,     0/
31108       DATA (IBAM5(1,K),K=1,19)
31109      &   /    42,    43,    46,    47,    71,    72,    73,    74,
31110      &       188,   191,   193,     0,     0,     0,     0,     0,
31111      &         0,     0,     0/
31112       DATA (IPDG5(2,K),K=1,19)
31113      &   / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31114      &     22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31115      &     20311, 12212, 12112/
31116       DATA (IBAM5(2,K),K=1,19)
31117      &   /    40,    41,    44,    45,    57,    58,    59,    60,
31118      &        63,    64,    65,    66,   129,   186,   187,   190,
31119      &       192,   208,   209/
31120
31121 * / DTPAIN /
31122 * internal particle names
31123       DATA BTYPE / 'PROTON  ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31124      &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON  ' , 'NEUTRON ' , 'ANEUTRON' ,
31125      &'MUON+   ' , 'MUON-   ' , 'KAONLONG' , 'PION+   ' , 'PION-   ' ,
31126      &'KAON+   ' , 'KAON-   ' , 'LAMBDA  ' , 'ALAMBDA ' , 'KAONSHRT' ,
31127      &'SIGMA-  ' , 'SIGMA+  ' , 'SIGMAZER' , 'PIZERO  ' , 'KAONZERO' ,
31128      &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31129      &'BLANK   ' /
31130
31131       END
31132
31133 *$ CREATE DT_BLKD46.FOR
31134 *COPY DT_BLKD46
31135 *
31136 *===blkd46=============================================================*
31137 *
31138       BLOCK DATA DT_BLKD46
31139
31140       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31141       SAVE
31142
31143       PARAMETER ( AMELCT = 0.51099906         D-03 )
31144       PARAMETER ( AMMUON = 0.105658389        D+00 )
31145
31146 * particle properties (BAMJET index convention)
31147       CHARACTER*8  ANAME
31148       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31149      &                IICH(210),IIBAR(210),K1(210),K2(210)
31150
31151 * / DTPART /
31152 * Particle  masses Engel version JETSET compatible
31153 C     DATA (AAM(K),K=1,85) /
31154 C    &   .9383D+00, .9383D+00,  AMELCT  ,  AMELCT  , .0000D+00,
31155 C    &   .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON   ,
31156 C    &   AMMUON   , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31157 C    &   .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31158 C    &   .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31159 C    &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31160 C    &   .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31161 C    &   .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31162 C    &   .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31163 C    &   .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31164 C    &   .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31165 C    &   .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31166 C    &   .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31167 C    &   .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31168 C    &   .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31169 C    &   .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31170 C    &   .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01  /
31171 C     DATA (AAM(K),K=86,183) /
31172 C    &   .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31173 C    &   .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31174 C    &   .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31175 C    &   .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31176 C    &   .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31177 C    &   .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31178 C    &   .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31179 C    &   .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31180 C    &   .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31181 C    &   .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31182 C    &   .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31183 C    &   .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31184 C    &   .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31185 C    &   .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31186 C    &   .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31187 C    &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31188 C    &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31189 C    &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31190 C    &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31191 C    &   .1250D+01, .1250D+01, .1250D+01  /
31192 C     DATA (AAM ( I ), I = 184,210 ) /
31193 C    & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31194 C    & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31195 C    & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31196 C    & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31197 C    & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31198 C    & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31199 C    & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31200 C    & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31201 C    & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31202 * sr 25.1.06: particle masses adjusted to Pythia
31203       DATA (AAM(K),K=1,85) /
31204      &   .938270E+00,.938270E+00, AMELCT    , AMELCT    ,.000000E+00,
31205      &   .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON    ,
31206      &    AMMUON    ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31207      &   .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31208      &   .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31209      &     .0000D+00,  .0000D+00,  .0000D+00 , .0000D+00,  .0000D+00,
31210      &   .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31211      &   .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31212      &   .129000E+01,.129000E+01,.129000E+01,  .1421D+01,  .1421D+01,
31213      &     .1421D+01,  .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31214      &     .1820D+01,  .2030D+01,  .1231D+01,  .1232D+01,  .1233D+01,
31215      &     .1234D+01,  .1675D+01,  .1675D+01,  .1675D+01,  .1675D+01,
31216      &     .1500D+01,  .1500D+01,  .1515D+01,  .1515D+01,  .1775D+01,
31217      &     .1775D+01,  .1231D+01,  .1232D+01,  .1233D+01,  .1234D+01,
31218      &     .1675D+01,  .1675D+01,  .1675D+01,  .1675D+01,  .1515D+01,
31219      &     .1515D+01,  .2500D+01,  .4890D+00,  .4890D+00,  .4890D+00,
31220      &     .1300D+01,  .1300D+01,  .1300D+01,  .1300D+01,  .2200D+01  /
31221       DATA (AAM(K),K=86,183) /
31222      &     .2200D+01,  .2200D+01,  .2200D+01,  .1700D+01,  .1700D+01,
31223      &     .1700D+01,  .1700D+01,  .1820D+01,  .2030D+01,.957770E+00,
31224      &   .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31225      &   .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31226      &   .138720E+01,.153180E+01,  .1535D+01,.167245E+01,.138280E+01,
31227      &   .138370E+01,.138720E+01,.153180E+01,  .1535D+01,.167245E+01,
31228      &   .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31229      &   .196850E+01,.297980E+01,.200670E+01,  .2010D+01,  .2010D+01,
31230      &   .200670E+01,.211240E+01,.211240E+01,  .3686D+01,.309688E+01,
31231      &   .177700E+01,.177700E+01,  .0000D+00,  .0000D+00,  .0000D+00,
31232      &     .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31233      &   .245350E+01,.245210E+01,  .2560D+01,  .2560D+01,  .2730D+01,
31234      &     .3610D+01,  .3610D+01,  .3790D+01,.228490E+01,.246560E+01,
31235      &     .2460D+01,.245290E+01,.245350E+01,.245210E+01,  .2560D+01,
31236      &     .2560D+01,  .2730D+01,  .3610D+01,  .3610D+01,  .3790D+01,
31237      &     .2490D+01,  .2490D+01,  .2490D+01,  .2610D+01,  .2610D+01,
31238      &     .2770D+01,  .3670D+01,  .3670D+01,  .3850D+01,  .4890D+01,
31239      &     .2490D+01,  .2490D+01,  .2490D+01,  .2610D+01,  .2610D+01,
31240      &     .2770D+01,  .3670D+01,  .3670D+01,  .3850D+01,  .4890D+01,
31241      &     .1250D+01,  .1250D+01,  .1250D+01  /
31242       DATA (AAM ( I ), I = 184,210 ) /
31243      & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31244      & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31245      & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31246      & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31247      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31248      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31249      & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31250      & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31251      & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31252 * Particle  mean lives
31253       DATA (TAU(K),K=1,183) /
31254      &   .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31255      &   .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31256      &   .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31257      &   .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31258      &   .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31259      &   70*.0000D+00,
31260      &   .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31261      &   .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31262      &   .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31263      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31264      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31265      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31266      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31267      &   .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31268      &   .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31269      &   40*.0000D+00,
31270      &   .0000D+00, .0000D+00, .0000D+00  /
31271       DATA ( TAU ( I ), I = 184,210 ) /
31272      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31273      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31274      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31275      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31276      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31277      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31278      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31279      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31280      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
31281 * Resonance width Gamma in GeV
31282       DATA (GA(K),K=  1,85) /
31283      &    30*.0000D+00,
31284      &   .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31285      &   .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31286      &   .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31287      &   .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31288      &   .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31289      &   .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31290      &   .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31291      &   .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31292      &   .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31293      &   .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31294      &   .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00  /
31295       DATA (GA(K),K= 86,183) /
31296      &   .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31297      &   .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31298      &   .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31299      &   .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31300      &   .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31301      &   .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31302      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31303      &   .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31304      &   .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31305      &   50*.0000D+00,
31306      &   .3000D+00, .3000D+00, .3000D+00  /
31307       DATA ( GA ( I ), I = 184,210 ) /
31308      & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31309      & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31310      & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31311      & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31312      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31313      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31314      & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31315      & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31316      & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31317 * Particle  names
31318 * S+1385+Sigma+(1385)    L02030+Lambda0(2030)
31319 * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31320 * designation N*@@ means N*@1(@2)
31321       DATA (ANAME(K),K=1,85) /
31322      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
31323      &  'ANUE    ','GAM     ','NEU     ','ANEU    ','MUE+    ',
31324      &  'MUE-    ','K0L     ','PI+     ','PI-     ','K+      ',
31325      &  'K-      ','LAM     ','ALAM    ','K0S     ','SIGM-   ',
31326      &  'SIGM+   ','SIGM0   ','PI0     ','K0      ','AK0     ',
31327      &  'BLANK   ','BLANK   ','BLANK   ','BLANK   ','BLANK   ',
31328      &  'ETA550  ','RHO+77  ','RHO077  ','RHO-77  ','OM0783  ',
31329      &  'K*+892  ','K*0892  ','K*-892  ','AK*089  ','KA+125  ',
31330      &  'KA0125  ','KA-125  ','AKA012  ','K*+142  ','K*0142  ',
31331      &  'K*-142  ','AK*014  ','S+1385  ','S01385  ','S-1385  ',
31332      &  'L01820  ','L02030  ','N*++12  ','N*+ 12  ','N*012   ',
31333      &  'N*-12   ','N*++16  ','N*+16   ','N*016   ','N*-16   ',
31334      &  'N*+14   ','N*014   ','N*+15   ','N*015   ','N*+18   ',
31335      &  'N*018   ','AN--12  ','AN*-12  ','AN*012  ','AN*+12  ',
31336      &  'AN--16  ','AN*-16  ','AN*016  ','AN*+16  ','AN*-15  ',
31337      &  'AN*015  ','DE*=24  ','RPI+49  ','RPI049  ','RPI-49  ',
31338      &  'PIN++   ','PIN+0   ','PIN+-   ','PIN-0   ','PPPI    ' /
31339       DATA (ANAME(K),K=86,183) /
31340      &  'PNPI    ','APPPI   ','APNPI   ','K+PPI   ','K-PPI   ',
31341      &  'K+NPI   ','K-NPI   ','S+1820  ','S-2030  ','ETA*    ',
31342      &  'PHI     ','TETA0   ','TETA-   ','ASIG-   ','ASIG0   ',
31343      &  'ASIG+   ','ATETA0  ','ATETA+  ','SIG*+   ','SIG*0   ',
31344      &  'SIG*-   ','TETA*0  ','TETA*   ','OMEGA-  ','ASIG*-  ',
31345      &  'ASIG*0  ','ASIG*+  ','ATET*0  ','ATET*+  ','OMEGA+  ',
31346      &  'D0      ','D+      ','D-      ','AD0     ','F+      ',
31347      &  'F-      ','ETAC    ','D*0     ','D*+     ','D*-     ',
31348      &  'AD*0    ','F*+     ','F*-     ','PSI     ','JPSI    ',
31349      &  'TAU+    ','TAU-    ','NUET    ','ANUET   ','NUEM    ',
31350      &  'ANUEM   ','C0+     ','A+      ','A0      ','C1++    ',
31351      &  'C1+     ','C10     ','S+      ','S0      ','T0      ',
31352      &  'XU++    ','XD+     ','XS+     ','AC0-    ','AA-     ',
31353      &  'AA0     ','AC1--   ','AC1-    ','AC10    ','AS-     ',
31354      &  'AS0     ','AT0     ','AXU--   ','AXD-    ','AXS     ',
31355      &  'C1*++   ','C1*+    ','C1*0    ','S*+     ','S*0     ',
31356      &  'T*0     ','XU*++   ','XD*+    ','XS*+    ','TETA++  ',
31357      &  'AC1*--  ','AC1*-   ','AC1*0   ','AS*-    ','AS*0    ',
31358      &  'AT*0    ','AXU*--  ','AXD*-   ','AXS*-   ','ATET--  ',
31359      &  'RO      ','R+      ','R-      '  /
31360       DATA (    ANAME ( I ), I = 184,210 ) /
31361      &'AN*-14  ','AN*014  ','PI+130  ','PI0130  ','PI-130  ','F01400  ',
31362      &'K*+146  ','K*-146  ','K*0146  ','AK0146  ','L01600  ','AL0160  ',
31363      &'S+1660  ','S01660  ','S-1660  ','AS-166  ','AS0166  ','AS+166  ',
31364      &'X01950  ','X-1950  ','AX0195  ','AX+195  ','OM-225  ','AOM+22  ',
31365      &'N*+14   ','N*014   ','BLANK   '/
31366 * Charge of particles and resonances
31367       DATA (IICH ( I ), I =   1,210 ) /
31368      &  1, -1, -1,  1,  0,  0,  0,  0,  0,  1, -1,  0,  1, -1,  1,
31369      & -1,  0,  0,  0, -1,  1,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31370      &  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0,
31371      & -1,  0,  1,  0, -1,  0,  0,  2,  1,  0, -1,  2,  1,  0, -1,
31372      &  1,  0,  1,  0,  1,  0, -2, -1,  0,  1, -2, -1,  0,  1, -1,
31373      &  0,  1,  1,  0, -1,  2,  1,  0, -1,  2,  1,  0, -1,  2,  0,
31374      &  1, -1,  1, -1,  0,  0,  0, -1, -1,  0,  1,  0,  1,  1,  0,
31375      & -1,  0, -1, -1, -1,  0,  1,  0,  1,  1,  0,  1, -1,  0,  1,
31376      & -1,  0,  0,  1, -1,  0,  1, -1,  0,  0,  1, -1,  0,  0,  0,
31377      &  0,  1,  1,  0,  2,  1,  0,  1,  0,  0,  2,  1,  1, -1, -1,
31378      &  0, -2, -1,  0, -1,  0,  0, -2, -1, -1,  2,  1,  0,  1,  0,
31379      &  0,  2,  1,  1,  2, -2, -1,  0, -1,  0,  0, -2, -1, -1, -2,
31380      &  0,  1, -1, -1,  0,  1,  0, -1,  0,  1, -1,  0,  0,  0,  0,
31381      &  1,  0, -1, -1,  0,  1,  0, -1,  0,  1, -1,  1,  1,  0,  0/
31382 * Particle  baryonic charges
31383       DATA (IIBAR ( I ), I =   1,210 ) /
31384      &  1, -1,  0,  0,  0,  0,  0,  1, -1,  0,  0,  0,  0,  0,  0,
31385      &  0,  1, -1,  0,  1,  1,  1,  0,  0,  0,  0,  0,  0,  0,  0,
31386      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31387      &  0,  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
31388      &  1,  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31389      & -1,  2,  0,  0,  0,  1,  1,  1,  1,  2,  2,  0,  0,  1,  1,
31390      &  1,  1,  1,  1,  0,  0,  1,  1, -1, -1, -1, -1, -1,  1,  1,
31391      &  1,  1,  1,  1, -1, -1, -1, -1, -1, -1,  0,  0,  0,  0,  0,
31392      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31393      &  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1, -1, -1,
31394      & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,  1,  1,  1,  1,  1,
31395      &  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31396      &  0,  0,  0, -1, -1,  0,  0,  0,  0,  0,  0,  0,  0,  1, -1,
31397      &  1,  1,  1, -1, -1, -1,  1,  1, -1, -1,  1, -1,  1,  1,  0/
31398 * First number of decay channels used for resonances
31399 * and decaying particles
31400       DATA K1/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 16, 17,
31401      &  18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31402      &   2*330, 46, 51, 52, 54, 55, 58,
31403 *                                                             50
31404      &  60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31405      & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31406      & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31407 *                                         85
31408      & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31409      & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31410      & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31411      & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31412      & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31413      & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31414      & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31415      & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31416      & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31417      & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31418      & 590, 596, 602 /
31419 * Last number of decay channels used for resonances
31420 * and decaying particles
31421       DATA K2/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 15, 16, 17,
31422      & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31423      & 2* 330, 50, 51, 53, 54, 57,
31424 *                                                                 50
31425      & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31426      & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31427      & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31428 *                                              85
31429      & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31430      & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31431      & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31432      & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31433      & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31434      & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31435      & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31436      & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31437      & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31438      & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31439      & 589, 595, 601, 602 /
31440
31441        END
31442
31443 *$ CREATE DT_BLKD47.FOR
31444 *COPY DT_BLKD47
31445 *
31446 *===blkd47=============================================================*
31447 *
31448       BLOCK DATA DT_BLKD47
31449
31450       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31451       SAVE
31452
31453 * HADRIN: decay channel information
31454       PARAMETER (IDMAX9=602)
31455       CHARACTER*8 ZKNAME
31456       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31457
31458 * Name of decay channel
31459 * Designation N*@ means N*@1(1236)
31460 * @1=# means ++,  @1 = = means --
31461 * Designation  P+/0/- means Pi+/Pi0/Pi- , respectively
31462       DATA (ZKNAME(K),K=  1, 85) /
31463      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
31464      &  'ANUE    ','GAM     ','PE-NUE  ','APEANU  ','EANUNU  ',
31465      &  'E-NUAN  ','3PI0    ','PI+-0   ','PIMUNU  ','PIE-NU  ',
31466      &  'MU+NUE  ','MU-NUE  ','MU+NUE  ','PI+PI0  ','PI++-   ',
31467      &  'PI+00   ','M+P0NU  ','E+P0NU  ','MU-NU   ','PI-0    ',
31468      &  'PI+--   ','PI-00   ','M-P0NU  ','E-P0NU  ','PPI-    ',
31469      &  'NPI0    ','PD-NUE  ','PM-NUE  ','APPI+   ','ANPI0   ',
31470      &  'APE+NU  ','APM+NU  ','PI+PI-  ','PI0PI0  ','NPI-    ',
31471      &  'PPI0    ','NPI+    ','LAGA    ','GAGA    ','GAE+E-  ',
31472      &  'GAGA    ','GAGAP0  ','PI000   ','PI+-0   ','PI+-GA  ',
31473      &  'PI+0    ','PI+-    ','PI00    ','PI-0    ','PI+-0   ',
31474      &  'PI+-    ','PI0GA   ','K+PI0   ','K0PI+   ','KOPI0   ',
31475      &  'K+PI-   ','K-PI0   ','AK0PI-  ','AK0PI0  ','K-PI+   ',
31476      &  'K+PI0   ','K0PI+   ','K0PI0   ','K+PI-   ','K-PI0   ',
31477      &  'K0PI-   ','AK0PI0  ','K-PI+   ','K+PI0   ','K0PI+   ',
31478      &  'K+89P0  ','K08PI+  ','K+RO77  ','K0RO+7  ','K+OM07  ',
31479      &  'K+E055  ','K0PI0   ','K+PI+   ','K089P0  ','K+8PI-  '  /
31480       DATA (ZKNAME(K),K= 86,170) /
31481      &  'K0R077  ','K+R-77  ','K+R-77  ','K0OM07  ','K0E055  ',
31482      &  'K-PI0   ','K0PI-   ','K-89P0  ','AK08P-  ','K-R077  ',
31483      &  'AK0R-7  ','K-OM07  ','K-E055  ','AK0PI0  ','K-PI+   ',
31484      &  'AK08P0  ','K-8PI+  ','AK0R07  ','AK0OM7  ','AK0E05  ',
31485      &  'LA0PI+  ','SI0PI+  ','SI+PI0  ','LA0PI0  ','SI+PI-  ',
31486      &  'SI-PI+  ','LA0PI-  ','SI0PI-  ','NEUAK0  ','PK-     ',
31487      &  'SI+PI-  ','SI0PI0  ','SI-PI+  ','LA0ET0  ','S+1PI-  ',
31488      &  'S-1PI+  ','SO1PI0  ','NEUAK0  ','PK-     ','LA0PI0  ',
31489      &  'LA0OM0  ','LA0RO0  ','SI+RO-  ','SI-RO+  ','SI0RO0  ',
31490      &  'LA0ET0  ','SI0ET0  ','SI+PI-  ','SI-PI+  ','SI0PI0  ',
31491      &  'K0S     ','K0L     ','K0S     ','K0L     ','P PI+   ',
31492      &  'P PI0   ','N PI+   ','P PI-   ','N PI0   ','N PI-   ',
31493      &  'P PI+   ','N*#PI0  ','N*+PI+  ','PRHO+   ','P PI0   ',
31494      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
31495      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
31496      &  'N*-PI+  ','PRHO-   ','NRHO0   ','N PI-   ','N*0PI-  ',
31497      &  'N*-PI0  ','NRHO-   ','PETA0   ','N*#PI-  ','N*+PI0  '  /
31498       DATA (ZKNAME(K),K=171,255) /
31499      &  'N*0PI+  ','PRHO0   ','NRHO+   ','NETA0   ','N*+PI-  ',
31500      &  'N*0PI0  ','N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ',
31501      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
31502      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
31503      &  'N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ','N PI+   ',
31504      &  'PRHO0   ','NRHO+   ','LAMK+   ','S+ K0   ','S0 K+   ',
31505      &  'PETA0   ','P PI-   ','N PI0   ','PRHO-   ','NRHO0   ',
31506      &  'LAMK0   ','S0 K0   ','S- K+   ','NETA/   ','APPI-   ',
31507      &  'APPI0   ','ANPI-   ','APPI+   ','ANPI0   ','ANPI+   ',
31508      &  'APPI-   ','AN*=P0  ','AN*-P-  ','APRHO-  ','APPI0   ',
31509      &  'ANPI-   ','AN*=P+  ','AN*-P0  ','AN*0P-  ','APRHO0  ',
31510      &  'ANRHO-  ','APPI+   ','ANPI0   ','AN*-P+  ','AN*0P0  ',
31511      &  'AN*+P-  ','APRHO+  ','ANRHO0  ','ANPI+   ','AN*0P+  ',
31512      &  'AN*+P0  ','ANRHO+  ','APPI0   ','ANPI-   ','AN*=P+  ',
31513      &  'AN*-P0  ','AN*0P-  ','APRHO0  ','ANRHO-  ','APPI+,  ',
31514      &  'ANPI0   ','AN*-P+  ','AN*0P0  ','AN*+P-  ','APRHO+  ',
31515      &  'ANRHO0  ','PN*014  ','NN*=14  ','PI+0    ','PI+-    '  /
31516       DATA (ZKNAME(K),K=256,340) /
31517      &  'PI-0    ','P+0     ','N++     ','P+-     ','P00     ',
31518      &  'N+0     ','N+-     ','N00     ','P-0     ','N-0     ',
31519      &  'P--     ','PPPI0   ','PNPI+   ','PNPI0   ','PPPI-   ',
31520      &  'NNPI+   ','APPPI0  ','APNPI+  ','ANNPI0  ','ANPPI-  ',
31521      &  'APNPI0  ','APPPI-  ','ANNPI-  ','K+PPI0  ','K+NPI+  ',
31522      &  'K0PPI0  ','K-PPI0  ','K-NPI+  ','AKPPI-  ','AKNPI0  ',
31523      &  'K+NPI0  ','K+PPI-  ','K0PPI0  ','K0NPI+  ','K-NPI0  ',
31524      &  'K-PPI-  ','AKNPI-  ','PAK0    ','SI+PI0  ','SI0PI+  ',
31525      &  'SI+ETA  ','S+1PI0  ','S01PI+  ','NEUK-   ','LA0PI-  ',
31526      &  'SI-OM0  ','LA0RO-  ','SI0RO-  ','SI-RO0  ','SI-ET0  ',
31527      &  'SI0PI-  ','SI-0    ','BLANC   ','BLANC   ','BLANC   ',
31528      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31529      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31530      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31531      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31532      &  'EPI+-   ','EPI00   ','GAPI+-  ','GAGA*   ','K+-     ',
31533      &  'KLKS    ','PI+-0   ','EGA     ','LPI0    ','LPI     '  /
31534       DATA (ZKNAME(K),K=341,425) /
31535      &  'APPI0   ','ANPI-   ','ALAGA   ','ANPI    ','ALPI0   ',
31536      &  'ALPI+   ','LAPI+   ','SI+PI0  ','SI0PI+  ','LAPI0   ',
31537      &  'SI+PI-  ','SI-PI+  ','LAPI-   ','SI-PI0  ','SI0PI-  ',
31538      &  'TE0PI0  ','TE-PI+  ','TE0PI-  ','TE-PI0  ','TE0PI   ',
31539      &  'TE-PI   ','LAK-    ','ALPI-   ','AS-PI0  ','AS0PI-  ',
31540      &  'ALPI0   ','AS+PI-  ','AS-PI+  ','ALPI+   ','AS+PI0  ',
31541      &  'AS0PI+  ','AT0PI0  ','AT+PI-  ','AT0PI+  ','AT+PI0  ',
31542      &  'AT0PI   ','AT+PI   ','ALK+    ','K-PI+   ','K-PI+0  ',
31543      &  'K0PI+-  ','K0PI0   ','K-PI++  ','AK0PI+  ','K+PI--  ',
31544      &  'K0PI-   ','K+PI-   ','K+PI-0  ','AKPI-+  ','AK0PI0  ',
31545      &  'ETAPIF  ','K++-    ','K+AK0   ','ETAPI-  ','K--+    ',
31546      &  'K-K0    ','PI00    ','PI+-    ','GAGA    ','D0PI0   ',
31547      &  'D0GA    ','D0PI+   ','D+PI0   ','DFGA    ','AD0PI-  ',
31548      &  'D-PI0   ','D-GA    ','AD0PI0  ','AD0GA   ','F+GA    ',
31549      &  'F+GA    ','F-GA    ','F-GA    ','PSPI+-  ','PSPI00  ',
31550      &  'PSETA   ','E+E-    ','MUE+-   ','PI+-0   ','M+NN    ',
31551      &  'E+NN    ','RHO+NT  ','PI+ANT  ','K*+ANT  ','M-NN    '  /
31552       DATA (ZKNAME(K),K=426,510) /
31553      &  'E-NN    ','RHO-NT  ','PI-NT   ','K*-NT   ','NUET    ',
31554      &  'ANUET   ','NUEM    ','ANUEM   ','SI+ETA  ','SI+ET*  ',
31555      &  'PAK0    ','TET0K+  ','SI*+ET  ','N*+AK0  ','N*++K-  ',
31556      &  'LAMRO+  ','SI0RO+  ','SI+RO0  ','SI+OME  ','PAK*0   ',
31557      &  'N*+AK*  ','N*++K*  ','SI+AK0  ','TET0PI  ','SI+AK*  ',
31558      &  'TET0RO  ','SI0AK*  ','SI+K*-  ','TET0OM  ','TET-RO  ',
31559      &  'SI*0AK  ','C0+PI+  ','C0+PI0  ','C0+PI-  ','A+GAM   ',
31560      &  'A0GAM   ','TET0AK  ','TET0K*  ','OM-RO+  ','OM-PI+  ',
31561      &  'C1++AK  ','A+PI+   ','C0+AK0  ','A0PI+   ','A+AK0   ',
31562      &  'T0PI+   ','ASI-ET  ','ASI-E*  ','APK0    ','ATET0K  ',
31563      &  'ASI*-E  ','AN*-K0  ','AN*--K  ','ALAMRO  ','ASI0RO  ',
31564      &  'ASI-RO  ','ASI-OM  ','APK*0   ','AN*-K*  ','AN*--K  ',
31565      &  'ASI-K0  ','ATETPI  ','ASI-K*  ','ATETRO  ','ASI0K*  ',
31566      &  'ASI-K*  ','ATE0OM  ','ATE+RO  ','ASI*0K  ','AC-PI-  ',
31567      &  'AC-PI0  ','AC-PI+  ','AA-GAM  ','AA0GAM  ','ATET0K  ',
31568      &  'ATE0K*  ','AOM+RO  ','AOM+PI  ','AC1--K  ','AA-PI-  ',
31569      &  'AC0-K0  ','AA0PI-  ','AA-K0   ','AT0PI-  ','C1++GA  '  /
31570       DATA (ZKNAME(K),K=511,540) /
31571      &  'C1++GA  ','C10GAM  ','S+GAM   ','S0GAM   ','T0GAM   ',
31572      &  'XU++GA  ','XD+GAM  ','XS+GAM  ','A+AKPI  ','T02PI+  ',
31573      &  'C1++2K  ','AC1--G  ','AC1-GA  ','AC10GA  ','AS-GAM  ',
31574      &  'AS0GAM  ','AT0GAM  ','AXU--G  ','AXD-GA  ','AXS-GA  ',
31575      &  'AA-KPI  ','AT02PI  ','AC1--K  ','RH-PI+  ','RH+PI-  ',
31576      &  'RH3PI0  ','RH0PI+  ','RH+PI0  ','RH0PI-  ','RH-PI0  '  /
31577       DATA (ZKNAME(I),I=541,602)/
31578      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31579      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31580      & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31581      & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31582      & 'PI+PI-','K+K-  ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31583      & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31584      & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31585      & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31586      & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31587 * Weight of decay channel
31588       DATA (WT(K),K=  1, 85) /
31589      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31590      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31591      &   .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31592      &   .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31593      &   .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31594      &   .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31595      &   .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31596      &   .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31597      &   .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31598      &   .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31599      &   .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31600      &   .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31601      &   .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31602      &   .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31603      &   .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31604      &   .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31605      &   .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00  /
31606       DATA (WT(K),K= 86,170) /
31607      &   .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31608      &   .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31609      &   .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31610      &   .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31611      &   .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31612      &   .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31613      &   .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31614      &   .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31615      &   .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31616      &   .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31617      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31618      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31619      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31620      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31621      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31622      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31623      &   .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00  /
31624       DATA (WT(K),K=171,255) /
31625      &   .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31626      &   .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31627      &   .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31628      &   .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31629      &   .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31630      &   .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31631      &   .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31632      &   .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31633      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31634      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31635      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31636      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31637      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31638      &   .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31639      &   .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31640      &   .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31641      &   .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01  /
31642       DATA (WT(K),K=256,340) /
31643      &   .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31644      &   .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31645      &   .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31646      &   .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31647      &   .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31648      &   .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31649      &   .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31650      &   .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31651      &   .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31652      &   .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31653      &   .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31654      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31655      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31656      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31657      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31658      &   .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31659      &   .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01  /
31660       DATA (WT(K),K=341,425) /
31661      &   .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31662      &   .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31663      &   .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31664      &   .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31665      &   .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31666      &   .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31667      &   .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31668      &   .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31669      &   .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31670      &   .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31671      &   .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31672      &   .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31673      &   .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31674      &   .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31675      &   .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31676      &   .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31677      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00  /
31678       DATA (WT(K),K=426,510) /
31679      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31680      &   .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31681      &   .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31682      &   .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31683      &   .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31684      &   .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31685      &   .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31686      &   .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31687      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31688      &   .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31689      &   .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31690      &   .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31691      &   .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31692      &   .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31693      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31694      &   .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31695      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01  /
31696       DATA (WT(K),K=511,540) /
31697      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31698      &   .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31699      &   .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31700      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31701      &   .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31702      &   .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00  /
31703 C
31704       DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31705      & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31706      & .125D+00,  0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31707      & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31708      & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31709      & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31710      & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31711 * Particle numbers in decay channel
31712       DATA (NZK(K,1),K=  1,170) /
31713      &     1,   2,   3,   4,   5,   6,   7,   1,   2,   4,
31714      &     3,  23,  13,  13,  13,  10,  11,  10,  13,  13,
31715      &    13,  10,   4,  11,  14,  14,  14,  11,   3,   1,
31716      &     8,   1,   1,   2,   9,   2,   2,  13,  23,   8,
31717      &     1,   8,  17,   7,   7,   7,  23,  23,  13,  13,
31718      &    13,  13,  23,  14,  13,  13,  23,  15,  24,  24,
31719      &    15,  16,  25,  25,  16,  15,  24,  24,  15,  16,
31720      &    24,  25,  16,  15,  24,  36,  37,  15,  24,  15,
31721      &    15,  24,  15,  37,  36,  24,  15,  24,  24,  16,
31722      &    24,  38,  39,  16,  25,  16,  16,  25,  16,  39,
31723      &    38,  25,  16,  25,  25,  17,  22,  21,  17,  21,
31724      &    20,  17,  22,   8,   1,  21,  22,  20,  17,  48,
31725      &    50,  49,   8,   1,  17,  17,  17,  21,  20,  22,
31726      &    17,  22,  21,  20,  22,  19,  12,  19,  12,   1,
31727      &     1,   8,   1,   8,   8,   1,  53,  54,   1,   1,
31728      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
31729      &    56,   1,   8,   8,  55,  56,   8,   1,  53,  54  /
31730       DATA (NZK(K,1),K=171,340) /
31731      &    55,   1,   8,   8,  54,  55,  56,   1,   8,   1,
31732      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
31733      &    56,   1,   8,   1,   8,   1,   8,  17,  21,  22,
31734      &     1,   1,   8,   1,   8,  17,  22,  20,   8,   2,
31735      &     2,   9,   2,   9,   9,   2,  67,  68,   2,   2,
31736      &     9,  67,  68,  69,   2,   9,   2,   9,  68,  69,
31737      &    70,   2,   9,   9,  69,  70,   9,   2,   9,  67,
31738      &    68,  69,   2,   9,   2,   9,  68,  69,  70,   2,
31739      &     9,   1,   8,  13,  13,  14,   1,   8,   1,   1,
31740      &     8,   8,   8,   1,   8,   1,   1,   1,   1,   1,
31741      &     8,   2,   2,   9,   9,   2,   2,   9,  15,  15,
31742      &    24,  16,  16,  25,  25,  15,  15,  24,  24,  16,
31743      &    16,  25,   1,  21,  22,  21,  48,  49,   8,  17,
31744      &    20,  17,  22,  20,  20,  22,  20,   0,   0,   0,
31745      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31746      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31747      &    31,  31,  13,   7,  15,  12,  13,  31,  17,  17  /
31748       DATA (NZK(K,1),K=341,510) /
31749      &     2,   9,  18,   9,  18,  18,  17,  21,  22,  17,
31750      &    21,  20,  17,  20,  22,  97,  98,  97,  98,  97,
31751      &    98,  17,  18,  99, 100,  18, 101,  99,  18, 101,
31752      &   100, 102, 103, 102, 103, 102, 103,  18,  16,  16,
31753      &    24,  24,  16,  25,  15,  24,  15,  15,  25,  25,
31754      &    31,  15,  15,  31,  16,  16,  23,  13,   7, 116,
31755      &   116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31756      &   120, 121, 121, 130, 130, 130,   4,  10,  13,  10,
31757      &     4,  32,  13,  36,  11,   3,  34,  14,  38, 133,
31758      &   134, 135, 136,  21,  21,   1,  97, 104,  54,  53,
31759      &    17,  22,  21,  21,   1,  54,  53,  21,  97,  21,
31760      &    97,  22,  21,  97,  98, 105, 137, 137, 137, 138,
31761      &   139,  97,  97, 109, 109, 140, 138, 137, 139, 138,
31762      &   145,  99,  99,   2, 102, 110,  68,  67,  18, 100,
31763      &    99,  99,   2,  68,  67,  99, 102,  99, 102, 100,
31764      &    99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31765      &   113, 115, 115, 152, 150, 149, 151, 150, 157, 140  /
31766       DATA (NZK(K,1),K=511,540) /
31767      &   141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31768      &   140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31769      &   150, 157, 152,  34,  32,  33,  33,  32,  33,  34  /
31770       DATA (NZK(I,1),I=541,602) /  2, 67, 68, 69,  2,  9,  9, 68, 69,
31771      & 70,  2,  9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31772      & 14, 189, 23, 13, 15, 24,  36,  38,  37,  39, 194, 195, 196, 197,
31773      & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31774      & 55, 8, 1, 8, 8, 54, 55, 210/
31775       DATA (NZK(K,2),K=  1,170) /
31776      &     0,   0,   0,   0,   0,   0,   0,   3,   4,   6,
31777      &     5,  23,  14,  11,   3,   5,   5,   5,  23,  13,
31778      &    23,  23,  23,   5,  23,  13,  23,  23,  23,  14,
31779      &    23,   3,  11,  13,  23,   4,  10,  14,  23,  14,
31780      &    23,  13,   7,   7,   4,   7,   7,  23,  14,  14,
31781      &    23,  14,  23,  23,  14,  14,   7,  23,  13,  23,
31782      &    14,  23,  14,  23,  13,  23,  13,  23,  14,  23,
31783      &    14,  23,  13,  23,  13,  23,  13,  33,  32,  35,
31784      &    31,  23,  14,  23,  14,  33,  34,  35,  31,  23,
31785      &    14,  23,  14,  33,  34,  35,  31,  23,  13,  23,
31786      &    13,  33,  32,  35,  31,  13,  13,  23,  23,  14,
31787      &    13,  14,  14,  25,  16,  14,  23,  13,  31,  14,
31788      &    13,  23,  25,  16,  23,  35,  33,  34,  32,  33,
31789      &    31,  31,  14,  13,  23,   0,   0,   0,   0,  13,
31790      &    23,  13,  14,  23,  14,  13,  23,  13,  78,  23,
31791      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
31792      &    13,  80,  79,  14,  14,  23,  80,  31,  14,  23  /
31793       DATA (NZK(K,2),K=171,340) /
31794      &    13,  79,  78,  31,  14,  23,  13,  80,  79,  23,
31795      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
31796      &    13,  80,  79,  23,  13,  33,  32,  15,  24,  15,
31797      &    31,  14,  23,  34,  33,  24,  24,  15,  31,  14,
31798      &    23,  14,  13,  23,  13,  14,  23,  14,  80,  23,
31799      &    14,  13,  23,  14,  79,  80,  13,  23,  13,  23,
31800      &    14,  78,  79,  13,  13,  23,  78,  23,  14,  13,
31801      &    23,  14,  79,  80,  13,  23,  13,  23,  14,  78,
31802      &    79,  62,  61,  23,  14,  23,  13,  13,  13,  23,
31803      &    13,  13,  23,  14,  14,  14,   1,   8,   8,   1,
31804      &     8,   1,   8,   8,   1,   8,   1,   8,   1,   8,
31805      &     1,   1,   8,   1,   8,   8,   1,   1,   8,   8,
31806      &     1,   8,  25,  23,  13,  31,  23,  13,  16,  14,
31807      &    35,  34,  34,  33,  31,  14,  23,   0,   0,   0,
31808      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31809      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31810      &    13,  23,  14,   7,  16,  19,  14,   7,  23,  14  /
31811       DATA (NZK(K,2),K=341,510) /
31812      &    23,  14,   7,  13,  23,  13,  13,  23,  13,  23,
31813      &    14,  13,  14,  23,  14,  23,  13,  14,  23,  14,
31814      &    23,  16,  14,  23,  14,  23,  14,  13,  13,  23,
31815      &    13,  23,  14,  13,  23,  13,  23,  15,  13,  13,
31816      &    13,  23,  13,  13,  14,  14,  14,  14,  14,  23,
31817      &    13,  16,  25,  14,  15,  24,  23,  14,   7,  23,
31818      &     7,  13,  23,   7,  14,  23,   7,  23,   7,   7,
31819      &     7,   7,   7,  13,  23,  31,   3,  11,  14, 135,
31820      &     5, 134, 134, 134, 136,   6, 133, 133, 133,   0,
31821      &     0,   0,   0,  31,  95,  25,  15,  31,  95,  16,
31822      &    32,  32,  33,  35,  39,  39,  38,  25,  13,  39,
31823      &    32,  39,  38,  35,  32,  39,  13,  23,  14,   7,
31824      &     7,  25,  37,  32,  13,  25,  13,  25,  13,  25,
31825      &    13,  31,  95,  24,  16,  31,  24,  15,  34,  34,
31826      &    33,  35,  37,  37,  36,  24,  14,  37,  34,  37,
31827      &    36,  35,  34,  37,  14,  23,  13,   7,   7,  24,
31828      &    39,  34,  14,  24,  14,  24,  14,  24,  14,   7  /
31829       DATA (NZK(K,2),K=511,540) /
31830      &     7,   7,   7,   7,   7,   7,   7,   7,  25,  13,
31831      &    25,   7,   7,   7,   7,   7,   7,   7,   7,   7,
31832      &    24,  14,  24,  13,  14,  23,  13,  23,  14,  23  /
31833       DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31834      & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31835      & 14, 14, 23, 14, 16, 25,
31836      & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31837      & 23, 13, 14, 23,  0 /
31838       DATA (NZK(K,3),K=  1,170) /
31839      &     0,   0,   0,   0,   0,   0,   0,   5,   6,   5,
31840      &     6,  23,  23,   5,   5,   0,   0,   0,   0,  14,
31841      &    23,   5,   5,   0,   0,  14,  23,   5,   5,   0,
31842      &     0,   5,   5,   0,   0,   5,   5,   0,   0,   0,
31843      &     0,   0,   0,   0,   3,   0,   7,  23,  23,   7,
31844      &     0,   0,   0,   0,  23,   0,   0,   0,   0,   0,
31845      &     110*0   /
31846       DATA (NZK(K,3),K=171,340) /
31847      &     80*0,
31848      &     0,   0,   0,   0,   0,   0,  23,  13,  14,  23,
31849      &    23,  14,  23,  23,  23,  14,  23,  13,  23,  14,
31850      &    13,  23,  13,  23,  14,  23,  14,  14,  23,  13,
31851      &    13,  23,  13,  14,  23,  23,  14,  23,  13,  23,
31852      &    14,  14,   0,   0,   0,   0,   0,   0,   0,   0,
31853      &     30*0,
31854      &    14,  23,   7,   0,   0,   0,  23,   0,   0,   0  /
31855       DATA (NZK(K,3),K=341,510) /
31856      &     30*0,
31857      &     0,   0,   0,   0,   0,   0,   0,   0,   0,  23,
31858      &    14,   0,  13,   0,  14,   0,   0,  23,  13,   0,
31859      &     0,  15,   0,   0,  16,   0,   0,   0,   0,   0,
31860      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31861      &     0,   0,   0,  14,  23,   0,   0,   0,  23, 134,
31862      &   134,   0,   0,   0, 133, 133,   0,   0,   0,   0,
31863      &     80*0  /
31864       DATA (NZK(K,3),K=511,540) /
31865      &     0,   0,   0,   0,   0,   0,   0,   0,  13,  13,
31866      &    25,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31867      &    14,  14,  24,   0,   0,   0,   0,   0,   0,   0  /
31868       DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31869      & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31870
31871       END
31872
31873 *$ CREATE DT_BDEVAP.FOR
31874 *COPY DT_BDEVAP
31875 *
31876 *=== bdevap ===========================================================*
31877 *
31878       BLOCK DATA DT_BDEVAP
31879
31880 C     INCLUDE '(DBLPRC)'
31881 * DBLPRC.ADD
31882       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31883       SAVE
31884 * (original name: GLOBAL)
31885       PARAMETER ( KALGNM = 2 )
31886       PARAMETER ( ANGLGB = 5.0D-16 )
31887       PARAMETER ( ANGLSQ = 2.5D-31 )
31888       PARAMETER ( AXCSSV = 0.2D+16 )
31889       PARAMETER ( ANDRFL = 1.0D-38 )
31890       PARAMETER ( AVRFLW = 1.0D+38 )
31891       PARAMETER ( AINFNT = 1.0D+30 )
31892       PARAMETER ( AZRZRZ = 1.0D-30 )
31893       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
31894       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
31895       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
31896       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
31897       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
31898       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
31899       PARAMETER ( CSNNRM = 2.0D-15 )
31900       PARAMETER ( DMXTRN = 1.0D+08 )
31901       PARAMETER ( ZERZER = 0.D+00 )
31902       PARAMETER ( ONEONE = 1.D+00 )
31903       PARAMETER ( TWOTWO = 2.D+00 )
31904       PARAMETER ( THRTHR = 3.D+00 )
31905       PARAMETER ( FOUFOU = 4.D+00 )
31906       PARAMETER ( FIVFIV = 5.D+00 )
31907       PARAMETER ( SIXSIX = 6.D+00 )
31908       PARAMETER ( SEVSEV = 7.D+00 )
31909       PARAMETER ( EIGEIG = 8.D+00 )
31910       PARAMETER ( ANINEN = 9.D+00 )
31911       PARAMETER ( TENTEN = 10.D+00 )
31912       PARAMETER ( HLFHLF = 0.5D+00 )
31913       PARAMETER ( ONETHI = ONEONE / THRTHR )
31914       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
31915       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
31916       PARAMETER ( THRTWO = THRTHR / TWOTWO )
31917       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
31918       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
31919       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
31920       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
31921       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
31922       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
31923       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
31924       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
31925       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
31926       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
31927       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
31928       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
31929       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
31930       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
31931       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
31932       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
31933       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
31934       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
31935       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
31936       PARAMETER ( CLIGHT = 2.99792458         D+10 )
31937       PARAMETER ( AVOGAD = 6.0221367          D+23 )
31938       PARAMETER ( BOLTZM = 1.380658           D-23 )
31939       PARAMETER ( AMELGR = 9.1093897          D-28 )
31940       PARAMETER ( PLCKBR = 1.05457266         D-27 )
31941       PARAMETER ( ELCCGS = 4.8032068          D-10 )
31942       PARAMETER ( ELCMKS = 1.60217733         D-19 )
31943       PARAMETER ( AMUGRM = 1.6605402          D-24 )
31944       PARAMETER ( AMMUMU = 0.113428913        D+00 )
31945       PARAMETER ( AMPRMU = 1.007276470        D+00 )
31946       PARAMETER ( AMNEMU = 1.008664904        D+00 )
31947       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
31948       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
31949       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
31950       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
31951       PARAMETER ( PLABRC = 0.197327053        D+00 )
31952       PARAMETER ( AMELCT = 0.51099906         D-03 )
31953       PARAMETER ( AMUGEV = 0.93149432         D+00 )
31954       PARAMETER ( AMMUON = 0.105658389        D+00 )
31955       PARAMETER ( AMPRTN = 0.93827231         D+00 )
31956       PARAMETER ( AMNTRN = 0.93956563         D+00 )
31957       PARAMETER ( AMDEUT = 1.87561339         D+00 )
31958       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
31959      &                   * 1.D-09 )
31960       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
31961       PARAMETER ( BLTZMN = 8.617385           D-14 )
31962       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
31963       PARAMETER ( GFOHB3 = 1.16639            D-05 )
31964       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
31965       PARAMETER ( SIN2TW = 0.2319             D+00 )
31966       PARAMETER ( GEVMEV = 1.0                D+03 )
31967       PARAMETER ( EMVGEV = 1.0                D-03 )
31968       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
31969       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
31970       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
31971       LOGICAL LGBIAS, LGBANA
31972       COMMON /FKGLOB/ LGBIAS, LGBANA
31973 C     INCLUDE '(DIMPAR)'
31974 * DIMPAR.ADD
31975       PARAMETER ( MXXRGN = 5000 )
31976       PARAMETER ( MXXMDF = 82   )
31977       PARAMETER ( MXXMDE = 54   )
31978       PARAMETER ( MFSTCK = 1000 )
31979       PARAMETER ( MESTCK = 100  )
31980       PARAMETER ( NELEMX = 80   )
31981       PARAMETER ( MPDPDX = 8    )
31982       PARAMETER ( ICOMAX = 180  )
31983       PARAMETER ( NSTBIS = 304  )
31984       PARAMETER ( IDMAXP = 220  )
31985       PARAMETER ( IDMXDC = 640  )
31986       PARAMETER ( MKBMX1 = 1    )
31987       PARAMETER ( MKBMX2 = 1    )
31988 C     INCLUDE '(IOUNIT)'
31989 * IOUNIT.ADD
31990       PARAMETER ( LUNIN  =  5 )
31991       PARAMETER ( LUNOUT =  6 )
31992 **sr 19.5. set error output-unit from 15 to 6
31993       PARAMETER ( LUNERR = 6  )
31994       PARAMETER ( LUNBER = 14 )
31995       PARAMETER ( LUNECH =  8 )
31996       PARAMETER ( LUNFLU = 13 )
31997       PARAMETER ( LUNGEO = 16 )
31998       PARAMETER ( LUNPMF = 12 )
31999       PARAMETER ( LUNRAN =  2 )
32000       PARAMETER ( LUNXSC =  9 )
32001       PARAMETER ( LUNDET = 17 )
32002       PARAMETER ( LUNRAY = 10 )
32003       PARAMETER ( LUNRDB =  1 )
32004       PARAMETER ( LUNPGO =  7 )
32005       PARAMETER ( LUNPGS =  4 )
32006       PARAMETER ( LUNSCR =  3 )
32007 *
32008 *----------------------------------------------------------------------*
32009 *                                                                      *
32010 *     Block Data for the EVAPoration routines:                         *
32011 *                                                                      *
32012 *     Created on    20 may 1990    by    Alfredo Ferrari & Paola Sala  *
32013 *                                                   Infn - Milan       *
32014 *                                                                      *
32015 *     Modified from the original version of J.M.Zazula                 *
32016 *     and, for cookcm, from a LAHET block data kindly provided by      *
32017 *     R.E.Prael-LANL                                                   *
32018 *                                                                      *
32019 *     Last change on  20-feb-95    by    Alfredo Ferrari               *
32020 *                                                                      *
32021 *                                                                      *
32022 *----------------------------------------------------------------------*
32023 *
32024 * (original name: COOKCM)
32025       PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
32026       LOGICAL LDEFOZ, LDEFON
32027       PARAMETER ( INCOOK = 150, IZCOOK = 98 )
32028       COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
32029      &                SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
32030      &                PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
32031 * (original name: EVA0)
32032       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
32033      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
32034      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
32035      *                T (4,7), RMASS (297), ALPH (297), BET (297),
32036      *                APRIME (250), IA (6), IZ (6)
32037 * (original name: HETTP)
32038       COMMON /FKHETP/  NHSTP,NBERTP,IOSUB,INSRS
32039 * (original name: HETC7)
32040       COMMON /FKHET7/ COSKS,SINKS, COSTH,SINTH, COSPHI,SINPHI
32041 * (original name: INPFLG)
32042       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
32043 *
32044       DATA B0   / 8.D+00 /, Y0 / 1.5D+00 /
32045       DATA IANG / 1 /, IFISS / 1 /,  IB0 / 2 /, IGEOM / 0 /
32046       DATA ISTRAG /0/, KEYDK /0/
32047       DATA NBERTP /LUNBER/
32048       DATA COSTH /ONEONE/, SINTH /ZERZER/, COSPHI /ONEONE/,
32049      &     SINPHI/ZERZER/
32050 *  /cookcm/
32051        DATA ( PZCOOK(I),I =  1, IZCOOK ) /
32052      & 0.000D+00, 5.440D+00, 0.000D+00, 2.760D+00, 0.000D+00, 3.340D+00,
32053      & 0.000D+00, 2.700D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.460D+00,
32054      & 0.000D+00, 2.090D+00, 0.000D+00, 1.620D+00, 0.000D+00, 1.620D+00,
32055      & 0.000D+00, 1.830D+00, 0.000D+00, 1.730D+00, 0.000D+00, 1.350D+00,
32056      & 0.000D+00, 1.540D+00, 0.000D+00, 1.280D+00, 2.600D-01, 8.800D-01,
32057      & 1.900D-01, 1.350D+00,-5.000D-02, 1.520D+00,-9.000D-02, 1.170D+00,
32058      & 4.000D-02, 1.240D+00, 2.900D-01, 1.090D+00, 2.600D-01, 1.170D+00,
32059      & 2.300D-01, 1.150D+00,-8.000D-02, 1.350D+00, 3.400D-01, 1.050D+00,
32060      & 2.800D-01, 1.270D+00, 0.000D+00, 1.050D+00, 0.000D+00, 1.000D+00,
32061      & 9.000D-02, 1.200D+00, 2.000D-01, 1.400D+00, 9.300D-01, 1.000D+00,
32062      &-2.000D-01, 1.190D+00, 9.000D-02, 9.700D-01, 0.000D+00, 9.200D-01,
32063      & 1.100D-01, 6.800D-01, 5.000D-02, 6.800D-01,-2.200D-01, 7.900D-01,
32064      & 9.000D-02, 6.900D-01, 1.000D-02, 7.200D-01, 0.000D+00, 4.000D-01,
32065      & 1.600D-01, 7.300D-01, 0.000D+00, 4.600D-01, 1.700D-01, 8.900D-01,
32066      & 0.000D+00, 7.900D-01, 0.000D+00, 8.900D-01, 0.000D+00, 8.100D-01,
32067      &-6.000D-02, 6.900D-01,-2.000D-01, 7.100D-01,-1.200D-01, 7.200D-01,
32068      & 0.000D+00, 7.700D-01/
32069        DATA ( PNCOOK(I),I =  1, 90 ) /
32070      & 0.000D+00, 5.980D+00, 0.000D+00, 2.770D+00, 0.000D+00, 3.160D+00,
32071      & 0.000D+00, 3.010D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.670D+00,
32072      & 0.000D+00, 1.800D+00, 0.000D+00, 1.670D+00, 0.000D+00, 1.860D+00,
32073      & 0.000D+00, 2.040D+00, 0.000D+00, 1.640D+00, 0.000D+00, 1.440D+00,
32074      & 0.000D+00, 1.540D+00, 0.000D+00, 1.300D+00, 0.000D+00, 1.270D+00,
32075      & 0.000D+00, 1.290D+00, 8.000D-02, 1.410D+00,-8.000D-02, 1.500D+00,
32076      &-5.000D-02, 2.240D+00,-4.700D-01, 1.430D+00,-1.500D-01, 1.440D+00,
32077      & 6.000D-02, 1.560D+00, 2.500D-01, 1.570D+00,-1.600D-01, 1.460D+00,
32078      & 0.000D+00, 9.300D-01, 1.000D-02, 6.200D-01,-5.000D-01, 1.420D+00,
32079      & 1.300D-01, 1.520D+00,-6.500D-01, 8.000D-01,-8.000D-02, 1.290D+00,
32080      &-4.700D-01, 1.250D+00,-4.400D-01, 9.700D-01, 8.000D-02, 1.650D+00,
32081      &-1.100D-01, 1.260D+00,-4.600D-01, 1.060D+00, 2.200D-01, 1.550D+00,
32082      &-7.000D-02, 1.370D+00, 1.000D-01, 1.200D+00,-2.700D-01, 9.200D-01,
32083      &-3.500D-01, 1.190D+00, 0.000D+00, 1.050D+00,-2.500D-01, 1.610D+00,
32084      &-2.100D-01, 9.000D-01,-2.100D-01, 7.400D-01,-3.800D-01, 7.200D-01/
32085        DATA ( PNCOOK(I),I = 91, INCOOK ) /
32086      &-3.400D-01, 9.200D-01,-2.600D-01, 9.400D-01, 1.000D-02, 6.500D-01,
32087      &-3.600D-01, 8.300D-01, 1.100D-01, 6.700D-01, 5.000D-02, 1.000D+00,
32088      & 5.100D-01, 1.040D+00, 3.300D-01, 6.800D-01,-2.700D-01, 8.100D-01,
32089      & 9.000D-02, 7.500D-01, 1.700D-01, 8.600D-01, 1.400D-01, 1.100D+00,
32090      &-2.200D-01, 8.400D-01,-4.700D-01, 4.800D-01, 2.000D-02, 8.800D-01,
32091      & 2.400D-01, 5.200D-01, 2.700D-01, 4.100D-01,-5.000D-02, 3.800D-01,
32092      & 1.500D-01, 6.700D-01, 0.000D+00, 6.100D-01, 0.000D+00, 7.800D-01,
32093      & 0.000D+00, 6.700D-01, 0.000D+00, 6.700D-01, 0.000D+00, 7.900D-01,
32094      & 0.000D+00, 6.000D-01, 4.000D-02, 6.400D-01,-6.000D-02, 4.500D-01,
32095      & 5.000D-02, 2.600D-01,-2.200D-01, 3.900D-01, 0.000D+00, 3.900D-01/
32096        DATA ( SZCOOK(I),I =  1, 98) /
32097      & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32098      & 0.000D+00, 0.000D+00,-1.100D-01,-8.100D-01,-2.910D+00,-4.170D+00,
32099      &-5.720D+00,-7.800D+00,-8.970D+00,-9.700D+00,-1.010D+01,-1.070D+01,
32100      &-1.138D+01,-1.207D+01,-1.255D+01,-1.324D+01,-1.393D+01,-1.471D+01,
32101      &-1.553D+01,-1.637D+01,-1.736D+01,-1.860D+01,-1.870D+01,-1.801D+01,
32102      &-1.787D+01,-1.708D+01,-1.660D+01,-1.675D+01,-1.650D+01,-1.635D+01,
32103      &-1.622D+01,-1.641D+01,-1.689D+01,-1.643D+01,-1.668D+01,-1.673D+01,
32104      &-1.745D+01,-1.729D+01,-1.744D+01,-1.782D+01,-1.862D+01,-1.827D+01,
32105      &-1.939D+01,-1.991D+01,-1.914D+01,-1.826D+01,-1.740D+01,-1.642D+01,
32106      &-1.577D+01,-1.437D+01,-1.391D+01,-1.310D+01,-1.311D+01,-1.143D+01,
32107      &-1.089D+01,-1.075D+01,-1.062D+01,-1.041D+01,-1.021D+01,-9.850D+00,
32108      &-9.470D+00,-9.030D+00,-8.610D+00,-8.130D+00,-7.460D+00,-7.480D+00,
32109      &-7.200D+00,-7.130D+00,-7.060D+00,-6.780D+00,-6.640D+00,-6.640D+00,
32110      &-7.680D+00,-7.890D+00,-8.410D+00,-8.490D+00,-7.880D+00,-6.300D+00,
32111      &-5.470D+00,-4.780D+00,-4.370D+00,-4.170D+00,-4.130D+00,-4.320D+00,
32112      &-4.550D+00,-5.040D+00,-5.280D+00,-6.060D+00,-6.280D+00,-6.870D+00,
32113      &-7.200D+00,-7.740D+00/
32114        DATA ( SNCOOK(I),I =  1, 90 ) /
32115      & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32116      & 0.000D+00, 0.000D+00, 1.030D+01, 5.660D+00, 6.800D+00, 7.530D+00,
32117      & 7.550D+00, 7.210D+00, 7.440D+00, 8.070D+00, 8.940D+00, 9.810D+00,
32118      & 1.060D+01, 1.139D+01, 1.254D+01, 1.368D+01, 1.434D+01, 1.419D+01,
32119      & 1.383D+01, 1.350D+01, 1.300D+01, 1.213D+01, 1.260D+01, 1.326D+01,
32120      & 1.413D+01, 1.492D+01, 1.552D+01, 1.638D+01, 1.716D+01, 1.755D+01,
32121      & 1.803D+01, 1.759D+01, 1.903D+01, 1.871D+01, 1.880D+01, 1.899D+01,
32122      & 1.846D+01, 1.825D+01, 1.776D+01, 1.738D+01, 1.672D+01, 1.562D+01,
32123      & 1.438D+01, 1.288D+01, 1.323D+01, 1.381D+01, 1.490D+01, 1.486D+01,
32124      & 1.576D+01, 1.620D+01, 1.762D+01, 1.773D+01, 1.816D+01, 1.867D+01,
32125      & 1.969D+01, 1.951D+01, 2.017D+01, 1.948D+01, 1.998D+01, 1.983D+01,
32126      & 2.020D+01, 1.972D+01, 1.987D+01, 1.924D+01, 1.844D+01, 1.761D+01,
32127      & 1.710D+01, 1.616D+01, 1.590D+01, 1.533D+01, 1.476D+01, 1.354D+01,
32128      & 1.263D+01, 1.065D+01, 1.010D+01, 8.890D+00, 1.025D+01, 9.790D+00,
32129      & 1.139D+01, 1.172D+01, 1.243D+01, 1.296D+01, 1.343D+01, 1.337D+01/
32130        DATA ( SNCOOK(I),I = 91, INCOOK ) /
32131      & 1.296D+01, 1.211D+01, 1.192D+01, 1.100D+01, 1.080D+01, 1.042D+01,
32132      & 1.039D+01, 9.690D+00, 9.270D+00, 8.930D+00, 8.570D+00, 8.020D+00,
32133      & 7.590D+00, 7.330D+00, 7.230D+00, 7.050D+00, 7.420D+00, 6.750D+00,
32134      & 6.600D+00, 6.380D+00, 6.360D+00, 6.490D+00, 6.250D+00, 5.850D+00,
32135      & 5.480D+00, 4.530D+00, 4.300D+00, 3.390D+00, 2.350D+00, 1.660D+00,
32136      & 8.100D-01, 4.600D-01,-9.600D-01,-1.690D+00,-2.530D+00,-3.160D+00,
32137      &-1.870D+00,-4.100D-01, 7.100D-01, 1.660D+00, 2.620D+00, 3.220D+00,
32138      & 3.760D+00, 4.100D+00, 4.460D+00, 4.830D+00, 5.090D+00, 5.180D+00,
32139      & 5.170D+00, 5.100D+00, 5.010D+00, 4.970D+00, 5.090D+00, 5.030D+00,
32140      & 4.930D+00, 5.280D+00, 5.490D+00, 5.500D+00, 5.370D+00, 5.300D+00/
32141       DATA LDEFOZ / 53*.FALSE.,25*.TRUE.,7*.FALSE.,13*.TRUE. /
32142       DATA LDEFON / 85*.FALSE.,37*.TRUE.,7*.FALSE.,21*.TRUE. /
32143 *=== End of Block Data Bdevap =========================================*
32144       END
32145
32146 *$ CREATE DT_BDNOPT.FOR
32147 *COPY DT_BDNOPT
32148 *
32149 *=== bdnopt ===========================================================*
32150 *==                                                                    *
32151       BLOCK DATA DT_BDNOPT
32152
32153 C     INCLUDE '(DBLPRC)'
32154 * DBLPRC.ADD
32155       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32156       SAVE
32157 * (original name: GLOBAL)
32158       PARAMETER ( KALGNM = 2 )
32159       PARAMETER ( ANGLGB = 5.0D-16 )
32160       PARAMETER ( ANGLSQ = 2.5D-31 )
32161       PARAMETER ( AXCSSV = 0.2D+16 )
32162       PARAMETER ( ANDRFL = 1.0D-38 )
32163       PARAMETER ( AVRFLW = 1.0D+38 )
32164       PARAMETER ( AINFNT = 1.0D+30 )
32165       PARAMETER ( AZRZRZ = 1.0D-30 )
32166       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32167       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32168       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32169       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32170       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
32171       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
32172       PARAMETER ( CSNNRM = 2.0D-15 )
32173       PARAMETER ( DMXTRN = 1.0D+08 )
32174       PARAMETER ( ZERZER = 0.D+00 )
32175       PARAMETER ( ONEONE = 1.D+00 )
32176       PARAMETER ( TWOTWO = 2.D+00 )
32177       PARAMETER ( THRTHR = 3.D+00 )
32178       PARAMETER ( FOUFOU = 4.D+00 )
32179       PARAMETER ( FIVFIV = 5.D+00 )
32180       PARAMETER ( SIXSIX = 6.D+00 )
32181       PARAMETER ( SEVSEV = 7.D+00 )
32182       PARAMETER ( EIGEIG = 8.D+00 )
32183       PARAMETER ( ANINEN = 9.D+00 )
32184       PARAMETER ( TENTEN = 10.D+00 )
32185       PARAMETER ( HLFHLF = 0.5D+00 )
32186       PARAMETER ( ONETHI = ONEONE / THRTHR )
32187       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32188       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32189       PARAMETER ( THRTWO = THRTHR / TWOTWO )
32190       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32191       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32192       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32193       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32194       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32195       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32196       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32197       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
32198       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
32199       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
32200       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
32201       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32202       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32203       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32204       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32205       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32206       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32207       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32208       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32209       PARAMETER ( CLIGHT = 2.99792458         D+10 )
32210       PARAMETER ( AVOGAD = 6.0221367          D+23 )
32211       PARAMETER ( BOLTZM = 1.380658           D-23 )
32212       PARAMETER ( AMELGR = 9.1093897          D-28 )
32213       PARAMETER ( PLCKBR = 1.05457266         D-27 )
32214       PARAMETER ( ELCCGS = 4.8032068          D-10 )
32215       PARAMETER ( ELCMKS = 1.60217733         D-19 )
32216       PARAMETER ( AMUGRM = 1.6605402          D-24 )
32217       PARAMETER ( AMMUMU = 0.113428913        D+00 )
32218       PARAMETER ( AMPRMU = 1.007276470        D+00 )
32219       PARAMETER ( AMNEMU = 1.008664904        D+00 )
32220       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32221       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32222       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32223       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32224       PARAMETER ( PLABRC = 0.197327053        D+00 )
32225       PARAMETER ( AMELCT = 0.51099906         D-03 )
32226       PARAMETER ( AMUGEV = 0.93149432         D+00 )
32227       PARAMETER ( AMMUON = 0.105658389        D+00 )
32228       PARAMETER ( AMPRTN = 0.93827231         D+00 )
32229       PARAMETER ( AMNTRN = 0.93956563         D+00 )
32230       PARAMETER ( AMDEUT = 1.87561339         D+00 )
32231       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32232      &                   * 1.D-09 )
32233       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32234       PARAMETER ( BLTZMN = 8.617385           D-14 )
32235       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32236       PARAMETER ( GFOHB3 = 1.16639            D-05 )
32237       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32238       PARAMETER ( SIN2TW = 0.2319             D+00 )
32239       PARAMETER ( GEVMEV = 1.0                D+03 )
32240       PARAMETER ( EMVGEV = 1.0                D-03 )
32241       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
32242       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32243       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32244       LOGICAL LGBIAS, LGBANA
32245       COMMON /FKGLOB/ LGBIAS, LGBANA
32246 C     INCLUDE '(DIMPAR)'
32247 * DIMPAR.ADD
32248       PARAMETER ( MXXRGN = 5000 )
32249       PARAMETER ( MXXMDF = 82   )
32250       PARAMETER ( MXXMDE = 54   )
32251       PARAMETER ( MFSTCK = 1000 )
32252       PARAMETER ( MESTCK = 100  )
32253       PARAMETER ( NELEMX = 80   )
32254       PARAMETER ( MPDPDX = 8    )
32255       PARAMETER ( ICOMAX = 180  )
32256       PARAMETER ( NSTBIS = 304  )
32257       PARAMETER ( IDMAXP = 220  )
32258       PARAMETER ( IDMXDC = 640  )
32259       PARAMETER ( MKBMX1 = 1    )
32260       PARAMETER ( MKBMX2 = 1    )
32261 C     INCLUDE '(IOUNIT)'
32262 * IOUNIT.ADD
32263       PARAMETER ( LUNIN  =  5 )
32264       PARAMETER ( LUNOUT =  6 )
32265 **sr 19.5. set error output-unit from 15 to 6
32266       PARAMETER ( LUNERR = 6  )
32267       PARAMETER ( LUNBER = 14 )
32268       PARAMETER ( LUNECH =  8 )
32269       PARAMETER ( LUNFLU = 13 )
32270       PARAMETER ( LUNGEO = 16 )
32271       PARAMETER ( LUNPMF = 12 )
32272       PARAMETER ( LUNRAN =  2 )
32273       PARAMETER ( LUNXSC =  9 )
32274       PARAMETER ( LUNDET = 17 )
32275       PARAMETER ( LUNRAY = 10 )
32276       PARAMETER ( LUNRDB =  1 )
32277       PARAMETER ( LUNPGO =  7 )
32278       PARAMETER ( LUNPGS =  4 )
32279       PARAMETER ( LUNSCR =  3 )
32280 *
32281 *----------------------------------------------------------------------*
32282 *                                                                      *
32283 *   Created on  20 september 1989    by  Alfredo Ferrari - Infn Milan  *
32284 *                                                                      *
32285 *         Last change on 20-apr-95   by  Alfredo Ferrari               *
32286 *                                                                      *
32287 *----------------------------------------------------------------------*
32288 *
32289 C     INCLUDE '(BLNKCM)'
32290 * BLNKCM.ADD
32291 **sr 17.5. commented since not used here
32292 C     PARAMETER ( NBLNMX = 1100000 )
32293 C     DIMENSION GMSTOR ( NBLNMX ), BRMBRR ( NBLNMX ), BRMEXP ( NBLNMX ),
32294 C    &          BRMSIG ( NBLNMX ), SIGGTT ( KALGNM*NBLNMX ),
32295 C    &          COMSCO ( NBLNMX ), LBSTOR ( KALGNM*NBLNMX )
32296 C     REAL SIGGTT
32297 C     LOGICAL LBSTOR
32298 C     COMMON   NSTOR  ( KALGNM*NBLNMX )
32299 **
32300 **sr 18.5. commented since not used for evap.
32301 C     COMMON / ADDRCM / MBLNMX, KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST,
32302 C    &                  KISBGN, KISLST, KDTBGN, KDTLST, KUBBGN, KUBLST,
32303 C    &                  KUXBGN, KUXLST, KTCBGN, KTCLST, KRNBGN, KRNLST,
32304 C    &                  KYLBGN, KYLLST, KXSBGN, KXSLST, KIHBGN, KIHLST,
32305 C    &                  KINBGN, KINLST, KIEBGN, KIELST, KETBGN, KETLST,
32306 C    &                  KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32307 C    &                  KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST,
32308 C    &                  KWLBGN, KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST,
32309 C    &                  KWSBGN, KWSLST, KNDBGN, KNDLST, KDPBGN, KDPLST,
32310 C    &                  KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN, KBRLST,
32311 C    &                  KTMBGN
32312 **
32313
32314 C     EQUIVALENCE ( NSTOR (1), GMSTOR (1) )
32315 C     EQUIVALENCE ( NSTOR (1), BRMBRR (1) )
32316 C     EQUIVALENCE ( NSTOR (1), BRMEXP (1) )
32317 C     EQUIVALENCE ( NSTOR (1), BRMSIG (1) )
32318 C     EQUIVALENCE ( NSTOR (1), COMSCO (1) )
32319 C     EQUIVALENCE ( NSTOR (1), SIGGTT (1) )
32320 C     EQUIVALENCE ( NSTOR (1), LBSTOR (1) )
32321 C     INCLUDE '(BLNTMP)'
32322 * BLNTMP.ADD
32323 **sr 18.5. commented since not used for evap.
32324 C     COMMON / BLNTMP / KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM,
32325 C    &                  KGCBTM, KGDWTM, KBDWTM, KWLOTM, KWHITM, KWMUTM,
32326 C    &                  KWSHTM, KEXTTM, KSTXTM, KSTNTM, KECTTM, KPCTTM,
32327 C    &                  KLPBTM, NXXRGN
32328 **
32329 C     INCLUDE '(CMMDNR)'
32330 * CMMDNR.ADD
32331 **sr 18.5. commented since not used for evap.
32332 C     LOGICAL LFLDNR
32333 C     COMMON / CMMDNR / DDNEAR, LFLDNR
32334 **
32335 C     INCLUDE '(CTITLE)'
32336 * CTITLE.ADD
32337 **sr 18.5. commented since not used for evap.
32338 C     CHARACTER RUNTIT*80, RUNTIM*32, RUNKEY*10
32339 C     COMMON / CTITLE / RUNTIT, RUNTIM, RUNKEY
32340 C     COMMON / CEXPCK / ITEXPI, ITEXMX
32341 **
32342 C     INCLUDE '(DETECT)'
32343 * DETECT.ADD
32344 **sr 18.5. commented since not used for evap.
32345 C     PARAMETER (NRGNMX = 10)
32346 C     PARAMETER (NDTCMX = 10)
32347 C     PARAMETER (NSCRMX = 10)
32348 C     PARAMETER (NDTBIN = 1024)
32349 C     CHARACTER*10 TITDET,TITSCO
32350 C     LOGICAL LDTCTR
32351 C     COMMON /DETCT/  EDTMIN(NDTCMX), EDTBIN(NDTCMX), EDTCUT(NDTCMX),
32352 C    &                KDTREG(NRGNMX,NDTCMX), KDTDET(NDTCMX,NSCRMX),
32353 C    &                NDTSCO, NDTDET, LDTCTR, IDTREG(MXXRGN),
32354 C    &                KDTSCD(NSCRMX)
32355 C     COMMON /DETCH/  TITDET(NDTCMX), TITSCO(NSCRMX)
32356 **
32357 C     INCLUDE '(DETLOC)'
32358 * DETLOC.ADD
32359 **sr 18.5. commented since not used for evap.
32360 C     PARAMETER (NDTCM2 = 10)
32361 C     COMMON /DETLOC/ ACCUMP (NDTCM2), ACCUMN (NDTCM2),
32362 C    &                ICOINC(NDTCM2), NCLAS
32363 **
32364 C     INCLUDE '(EMGTRN)'
32365 * EMGTRN.ADD
32366 **sr 18.5. commented since not used for evap.
32367 C     LOGICAL LMCSMG
32368 C     COMMON / EMGTRN / UMCSMG, VMCSMG, WMCSMG, LMCSMG
32369 **
32370 C     INCLUDE '(EMSHO)'
32371 * EMSHO.ADD
32372 **sr 18.5. commented since not used for evap.
32373 C     LOGICAL EMFLO, EMFHLO, EMFELO, LIMPRE, LEXPTE
32374 C     COMMON /EMSHO/ EMFETH, EMFPTH, EMFHET, EMFHPT, EMFBIA, EMFLO,
32375 C    &               EMFHLO, EMFELO, LIMPRE, LEXPTE
32376 **
32377 C     INCLUDE '(EPISOR)'
32378 * EPISOR.ADD
32379 **sr 18.5. commented since not used for evap.
32380 C     LOGICAL LUSSRC
32381 C     COMMON/EPISOR/TKESUM,LUSSRC
32382 **
32383 * (original name: FHEAVY,FHEAVC)
32384       PARAMETER ( MXHEAV = 100 )
32385       CHARACTER*8 ANHEAV
32386       COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
32387      &                CZHEAV (MXHEAV), TKHEAV (MXHEAV),
32388      &                PHEAVY (MXHEAV), WHEAVY (MXHEAV),
32389      &                AMHEAV  ( 12 ) , AMNHEA  ( 12 ) ,
32390      &                KHEAVY (MXHEAV), ICHEAV  ( 12 ) ,
32391      &                IBHEAV  ( 12 ) , NPHEAV
32392       COMMON /FKFHVC/ ANHEAV  ( 12 )
32393 * (original name: FINUC)
32394       PARAMETER (MXP=999)
32395       COMMON /FKFINU/ CXR    (MXP), CYR    (MXP), CZR    (MXP),
32396      &                CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
32397      &                TKI    (MXP), PLR    (MXP), WEI    (MXP),
32398      &                TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
32399      &                KPART  (MXP)
32400 C     INCLUDE '(GENTHR)'
32401 * GENTHR.ADD
32402 **sr 18.5. commented since not used for evap.
32403 C     COMMON / GENTHR / PEANCT, PEAPIT, PLDNCT, PTHRSH (NALLWP),
32404 C    &                  PTHDFF (NALLWP), IJNUCR (NALLWP)
32405 **
32406 C     INCLUDE '(LOWNEU)'
32407 * LOWNEU.ADD
32408 **sr 18.5. commented since not used for evap.
32409 C     PARAMETER ( MXGTHN =  15 )
32410 C     PARAMETER ( MXGLWN = 200 )
32411 C     PARAMETER ( MXSHPP =   5 )
32412 C     LOGICAL LCOMPN, LIMPRN, LBIASN, LDOWNN, LRECPR, LLOWWW, LLOWET
32413 C     CHARACTER*10 TITLOW
32414 C     COMMON / LOWNEU / ATOLOW (MXXMDF), WSHPLN (MXGLWN,MXSHPP), EXTWWL,
32415 C    &                  SHPIMP (MXGLWN), EXTETL (MXGLWN), WWAMFL,
32416 C    &                  VLLNTH (MXGTHN,MXXMDF), ABLNTH (MXGTHN,MXXMDF),
32417 C    &                  STLNTH (MXGTHN,MXXMDF), TMRTLN (MXXMDF),
32418 C    &                  TMNMLN (MXXMDF), ICHCPT (MXXMDF),
32419 C    &                  IGTMRT (MXXMDF), NEUMED (MXXMDF),
32420 C    &                  ID1MED (MXXMDF), ID2MED (MXXMDF),
32421 C    &                  ID3MED (MXXMDF), MGTMED (MXXMDF),
32422 C    &                  LCOMPN (MXXMDF), LRECPR (MXXMDF), KPRLOW, NMGP,
32423 C    &                  NMTG  , IGRTHN, LIMPRN, LBIASN, LDOWNN, LLOWWW,
32424 C    &                  LLOWET, ICLMED, IKRBGN, INABGN, IDWBGN, IETBGN,
32425 C    &                  I0XSEC, IDXSEC, ISENAV, ISVELN, ISPNAV, IWWLWB,
32426 C    &                  IWWLWT, IPXBGN, NPXSEC
32427 C     COMMON / CHLWNT / TITLOW (MXXMDF)
32428 **
32429 C     INCLUDE '(LTCLCM)'
32430 * LTCLCM.ADD
32431 **sr 18.5. commented since not used for evap.
32432 C     COMMON / LTCLCM / MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1
32433 **
32434 C     INCLUDE '(MULBOU)'
32435 * MULBOU.ADD
32436 **sr 18.5. commented since not used for evap.
32437 C     LOGICAL LLDA  , LAGAIN, LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32438 C     COMMON / MULBOU / UOLD  , VOLD  , WOLD  , UMAG  , VMAG  , WMAG  ,
32439 C    &                  UNORML, VNORML, WNORML, USENSE, VSENSE, WSENSE,
32440 C    &                  TSENSE, DDSENS, DSMALL, NSSENS, LLDA  , LAGAIN,
32441 C    &                  LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32442 **
32443 C     INCLUDE '(MULHD)'
32444 * MULHD.ADD
32445 **sr 18.5. commented since not used for evap.
32446 C     PARAMETER ( MXXPT1 = 1 )
32447 C     PARAMETER ( TIMESS = 2.00D+00 )
32448 C     PARAMETER ( TMSRLX = 1.50D+00 )
32449 C     PARAMETER ( EPSINS = 0.15D+00 )
32450 C     PARAMETER ( EPSRLX = 0.50D+00 )
32451 C     PARAMETER ( SQEPSN = 0.3872983346207417 D+00 )
32452 C     PARAMETER ( SQEPSR = 0.7071067811865475 D+00 )
32453 C     PARAMETER ( PARNSI = 1.732050807568877 D+00 * SQEPSN )
32454 C     PARAMETER ( PRNSR0 = 1.732050807568877 D+00 * SQEPSR )
32455 C     PARAMETER ( R0NCMS = 1.20 D+00 )
32456 C     LOGICAL LTOPT, LSRCRH, LNSCRH
32457 C     COMMON / MULHD / BLCC   ( MXXMDF ), BLCCRA ( MXXMDF ),
32458 C    &                 XCC    ( MXXMDF ), ZTILDE ( MXXMDF, 0:MXXPT1 ),
32459 C    &                 ALPZTL ( MXXMDF, 0:MXXPT1 ), RLDU   ( MXXMDF ),
32460 C    &                 ALPZT2 ( MXXMDF, 0:MXXPT1 ), TEFF0  ( MXXMDF ),
32461 C    &                 XR0    ( MXXMDF ), ECUTM  ( MXXMDF, 39, 2 ),
32462 C    &                 ESTEPF ( MXXMDF ), HTHNSZ ( MXXMDF, 39 ),
32463 C    &                 AE1O3  ( MXXMDF ), PARNSR ( MXXMDF ),
32464 C    &                 HEESLI ( MXXMDF ), THMSPR, THMSSC, HMSAMP,
32465 C    &                 HMREJE, LSRCRH ( MXXMDF ), LNSCRH ( MXXMDF ),
32466 C    &                 LTOPT  ( MXXMDF ), NFSCAT
32467 **
32468 * (original name: PAREVT)
32469       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
32470      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
32471       PARAMETER ( NALLWP = 39   )
32472       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
32473      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
32474      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
32475      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
32476 * (original name: RESNUC)
32477       LOGICAL LRNFSS, LFRAGM
32478       COMMON /FKRESN/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
32479      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
32480      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
32481      &                  PYRES,  PZRES, PTRES2,  KTARP,  KTARN, IGREYP,
32482      &                 IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
32483      &                  ICRES,  IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
32484      &                 IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
32485      &                  IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
32486      &                 LFRAGM
32487 C     INCLUDE '(SCOHLP)'
32488 * SCOHLP.ADD
32489 **sr 18.5. commented since not used for evap.
32490 C     LOGICAL LSCZER
32491 C     COMMON / SCOHLP / ISCRNG, JSCRNG, LSCZER
32492 **
32493 C     INCLUDE '(TRACKR)'
32494 * TRACKR.ADD
32495 **sr 18.5. commented since not used for evap.
32496 C     PARAMETER ( MXTRCK = 2500 )
32497 C     LOGICAL LFSSSC
32498 C     COMMON / TRACKR /  XTRACK ( 0:MXTRCK ), YTRACK ( 0:MXTRCK ),
32499 C    &                   ZTRACK ( 0:MXTRCK ), TTRACK   ( MXTRCK ),
32500 C    &                   DTRACK   ( MXTRCK ), ETRACK, PTRACK, WTRACK,
32501 C    &                   ATRACK, CTRACK, AKSHRT, AKLONG, WSCRNG,
32502 C    &                   NTRACK, MTRACK, JTRACK, KTRACK, MMTRCK,
32503 C    &                   LT1TRK, LT2TRK, LTRACK, LLOUSE, LFSSSC
32504 **
32505 C     INCLUDE '(USRBDX)'
32506 * USRBDX.ADD
32507 **sr 18.5. commented since not used for evap.
32508 C     PARAMETER ( MXUSBX = 600 )
32509 C     LOGICAL LUSBDX, LFUSBX, LWUSBX, LLNUSX
32510 C     CHARACTER*10 TITUSX
32511 C     COMMON /USRBX/  EBXLOW(MXUSBX), EBXHGH(MXUSBX), ABXLOW(MXUSBX),
32512 C    &                ABXHGH(MXUSBX), DEBXBN(MXUSBX), DABXBN(MXUSBX),
32513 C    &                AUSBDX(MXUSBX),
32514 C    &                NEBXBN(MXUSBX), NABXBN(MXUSBX), NR1USX(MXUSBX),
32515 C    &                NR2USX(MXUSBX), ITUSBX(MXUSBX), IDUSBX(MXUSBX),
32516 C    &                KBUSBX(MXUSBX), IPUSBX(MXUSBX), IGMUSX(MXUSBX),
32517 C    &                LFUSBX(MXUSBX), LWUSBX(MXUSBX), LLNUSX(MXUSBX),
32518 C    &                NUSRBX, LUSBDX
32519 C     COMMON /USXCH/  TITUSX(MXUSBX)
32520 **
32521 C     INCLUDE '(USRBIN)'
32522 * USRBIN.ADD
32523 **sr 18.5. commented since not used for evap.
32524 C     PARAMETER ( MXUSBN = 100 )
32525 C     LOGICAL LUSBIN, LEVTBN, LNTZER, LUSEVT, LUSTKB, LTRKBN
32526 C     CHARACTER*10 TITUSB
32527 C     COMMON /USRBN/  XLOW  (MXUSBN), XHIGH (MXUSBN), YLOW  (MXUSBN),
32528 C    &                YHIGH (MXUSBN), ZLOW  (MXUSBN), ZHIGH (MXUSBN),
32529 C    &                DXUSBN(MXUSBN), DYUSBN(MXUSBN), DZUSBN(MXUSBN),
32530 C    &                TCUSBN(MXUSBN), BKUSBN(MXUSBN), B2USBN(MXUSBN),
32531 C    &                NXBIN (MXUSBN), NYBIN (MXUSBN), NZBIN (MXUSBN),
32532 C    &                ITUSBN(MXUSBN), IDUSBN(MXUSBN), KBUSBN(MXUSBN),
32533 C    &                IPUSBN(MXUSBN), LEVTBN(MXUSBN), LNTZER(MXUSBN),
32534 C    &                LTRKBN(MXUSBN), NUSRBN, LUSBIN, LUSEVT, LUSTKB
32535 C     COMMON /USRCH/  TITUSB(MXUSBN)
32536 **
32537 C     INCLUDE '(USRSNC)'
32538 * USRSNC.ADD
32539 **sr 18.5. commented since not used for evap.
32540 C     PARAMETER ( MXRSNC = 400 )
32541 C     PARAMETER ( NMZMIN =  -5 )
32542 C     LOGICAL LURSNC
32543 C     CHARACTER*10 TIURSN
32544 C     COMMON /USRSNC/  VURSNC(MXRSNC), IZRHGH(MXRSNC), IMRHGH(MXRSNC),
32545 C    &                 NRURSN(MXRSNC), ITURSN(MXRSNC), KBURSN(MXRSNC),
32546 C    &                 IPURSN(MXRSNC), NURSNC, LURSNC
32547 C     COMMON /USRSCH/  TIURSN(MXRSNC)
32548 C     INCLUDE '(USRTRC)'
32549 * USRTRC.ADD
32550 **sr 18.5. commented since not used for evap.
32551 C     PARAMETER ( MXUSTC = 400 )
32552 C     LOGICAL LUSRTC, LUSTRK, LUSCLL, LLNUTC
32553 C     CHARACTER*10 TITUTC
32554 C     COMMON /USRTC/  ETCLOW(MXUSTC), ETCHGH(MXUSTC), DETCBN(MXUSTC),
32555 C    &                VUSRTC(MXUSTC),
32556 C    &                IUSTRK(MXUSTC), IUSCLL(MXUSTC), NETCBN(MXUSTC),
32557 C    &                NRUSTC(MXUSTC), ITUSTC(MXUSTC), IDUSTC(MXUSTC),
32558 C    &                KBUSTC(MXUSTC), IPUSTC(MXUSTC), IGMUTC(MXUSTC),
32559 C    &                LLNUTC(MXUSTC), NUSRTC, NUSTRK, NUSCLL, LUSRTC,
32560 C    &                LUSTRK, LUSCLL
32561 C     COMMON /USTCH/  TITUTC(MXUSTC)
32562 **
32563 C     INCLUDE '(USRYLD)'
32564 * USRYLD.ADD
32565 **sr 18.5. commented since not used for evap.
32566 C     PARAMETER ( MXUSYL = 500 )
32567 C     LOGICAL LUSRYL, LLNUYL, LSCUYL
32568 C     CHARACTER*10 TITUYL
32569 C     COMMON /USRYL/  EYLLOW(MXUSYL), EYLHGH(MXUSYL), DEYLBN(MXUSYL),
32570 C    &                USNRYL(MXUSYL), SGUSYL(MXUSYL), AYLLOW(MXUSYL),
32571 C    &                AYLHGH(MXUSYL), PUSRYL, UUSRYL, VUSRYL, WUSRYL,
32572 C    &                ETXUYL, ETYUYL, ETZUYL, GAMUYL, SQSUYL, UCMUYL,
32573 C    &                VCMUYL, WCMUYL, IJUSYL, JTUSYL,
32574 C    &                NEYLBN(MXUSYL), NR1UYL(MXUSYL), NR2UYL(MXUSYL),
32575 C    &                IXUSYL(MXUSYL), ITUSYL(MXUSYL), IDUSYL(MXUSYL),
32576 C    &                KBUSYL(MXUSYL), IPUSYL(MXUSYL), IGMUYL(MXUSYL),
32577 C    &                IEUSYL(MXUSYL), IAUSYL(MXUSYL), LLNUYL(MXUSYL),
32578 C    &                NUSRYL, LUSRYL, LSCUYL
32579 C     COMMON /USYCH/  TITUYL(MXUSYL)
32580 **
32581 C     INCLUDE '(WWINDW)'
32582 * WWINDW.ADD
32583 **sr 18.5. commented since not used for evap.
32584 C     PARAMETER ( MXWWSP = 3 )
32585 C     PARAMETER ( WWSPMX = 50.D+00 )
32586 C     LOGICAL LWWNDW, LWWPRM
32587 C     COMMON / WWINDW / ETHWW1 (NALLWP), ETHWW2 (NALLWP),
32588 C    &                  WWEXWD (NALLWP), EXTWWN (NALLWP),
32589 C    &                  IWLBGN, IWHBGN, IWMBGN, LWWNDW, LWWPRM
32590 **
32591
32592 * /blnkcm/
32593 * *** If blank common dimension has to be superseded substitute in the
32594 * *** following two lines the new dimension in real*8 units to Nblnmx
32595 **sr 18.5. commented since not used for evap.
32596 C     PARAMETER (MXDUMM = KALGNM * NBLNMX)
32597 C     DATA KTMBGN / NBLNMX /
32598 C     DATA MBLNMX / MXDUMM /
32599 C     DATA KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST, KISBGN, KISLST,
32600 C    &     KDTBGN, KDTLST, KUBBGN, KUBLST, KUXBGN, KUXLST, KTCBGN,
32601 C    &     KTCLST, KRNBGN, KRNLST, KYLBGN, KYLLST, KXSBGN, KXSLST,
32602 C    &     KIHBGN, KIHLST, KINBGN, KINLST, KIEBGN, KIELST, KETBGN,
32603 C    &     KETLST, KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32604 C    &     KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST, KWLBGN,
32605 C    &     KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST, KWSBGN, KWSLST,
32606 C    &     KDPBGN, KDPLST, KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN,
32607 C    &     KBRLST / 57*0 /
32608
32609 * /blntmp/
32610 **sr 18.5. commented since not used for evap.
32611 C     DATA KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM, KGDWTM,
32612 C    &     KBDWTM, KGCBTM, KWLOTM, KWHITM, KWMUTM, KWSHTM, KEXTTM,
32613 C    &     KSTXTM, KSTNTM, KECTTM, KPCTTM, KLPBTM / 19*0 /
32614
32615 * /cmmdnr/
32616 **sr 18.5. commented since not used for evap.
32617 C     DATA DDNEAR / 0.D+00 /, LFLDNR / .FALSE. /
32618
32619 * /ctitle/
32620 **sr 18.5. commented since not used for evap.
32621 C     DATA RUNTIT (1:40) / '****************************************' /
32622 C     DATA RUNTIT(41:80) / '****************************************' /
32623 C     DATA ITEXPI, ITEXMX / 100000000, 150 /
32624 * /detect/
32625 **sr 18.5. commented since not used for evap.
32626 C     PARAMETER (NNN1 = NRGNMX*NDTCMX)
32627 C     PARAMETER (NNN2 = NSCRMX*NDTCMX)
32628 C     DATA LDTCTR /.FALSE./, NDTSCO /0/, NDTDET /0/
32629 C     DATA EDTMIN/NDTCMX*0.D0/, EDTBIN/NDTCMX*0.D0/, EDTCUT/NDTCMX*0.D0/
32630 C     DATA KDTREG/NNN1*0/, KDTDET/NNN2*0/, KDTSCD/NSCRMX*0/
32631 C     DATA TITDET/NDTCMX*'          '/, TITSCO/NSCRMX*'          '/
32632
32633 * /detloc/
32634 **sr 18.5. commented since not used for evap.
32635 C     DATA ACCUMP /NDTCM2*0.D0/, ACCUMN /NDTCM2*0.D0/, ICOINC /NDTCM2*0/
32636 C     DATA NCLAS /0/
32637
32638 * /emgtrn/
32639 **sr 18.5. commented since not used for evap.
32640 C     DATA LMCSMG / .FALSE. /
32641
32642 * /emsho/
32643 **sr 18.5. commented since not used for evap.
32644 C     DATA LIMPRE, LEXPTE / 2 * .FALSE. /
32645
32646 * /episor/
32647 **sr 18.5. commented since not used for evap.
32648 C     DATA TKESUM / 0.D+00 /, LUSSRC / .FALSE. /
32649
32650 * /fheavy/
32651       DATA AMHEAV / 12 * 0.D+00 /
32652       DATA ANHEAV / 'NEUTRON ', 'PROTON  ', 'DEUTERON', '3-H     ',
32653      &              '3-He    ', '4-He    ', 'H-FRAG-1', 'H-FRAG-2',
32654      &              'H-FRAG-3', 'H-FRAG-4', 'H-FRAG-5', 'H-FRAG-6'/
32655       DATA ICHEAV / 0, 1, 1, 1, 2, 2, 6*0 /,
32656      &     IBHEAV / 1, 1, 2, 3, 3, 4, 6*0 /
32657       DATA NPHEAV / 0 /
32658
32659 * /finuc/
32660       DATA NP / 0 /, TV / 0.D+00 /, TVCMS / 0.D+00 /, TVRECL / 0.D+00/,
32661      &     TVHEAV / 0.D+00 /, TVBIND / 0.D+00 /
32662
32663 * /genthr/
32664 * Up to 20-apr-'95
32665 *     DATA PEANCT, PEAPIT / 2*1.D+00 /
32666 *     DATA PTHRSH / 16*5.D+00,2*2.5D+00,5.D+00,3*2.5D+00,8*5.D+00,
32667 *    &              9*2.5D+00 /
32668 *     DATA PTHDFF / 39*5.D+00 /
32669 *    &              9*2.5D+00 /
32670 * New values:
32671 **sr 18.5. commented since not used for evap.
32672 C     DATA PEANCT, PEAPIT / 1.3D+00, 1.1D+00 /
32673 C     DATA PTHRSH / 12*5.D+00, 2*3.5D+00, 2*5.D+00, 2*2.5D+00, 5.D+00,
32674 C    &              3*2.5D+00, 3.5D+00, 2*5.D+00, 3.5D+00, 4*5.D+00,
32675 C    &              9*2.5D+00 /
32676 C     DATA PTHDFF / 12*5.D+00, 2*3.5D+00, 8*5.D+00, 3.5D+00, 2*5.D+00,
32677 C    &              3.5D+00, 13*5.D+00 /
32678 C     DATA PLDNCT / 0.26D+00 /
32679 C     DATA IJNUCR / 16*1, 2*0, 1, 3*0, 8*1, 9*0 /
32680
32681 * /lowneu/
32682 **sr 18.5. commented since not used for evap.
32683 C     DATA WWAMFL / 10.D+00 /, EXTWWL / 1.D+00 /
32684 C     DATA IWWLWB, IWWLWT / 2 * 100000000 /
32685 C     DATA ICLMED, INABGN, IDWBGN, IETBGN / 4*0 /
32686 C     DATA IGRTHN / 1 /
32687 C     DATA LIMPRN / .FALSE. /, LBIASN / .FALSE. /, LDOWNN / .FALSE. /,
32688 C    &     LLOWWW / .FALSE. /, LLOWET / .FALSE. /
32689
32690 * /ltclcm/
32691 **sr 18.5. commented since not used for evap.
32692 C     DATA MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1 / 6*0 /
32693
32694 * /mulbou/
32695 **sr 18.5. commented since not used for evap.
32696 C     DATA LLDA, LAGAIN, LSTNEW, LARTEF, LSENSE, LNORML, LMGNOR
32697 C    &     / 7 * .FALSE. /
32698 C     DATA TSENSE / AINFNT /, NSSENS / -1 /
32699 C     DATA DSMALL / ANGLGB /
32700
32701 * /mulhd/
32702 **sr 18.5. commented since not used for evap.
32703 C     DATA LTOPT  / MXXMDF * .FALSE. /, NFSCAT / 0 /
32704 C     DATA ESTEPF / MXXMDF * 0.1D+00 /
32705 C     DATA LSRCRH / MXXMDF * .FALSE. /, LNSCRH / MXXMDF * .FALSE. /
32706 C     DATA THMSPR / 0.02D+00 /, THMSSC / 1.D+00 /
32707
32708 * /parevt/
32709       DATA DPOWER /-13.D+00 /, FSPRD0 / 0.6D+00 /, FSHPFN / 0.0D+00 /,
32710      &     RN1GSC /-1.0D+00 /, RN2GSC /-1.0D+00 /
32711       DATA LDIFFR /  .TRUE., .TRUE., 6 * .TRUE., .TRUE., 8 * .TRUE.,
32712      &               .TRUE., 4 * .TRUE., .TRUE., 3 * .TRUE.,
32713      &              4 * .FALSE., 9 * .TRUE./
32714 **sr 17.5.95
32715 * default value for LEVPRT changed (reset sr 25.7.97)
32716 * default value for LHEAVY changed 25.7.97
32717 C     DATA LPOWER / .TRUE.  /, LINCTV / .TRUE.  /, LEVPRT / .TRUE.  /,
32718 C    &     LHEAVY / .FALSE. /, LDEEXG / .TRUE.  /, LGDHPR / .TRUE.  /,
32719 C    &     LPREEX / .TRUE.  /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32720 C    &     LPARWV / .TRUE.  /, LSNGCH / .TRUE.  /, LSCHDF / .TRUE.  /
32721       DATA LPOWER / .TRUE.  /, LINCTV / .TRUE.  /, LEVPRT / .TRUE.  /,
32722      &     LHEAVY / .TRUE.  /, LDEEXG / .TRUE.  /, LGDHPR / .TRUE.  /,
32723      &     LPREEX / .TRUE.  /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32724      &     LPARWV / .TRUE.  /, LSNGCH / .TRUE.  /, LSCHDF / .TRUE.  /
32725 **
32726 **sr 27.5.97
32727 * default value for ILVMOD changed
32728 C     DATA ILVMOD / 0 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32729       DATA ILVMOD / 1 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32730 **
32731
32732 * /resnuc/
32733       DATA IPREEH / 0 /, IPRTRI / 0 /, IPRDEU / 0 /, IPR3HE / 0 /,
32734      &     IPR4HE / 0 /
32735       DATA IEVAPL / 0 /, IEVAPH / 0 /, IEVNEU / 0 /, IEVPRO / 0 /,
32736      &     IEVTRI / 0 /, IEVDEU / 0 /, IEV3HE / 0 /, IEV4HE / 0 /,
32737      &     IDEEXG / 0 /
32738       DATA LRNFSS / .FALSE. /
32739
32740 * /scohlp/
32741 **sr 18.5. commented since not used for evap.
32742 C     DATA ISCRNG, JSCRNG / 2*0 /, LSCZER / .FALSE. /
32743
32744 * /trackr/
32745 **sr 18.5. commented since not used for evap.
32746 C     DATA ETRACK /0.D+00/, WTRACK /0.D+00/, ATRACK /0.D+00/,
32747 C    &     CTRACK /0.D+00/, NTRACK /0/, MTRACK /0/, JTRACK /0/
32748
32749 * /usrbin/
32750 **sr 18.5. commented since not used for evap.
32751 C     DATA LUSBIN, LUSEVT, LUSTKB /3*.FALSE./, NUSRBN /0/
32752
32753 * /usrbdx/
32754 **sr 18.5. commented since not used for evap.
32755 C     DATA LUSBDX /.FALSE./, NUSRBX /0/
32756
32757 * /usrsnc/
32758 **sr 18.5. commented since not used for evap.
32759 C     DATA LURSNC /.FALSE./, NURSNC /0/
32760
32761 * /usrtrc/
32762 **sr 18.5. commented since not used for evap.
32763 C     DATA LUSRTC, LUSTRK, LUSCLL / 3*.FALSE. /
32764 C     DATA NUSRTC, NUSTRK, NUSCLL / 3*0 /
32765
32766 * /usryld/
32767 **sr 18.5. commented since not used for evap.
32768 C     DATA LUSRYL / .FALSE./, LSCUYL / .FALSE. /, NUSRYL /0/,
32769 C    &     IJUSYL /0/, JTUSYL /0/
32770 C     DATA PUSRYL, UUSRYL, VUSRYL, WUSRYL / 4*ZERZER /
32771
32772 * /wwindw/
32773 **sr 18.5. commented since not used for evap.
32774 C     DATA IWLBGN, IWHBGN, IWMBGN / 3*0 /
32775 C     DATA LWWPRM / .TRUE. /
32776
32777 *=                                               end*block.bdnopt      *
32778       END
32779
32780 *$ CREATE DT_BDPREE.FOR
32781 *COPY DT_BDPREE
32782 *
32783 *=== bdpree ===========================================================*
32784 *
32785       BLOCK DATA DT_BDPREE
32786
32787 C     INCLUDE '(DBLPRC)'
32788 * DBLPRC.ADD
32789       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32790       SAVE
32791 * (original name: GLOBAL)
32792       PARAMETER ( KALGNM = 2 )
32793       PARAMETER ( ANGLGB = 5.0D-16 )
32794       PARAMETER ( ANGLSQ = 2.5D-31 )
32795       PARAMETER ( AXCSSV = 0.2D+16 )
32796       PARAMETER ( ANDRFL = 1.0D-38 )
32797       PARAMETER ( AVRFLW = 1.0D+38 )
32798       PARAMETER ( AINFNT = 1.0D+30 )
32799       PARAMETER ( AZRZRZ = 1.0D-30 )
32800       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32801       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32802       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32803       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32804       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
32805       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
32806       PARAMETER ( CSNNRM = 2.0D-15 )
32807       PARAMETER ( DMXTRN = 1.0D+08 )
32808       PARAMETER ( ZERZER = 0.D+00 )
32809       PARAMETER ( ONEONE = 1.D+00 )
32810       PARAMETER ( TWOTWO = 2.D+00 )
32811       PARAMETER ( THRTHR = 3.D+00 )
32812       PARAMETER ( FOUFOU = 4.D+00 )
32813       PARAMETER ( FIVFIV = 5.D+00 )
32814       PARAMETER ( SIXSIX = 6.D+00 )
32815       PARAMETER ( SEVSEV = 7.D+00 )
32816       PARAMETER ( EIGEIG = 8.D+00 )
32817       PARAMETER ( ANINEN = 9.D+00 )
32818       PARAMETER ( TENTEN = 10.D+00 )
32819       PARAMETER ( HLFHLF = 0.5D+00 )
32820       PARAMETER ( ONETHI = ONEONE / THRTHR )
32821       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32822       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32823       PARAMETER ( THRTWO = THRTHR / TWOTWO )
32824       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32825       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32826       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32827       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32828       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32829       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32830       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32831       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
32832       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
32833       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
32834       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
32835       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32836       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32837       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32838       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32839       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32840       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32841       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32842       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32843       PARAMETER ( CLIGHT = 2.99792458         D+10 )
32844       PARAMETER ( AVOGAD = 6.0221367          D+23 )
32845       PARAMETER ( BOLTZM = 1.380658           D-23 )
32846       PARAMETER ( AMELGR = 9.1093897          D-28 )
32847       PARAMETER ( PLCKBR = 1.05457266         D-27 )
32848       PARAMETER ( ELCCGS = 4.8032068          D-10 )
32849       PARAMETER ( ELCMKS = 1.60217733         D-19 )
32850       PARAMETER ( AMUGRM = 1.6605402          D-24 )
32851       PARAMETER ( AMMUMU = 0.113428913        D+00 )
32852       PARAMETER ( AMPRMU = 1.007276470        D+00 )
32853       PARAMETER ( AMNEMU = 1.008664904        D+00 )
32854       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32855       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32856       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32857       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32858       PARAMETER ( PLABRC = 0.197327053        D+00 )
32859       PARAMETER ( AMELCT = 0.51099906         D-03 )
32860       PARAMETER ( AMUGEV = 0.93149432         D+00 )
32861       PARAMETER ( AMMUON = 0.105658389        D+00 )
32862       PARAMETER ( AMPRTN = 0.93827231         D+00 )
32863       PARAMETER ( AMNTRN = 0.93956563         D+00 )
32864       PARAMETER ( AMDEUT = 1.87561339         D+00 )
32865       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32866      &                   * 1.D-09 )
32867       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32868       PARAMETER ( BLTZMN = 8.617385           D-14 )
32869       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32870       PARAMETER ( GFOHB3 = 1.16639            D-05 )
32871       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32872       PARAMETER ( SIN2TW = 0.2319             D+00 )
32873       PARAMETER ( GEVMEV = 1.0                D+03 )
32874       PARAMETER ( EMVGEV = 1.0                D-03 )
32875       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
32876       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32877       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32878       LOGICAL LGBIAS, LGBANA
32879       COMMON /FKGLOB/ LGBIAS, LGBANA
32880 C     INCLUDE '(DIMPAR)'
32881 * DIMPAR.ADD
32882       PARAMETER ( MXXRGN = 5000 )
32883       PARAMETER ( MXXMDF = 82   )
32884       PARAMETER ( MXXMDE = 54   )
32885       PARAMETER ( MFSTCK = 1000 )
32886       PARAMETER ( MESTCK = 100  )
32887       PARAMETER ( NALLWP = 39   )
32888       PARAMETER ( NELEMX = 80   )
32889       PARAMETER ( MPDPDX = 8    )
32890       PARAMETER ( ICOMAX = 180  )
32891       PARAMETER ( NSTBIS = 304  )
32892       PARAMETER ( IDMAXP = 220  )
32893       PARAMETER ( IDMXDC = 640  )
32894       PARAMETER ( MKBMX1 = 1    )
32895       PARAMETER ( MKBMX2 = 1    )
32896 C     INCLUDE '(IOUNIT)'
32897 * IOUNIT.ADD
32898       PARAMETER ( LUNIN  =  5 )
32899       PARAMETER ( LUNOUT =  6 )
32900 **sr 19.5. set error output-unit from 15 to 6
32901       PARAMETER ( LUNERR = 6  )
32902       PARAMETER ( LUNBER = 14 )
32903       PARAMETER ( LUNECH =  8 )
32904       PARAMETER ( LUNFLU = 13 )
32905       PARAMETER ( LUNGEO = 16 )
32906       PARAMETER ( LUNPMF = 12 )
32907       PARAMETER ( LUNRAN =  2 )
32908       PARAMETER ( LUNXSC =  9 )
32909       PARAMETER ( LUNDET = 17 )
32910       PARAMETER ( LUNRAY = 10 )
32911       PARAMETER ( LUNRDB =  1 )
32912       PARAMETER ( LUNPGO =  7 )
32913       PARAMETER ( LUNPGS =  4 )
32914       PARAMETER ( LUNSCR =  3 )
32915 *
32916 *----------------------------------------------------------------------*
32917 *                                                                      *
32918 *     Created on 16 september 1991 by    Alfredo Ferrari & Paola Sala  *
32919 *                                                   Infn - Milan       *
32920 *                                                                      *
32921 *     Last change on 03-feb-94     by    Alfredo Ferrari               *
32922 *                                                                      *
32923 *                                                                      *
32924 *----------------------------------------------------------------------*
32925 *
32926 * (original name: CMPISG,CHPISG)
32927       PARAMETER ( TPPPI0 = 0.279656044337515D+00 )
32928       PARAMETER ( TNNPI0 = 0.279642680857450D+00 )
32929       PARAMETER ( TPPPIP = 0.292295207182790D+00 )
32930       PARAMETER ( TPPDEP = 0.287514778898469D+00 )
32931       PARAMETER ( TNNPIM = 0.286723140900975D+00 )
32932       PARAMETER ( TNNDEM = 0.281949292916434D+00 )
32933       PARAMETER ( TPNPI0 = 0.279456888147740D+00 )
32934       PARAMETER ( TPNDE0 = 0.274693916135245D+00 )
32935       PARAMETER ( TPNPIP = 0.292086756473890D+00 )
32936       PARAMETER ( TNPPI0 = 0.279842093144975D+00 )
32937       PARAMETER ( TNPDE0 = 0.275072555824202D+00 )
32938       PARAMETER ( TNPPIP = 0.292489370554958D+00 )
32939       PARAMETER ( PIRSMX = 1.2D+00 )
32940       PARAMETER ( NPIREA = 10 )
32941       PARAMETER ( NPIRTA = 68 )
32942       PARAMETER ( NPIRLN = 21 )
32943       PARAMETER ( NPIRLG = NPIRTA - NPIRLN )
32944       PARAMETER ( NPISIS = NPIRLN + 20 )
32945       PARAMETER ( NPISEX = NPIRLN + 21 )
32946       PARAMETER ( NPIIMN = 14 )
32947       PARAMETER ( NPIIRC =  6 )
32948       PARAMETER ( DELWLL = 0.035D+00 )
32949       CHARACTER CHPIRE*8
32950       LOGICAL LDLRES
32951       COMMON /FKCMPI/ PMNPIS, PMMPIS, PISPIS, PEXPIS, PMXPIS, DPPISG,
32952      &                RTPISG, AMNPIS, AMMPIS, AISPIS, AEXPIS, AMXPIS,
32953      &                ARPISG, BPISLO (NPIRLN:NPIRTA,NPIREA),
32954      &                CPISLO (NPIRLN:NPIRTA,NPIREA), PPITHR (NPIREA),
32955      &                SPISLO (NPIRLN:NPIRTA,NPIREA), APITHR (NPIREA),
32956      &                SGPIIN (NPIIMN:NPIRTA,NPIIRC), RHPICR (1:5)   ,
32957      &                SGPICU (0:20,NPIRTA,NPIREA)  , SGRTRS (NPIREA),
32958      &                SGPIDF (0:20,NPIRTA,NPIREA)  , BRREIN (NPIREA),
32959      &                SGPIIS (NPIRTA,NPIREA)       , BRREOU (NPIREA),
32960      &                BRD3OU (2,2,-1:2), BRDEOU (2,-1:2),
32961      &                SGABSR (2,2,4)   , PRRSDL,
32962      &                IPIREA (2,2,3:5) , IPIINE (2,3:5)    , NPIRVR ,
32963      &                KPIIRE (2,NPIREA), KPIORE (2,NPIREA) ,
32964      &                JSTOKP (5), KPTOJS (23), ITTRRS (3:5), LDLRES
32965       COMMON /FKCHPI/ CHPIRE (NPIREA)
32966       DIMENSION SG2BRS (2,2), SGABSW (2,2), SG3BRS (2,2,2)
32967       EQUIVALENCE ( SG2BRS   (1,1), SGABSR (1,1,1) )
32968       EQUIVALENCE ( SGABSW   (1,1), SGABSR (1,1,2) )
32969       EQUIVALENCE ( SG3BRS (1,1,1), SGABSR (1,1,3) )
32970 * (original name: FRBKCM)
32971       PARAMETER ( MXFFBK =     6 )
32972       PARAMETER ( MXZFBK =     9 )
32973       PARAMETER ( MXNFBK =    10 )
32974       PARAMETER ( MXAFBK =    16 )
32975       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
32976       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
32977       PARAMETER ( NXAFBK = MXAFBK + 1 )
32978       PARAMETER ( MXPSST =   300 )
32979       PARAMETER ( MXPSFB = 41000 )
32980       LOGICAL LFRMBK, LNCMSS
32981       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
32982      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
32983      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
32984      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
32985      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
32986      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
32987      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
32988      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
32989      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
32990 * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
32991       PARAMETER ( PI     = PIPIPI )
32992       PARAMETER ( PISQ   = PIPISQ )
32993       PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
32994       PARAMETER ( RZNUCL = 1.12        D+00 )
32995       PARAMETER ( RMSPRO = 0.8         D+00 )
32996       PARAMETER ( R0PROT = RMSPRO / SQRT12  )
32997       PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
32998      &          / R0PROT )
32999       PARAMETER ( RLLE04 = RZNUCL )
33000       PARAMETER ( RLLE16 = RZNUCL )
33001       PARAMETER ( RLGT16 = RZNUCL )
33002       PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
33003       PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
33004       PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
33005       PARAMETER ( SKLE04 = 1.4D+00 )
33006       PARAMETER ( SKLE16 = 1.9D+00 )
33007       PARAMETER ( SKGT16 = 2.4D+00 )
33008       PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
33009       PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
33010       PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
33011       PARAMETER ( ALPHA0 = 0.1D+00 )
33012       PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
33013       PARAMETER ( GAMSK0 = 0.9D+00 )
33014       PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
33015       PARAMETER ( POTME0 = 0.6666666666666667D+00 )
33016       PARAMETER ( POTBA0 = 1.D+00 )
33017       PARAMETER ( PNFRAT = 1.533D+00 )
33018       PARAMETER ( RADPIM = 0.035D+00 )
33019       PARAMETER ( RDPMHL = 14.D+00   )
33020       PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
33021       PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
33022       PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
33023       PARAMETER ( AP0PFS = 0.5D+00 )
33024       PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
33025       PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
33026       PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
33027       PARAMETER ( MXSCIN = 50     )
33028       LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
33029      &        LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
33030       COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
33031      &                RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
33032      &                SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
33033      &                CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
33034      &                PFRTAB (2:260)
33035       COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
33036      &                ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
33037      &                RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
33038      &                YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
33039      &                RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
33040      &                PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
33041      &                PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
33042      &                BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
33043      &                YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
33044      &                XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
33045      &                SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
33046      &                R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
33047      &                PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
33048      &                EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
33049      &                PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
33050      &                EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
33051      &                PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
33052      &                BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
33053       COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
33054      &                RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
33055      &                EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
33056      &                BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
33057      &                WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
33058      &                POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
33059      &                BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
33060      &                SIGPAB (3), SIGNAB (3), HHLP   (2), FORTOT (2),
33061      &                FPNBLC, DPNBLC, FFTFLG, IFTFLG,
33062      &                IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
33063      &                KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
33064      &                NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
33065      &                IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
33066      &                LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
33067       COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
33068       COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
33069      &                YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
33070      &                AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
33071      &                NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
33072      &                NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
33073      &                ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
33074      &                LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
33075      &                LNCDCY, LNUSCT
33076       DIMENSION AWSTAB (2:260), SIGMAB (3)
33077       EQUIVALENCE ( DEFPRO, DEFNUC (1) )
33078       EQUIVALENCE ( DEFNEU, DEFNUC (2) )
33079       EQUIVALENCE ( RHOIPP, RHONCP (1) )
33080       EQUIVALENCE ( RHOINP, RHONCP (2) )
33081       EQUIVALENCE ( RHOIP2, RHONC2 (1) )
33082       EQUIVALENCE ( RHOIN2, RHONC2 (2) )
33083       EQUIVALENCE ( RHOIP3, RHONC3 (1) )
33084       EQUIVALENCE ( RHOIN3, RHONC3 (2) )
33085       EQUIVALENCE ( RHOIPT, RHONCT (1) )
33086       EQUIVALENCE ( RHOINT, RHONCT (2) )
33087       EQUIVALENCE ( OMALHL, SK3PAR )
33088       EQUIVALENCE ( ALPHAL, HABPAR )
33089       EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
33090       EQUIVALENCE ( SIGMPE, SIGMPR (1) )
33091       EQUIVALENCE ( SIGMPC, SIGMPR (2) )
33092       EQUIVALENCE ( SIGMPI, SIGMPR (3) )
33093       EQUIVALENCE ( SIGMPA, SIGMPR (4) )
33094       EQUIVALENCE ( SIGMNE, SIGMNU (1) )
33095       EQUIVALENCE ( SIGMNC, SIGMNU (2) )
33096       EQUIVALENCE ( SIGMNI, SIGMNU (3) )
33097       EQUIVALENCE ( SIGMNA, SIGMNU (4) )
33098       EQUIVALENCE ( SIGMA2, SIGPAB (1) )
33099       EQUIVALENCE ( SIGMA3, SIGPAB (2) )
33100       EQUIVALENCE ( SIGMAS, SIGPAB (3) )
33101       EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
33102 * (original name: NUCLEV)
33103       LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
33104       COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
33105      &                DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
33106      &                CUMRAD (0:160,2), RUSNUC (2),
33107      &                ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
33108      &                NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
33109      &                NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
33110      &                JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
33111      &                MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
33112      &                NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
33113      &                LFLVSL, LRLVSL, LEQSBL
33114       DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
33115      &          MGSSPR (19) , MGSSNE (25)
33116       EQUIVALENCE ( RUSNUC (1), RUSPRO )
33117       EQUIVALENCE ( RUSNUC (2), RUSNEU )
33118       EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
33119       EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
33120       EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
33121       EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
33122       EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
33123       EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
33124       EQUIVALENCE ( NTANUC (1), NTAPRO )
33125       EQUIVALENCE ( NTANUC (2), NTANEU )
33126       EQUIVALENCE ( NAVNUC (1), NAVPRO )
33127       EQUIVALENCE ( NAVNUC (2), NAVNEU )
33128       EQUIVALENCE ( NLSNUC (1), NLSPRO )
33129       EQUIVALENCE ( NLSNUC (2), NLSNEU )
33130       EQUIVALENCE ( NCONUC (1), NCOPRO )
33131       EQUIVALENCE ( NCONUC (2), NCONEU )
33132       EQUIVALENCE ( NSKNUC (1), NSKPRO )
33133       EQUIVALENCE ( NSKNUC (2), NSKNEU )
33134       EQUIVALENCE ( NHANUC (1), NHAPRO )
33135       EQUIVALENCE ( NHANUC (2), NHANEU )
33136       EQUIVALENCE ( NUSNUC (1), NUSPRO )
33137       EQUIVALENCE ( NUSNUC (2), NUSNEU )
33138       EQUIVALENCE ( NACNUC (1), NACPRO )
33139       EQUIVALENCE ( NACNUC (2), NACNEU )
33140       EQUIVALENCE ( JMXNUC (1), JMXPRO )
33141       EQUIVALENCE ( JMXNUC (2), JMXNEU )
33142       EQUIVALENCE ( MAGNUC (1), MAGPRO )
33143       EQUIVALENCE ( MAGNUC (2), MAGNEU )
33144 * (original name: PARNUC)
33145       PARAMETER ( PIGRK  = PIPIPI )
33146       PARAMETER ( ALEVEL = 8.D-03 )
33147       PARAMETER ( RCNUCL = 1.12D+00 )
33148       PARAMETER ( R0SIG  = 1.3D+00 )
33149       PARAMETER ( R0SIGK = 1.5D+00 )
33150       PARAMETER ( RCOULB = 1.5D+00 )
33151       PARAMETER ( COULBH = 0.88235D-03 )
33152       PARAMETER ( RHONU0 = 0.75D+00 / PIGRK / RCNUCL / RCNUCL / RCNUCL )
33153       PARAMETER ( TAUFO0 = 10.0D+00 )
33154       PARAMETER ( EKEEXP = 0.03D+00 )
33155       PARAMETER ( EKREXP = 0.05D+00 )
33156       PARAMETER ( EKEMNM = 0.01D+00 )
33157       PARAMETER ( NCPMX = 120 )
33158       COMMON /FKPARN/ EKORI , PXORI , PYORI , PZORI , PTORI , TAUFOR,
33159      &                ENNUC  (NCPMX), PNUCL  (NCPMX), EKFNUC (NCPMX),
33160      &                XSTNUC (NCPMX), YSTNUC (NCPMX), ZSTNUC (NCPMX),
33161      &                PXNUCL (NCPMX), PYNUCL (NCPMX), PZNUCL (NCPMX),
33162      &                RSTNUC (NCPMX), FREEPA (NCPMX), CRRPAN (NCPMX),
33163      &                CRRPAP (NCPMX), BSTNUC (NCPMX), AGENUC (NCPMX),
33164      &                TAUFPA (NCPMX), RHNUCL(NCPMX,2), BNDGAV, DEFMIN,
33165      &                KPNUCL (NCPMX), KRFNUC (NCPMX), ILINUC (NCPMX),
33166      &                INUCTS (NCPMX), ISFNUC (NCPMX), KPORI , IBORI ,
33167      &                IBNUCL, NPNUC , NNUCTS
33168 *
33169       DATA LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH / 6*.FALSE. /
33170       DATA POTBAR / POTBA0 /, POTMES / POTME0 /, WLLRES / 0.D+00 /
33171       DATA JUSNUC / 320 * 0 /, INUCLV / 1 /, IEVPRE / 0 /
33172       DATA MAGNUM / 2, 8, 20, 28, 50, 82, 126, 160 /
33173       DATA LPREEQ / .FALSE. /
33174 * /cmpisg/
33175       DATA JSTOKP / 1, 8, 13, 14, 23 /
33176       DATA KPTOJS / 1, 6*0, 2, 4*0, 3, 4, 8*0, 5 /
33177       DATA CHPIRE / 'PI+PPI+P','PI-PPI-P','PI-PPI0N','PI0PPI0P',
33178      &              'PI0PPI+N','PI-NPI-N','PI+NPI+N','PI+NPI0P',
33179      &              'PI0NPI0N','PI0NPI-P' /
33180       DATA KPIIRE / 13, 1, 14, 1, 14, 1, 23, 1, 23, 1, 14, 8,
33181      &              13, 8, 13, 8, 23, 8, 23, 8 /
33182       DATA KPIORE / 13, 1, 14, 1, 23, 8, 23, 1, 13, 8, 14, 8,
33183      &              13, 8, 23, 1, 23, 8, 14, 1 /
33184       DATA IPIREA / 1, 0, 7, 8, 2, 3, 6, 0, 4, 5, 9, 10 /
33185       DATA IPIINE / 1, 2, 3, 4, 5, 6 /
33186 * /frbkcm/
33187       DATA LFRMBK / .FALSE. /
33188       DATA NBUFBK /   500  /
33189       DATA EXMXFB / 80.0 D+00 /
33190       DATA R0FRBK / 1.18 D+00 /
33191       DATA R0CFBK / 2.173D+00 /
33192       DATA C1CFBK / 6.103D-03 /
33193       DATA C2CFBK / 9.443D-03 /
33194 * /parnuc/
33195       DATA TAUFOR / TAUFO0 /
33196 *=== End of Block Data Bdpree =========================================*
33197       END
33198
33199 *$ CREATE DT_XHOINI.FOR
33200 *COPY DT_XHOINI
33201 *
33202 *====phoini============================================================*
33203 *
33204       SUBROUTINE DT_XHOINI
33205 C     SUBROUTINE DT_PHOINI
33206
33207       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33208       SAVE
33209       PARAMETER ( LINP = 10 ,
33210      &            LOUT = 6 ,
33211      &            LDAT = 9 )
33212
33213       RETURN
33214       END
33215
33216 *$ CREATE DT_XVENTB.FOR
33217 *COPY DT_XVENTB
33218 *
33219 *====eventb============================================================*
33220 *
33221       SUBROUTINE DT_XVENTB(NCSY,IREJ)
33222 C     SUBROUTINE DT_EVENTB(NCSY,IREJ)
33223
33224       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33225       SAVE
33226       PARAMETER ( LINP = 10 ,
33227      &            LOUT = 6 ,
33228      &            LDAT = 9 )
33229
33230       WRITE(LOUT,1000)
33231  1000 FORMAT(1X,'EVENTB:   PHOJET-package requested but not linked!')
33232       STOP
33233
33234       END
33235
33236 *$ CREATE DT_XVENT.FOR
33237 *COPY DT_XVENT
33238 *
33239 *===event==============================================================*
33240 *
33241       SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
33242 C     SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
33243
33244       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33245       SAVE
33246
33247       DIMENSION PP(4),PT(4)
33248
33249       RETURN
33250       END
33251
33252 *$ CREATE DT_XOHISX.FOR
33253 *COPY DT_XOHISX
33254 *
33255 *===pohisx=============================================================*
33256 *
33257       SUBROUTINE DT_XOHISX(I,X)
33258 C     SUBROUTINE POHISX(I,X)
33259
33260       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33261       SAVE
33262
33263       RETURN
33264       END
33265
33266 *$ CREATE PHO_LHIST.FOR
33267 *COPY PHO_LHIST
33268 *
33269 *===poluhi=============================================================*
33270 *
33271       SUBROUTINE PHO_LHIST(I,X)
33272 **
33273
33274       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33275       SAVE
33276
33277       RETURN
33278       END
33279
33280 *$ CREATE PDFSET.FOR
33281 *COPY PDFSET
33282 *
33283 C**********************************************************************
33284 C
33285 C   dummy subroutines, remove to link PDFLIB
33286 C
33287 C**********************************************************************
33288       SUBROUTINE PDFSET(PARAM,VALUE)
33289       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33290       DIMENSION PARAM(20),VALUE(20)
33291       CHARACTER*20 PARAM
33292       END
33293
33294 *$ CREATE STRUCTM.FOR
33295 *COPY STRUCTM
33296 *
33297       SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33298       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33299       END
33300
33301 *$ CREATE STRUCTP.FOR
33302 *COPY STRUCTP
33303 *
33304       SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33305       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33306       END
33307
33308 *$ CREATE DT_DIQBRK.FOR
33309 *COPY DT_DIQBRK
33310 *
33311 *===diqbrk=============================================================*
33312 *
33313       SUBROUTINE DT_XIQBRK
33314 C     SUBROUTINE DT_DIQBRK
33315
33316       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33317       SAVE
33318
33319       STOP 'diquark-breaking not implemeted !'
33320
33321       RETURN
33322       END
33323
33324 *$ CREATE DT_ELHAIN.FOR
33325 *COPY DT_ELHAIN
33326 *
33327 *===elhain=============================================================*
33328 *
33329       SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
33330
33331 ************************************************************************
33332 * Elastic hadron-hadron scattering.                                    *
33333 * This is a revised version of the original.                           *
33334 * This version dated 03.04.98 is written by S. Roesler                 *
33335 ************************************************************************
33336
33337       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33338       SAVE
33339       PARAMETER ( LINP = 10 ,
33340      &            LOUT = 6 ,
33341      &            LDAT = 9 )
33342       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33343      &           TINY10=1.0D-10)
33344
33345       PARAMETER (ENNTHR = 3.5D0)
33346       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
33347      &           BLOWB=0.05D0,BHIB=0.2D0,
33348      &           BLOWM=0.1D0, BHIM=2.0D0)
33349
33350 * particle properties (BAMJET index convention)
33351       CHARACTER*8  ANAME
33352       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33353      &                IICH(210),IIBAR(210),K1(210),K2(210)
33354 * final state from HADRIN interaction
33355       PARAMETER (MAXFIN=10)
33356       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33357      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33358
33359 C     DATA TSLOPE /10.0D0/
33360
33361       IREJ = 0
33362
33363     1 CONTINUE
33364
33365       PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
33366       EKIN = ELAB-AAM(IP)
33367 *   kinematical quantities in cms of the hadrons
33368       AMP2 = AAM(IP)**2
33369       AMT2 = AAM(IT)**2
33370       S    = AMP2+AMT2+TWO*ELAB*AAM(IT)
33371       ECM  = SQRT(S)
33372       ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
33373       PCM  = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
33374
33375 * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
33376       IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
33377      &     ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
33378 *   TSAMCS treats pp and np only, therefore change pn into np and
33379 *   nn into pp
33380          IF (IT.EQ.1) THEN
33381             KPROJ = IP
33382          ELSE
33383             KPROJ = 8
33384             IF (IP.EQ.8) KPROJ = 1
33385          ENDIF
33386          CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
33387          T = TWO*PCM**2*(CTCMS-ONE)
33388
33389 * very crude treatment otherwise: sample t from exponential dist.
33390       ELSE
33391 *   momentum transfer t
33392          TMAX = TWO*TWO*PCM**2
33393          RR = (PLAB-PLOWH)/(PHIH-PLOWH)
33394          IF (IIBAR(IP).NE.0) THEN
33395             TSLOPE = BLOWB+RR*(BHIB-BLOWB)
33396          ELSE
33397             TSLOPE = BLOWM+RR*(BHIM-BLOWM)
33398          ENDIF
33399          FMAX = EXP(-TSLOPE*TMAX)-ONE
33400          R = DT_RNDM(RR)
33401          T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
33402          IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
33403       ENDIF
33404
33405 *   target hadron in Lab after scattering
33406       ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
33407       PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
33408       IF (PLRH(2).LE.TINY10) THEN
33409 C        WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
33410          GOTO 1
33411       ENDIF
33412 *   projectile hadron in Lab after scattering
33413       ELRH(1) = ELAB+AAM(IT)-ELRH(2)
33414       PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
33415 *   scattering angle of projectile in Lab
33416       CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
33417       STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
33418       CALL DT_DSFECF(SPLABP,CPLABP)
33419 *   direction cosines of projectile in Lab
33420       CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
33421      &                          CXRH(1),CYRH(1),CZRH(1))
33422 *   scattering angle of target in Lab
33423       PLLABT = PLAB-CTLABP*PLRH(1)
33424       CTLABT = PLLABT/PLRH(2)
33425       STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
33426 *   direction cosines of target in Lab
33427       CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
33428      &                            CXRH(2),CYRH(2),CZRH(2))
33429 *   fill /HNFSPA/
33430       IRH = 2
33431       ITRH(1) = IP
33432       ITRH(2) = IT
33433
33434       RETURN
33435       END
33436
33437 *$ CREATE DT_TSAMCS.FOR
33438 *COPY DT_TSAMCS
33439 *
33440 *===tsamcs=============================================================*
33441 *
33442       SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
33443
33444 ************************************************************************
33445 * Sampling of cos(theta) for nucleon-proton scattering according to    *
33446 * hetkfa2/bertini parametrization.                                     *
33447 * This is a revised version of the original (HJM 24/10/88)             *
33448 * This version dated 28.10.95 is written by S. Roesler                 *
33449 ************************************************************************
33450
33451       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33452       SAVE
33453       PARAMETER ( LINP = 10 ,
33454      &            LOUT = 6 ,
33455      &            LDAT = 9 )
33456       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33457      &           TINY10=1.0D-10)
33458
33459       DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
33460       DIMENSION PDCI(60),PDCH(55)
33461
33462       DATA (DCLIN(I),I=1,80) /
33463      &     5.000D-01,  1.000D+00,  0.000D+00,  1.000D+00,  0.000D+00,
33464      &     4.993D-01,  9.881D-01,  5.963D-02,  9.851D-01,  5.945D-02,
33465      &     4.936D-01,  8.955D-01,  5.224D-01,  8.727D-01,  5.091D-01,
33466      &     4.889D-01,  8.228D-01,  8.859D-01,  7.871D-01,  8.518D-01,
33467      &     4.874D-01,  7.580D-01,  1.210D+00,  7.207D-01,  1.117D+00,
33468      &     4.912D-01,  6.969D-01,  1.516D+00,  6.728D-01,  1.309D+00,
33469      &     5.075D-01,  6.471D-01,  1.765D+00,  6.667D-01,  1.333D+00,
33470      &     5.383D-01,  6.054D-01,  1.973D+00,  7.059D-01,  1.176D+00,
33471      &     5.397D-01,  5.990D-01,  2.005D+00,  7.023D-01,  1.191D+00,
33472      &     5.336D-01,  6.083D-01,  1.958D+00,  6.959D-01,  1.216D+00,
33473      &     5.317D-01,  6.075D-01,  1.962D+00,  6.897D-01,  1.241D+00,
33474      &     5.300D-01,  6.016D-01,  1.992D+00,  6.786D-01,  1.286D+00,
33475      &     5.281D-01,  6.063D-01,  1.969D+00,  6.786D-01,  1.286D+00,
33476      &     5.280D-01,  5.960D-01,  2.020D+00,  6.667D-01,  1.333D+00,
33477      &     5.273D-01,  5.920D-01,  2.040D+00,  6.604D-01,  1.358D+00,
33478      &     5.273D-01,  5.862D-01,  2.069D+00,  6.538D-01,  1.385D+00/
33479       DATA (DCLIN(I),I=81,160) /
33480      &     5.223D-01,  5.980D-01,  2.814D+00,  6.538D-01,  1.385D+00,
33481      &     5.202D-01,  5.969D-01,  2.822D+00,  6.471D-01,  1.412D+00,
33482      &     5.183D-01,  5.881D-01,  2.883D+00,  6.327D-01,  1.469D+00,
33483      &     5.159D-01,  5.866D-01,  2.894D+00,  6.250D-01,  1.500D+00,
33484      &     5.133D-01,  5.850D-01,  2.905D+00,  6.170D-01,  1.532D+00,
33485      &     5.106D-01,  5.833D-01,  2.917D+00,  6.087D-01,  1.565D+00,
33486      &     5.084D-01,  5.801D-01,  2.939D+00,  6.000D-01,  1.600D+00,
33487      &     5.063D-01,  5.763D-01,  2.966D+00,  5.909D-01,  1.636D+00,
33488      &     5.036D-01,  5.730D-01,  2.989D+00,  5.814D-01,  1.674D+00,
33489      &     5.014D-01,  5.683D-01,  3.022D+00,  5.714D-01,  1.714D+00,
33490      &     4.986D-01,  5.641D-01,  3.051D+00,  5.610D-01,  1.756D+00,
33491      &     4.964D-01,  5.580D-01,  3.094D+00,  5.500D-01,  1.800D+00,
33492      &     4.936D-01,  5.573D-01,  3.099D+00,  5.431D-01,  1.827D+00,
33493      &     4.909D-01,  5.509D-01,  3.144D+00,  5.313D-01,  1.875D+00,
33494      &     4.885D-01,  5.512D-01,  3.142D+00,  5.263D-01,  1.895D+00,
33495      &     4.857D-01,  5.437D-01,  3.194D+00,  5.135D-01,  1.946D+00/
33496       DATA (DCLIN(I),I=161,195) /
33497      &     4.830D-01,  5.353D-01,  3.253D+00,  5.000D-01,  2.000D+00,
33498      &     4.801D-01,  5.323D-01,  3.274D+00,  4.915D-01,  2.034D+00,
33499      &     4.770D-01,  5.228D-01,  3.341D+00,  4.767D-01,  2.093D+00,
33500      &     4.738D-01,  5.156D-01,  3.391D+00,  4.643D-01,  2.143D+00,
33501      &     4.701D-01,  5.010D-01,  3.493D+00,  4.444D-01,  2.222D+00,
33502      &     4.672D-01,  4.990D-01,  3.507D+00,  4.375D-01,  2.250D+00,
33503      &     4.634D-01,  4.856D-01,  3.601D+00,  4.194D-01,  2.323D+00/
33504
33505       DATA PDCI /
33506      &     4.400D+02,  1.896D-01,  1.931D-01,  1.982D-01,  1.015D-01,
33507      &     1.029D-01,  4.180D-02,  4.228D-02,  4.282D-02,  4.350D-02,
33508      &     2.204D-02,  2.236D-02,  5.900D+02,  1.433D-01,  1.555D-01,
33509      &     1.774D-01,  1.000D-01,  1.128D-01,  5.132D-02,  5.600D-02,
33510      &     6.158D-02,  6.796D-02,  3.660D-02,  3.820D-02,  6.500D+02,
33511      &     1.192D-01,  1.334D-01,  1.620D-01,  9.527D-02,  1.141D-01,
33512      &     5.283D-02,  5.952D-02,  6.765D-02,  7.878D-02,  4.796D-02,
33513      &     6.957D-02,  8.000D+02,  4.872D-02,  6.694D-02,  1.152D-01,
33514      &     9.348D-02,  1.368D-01,  6.912D-02,  7.953D-02,  9.577D-02,
33515      &     1.222D-01,  7.755D-02,  9.525D-02,  1.000D+03,  3.997D-02,
33516      &     5.456D-02,  9.804D-02,  8.084D-02,  1.208D-01,  6.520D-02,
33517      &     8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,  1.093D-01/
33518
33519       DATA PDCH /
33520      &     1.000D+03,  9.453D-02,  9.804D-02,  8.084D-02,  1.208D-01,
33521      &     6.520D-02,  8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,
33522      &     1.093D-01,  1.400D+03,  1.072D-01,  7.450D-02,  6.645D-02,
33523      &     1.136D-01,  6.750D-02,  8.580D-02,  1.110D-01,  1.530D-01,
33524      &     1.010D-01,  1.350D-01,  2.170D+03,  4.004D-02,  3.013D-02,
33525      &     2.664D-02,  5.511D-02,  4.240D-02,  7.660D-02,  1.364D-01,
33526      &     2.300D-01,  1.670D-01,  2.010D-01,  2.900D+03,  1.870D-02,
33527      &     1.804D-02,  1.320D-02,  2.970D-02,  2.860D-02,  5.160D-02,
33528      &     1.020D-01,  2.400D-01,  2.250D-01,  3.370D-01,  4.400D+03,
33529      &     1.196D-03,  8.784D-03,  1.517D-02,  2.874D-02,  2.488D-02,
33530      &     4.464D-02,  8.330D-02,  2.008D-01,  2.360D-01,  3.567D-01/
33531
33532       DATA (DCHN(I),I=1,90) /
33533      &     4.770D-01,  4.750D-01,  4.715D-01,  4.685D-01,  4.650D-01,
33534      &     4.610D-01,  4.570D-01,  4.550D-01,  4.500D-01,  4.450D-01,
33535      &     4.405D-01,  4.350D-01,  4.300D-01,  4.250D-01,  4.200D-01,
33536      &     4.130D-01,  4.060D-01,  4.000D-01,  3.915D-01,  3.840D-01,
33537      &     3.760D-01,  3.675D-01,  3.580D-01,  3.500D-01,  3.400D-01,
33538      &     3.300D-01,  3.200D-01,  3.100D-01,  3.000D-01,  2.900D-01,
33539      &     2.800D-01,  2.700D-01,  2.600D-01,  2.500D-01,  2.400D-01,
33540      &     2.315D-01,  2.240D-01,  2.150D-01,  2.060D-01,  2.000D-01,
33541      &     1.915D-01,  1.850D-01,  1.780D-01,  1.720D-01,  1.660D-01,
33542      &     1.600D-01,  1.550D-01,  1.500D-01,  1.450D-01,  1.400D-01,
33543      &     1.360D-01,  1.320D-01,  1.280D-01,  1.250D-01,  1.210D-01,
33544      &     1.180D-01,  1.150D-01,  1.120D-01,  1.100D-01,  1.070D-01,
33545      &     1.050D-01,  1.030D-01,  1.010D-01,  9.900D-02,  9.700D-02,
33546      &     9.550D-02,  9.480D-02,  9.400D-02,  9.200D-02,  9.150D-02,
33547      &     9.100D-02,  9.000D-02,  8.990D-02,  8.900D-02,  8.850D-02,
33548      &     8.750D-02,  8.700D-02,  8.650D-02,  8.550D-02,  8.500D-02,
33549      &     8.499D-02,  8.450D-02,  8.350D-02,  8.300D-02,  8.250D-02,
33550      &     8.150D-02,  8.100D-02,  8.030D-02,  8.000D-02,  7.990D-02/
33551       DATA (DCHN(I),I=91,143) /
33552      &     7.980D-02,  7.950D-02,  7.900D-02,  7.860D-02,  7.800D-02,
33553      &     7.750D-02,  7.650D-02,  7.620D-02,  7.600D-02,  7.550D-02,
33554      &     7.530D-02,  7.500D-02,  7.499D-02,  7.498D-02,  7.480D-02,
33555      &     7.450D-02,  7.400D-02,  7.350D-02,  7.300D-02,  7.250D-02,
33556      &     7.230D-02,  7.200D-02,  7.100D-02,  7.050D-02,  7.020D-02,
33557      &     7.000D-02,  6.999D-02,  6.995D-02,  6.993D-02,  6.991D-02,
33558      &     6.990D-02,  6.870D-02,  6.850D-02,  6.800D-02,  6.780D-02,
33559      &     6.750D-02,  6.700D-02,  6.650D-02,  6.630D-02,  6.600D-02,
33560      &     6.550D-02,  6.525D-02,  6.510D-02,  6.500D-02,  6.499D-02,
33561      &     6.498D-02,  6.496D-02,  6.494D-02,  6.493D-02,  6.490D-02,
33562      &     6.488D-02,  6.485D-02,  6.480D-02/
33563
33564       DATA DCHNA /
33565      &     6.300D+02,  7.810D-02,  1.421D-01,  1.979D-01,  2.479D-01,
33566      &     3.360D-01,  5.400D-01,  7.236D-01,  1.000D+00,  1.540D+03,
33567      &     2.225D-01,  3.950D-01,  5.279D-01,  6.298D-01,  7.718D-01,
33568      &     9.405D-01,  9.835D-01,  1.000D+00,  2.560D+03,  2.625D-01,
33569      &     4.550D-01,  5.963D-01,  7.020D-01,  8.380D-01,  9.603D-01,
33570      &     9.903D-01,  1.000D+00,  3.520D+03,  4.250D-01,  6.875D-01,
33571      &     8.363D-01,  9.163D-01,  9.828D-01,  1.000D+00,  1.000D+00,
33572      &     1.000D+00/
33573
33574       DATA DCHNB /
33575      &     6.300D+02,  3.800D-02,  7.164D-02,  1.275D-01,  2.171D-01,
33576      &     3.227D-01,  4.091D-01,  5.051D-01,  6.061D-01,  7.074D-01,
33577      &     8.434D-01,  1.000D+00,  2.040D+03,  1.200D-01,  2.115D-01,
33578      &     3.395D-01,  5.295D-01,  7.251D-01,  8.511D-01,  9.487D-01,
33579      &     9.987D-01,  1.000D+00,  1.000D+00,  1.000D+00,  2.200D+03,
33580      &     1.344D-01,  2.324D-01,  3.754D-01,  5.674D-01,  7.624D-01,
33581      &     8.896D-01,  9.808D-01,  1.000D+00,  1.000D+00,  1.000D+00,
33582      &     1.000D+00,  2.850D+03,  2.330D-01,  4.130D-01,  6.610D-01,
33583      &     9.010D-01,  9.970D-01,  1.000D+00,  1.000D+00,  1.000D+00,
33584      &     1.000D+00,  1.000D+00,  1.000D+00,  3.500D+03,  3.300D-01,
33585      &     5.450D-01,  7.950D-01,  1.000D+00,  1.000D+00,  1.000D+00,
33586      &     1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00/
33587
33588       CST = ONE
33589       IF (EKIN.GT.3.5D0) RETURN
33590 C
33591       IF(KPROJ.EQ.8) GOTO 101
33592       IF(KPROJ.EQ.1) GOTO 102
33593 C*                                             INVALID REACTION
33594       WRITE(LOUT,'(A,I5/A)')
33595      &        ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
33596      &        ' COS(THETA) = 1D0 RETURNED'
33597       RETURN
33598 C-------------------------------- NP ELASTIC SCATTERING----------
33599 101   CONTINUE
33600       IF (EKIN.GT.0.740D0)GOTO 1000
33601       IF (EKIN.LT.0.300D0)THEN
33602 C                                 EKIN .LT. 300 MEV
33603          IDAT=1
33604       ELSE
33605 C                                 300 MEV < EKIN < 740 MEV
33606          IDAT=6
33607       END IF
33608 C
33609       ENER=EKIN
33610       IE=INT(ABS(ENER/0.020D0))
33611       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33612 C                                            FORWARD/BACKWARD DECISION
33613       K=IDAT+5*IE
33614       BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33615       IF (DT_RNDM(CST).LT.BWFW)THEN
33616          VALUE2=-1D0
33617          K=K+1
33618       ELSE
33619          VALUE2=1D0
33620          K=K+3
33621       END IF
33622 C
33623       COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33624       RND=DT_RNDM(COEF)
33625 C
33626       IF(RND.LT.COEF)THEN
33627          CST=DT_RNDM(RND)
33628          CST=CST*VALUE2
33629       ELSE
33630          R1=DT_RNDM(CST)
33631          R2=DT_RNDM(R1)
33632          R3=DT_RNDM(R2)
33633          R4=DT_RNDM(R3)
33634 C
33635          IF(VALUE2.GT.0.0)THEN
33636             CST=MAX(R1,R2,R3,R4)
33637             GOTO 1500
33638          ELSE
33639             R5=DT_RNDM(R4)
33640 C
33641             IF (IDAT.EQ.1)THEN
33642                CST=-MAX(R1,R2,R3,R4,R5)
33643             ELSE
33644                R6=DT_RNDM(R5)
33645                R7=DT_RNDM(R6)
33646                CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
33647             END IF
33648 C
33649          END IF
33650 C
33651       END IF
33652 C
33653       GOTO 1500
33654 C
33655 C********                                EKIN  .GT.  0.74 GEV
33656 C
33657 1000  ENER=EKIN - 0.66D0
33658 C     IE=ABS(ENER/0.02)
33659       IE=INT(ENER/0.02D0)
33660       EMEV=EKIN*1D3
33661 C
33662       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33663       K=IE
33664       BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
33665       RND=DT_RNDM(BWFW)
33666 C                                        FORWARD NEUTRON
33667       IF (RND.GE.BWFW)THEN
33668          DO 1200 K=10,36,9
33669            IF (DCHNA(K).GT.EMEV) THEN
33670               UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
33671               UNIV=DT_RNDM(UNIVE)
33672               DO 1100 I=1,8
33673                  II=K+I
33674                  P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
33675 C
33676                  IF (P.GT.UNIV)THEN
33677                     UNIV=DT_RNDM(UNIVE)
33678                     FLTI=DBLE(I)-UNIV
33679                     GOTO(290,290,290,290,330,340,350,360) I
33680                  END IF
33681  1100         CONTINUE
33682            END IF
33683  1200    CONTINUE
33684 C
33685       ELSE
33686 C                                        BACKWARD NEUTRON
33687          DO 1400 K=13,60,12
33688             IF (DCHNB(K).GT.EMEV) THEN
33689                UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
33690                UNIV=DT_RNDM(UNIVE)
33691                DO 1300 I=1,11
33692                  II=K+I
33693                  P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
33694 C
33695                  IF (P.GT.UNIV)THEN
33696                    UNIV=DT_RNDM(P)
33697                    FLTI=DBLE(I)-UNIV
33698                    GOTO(120,120,140,150,160,160,180,190,200,210,220) I
33699                  END IF
33700  1300          CONTINUE
33701             END IF
33702  1400    CONTINUE
33703       END IF
33704 C
33705 120   CST=1.0D-2*FLTI-1.0D0
33706       GOTO 1500
33707 140   CST=2.0D-2*UNIV-0.98D0
33708       GOTO 1500
33709 150   CST=4.0D-2*UNIV-0.96D0
33710       GOTO 1500
33711 160   CST=6.0D-2*FLTI-1.16D0
33712       GOTO 1500
33713 180   CST=8.0D-2*UNIV-0.80D0
33714       GOTO 1500
33715 190   CST=1.0D-1*UNIV-0.72D0
33716       GOTO 1500
33717 200   CST=1.2D-1*UNIV-0.62D0
33718       GOTO 1500
33719 210   CST=2.0D-1*UNIV-0.50D0
33720       GOTO 1500
33721 220   CST=3.0D-1*(UNIV-1.0D0)
33722       GOTO 1500
33723 C
33724 290   CST=1.0D0-2.5d-2*FLTI
33725       GOTO 1500
33726 330   CST=0.85D0+0.5D-1*UNIV
33727       GOTO 1500
33728 340   CST=0.70D0+1.5D-1*UNIV
33729       GOTO 1500
33730 350   CST=0.50D0+2.0D-1*UNIV
33731       GOTO 1500
33732 360   CST=0.50D0*UNIV
33733 C
33734 1500  RETURN
33735 C
33736 C-----------------------------------  PP ELASTIC SCATTERING -------
33737 C
33738  102  CONTINUE
33739       EMEV=EKIN*1D3
33740 C
33741       IF (EKIN.LE.0.500D0) THEN
33742          RND=DT_RNDM(EMEV)
33743          CST=2.0D0*RND-1.0D0
33744          RETURN
33745 C
33746       ELSEIF (EKIN.LT.1.0D0) THEN
33747          DO 2200 K=13,60,12
33748             IF (PDCI(K).GT.EMEV) THEN
33749                UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
33750                UNIV=DT_RNDM(UNIVE)
33751                SUM=0
33752                DO 2100 I=1,11
33753                  II=K+I
33754                  SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
33755 C
33756                  IF (UNIV.LT.SUM)THEN
33757                    UNIV=DT_RNDM(SUM)
33758                    FLTI=DBLE(I)-UNIV
33759                    GOTO(55,55,55,60,60,65,65,65,65,70,70) I
33760                  END IF
33761  2100          CONTINUE
33762             END IF
33763  2200    CONTINUE
33764       ELSE
33765          DO 2400 K=12,55,11
33766             IF (PDCH(K).GT.EMEV) THEN
33767               UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
33768               UNIV=DT_RNDM(UNIVE)
33769               SUM=0.0D0
33770               DO 2300 I=1,10
33771                 II=K+I
33772                 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
33773 C
33774                 IF (UNIV.LT.SUM)THEN
33775                   UNIV=DT_RNDM(SUM)
33776                   FLTI=UNIV+DBLE(I)
33777                   GOTO(50,55,60,60,65,65,65,65,70,70) I
33778                 END IF
33779  2300         CONTINUE
33780             END IF
33781  2400    CONTINUE
33782       END IF
33783 C
33784 50    CST=0.4D0*UNIV
33785       GOTO 2500
33786 55    CST=0.2D0*FLTI
33787       GOTO 2500
33788 60    CST=0.3D0+0.1D0*FLTI
33789       GOTO 2500
33790 65    CST=0.6D0+0.04D0*FLTI
33791       GOTO 2500
33792 70    CST=0.78D0+0.02D0*FLTI
33793 C
33794 2500  CONTINUE
33795       IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
33796 C
33797       RETURN
33798       END
33799
33800 *$ CREATE DT_DHADRI.FOR
33801 *COPY DT_DHADRI
33802 *
33803 *===dhadri=============================================================*
33804 *
33805       SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
33806
33807       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33808       SAVE
33809
33810       PARAMETER ( LINP = 10 ,
33811      &            LOUT = 6 ,
33812      &            LDAT = 9 )
33813 C
33814 C-----------------------------
33815 C*** INPUT VARIABLES LIST:
33816 C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
33817 C*** GEV/C LABORATORY MOMENTUM REGION
33818 C*** N    - PROJECTILE HADRON INDEX
33819 C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
33820 C*** ELAB - LABORATORY ENERGY OF N (GEV)
33821 C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
33822 C*** ITTA - TARGET NUCLEON INDEX
33823 C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
33824 C  IR COUNTS THE NUMBER OF PRODUCED PARTICLES
33825 C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
33826 C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
33827 C*** RESPECT., UNITS (GEV/C AND GEV)
33828 C----------------------------
33829
33830       COMMON /HNGAMR/ REDU,AMO,AMM(15)
33831       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33832       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33833      &                NRK(2,268),NURE(30,2)
33834 * particle properties (BAMJET index convention),
33835 * (dublicate of DTPART for HADRIN)
33836       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33837      &                K1H(110),K2H(110)
33838       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33839       COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
33840      &                ITS(149),IS
33841       COMMON /HNDRUN/ RUNTES,EFTES
33842 * particle properties (BAMJET index convention)
33843       CHARACTER*8  ANAME
33844       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33845      &                IICH(210),IIBAR(210),K1(210),K2(210)
33846 * final state from HADRIN interaction
33847       PARAMETER (MAXFIN=10)
33848       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33849      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33850
33851       DIMENSION ITPRF(110)
33852       DATA NNN/0/
33853       DATA UMODA/0./
33854       DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
33855       LOWP=0
33856       IF (N.LE.0.OR.N.GE.111)N=1
33857       IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
33858         GOTO 280
33859 *       WRITE (6,1000)
33860 *    +  ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
33861 *       STOP
33862 *1000   FORMAT (3(5H ****/),A,2I4,3(5H ****/))
33863 *    +  45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
33864       ENDIF
33865       IATMPT=0
33866       IF (ABS(PLAB-5.0D0).LT.4.99999D0)                        GO TO 20
33867 C     IF(IPRI.GE.1) WRITE (6,1010) PLAB
33868 C     STOP
33869  1010 FORMAT ( '  PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
33870      + ALLOWED REGION, PLAB=',1E15.5)
33871
33872    20 CONTINUE
33873       UMODAT=N*1.11111D0+ITTA*2.19291D0
33874       IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
33875       UMODA=UMODAT
33876    30 IATMPT=0
33877       LOWP=LOWP+1
33878    40 CONTINUE
33879       IMACH=0
33880       REDU=2.0D0
33881       IF (LOWP.GT.20) THEN
33882 C        WRITE(LOUT,*) ' jump 1'
33883          GO TO 280
33884       ENDIF
33885       NNN=N
33886       IF (NNN.EQ.N)                                             GO TO 50
33887       RUNTES=0.0D0
33888       EFTES=0.0D0
33889    50 CONTINUE
33890       IS=1
33891       IRH=0
33892       IST=1
33893       NSTAB=23
33894       IRE=NURE(N,1)
33895       IF(ITTA.GT.1) IRE=NURE(N,2)
33896 C
33897 C-----------------------------
33898 C*** IE,AMT,ECM,SI DETERMINATION
33899 C----------------------------
33900       CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
33901       IANTH=-1
33902 **sr
33903 C     IF (AMH(1).NE.0.93828D0) IANTH=1
33904       IF (AMH(1).NE.0.9383D0) IANTH=1
33905 **
33906       IF (IANTH.GE.0) SI=1.0D0
33907       ECMMH=ECM
33908 C
33909 C-----------------------------
33910 C    ENERGY INDEX
33911 C  IRE CHARACTERIZES THE REACTION
33912 C  IE IS THE ENERGY INDEX
33913 C----------------------------
33914       IF (SI.LT.1.D-6) THEN
33915 C        WRITE(LOUT,*) ' jump 2'
33916          GO TO 280
33917       ENDIF
33918       IF (N.LE.NSTAB)                                           GO TO 60
33919       RUNTES=RUNTES+1.0D0
33920       IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
33921  1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
33922       IF(IBARH(N).EQ.1) N=8
33923       IF(IBARH(N).EQ.-1)  N=9
33924    60 CONTINUE
33925       IMACH=IMACH+1
33926 **sr 19.2.97: loop for direct channel suppression
33927 C     IF (IMACH.GT.10) THEN
33928       IF (IMACH.GT.1000) THEN
33929 **
33930 C        WRITE(LOUT,*) ' jump 3'
33931          GO TO 280
33932       ENDIF
33933       ECM =ECMMH
33934       AMN2=AMN**2
33935       AMT2=AMT**2
33936       ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM    )
33937       IF(ECMN.LE.AMN) ECMN=AMN
33938       PCMN=SQRT(ECMN**2-AMN2)
33939       GAM=(ELAB+AMT)/ECM
33940       BGAM=PLAB/ECM
33941       IF (IANTH.GE.0) ECM=2.1D0
33942 C
33943 C-----------------------------
33944 C*** RANDOM CHOICE OF REACTION CHANNEL
33945 C----------------------------
33946       IST=0
33947       VV=DT_RNDM(AMN2)
33948       VV=VV-1.D-17
33949 C
33950 C-----------------------------
33951 C***  PLACE REDUCED VERSION
33952 C----------------------------
33953       IIEI=IEII(IRE)
33954       IDWK=IEII(IRE+1)-IIEI
33955       IIWK=IRII(IRE)
33956       IIKI=IKII(IRE)
33957 C
33958 C-----------------------------
33959 C***  SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
33960 C----------------------------
33961       HECM=ECM
33962       HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
33963       IF (HUMO.LT.ECM) ECM=HUMO
33964 C
33965 C-----------------------------
33966 C*** INTERPOLATION PREPARATION
33967 C----------------------------
33968       ECMO=UMO(IE)
33969       ECM1=UMO(IE-1)
33970       DECM=ECMO-ECM1
33971       DEC=ECMO-ECM
33972 C
33973 C-----------------------------
33974 C*** RANDOM LOOP
33975 C----------------------------
33976       IK=0
33977       WKK=0.0D0
33978       WICOR=0.0D0
33979    70 IK=IK+1
33980       IWK=IIWK+(IK-1)*IDWK+IE-IIEI
33981       WOK=WK(IWK)
33982       WDK=WOK-WK(IWK-1)
33983 C
33984 C-----------------------------
33985 C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
33986 C    GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
33987 C    CONTRIBUTE
33988 C----------------------------
33989       IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
33990       WICO=WOK*1.23459876D0+WDK*1.735218469D0
33991       IF (WICO.EQ.WICOR)                                        GO TO 70
33992       IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
33993       WICOR=WICO
33994 C
33995 C-----------------------------
33996 C*** INTERPOLATION IN CHANNEL WEIGHTS
33997 C----------------------------
33998       EKLIM=-THRESH(IIKI+IK)
33999       IELIM=IDT_IEFUND(EKLIM,IRE)
34000       DELIM=UMO(IELIM)+EKLIM
34001      *+1.D-16
34002       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
34003       IF (DELIM*DELIM-DETE*DETE) 90,90,80
34004    80 DECC=DELIM
34005                                                                GO TO 100
34006    90 DECC=DECM
34007   100 CONTINUE
34008       WKK=WOK-WDK*DEC/(DECC+1.D-9)
34009 C
34010 C-----------------------------
34011 C*** RANDOM CHOICE
34012 C----------------------------
34013 C
34014       IF (VV.GT.WKK)                                            GO TO 70
34015 C
34016 C***IK IS THE REACTION CHANNEL
34017 C----------------------------
34018       INRK=IKII(IRE)+IK
34019       ECM=HECM
34020       I1001 =0
34021 C
34022   110 CONTINUE
34023       IT1=NRK(1,INRK)
34024       AM1=DT_DAMG(IT1)
34025       IT2=NRK(2,INRK)
34026       AM2=DT_DAMG(IT2)
34027       AMS=AM1+AM2
34028       I1001=I1001+1
34029       IF (I1001.GT.50)                                          GO TO 60
34030 C
34031       IF (IT2*AMS.GT.IT2*ECM)                                  GO TO 110
34032       IT11=IT1
34033       IT22=IT2
34034       IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
34035       AM11=AM1
34036       AM22=AM2
34037       IF (IT2.GT.0)                                            GO TO 120
34038 **sr 19.2.97: supress direct channel for pp-collisions
34039       IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
34040          RR = DT_RNDM(AM11)
34041          IF (RR.LE.0.75D0) GOTO 60
34042       ENDIF
34043 **
34044 C
34045 C-----------------------------
34046 C  INCLUSION OF DIRECT RESONANCES
34047 C  RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE  IT1
34048 C------------------------
34049       KZ1=K1H(IT1)
34050       IST=IST+1
34051       IECO=0
34052       ECO=ECM
34053       GAM=(ELAB+AMT)/ECO
34054       BGAM=PLAB/ECO
34055       CXS(1)=CX
34056       CYS(1)=CY
34057       CZS(1)=CZ
34058                                                                GO TO 170
34059   120 CONTINUE
34060       WW=DT_RNDM(ECO)
34061       IF(WW.LT. 0.5D0)                                         GO TO 130
34062       IT1=IT22
34063       IT2=IT11
34064       AM1=AM22
34065       AM2=AM11
34066   130 CONTINUE
34067 C
34068 C-----------------------------
34069 C   THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
34070       IBN=IBARH(N)
34071       IB1=IBARH(IT1)
34072       IT11=IT1
34073       IT22=IT2
34074       AM11=AM1
34075       AM22=AM2
34076       IF(IB1.EQ.IBN)                                           GO TO 140
34077       IT1=IT22
34078       IT2=IT11
34079       AM1=AM22
34080       AM2=AM11
34081   140 CONTINUE
34082 C-----------------------------
34083 C***IT1,IT2 ARE THE CREATED PARTICLES
34084 C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
34085 C------------------------
34086       CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34087      *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
34088       IST=IST+1
34089       ITS(IST)=IT1
34090       AMM(IST)=AM1
34091 C
34092 C-----------------------------
34093 C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
34094 C----------------------------
34095       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
34096      &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34097       IST=IST+1
34098       ITS(IST)=IT2
34099       AMM(IST)=AM2
34100       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
34101      *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34102   150 CONTINUE
34103 C
34104 C-----------------------------
34105 C***TEST   STABLE OR UNSTABLE
34106 C----------------------------
34107       IF(ITS(IST).GT.NSTAB)                                    GO TO 160
34108       IRH=IRH+1
34109 C
34110 C-----------------------------
34111 C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
34112 C----------------------------
34113 C*    IF (REDU.LT.0.D0) GO TO 1009
34114       ITRH(IRH)=ITS(IST)
34115       PLRH(IRH)=PLS(IST)
34116       CXRH(IRH)=CXS(IST)
34117       CYRH(IRH)=CYS(IST)
34118       CZRH(IRH)=CZS(IST)
34119       ELRH(IRH)=ELS(IST)
34120       IST=IST-1
34121       IF(IST.GE.1)                                             GO TO 150
34122                                                                GO TO 260
34123   160 CONTINUE
34124 C
34125 C  RANDOM CHOICE OF DECAY CHANNELS
34126 C----------------------------
34127 C
34128       IT=ITS(IST)
34129       ECO=AMM(IST)
34130       GAM=ELS(IST)/ECO
34131       BGAM=PLS(IST)/ECO
34132       IECO=0
34133       KZ1=K1H(IT)
34134   170 CONTINUE
34135       IECO=IECO+1
34136       VV=DT_RNDM(GAM)
34137       VV=VV-1.D-17
34138       IIK=KZ1-1
34139   180 IIK=IIK+1
34140       IF (VV.GT.WTI(IIK))                                      GO TO 180
34141 C
34142 C  IIK IS THE DECAY CHANNEL
34143 C----------------------------
34144       IT1=NZKI(IIK,1)
34145       I310=0
34146   190 CONTINUE
34147       I310=I310+1
34148       AM1=DT_DAMG(IT1)
34149       IT2=NZKI(IIK,2)
34150       AM2=DT_DAMG(IT2)
34151       IF (IT2-1.LT.0)                                          GO TO 240
34152       IT3=NZKI(IIK,3)
34153       AM3=DT_DAMG(IT3)
34154       AMS=AM1+AM2+AM3
34155 C
34156 C  IF  IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
34157 C----------------------------
34158       IF (IECO.LE.10)                                          GO TO 200
34159       IATMPT=IATMPT+1
34160       IF(IATMPT.GT.3) THEN
34161 C        WRITE(LOUT,*) ' jump 4'
34162          GO TO 280
34163       ENDIF
34164                                                                 GO TO 40
34165   200 CONTINUE
34166       IF (I310.GT.50)                                          GO TO 170
34167       IF (AMS.GT.ECO)                                          GO TO 190
34168 C
34169 C  FOR THE DECAY CHANNEL
34170 C  IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM  IT
34171 C----------------------------
34172       IF (REDU.LT.0.D0)                                        GO TO 30
34173       ITWTHC=0
34174       REDU=2.0D0
34175       IF(IT3.EQ.0)                                             GO TO 220
34176   210 CONTINUE
34177       ITWTH=1
34178       CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
34179      *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
34180                                                                GO TO 230
34181   220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
34182      &COD2,COF2,SIF2,AM1,AM2)
34183       ITWTH=-1
34184       IT3=0
34185   230 CONTINUE
34186       ITWTHC=ITWTHC+1
34187       IF (REDU.GT.0.D0)                                        GO TO 240
34188       REDU=2.0D0
34189       IF (ITWTHC.GT.100)                                        GO TO 30
34190       IF (ITWTH) 220,220,210
34191   240 CONTINUE
34192       ITS(IST  )=IT1
34193       IF (IT2-1.LT.0)                                          GO TO 250
34194       ITS(IST+1)  =IT2
34195       ITS(IST+2)=IT3
34196       RX=CXS(IST)
34197       RY=CYS(IST)
34198       RZ=CZS(IST)
34199       AMM(IST)=AM1
34200       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
34201      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34202       IST=IST+1
34203       AMM(IST)=AM2
34204       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
34205      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34206       IF (IT3.LE.0)                                            GO TO 250
34207       IST=IST+1
34208       AMM(IST)=AM3
34209       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
34210      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34211   250 CONTINUE
34212                                                                GO TO 150
34213   260 CONTINUE
34214   270 CONTINUE
34215       RETURN
34216   280 CONTINUE
34217 C
34218 C----------------------------
34219 C
34220 C   ZERO CROSS SECTION CASE
34221 C----------------------------
34222 C
34223       IRH=1
34224       ITRH(1)=N
34225       CXRH(1)=CX
34226       CYRH(1)=CY
34227       CZRH(1)=CZ
34228       ELRH(1)=ELAB
34229       PLRH(1)=PLAB
34230       RETURN
34231       END
34232
34233 *$ CREATE DT_RUNTT.FOR
34234 *COPY DT_RUNTT
34235 *
34236 *===runtt==============================================================*
34237 *
34238       BLOCK DATA DT_RUNTT
34239
34240       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34241       SAVE
34242
34243       COMMON /HNDRUN/ RUNTES,EFTES
34244
34245       DATA RUNTES,EFTES /100.D0,100.D0/
34246
34247       END
34248
34249 *$ CREATE DT_NONAME.FOR
34250 *COPY DT_NONAME
34251 *
34252 *===noname=============================================================*
34253 *
34254       BLOCK DATA DT_NONAME
34255
34256       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34257       SAVE
34258
34259 * slope parameters for HADRIN interactions
34260       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34261       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34262
34263 C     DATAS     DATAS    DATAS      DATAS     DATAS
34264 C******          *********
34265       DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
34266      &           207, 224, 241, 252, 268 /
34267       DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
34268      &           220, 241, 262, 279, 296 /
34269       DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
34270      &           3364, 3507, 4011, 4368, 4725, 4912, 5184/
34271
34272 C
34273 C     MASSES FOR THE SLOPE B(M) IN GEV
34274 C     SLOPE B(M) FOR AN MESONIC SYSTEM
34275 C     SLOPE B(M) FOR A BARYONIC SYSTEM
34276
34277 *
34278       DATA SM,BBM,BBB/  0.8D0, 0.85D0,  0.9D0, 0.95D0, 1.D0,
34279      &     1.05D0,  1.1D0, 1.15D0,  1.2D0, 1.25D0,
34280      &      1.3D0,  1.35D0, 1.4D0,  1.45D0,  1.5D0,
34281      &     1.55D0,  1.6D0,  1.65D0, 1.7D0,   1.75D0,
34282      &      1.8D0,  1.85D0, 1.9D0,  1.95D0,  2.D0,
34283      &     15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
34284      &    12.35D0, 11.7D0, 10.85D0, 10.D0,  9.15D0,
34285      &      8.3D0,  7.8D0,  7.3D0,  7.25D0,  7.2D0,
34286      &     6.95D0,  6.7D0,  6.6D0,  6.5D0,   6.3D0,
34287      &      6.1D0,  5.85D0, 5.6D0,  5.35D0,  5.1D0,
34288      &      15.D0,   15.D0, 15.D0,  15.D0,   15.D0, 15.D0, 15.D0,
34289      &     14.2D0,  13.4D0, 12.6D0,
34290      &     11.8D0, 11.2D0, 10.6D0,  9.8D0,    9.D0,
34291      &     8.25D0,  7.5D0, 6.25D0,  5.D0,    4.5D0, 5*4.D0 /
34292 *
34293       END
34294
34295 *$ CREATE DT_DAMG.FOR
34296 *COPY DT_DAMG
34297 *
34298 *===damg===============================================================*
34299 *
34300       DOUBLE PRECISION FUNCTION DT_DAMG(IT)
34301
34302       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34303       SAVE
34304
34305 * particle properties (BAMJET index convention),
34306 * (dublicate of DTPART for HADRIN)
34307       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34308      &                K1H(110),K2H(110)
34309
34310       DIMENSION GASUNI(14)
34311       DATA GASUNI/
34312      *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
34313      *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
34314       DATA GAUNO/2.352D0/
34315       DATA GAUNON/2.4D0/
34316       DATA IO/14/
34317       DATA NSTAB/23/
34318
34319       I=1
34320       IF (IT.LE.0)                                              GO TO 30
34321       IF (IT.LE.NSTAB)                                          GO TO 20
34322       DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
34323       VV=DT_RNDM(DGAUNI)
34324       VV=VV*2.0D0-1.0D0+1.D-16
34325    10 CONTINUE
34326       VO=GASUNI(I)
34327       I=I+1
34328       V1=GASUNI(I)
34329       IF (VV.GT.V1)                                             GO TO 10
34330       UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
34331      &      (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
34332       DAM=GAH(IT)*UNIGA/GAUNO
34333       AAM=AMH(IT)+DAM
34334       DT_DAMG=AAM
34335       RETURN
34336    20 CONTINUE
34337       DT_DAMG=AMH(IT)
34338       RETURN
34339    30 CONTINUE
34340       DT_DAMG=0.0D0
34341       RETURN
34342       END
34343
34344 *$ CREATE DT_DCALUM.FOR
34345 *COPY DT_DCALUM
34346 *
34347 *===dcalum=============================================================*
34348 *
34349       SUBROUTINE DT_DCALUM(N,ITTA)
34350
34351       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34352       SAVE
34353
34354 C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
34355
34356 * particle properties (BAMJET index convention),
34357 * (dublicate of DTPART for HADRIN)
34358       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34359      &                K1H(110),K2H(110)
34360       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34361       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34362       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34363      &                NRK(2,268),NURE(30,2)
34364
34365       IRE=NURE(N,ITTA/8+1)
34366       IEO=IEII(IRE)+1
34367       IEE=IEII(IRE +1)
34368       AM1=AMH(N   )
34369       AM12=AM1**2
34370       AM2=AMH(ITTA)
34371       AM22=AM2**2
34372       DO 10 IE=IEO,IEE
34373         PLAB2=PLABF(IE)**2
34374         ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
34375         UMO(IE)=ELAB
34376    10 CONTINUE
34377       IKO=IKII(IRE)+1
34378       IKE=IKII(IRE +1)
34379       UMOO=UMO(IEO)
34380       DO 30 IK=IKO,IKE
34381         IF(NRK(2,IK).GT.0)                                      GO TO 30
34382         IKI=NRK(1,IK)
34383         AMSS=5.0D0
34384         K11=K1H(IKI)
34385         K22=K2H(IKI)
34386         DO 20 IK1=K11,K22
34387           IN=NZKI(IK1,1)
34388           AMS=AMH(IN)
34389           IN=NZKI(IK1,2)
34390           IF(IN.GT.0)AMS=AMS+AMH(IN)
34391           IN=NZKI(IK1,3)
34392           IF(IN.GT.0) AMS=AMS+AMH(IN)
34393           IF (AMS.LT.AMSS) AMSS=AMS
34394    20   CONTINUE
34395         IF(UMOO.LT.AMSS) UMOO=AMSS
34396         THRESH(IK)=UMOO
34397    30 CONTINUE
34398       RETURN
34399       END
34400
34401 *$ CREATE DT_DCHANH.FOR
34402 *COPY DT_DCHANH
34403 *
34404 *===dchanh=============================================================*
34405 *
34406       SUBROUTINE DT_DCHANH
34407
34408       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34409       SAVE
34410
34411       PARAMETER ( LINP = 10 ,
34412      &            LOUT = 6 ,
34413      &            LDAT = 9 )
34414 * particle properties (BAMJET index convention),
34415 * (dublicate of DTPART for HADRIN)
34416       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34417      &                K1H(110),K2H(110)
34418       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34419       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34420       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34421      &                NRK(2,268),NURE(30,2)
34422
34423       DIMENSION HWT(460),HWK(40),SI(5184)
34424       EQUIVALENCE (WK(1),SI(1))
34425 C--------------------
34426 C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
34427 C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
34428 C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
34429 C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
34430 C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
34431 C--------------------------
34432       IREG=16
34433       DO 90 IRE=1,IREG
34434         IWKO=IRII(IRE)
34435         IEE=IEII(IRE+1)-IEII(IRE)
34436         IKE=IKII(IRE+1)-IKII(IRE)
34437         IEO=IEII(IRE)+1
34438         IIKA=IKII(IRE)
34439 *   modifications to suppress elestic scattering  24/07/91
34440         DO 80 IE=1,IEE
34441           SIS=1.D-14
34442           SINORC=0.0D0
34443           DO 10 IK=1,IKE
34444             IWK=IWKO+IEE*(IK-1)+IE
34445             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34446             SIS=SIS+SI(IWK)*SINORC
34447    10     CONTINUE
34448           SIIN(IEO+IE-1)=SIS
34449           SIO=0.D0
34450           IF (SIS.GE.1.D-12)                                    GO TO 20
34451           SIS=1.D0
34452           SIO=1.D0
34453    20     CONTINUE
34454           SINORC=0.0D0
34455           DO 30 IK=1,IKE
34456             IWK=IWKO+IEE*(IK-1)+IE
34457             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34458             SIO=SIO+SI(IWK)*SINORC/SIS
34459             HWK(IK)=SIO
34460    30     CONTINUE
34461           DO 40 IK=1,IKE
34462             IWK=IWKO+IEE*(IK-1)+IE
34463    40     WK(IWK)=HWK(IK)
34464           IIKI=IKII(IRE)
34465           DO 70 IK=1,IKE
34466             AM111=0.D0
34467             INRK1=NRK(1,IIKI+IK)
34468             IF (INRK1.GT.0) AM111=AMH(INRK1)
34469             AM222=0.D0
34470             INRK2=NRK(2,IIKI+IK)
34471             IF (INRK2.GT.0) AM222=AMH(INRK2)
34472             THRESH(IIKI+IK)=AM111 +AM222
34473             IF (INRK2-1.GE.0)                                   GO TO 60
34474             INRKK=K1H(INRK1)
34475             AMSS=5.D0
34476             INRKO=K2H(INRK1)
34477             DO 50 INRK1=INRKK,INRKO
34478               INZK1=NZKI(INRK1,1)
34479               INZK2=NZKI(INRK1,2)
34480               INZK3=NZKI(INRK1,3)
34481               IF (INZK1.LE.0.OR.INZK1.GT.110)                   GO TO 50
34482               IF (INZK2.LE.0.OR.INZK2.GT.110)                   GO TO 50
34483               IF (INZK3.LE.0.OR.INZK3.GT.110)                   GO TO 50
34484 C     WRITE (6,310)INRK1,INZK1,INZK2,INZK3
34485  1000 FORMAT (4I10)
34486               AMS=AMH(INZK1)+AMH(INZK2)
34487               IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
34488               IF (AMSS.GT.AMS) AMSS=AMS
34489    50       CONTINUE
34490             AMS=AMSS
34491             IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
34492             THRESH(IIKI+IK)=AMS
34493    60       CONTINUE
34494    70     CONTINUE
34495    80   CONTINUE
34496    90 CONTINUE
34497       DO 100 J=1,460
34498   100 HWT(J)=0.D0
34499       DO 120 I=1,110
34500         IK1=K1H(I)
34501         IK2=K2H(I)
34502         HV=0.D0
34503         IF (IK2.GT.460)IK2=460
34504         IF (IK1.LE.0)IK1=1
34505         DO 110 J=IK1,IK2
34506           HV=HV+WTI(J)
34507           HWT(J)=HV
34508           JI=J
34509   110   CONTINUE
34510         IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
34511  1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
34512   120 CONTINUE
34513       DO 130 J=1,460
34514   130 WTI(J)=HWT(J)
34515       RETURN
34516       END
34517
34518 *$ CREATE DT_DHADDE.FOR
34519 *COPY DT_DHADDE
34520 *
34521 *===dhadde=============================================================*
34522 *
34523       SUBROUTINE DT_DHADDE
34524
34525       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34526       SAVE
34527
34528 * particle properties (BAMJET index convention)
34529       CHARACTER*8  ANAME
34530       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
34531      &                IICH(210),IIBAR(210),K1(210),K2(210)
34532 * HADRIN: decay channel information
34533       PARAMETER (IDMAX9=602)
34534       CHARACTER*8 ZKNAME
34535       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
34536 * particle properties (BAMJET index convention),
34537 * (dublicate of DTPART for HADRIN)
34538       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34539      &                K1H(110),K2H(110)
34540       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34541 * decay channel information for HADRIN
34542       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34543      &                K1Z(16),K2Z(16),WTZ(153),II22,
34544      &                NZK1(153),NZK2(153),NZK3(153)
34545
34546       DATA IRETUR/0/
34547
34548       IRETUR=IRETUR+1
34549       AMH(31)=0.48D0
34550       IF (IRETUR.GT.1) RETURN
34551       DO 10 I=1,94
34552         AMH(I)   = AAM(I)
34553         GAH(I)   = GA(I)
34554         TAUH(I)  = TAU(I)
34555         ICHH(I)  = IICH(I)
34556         IBARH(I) = IIBAR(I)
34557         K1H(I)   = K1(I)
34558         K2H(I)   = K2(I)
34559    10 CONTINUE
34560 **sr
34561 C     AMH(1)=0.93828D0
34562       AMH(1)=0.9383D0
34563 **
34564       AMH(2)=AMH(1)
34565       DO 20 I=26,30
34566         K1H(I)=452
34567         K2H(I)=452
34568    20 CONTINUE
34569       DO 30 I=1,307
34570         WTI(I)    = WT(I)
34571         NZKI(I,1) = NZK(I,1)
34572         NZKI(I,2) = NZK(I,2)
34573         NZKI(I,3) = NZK(I,3)
34574    30 CONTINUE
34575       DO 40 I=1,16
34576         L=I+94
34577         AMH(L)=AMZ(I)
34578         GAH( L)=GAZ(I)
34579         TAUH( L)=TAUZ(I)
34580         ICHH( L)=ICHZ(I)
34581         IBARH( L)=IBARZ(I)
34582         K1H( L)=K1Z(I)
34583         K2H( L)=K2Z(I)
34584    40 CONTINUE
34585       DO 50 I=1,153
34586         L=I+307
34587         WTI(L)    = WTZ(I)
34588         NZKI(L,3) = NZK3(I)
34589         NZKI(L,2) = NZK2(I)
34590         NZKI(L,1) = NZK1(I)
34591    50 CONTINUE
34592       RETURN
34593       END
34594
34595 *$ CREATE IDT_IEFUND.FOR
34596 *COPY IDT_IEFUND
34597 *
34598 *===iefund=============================================================*
34599 *
34600       INTEGER FUNCTION IDT_IEFUND(PL,IRE)
34601
34602       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34603       SAVE
34604
34605 C*****IEFUN CALCULATES A MOMENTUM INDEX
34606
34607       PARAMETER ( LINP = 10 ,
34608      &            LOUT = 6 ,
34609      &            LDAT = 9 )
34610       COMMON /HNDRUN/ RUNTES,EFTES
34611       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34612       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34613      &                NRK(2,268),NURE(30,2)
34614
34615       IPLA=IEII(IRE)+1
34616      *+1
34617       IPLE=IEII(IRE+1)
34618       IF (PL.LT.0.)                                             GO TO 30
34619       DO 10 I=IPLA,IPLE
34620         J=I-IPLA+1
34621         IF (PL.LE.PLABF(I))                                     GO TO 60
34622    10 CONTINUE
34623       I=IPLE
34624       IF ( EFTES.GT.40.D0)                                      GO TO 20
34625       EFTES=EFTES+1.0D0
34626       WRITE(LOUT,1000)PL,J
34627    20 CONTINUE
34628                                                                 GO TO 70
34629    30 CONTINUE
34630       DO 40 I=IPLA,IPLE
34631         J=I-IPLA+1
34632         IF (-PL.LE.UMO(I))                                      GO TO 60
34633    40 CONTINUE
34634       I=IPLE
34635       IF ( EFTES.GT.40.D0)                                      GO TO 50
34636       EFTES=EFTES+1.0D0
34637       WRITE(LOUT,1000)PL,I
34638    50 CONTINUE
34639    60 CONTINUE
34640    70 CONTINUE
34641       IDT_IEFUND=I
34642       RETURN
34643  1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
34644      +7H IEFUN=,I5)
34645       END
34646
34647 *$ CREATE DT_DSIGIN.FOR
34648 *COPY DT_DSIGIN
34649 *
34650 *===dsigin=============================================================*
34651 *
34652       SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
34653
34654       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34655       SAVE
34656
34657 * particle properties (BAMJET index convention),
34658 * (dublicate of DTPART for HADRIN)
34659       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34660      &                K1H(110),K2H(110)
34661       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34662       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34663      &                NRK(2,268),NURE(30,2)
34664
34665       IE=IDT_IEFUND(PLAB,IRE)
34666       IF (IE.LE.IEII(IRE)) IE=IE+1
34667       AMT=AMH(ITAR)
34668       AMN=AMH(N)
34669       AMN2=AMN*AMN
34670       AMT2=AMT*AMT
34671       ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
34672 C*** INTERPOLATION PREPARATION
34673       ECMO=UMO(IE)
34674       ECM1=UMO(IE-1)
34675       DECM=ECMO-ECM1
34676       DEC=ECMO-ECM
34677       IIKI=IKII(IRE)+1
34678       EKLIM=-THRESH(IIKI)
34679       WOK=SIIN(IE)
34680       WDK=WOK-SIIN(IE-1)
34681       IF (ECM.GT.ECMO) WDK=0.0D0
34682 C*** INTERPOLATION IN CHANNEL WEIGHTS
34683       IELIM=IDT_IEFUND(EKLIM,IRE)
34684       DELIM=UMO(IELIM)+EKLIM
34685      *+1.D-16
34686       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
34687       IF (DELIM*DELIM-DETE*DETE) 20,20,10
34688    10 DECC=DELIM
34689                                                                 GO TO 30
34690    20 DECC=DECM
34691    30 CONTINUE
34692       WKK=WOK-WDK*DEC/(DECC+1.D-9)
34693       IF (WKK.LT.0.0D0) WKK=0.0D0
34694       SI=WKK+1.D-12
34695       IF (-EKLIM.GT.ECM) SI=1.D-14
34696       RETURN
34697       END
34698
34699 *$ CREATE DT_DTCHOI.FOR
34700 *COPY DT_DTCHOI
34701 *
34702 *===dtchoi=============================================================*
34703 *
34704       SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
34705
34706       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34707       SAVE
34708
34709 C     ****************************
34710 C     TCHOIC CALCULATES A RANDOM VALUE
34711 C     FOR THE FOUR-MOMENTUM-TRANSFER T
34712 C     ****************************
34713
34714 * particle properties (BAMJET index convention),
34715 * (dublicate of DTPART for HADRIN)
34716       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34717      &                K1H(110),K2H(110)
34718 * slope parameters for HADRIN interactions
34719       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34720
34721       AMA=AM1
34722       AMB=AM2
34723       IF (I.GT.30.AND.II.GT.30)                                 GO TO 20
34724       III=II
34725       AM3=AM2
34726       IF (I.LE.30)                                              GO TO 10
34727       III=I
34728       AM3=AM1
34729    10 CONTINUE
34730                                                                 GO TO 30
34731    20 CONTINUE
34732       III=II
34733       AM3=AM2
34734       IF (AMA.LE.AMB)                                           GO TO 30
34735       III=I
34736       AM3=AM1
34737    30 CONTINUE
34738       IB=IBARH(III)
34739       AMA=AM3
34740       K=INT((AMA-0.75D0)/0.05D0)
34741       IF (K-2.LT.0) K=1
34742       IF (K-26.GE.0) K=25
34743       IF (IB)50,40,50
34744    40 BM=BBM(K)
34745                                                                 GO TO 60
34746    50 BM=BBB(K)
34747    60 CONTINUE
34748 C     NORMALIZATION
34749       TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1  **2
34750       TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1  **2
34751       VB=DT_RNDM(TMIN)
34752 **sr test
34753 C     IF (VB.LT.0.2D0) BM=BM*0.1
34754 C    **0.5
34755       BM = BM*5.05D0
34756 **
34757       TMI=BM*TMIN
34758       TMA=BM*TMAX
34759       ETMA=0.D0
34760       IF (ABS(TMA).GT.120.D0)                                   GO TO 70
34761       ETMA=EXP(TMA)
34762    70 CONTINUE
34763       AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
34764 C*** RANDOM CHOICE OF THE T - VALUE
34765       R=DT_RNDM(TMI)
34766       T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
34767       RETURN
34768       END
34769
34770 *$ CREATE DT_DTWOPA.FOR
34771 *COPY DT_DTWOPA
34772 *
34773 *===dtwopa=============================================================*
34774 *
34775       SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34776      &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
34777
34778       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34779       SAVE
34780
34781 C     ******************************************************
34782 C     QUASI TWO PARTICLE PRODUCTION
34783 C     TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
34784 C     FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
34785 C     IN THE CM - SYSTEM
34786 C     COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
34787 C     SPHERICAL COORDINATES
34788 C     ******************************************************
34789
34790 * particle properties (BAMJET index convention),
34791 * (dublicate of DTPART for HADRIN)
34792       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34793      &                K1H(110),K2H(110)
34794
34795       AMA=AM1
34796       AMB=AM2
34797       AMA2=AMA*AMA
34798       E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
34799       E2=UMOO - E1
34800       IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
34801       AMTE=(E1-AMA)*(E1+AMA)
34802       AMTE=AMTE+1.D-18
34803       P1=SQRT(AMTE)
34804       P2=P1
34805 C     / P2 / = / P1 /  BUT OPPOSITE DIRECTIONS
34806 C     DETERMINATION  OF  THE ANGLES
34807 C     COS(THETA1)=COD1      COS(THETA2)=COD2
34808 C     SIN(PHI1)=SIF1        SIN(PHI2)=SIF2
34809 C     COS(PHI1)=COF1        COS(PHI2)=COF2
34810 C     PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
34811       CALL DT_DSFECF(COF1,SIF1)
34812       COF2=-COF1
34813       SIF2=-SIF1
34814 C     CALCULATION OF THETA1
34815       CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
34816       COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
34817       IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
34818       COD2=-COD1
34819       RETURN
34820       END
34821
34822 *$ CREATE DT_ZK.FOR
34823 *COPY DT_ZK
34824 *
34825 *===zk=================================================================*
34826 *
34827       BLOCK DATA DT_ZK
34828
34829       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34830       SAVE
34831
34832 * decay channel information for HADRIN
34833       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34834      &                K1Z(16),K2Z(16),WTZ(153),II22,
34835      &                NZK1(153),NZK2(153),NZK3(153)
34836 * decay channel information for HADRIN
34837       CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
34838       COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
34839
34840 *     Particle masses in GeV                                           *
34841       DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
34842      &          2*1.7D0, 3*0.D0/
34843 *     Resonance width Gamma in GeV                                     *
34844       DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
34845 *     Mean life time in seconds                                        *
34846       DATA TAUZ / 16*0.D0 /
34847 *     Charge of particles and resonances                               *
34848       DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
34849 *     Baryonic charge                                                  *
34850       DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
34851 *     First number of decay channels used for resonances               *
34852 *     and decaying particles                                           *
34853       DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
34854      &          3*460/
34855 *     Last number of decay channels used for resonances                *
34856 *     and decaying particles                                           *
34857       DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
34858      &          3*460/
34859 *     Weight of decay channel                                          *
34860       DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
34861      & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
34862      & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
34863      & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
34864      & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
34865      & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
34866      & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
34867      & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
34868      & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
34869      & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
34870      & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
34871      & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
34872      & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
34873      & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
34874      & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
34875      & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
34876      & .05D0, .65D0, 9*1.D0 /
34877 *     Particle numbers in decay channel                                *
34878       DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
34879      & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
34880      & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
34881      & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
34882      & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
34883      & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
34884      & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
34885      & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
34886       DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
34887      & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
34888      & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
34889      & 4*33, 32, 3*35,  2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
34890      & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
34891      & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
34892      & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
34893      & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
34894      & 1, 8, 1, 8, 1, 9*0 /
34895       DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
34896      & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
34897      & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
34898      & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
34899      & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
34900      & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
34901 *     Particle  names                                                  *
34902       DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS  ',' PAP  ',' PAN  ',
34903      & 'APN', 'DEO   ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
34904      & 3*'BLANK' /
34905 *     Name of decay channel                                            *
34906       DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
34907      & 'ANNPI0','APPPI0','ANPPI-'/
34908       DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K-  ','K0AK0 ',
34909      & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET  ','&0R0  ','P-R+  ',
34910      & 'P+R-  ','POOM  ',' ETET ','ETSP0 ','R0ET  ',' R0R0 ','R+R-  ',
34911      & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
34912      & 'P+R-R0','R0OM  ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
34913      & 'P+R-OM','OMOM  ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
34914      & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
34915      & 'OMOMOM',
34916      & ' P+PO ','P+POPO','P+P+P-','P+ET  ','P0R+  ','P+R0  ','ETSP+ ',
34917      & 'R+ET  ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
34918      & 'P+R-R+','R+OM  ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
34919      & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
34920      & 'P-PO  ','P-POPO','P-P-P+','P-ET  ','POR-  ','P-R0  ','ETSP- ',
34921      & 'R-ET  ','R-R0  ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
34922       DATA ZKNAM6/'P+R-R-','R-OM  ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
34923      & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
34924      & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO  ','LPI+  ',
34925      & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
34926      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
34927      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
34928      & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
34929      & 9*'BLANK'/
34930 *=                                               end*block.zk      *
34931       END
34932
34933 *$ CREATE DT_BLKD43.FOR
34934 *COPY DT_BLKD43
34935 *
34936 *===blkd43=============================================================*
34937 *
34938       BLOCK DATA DT_BLKD43
34939
34940       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34941       SAVE
34942
34943 *
34944 *=== reac =============================================================*
34945 *
34946 *----------------------------------------------------------------------*
34947 *                                                                      *
34948 *     Created on 10 december 1991  by    Alfredo Ferrari & Paola Sala  *
34949 *                                                   Infn - Milan       *
34950 *                                                                      *
34951 *     Last change on 10-dec-91     by    Alfredo Ferrari               *
34952 *                                                                      *
34953 *     This is the original common reac of Hadrin                       *
34954 *                                                                      *
34955 *----------------------------------------------------------------------*
34956 *
34957       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34958      &                NRK(2,268),NURE(30,2)
34959
34960       DIMENSION
34961      & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
34962      & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
34963      & SPIKP1(315), SPIKPU(278), SPIKPV(372),
34964      & SPIKPW(278), SPIKPX(372), SPIKP4(315),
34965      & SPIKP5(187), SPIKP6(289),
34966      & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
34967      & SPIKP9(143), SPIKP0(169), SPKPV(143),
34968      & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
34969      & SANPEL(84) , SPIKPF(273),
34970      & SPKP15(187), SPKP16(272),
34971      & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
34972      & NURELN(60)
34973 *
34974        DIMENSION NRKLIN(532)
34975        EQUIVALENCE (NRK(1,1), NRKLIN(1))
34976        EQUIVALENCE (   UMO(  1),  UMOPI(1)), (   UMO( 93),  UMOKC(1))
34977        EQUIVALENCE (   UMO(161),   UMOP(1)), (   UMO(200),   UMON(1))
34978        EQUIVALENCE (   UMO(263),  UMOK0(1))
34979        EQUIVALENCE ( PLABF(  1),  PLAPI(1)), ( PLABF( 93),  PLAKC(1))
34980        EQUIVALENCE ( PLABF(161),   PLAP(1)), ( PLABF(200),   PLAN(1))
34981        EQUIVALENCE ( PLABF(263),  PLAK0(1))
34982        EQUIVALENCE (   WK(   1), SPIKP1(1)), (   WK( 316), SPIKPU(1))
34983        EQUIVALENCE (   WK( 594), SPIKPV(1)), (   WK( 966), SPIKPW(1))
34984        EQUIVALENCE (   WK(1244), SPIKPX(1)), (   WK(1616), SPIKP4(1))
34985        EQUIVALENCE (   WK(1931), SPIKP5(1)), (   WK(2118), SPIKP6(1))
34986        EQUIVALENCE (   WK(2407), SKMPEL(1)), (   WK(2509), SPIKP7(1))
34987        EQUIVALENCE (   WK(2798), SKMNEL(1)), (   WK(2866), SPIKP8(1))
34988        EQUIVALENCE (   WK(3053), SPIKP9(1)), (   WK(3196), SPIKP0(1))
34989        EQUIVALENCE (   WK(3365),  SPKPV(1)), (   WK(3508), SAPPEL(1))
34990        EQUIVALENCE (   WK(3613), SPIKPE(1)), (   WK(4012), SAPNEL(1))
34991        EQUIVALENCE (   WK(4096), SPIKPZ(1)), (   WK(4369), SANPEL(1))
34992        EQUIVALENCE (   WK(4453), SPIKPF(1)), (   WK(4726), SPKP15(1))
34993        EQUIVALENCE (   WK(4913), SPKP16(1))
34994        EQUIVALENCE (NRK(1,1), NRKLIN(1))
34995        EQUIVALENCE (NRKLIN(   1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
34996        EQUIVALENCE (NRKLIN( 297),  NRKP(1)), (NRKLIN( 367),  NRKN(1))
34997        EQUIVALENCE (NRKLIN( 483), NRKK0(1))
34998        EQUIVALENCE (NURE(1,1), NURELN(1))
34999 *
35000 **** pi- p data                                                        *
35001 **** pi+ n data                                                        *
35002       DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
35003      & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
35004      & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
35005      & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
35006      & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
35007      & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
35008      & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
35009      & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
35010      & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
35011      & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
35012       DATA PLAKC /
35013      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35014      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35015      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35016      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35017      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35018      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35019      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35020      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35021      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35022      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35023      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35024      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
35025       DATA PLAK0 /
35026      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35027      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35028      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35029      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35030      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35031      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
35032 *                 pp   pn   np   nn                                    *
35033       DATA PLAP /
35034      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35035      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35036      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35037      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35038      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35039      & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
35040 *    app   apn   anp   ann                                             *
35041       DATA PLAN /
35042      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
35043      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35044      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35045      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
35046      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35047      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35048      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
35049      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35050      & 3.43D0, 3.75D0, 4.07D0, 4.43D0  /
35051       DATA SIIN / 296*0.D0 /
35052       DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35053      & 1.557D0,1.615D0,1.6435D0,
35054      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35055      & 2.286D0,2.366D0,2.482D0,2.56D0,
35056      & 2.735D0,2.90D0,
35057      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35058      & 1.496D0,1.527D0,1.557D0,
35059      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35060      & 2.071D0,2.159D0,2.286D0,2.366D0,
35061      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35062      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35063      & 1.496D0,1.527D0,1.557D0,
35064      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35065      & 2.071D0,2.159D0,2.286D0,2.366D0,
35066      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35067      &                   1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35068      & 1.557D0,1.615D0,1.6435D0,
35069      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35070      & 2.286D0,2.366D0,2.482D0,2.56D0,
35071      &  2.735D0, 2.90D0/
35072       DATA UMOKC/ 1.44D0,
35073      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35074      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35075      & 3.1D0,1.44D0,
35076      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35077      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35078      & 3.1D0,1.44D0,
35079      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35080      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35081      & 3.1D0,1.44D0,
35082      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35083      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35084      &  3.1D0/
35085       DATA UMOK0/ 1.44D0,
35086      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35087      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35088      & 3.1D0,1.44D0,
35089      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35090      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35091      &  3.1D0/
35092 *                 pp   pn   np   nn                                    *
35093       DATA UMOP/
35094      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35095      & 3.D0,3.1D0,3.2D0,
35096      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35097      & 3.D0,3.1D0,3.2D0,
35098      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35099      & 3.D0,3.1D0,3.2D0/
35100 *    app   apn   anp   ann                                             *
35101       DATA UMON /
35102      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35103      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35104      & 3.D0,3.1D0,3.2D0,
35105      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35106      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35107      & 3.D0,3.1D0,3.2D0,
35108      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35109      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35110      &  3.D0,3.1D0,3.2D0/
35111 **** reaction channel state particles                                  *
35112       DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
35113      & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
35114      & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
35115      & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
35116      & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
35117      & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
35118      & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
35119      & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
35120      & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
35121      & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
35122       DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
35123      & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
35124      & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
35125      & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
35126      & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
35127      & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
35128      & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
35129      & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
35130 *                                                                      *
35131 *   k0 p   k0 n   ak0 p   ak/ n                                        *
35132 *                                                                      *
35133       DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
35134      & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13,   22, 13, 21, 23,
35135      & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
35136      & 53, 47, 1, 103, 0, 93, 0/
35137 *   pp  pn   np   nn                                                   *
35138       DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
35139      & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
35140      & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
35141      & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
35142 *     app   apn   anp   ann                                            *
35143       DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
35144      & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
35145      & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
35146      & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
35147      & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
35148      & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
35149      & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
35150 **** channel cross section                                             *
35151       DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
35152      & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
35153      & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
35154      & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
35155      & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
35156      &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
35157      & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
35158      & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
35159      &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
35160      & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
35161      & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
35162      & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
35163      & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
35164      & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
35165      & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
35166      & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
35167      & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
35168      & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
35169      & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
35170      & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
35171 **** pi+ n data                                                        *
35172       DATA SPIKPU/   0.D0, 25.D0, 13.D0,  11.D0, 10.5D0, 14.D0,  20.D0,
35173      & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35174      & 10.D0, 10.D0, 9.5D0,  9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35175      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0,   5.5D0,  4.8D0,
35176      & 4.2D0, 7.5D0, 3.4D0,  2.5D0, 2.5D0, 2.1D0, 1.4D0,   1.D0,   .8D0,
35177      &  .6D0, .46D0,  .3D0, .2D0, .15D0, .13D0, 11*0.D0,  .95D0,  .65D0,
35178      & .48D0, .35D0,  .2D0, .18D0, .17D0, .16D0,  .15D0,   .1D0,  .09D0,
35179      & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0,  .2D0,   .1D0,
35180      & .08D0, .06D0, .045D0,   .03D0, .02D0, .01D0,      .005D0, .003D0,
35181      & 12*0.D0, .3D0, .24D0,   .18D0, .15D0, .13D0,  .12D0, .11D0, .1D0,
35182      & .09D0,  .08D0, .05D0,   .04D0, .03D0,  0.D0, 0.16D0, .7D0, 1.3D0,
35183      & 3.1D0,  4.5D0,  2.D0, 18*0.D0, 3*.0D0,  0.D0, 0.D0, 4.0D0, 11.D0,
35184      & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0,  1.5D0, .9D0, .55D0,
35185      &  .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0,   2.25D0, 3.3D0,
35186      & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
35187      & .64D0,  1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0,  4.4D0,   3.D0, 1.8D0,
35188      &  .9D0, .53D0, .28D0,      10*0.D0, 2*0.D0,  .25D0,  .82D0,
35189      & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0,  5.7D0, 3.9D0, 2.35D0, 1.15D0,
35190      & .69D0, .37D0, 10*0.D0,     7*0.D0,   .0D0, .34D0,  1.5D0, 3.47D0,
35191      & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0,  .3D0,  .15D0, 6*0.D0/
35192 *
35193       DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35194      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
35195      & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
35196      & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
35197      & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
35198      & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
35199      & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
35200      & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
35201      & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
35202      & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
35203      & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
35204      & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
35205      & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
35206      & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
35207      & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
35208      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35209      & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
35210      & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
35211      & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
35212      & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
35213 **** pi- p data                                                        *
35214       DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
35215      & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35216      & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35217      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
35218      & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
35219      & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
35220      & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
35221      & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
35222      & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
35223      & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
35224      & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
35225      & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
35226      & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
35227      & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
35228      & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
35229      & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
35230      & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
35231      & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
35232      & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
35233 *
35234       DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35235      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
35236      & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
35237      & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
35238      & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
35239      & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
35240      & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
35241      & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
35242      & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
35243      & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
35244      & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
35245      & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
35246      & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
35247      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35248      & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
35249      & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
35250      & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
35251      & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
35252      & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
35253      & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
35254 **** pi- n data                                                        *
35255       DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
35256      & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
35257      & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
35258      & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
35259      & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
35260      & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
35261      & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
35262      & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
35263      & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
35264      & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
35265      & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
35266      & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
35267      & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
35268      & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
35269      & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
35270      & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
35271      & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
35272      & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
35273      & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
35274      & 3.3D0, 5.4D0, 7.D0 /
35275 **** k+  p data                                                        *
35276       DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
35277      & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35278      & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
35279      & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
35280      & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35281      & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35282      & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
35283      & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
35284      & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
35285      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35286      & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
35287      & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
35288      & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
35289 **** k+  n data                                                        *
35290       DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
35291      & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
35292      & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
35293      & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
35294      & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35295      & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
35296      & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
35297      & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
35298      & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
35299      & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
35300      & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
35301      & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
35302      & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
35303      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35304      & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
35305      & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
35306      & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
35307      & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
35308      & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
35309 **** k-  p data                                                        *
35310       DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
35311      &     7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
35312      &    0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
35313      &    .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
35314      &    0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
35315      &    .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
35316      &    0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
35317      &    .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
35318      &    0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
35319      &    .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
35320      &    0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
35321      &    .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
35322       DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
35323      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35324      & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
35325      & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
35326      & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,  3*0.D0, 1.0D0, 3.03D0,
35327      & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
35328      & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
35329      & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
35330      & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35331      & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
35332      & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
35333      & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
35334      & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35335      & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
35336      & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
35337      & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
35338      & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
35339      & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
35340      & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
35341      & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
35342      & 10*0.D0/
35343 ***** k- n data                                                        *
35344       DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35345      &        3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
35346      &        0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
35347      &        1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
35348      &        0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
35349      &        .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
35350      &        0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
35351      &       .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
35352       DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35353      &  14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35354      &  1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
35355      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35356      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35357      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35358      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35359      &  7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
35360      &  .39D0, .22D0, .07D0, 0.D0,
35361      &  6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35362      &  4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
35363      &  10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
35364      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35365      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35366      &  9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
35367      &  5.10D0, 5.44D0, 5.3D0,
35368      &  4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
35369 *****  p p data                                                        *
35370       DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35371      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35372      &              0.D0, 3.6D0, 1.7D0, 10*0.D0,
35373      &              .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
35374      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35375      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35376      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35377      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35378      &              16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
35379      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
35380      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
35381      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35382      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35383      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35384      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35385 *****  p n data                                                        *
35386       DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35387      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35388      &              0.D0, 1.8D0, .2D0,  12*0.D0,
35389      &              3.2D0, 6.05D0, 9.9D0, 5.1D0,
35390      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35391      &              2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
35392      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35393      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35394      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35395      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35396      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35397      &              10*0.D0, .7D0, 5.1D0, 8.D0,
35398      &              10*0.D0, .7D0, 5.1D0, 8.D0,
35399      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
35400      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
35401      &              7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
35402      &              7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
35403      &              5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
35404 *   nn - data                                                          *
35405 *                                                                      *
35406       DATA SPKPV/  0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35407      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35408      &              0.D0, 3.6D0, 1.7D0, 12*0.D0,
35409      &              8.7D0, 17.7D0, 18.8D0, 15.9D0,
35410      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35411      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35412      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35413      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
35414      &              11.D0, 5.5D0, 3.5D0,
35415      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
35416      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
35417      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35418      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35419      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35420      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35421 ****************   ap - p - data                                       *
35422       DATA SAPPEL/ 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
35423      &  50.D0,  50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35424      &  25.D0,  22.D0, 21.D0, 20.D0, 18.D0, 17.D0,  11*0.D0,
35425      &  .05D0,  .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
35426      &  0.D0,  1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
35427      &  .1D0,  .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35428      &  0.D0,  55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
35429      &  10.D0,  7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
35430      &  1.55D0,  1.3D0, .95D0, .75D0,
35431      &  0.D0,  3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
35432      &  .25D0,  .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35433      & .01D0,  .008D0, .006D0, .005D0/
35434       DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35435      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35436      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
35437      & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
35438      & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
35439      & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
35440      & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
35441      & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
35442      & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
35443      & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
35444      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35445      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35446      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35447      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
35448      & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
35449      & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
35450      & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
35451      & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
35452      & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
35453      & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
35454 ****************   ap - n - data                                       *
35455       DATA SAPNEL/
35456      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0,  68.D0, 65.D0,
35457      & 50.D0, 50.D0,  43.D0,  42.D0,  40.5D0, 35.D0, 30.D0,  28.D0,
35458      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0,  17.D0, 11*0.D0,
35459      & .05D0, .15D0, .18D0,  .2D0,    .2D0,  .3D0,  .4D0,   .6D0,  .7D0,
35460      & .85D0,  0.D0,  1.D0,  .9D0,    .46D0, .3D0,  .23D0, .18D0, .16D0,
35461      & .14D0,  .1D0, .08D0, .05D0,    .02D0, .015D0, 4*.011D0, 3*.005D0,
35462      & 0.D0,  3.3D0,  3.D0, 1.5D0,     1.D0, .7D0,  .4D0,  .35D0, .4D0,
35463      & .25D0, .18D0, .08D0, .04D0,    .03D0, .023D0, .016D0, .014D0,
35464      & .01D0, .008D0, .006D0, .005D0 /
35465        DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35466      &  84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35467      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35468      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35469      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35470      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35471      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35472      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35473      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35474      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35475      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35476      & 4.9D0, 8.5D0,  15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35477      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35478      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35479 *                                                                      *
35480 *                                                                      *
35481 ****************   an - p - data                                       *
35482 *                                                                      *
35483       DATA SANPEL/
35484      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
35485      & 50.D0, 43.D0,  42.D0,  40.5D0, 35.D0, 30.D0, 28.D0,
35486      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0, 17.D0, 11*0.D0, .05D0,
35487      & .15D0, .18D0,   .2D0,   .2D0,   .3D0,  .4D0, .6D0,   .7D0, .85D0,
35488      & 0.D0,   1.D0,   .9D0,  .46D0,  .3D0,  .23D0, .18D0, .16D0, .14D0,
35489      & .1D0,  .08D0,  .05D0,  .02D0, .015D0, 4*.011D0, 3*.005D0,
35490      & 0.D0,  3.3D0,  3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
35491      & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35492      & .01D0, .008D0, .006D0, .005D0 /
35493       DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35494      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35495      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35496      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35497      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35498      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35499      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35500      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35501      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35502      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35503      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35504      & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35505      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35506      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35507 ****  ko - n - data                                                    *
35508       DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
35509      &      6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35510      &      0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
35511      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35512      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35513      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35514      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35515      &    4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
35516      &     1.4D0, 1.2D0, 1.05D0, .9D0, .66D0,  .5D0,
35517      &    7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
35518      &   11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
35519      &    4.85D0, 4.9D0,
35520      &   10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
35521      &    6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
35522      &    2.85D0, 2.35D0, 2.01D0, 1.8D0,
35523      &   12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
35524      &   12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0  /
35525 **** ako - p - data                                                    *
35526       DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35527      & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
35528      & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
35529      & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
35530      & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
35531      & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
35532      & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
35533      & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35534      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
35535      & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
35536      & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
35537      & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
35538      & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
35539      & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35540      & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
35541      & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
35542      & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
35543      & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
35544      & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
35545      & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
35546      & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
35547       DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
35548      & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
35549 *=                                               end*block.blkdt3      *
35550       END
35551
35552 *$ CREATE DT_QEL_POL.FOR
35553 *COPY DT_QEL_POL
35554 *
35555 *===qel_pol============================================================*
35556 *
35557       SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
35558
35559       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35560       SAVE
35561
35562       CALL DT_MASS_INI
35563       CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35564
35565       RETURN
35566       END
35567
35568 *$ CREATE DT_GEN_QEL.FOR
35569 *COPY DT_GEN_QEL
35570 C==================================================================
35571 C   Generation of  a Quasi-Elastic neutrino scattering
35572 C==================================================================
35573 *
35574 *===gen_qel============================================================*
35575 *
35576       SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35577
35578 C...Generate a quasi-elastic   neutrino/antineutrino
35579 C.  Interaction on a nuclear target
35580 C.  INPUT  : LTYP = neutrino type (1,...,6)
35581 C.           ENU (GeV) = neutrino energy
35582 C----------------------------------------------------
35583
35584       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35585       SAVE
35586
35587       PARAMETER ( LINP = 10 ,
35588      &            LOUT = 6 ,
35589      &            LDAT = 9 )
35590       PARAMETER (MAXLND=4000)
35591       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35592 * nuclear potential
35593       LOGICAL LFERMI
35594       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
35595      &                EBINDP(2),EBINDN(2),EPOT(2,210),
35596      &                ETACOU(2),ICOUL,LFERMI
35597 * steering flags for qel neutrino scattering modules
35598       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
35599 **sr - removed (not needed)
35600 C     COMMON /CBAD/  LBAD, NBAD
35601 C     COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
35602 **
35603
35604       DIMENSION PI(3),PO(3)
35605 CJR+
35606       DATA ININU/0/
35607 CJR-
35608 C     REAL*8 DBETA(3)
35609 C     REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
35610       DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
35611       DATA AMN  /0.93827231D0, 0.93956563D0/
35612       DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
35613       DATA INIPRI/0/
35614
35615 C     DATA PFERMI/0.22D0/
35616 CGB+...Binding Energy
35617       DATA EBIND/0.008D0/
35618 CGB-...
35619
35620       ININU=ININU+1
35621       IF(ININU.EQ.1)NDSIG=0
35622       LBAD = 0
35623       enu0=enu
35624 c      write(*,*) enu0
35625 C...Lepton mass
35626       AML = AML0(LTYP)       !  massa leptoni
35627       AML2 = AML**2          !  massa leptoni **2
35628 C...Particle labels (LUND)
35629       N = 5
35630       K(1,1) = 21
35631       K(2,1) = 21
35632       K(3,1) = 21
35633       K(3,3) = 1
35634       K(4,1) = 1
35635       K(4,3) = 1
35636       K(5,1) = 1
35637       K(5,3) = 2
35638       K0 = (LTYP-1)/2          !  2
35639       K1 = LTYP/2              !  2
35640       KA = 12 + 2*K0           !  16
35641       IS = -1 + 2*LTYP - 4*K1  !  -1 +10 -8 = 1
35642       K(1,2) = IS*KA
35643       K(4,2) = IS*(KA-1)
35644       K(3,2) = IS*24
35645       LNU = 2 - LTYP + 2*K1    !  2 - 5 + 2 = - 1
35646       IF (LNU .EQ. 2)  THEN
35647         K(2,2) = 2212
35648         K(5,2) = 2112
35649         AMI = AMN(1)
35650         AMF = AMN(2)
35651 CJR+
35652         PFERMI=PFERMN(2)
35653 CJR-
35654       ELSE
35655         K(2,2) = 2112
35656         K(5,2) = 2212
35657         AMI = AMN(2)
35658         AMF = AMN(1)
35659 CJR+
35660         PFERMI=PFERMP(2)
35661 CJR-
35662       ENDIF
35663       AMI2 = AMI**2
35664       AMF2 = AMF**2
35665
35666       DO IGB=1,5
35667         P(3,IGB) = 0.
35668         P(4,IGB) = 0.
35669         P(5,IGB) = 0.
35670       END DO
35671
35672       NTRY = 0
35673 CGB+...
35674       EFMAX  = SQRT(PFERMI**2 + AMI2) -AMI             ! max. Fermi Energy
35675       ENWELL = EFMAX + EBIND ! depth of nuclear potential well
35676 CGB-...
35677
35678   100 CONTINUE
35679
35680 C...4-momentum initial lepton
35681       P(1,5) = 0.     ! massa
35682       P(1,4) = ENU0    ! energia
35683       P(1,1) = 0.     ! px
35684       P(1,2) = 0.     ! py
35685       P(1,3) = ENU0    ! pz
35686
35687 C     PF = PFERMI*PYR(0)**(1./3.)
35688 c       write(23,*) PYR(0)
35689 c      write(*,*) 'Pfermi=',PF
35690 c      PF = 0.
35691       NTRY=NTRY+1
35692 C     IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
35693       IF (NTRY .GT. 500)  THEN
35694         LBAD = 1
35695         WRITE (LOUT,1001)  NBAD, ENU
35696         RETURN
35697       ENDIF
35698 C     CT = -1. + 2.*PYR(0)
35699 c      CT = -1.
35700 C     ST =  SQRT(1.-CT*CT)
35701 C     F = 2.*3.1415926*PYR(0)
35702 c      F = 0.
35703
35704 C     P(2,4) = SQRT(PF*PF + MI2) - EBIND  ! energia
35705 C     P(2,1) = PF*ST*COS(F)               ! px
35706 C     P(2,2) = PF*ST*SIN(F)               ! py
35707 C     P(2,3) = PF*CT                      ! pz
35708 C     P(2,5) = SQRT(P(2,4)**2-PF*PF)      ! massa
35709        P(2,1) = P21
35710        P(2,2) = P22
35711        P(2,3) = P23
35712        P(2,4) = P24
35713        P(2,5) = P25
35714       beta1=-p(2,1)/p(2,4)
35715       beta2=-p(2,2)/p(2,4)
35716       beta3=-p(2,3)/p(2,4)
35717       N=2
35718 C      WRITE(6,*)' before transforming into target rest frame'
35719       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35720 C      print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35721       N=5
35722
35723       phi11=atan(p(1,2)/p(1,3))
35724       pi(1)=p(1,1)
35725       pi(2)=p(1,2)
35726       pi(3)=p(1,3)
35727
35728       CALL DT_TESTROT(PI,Po,PHI11,1)
35729       DO ll=1,3
35730         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35731       END DO
35732 c        WRITE(*,*) po
35733       p(1,1)=po(1)
35734       p(1,2)=po(2)
35735       p(1,3)=po(3)
35736       phi12=atan(p(1,1)/p(1,3))
35737
35738       pi(1)=p(1,1)
35739       pi(2)=p(1,2)
35740       pi(3)=p(1,3)
35741       CALL DT_TESTROT(Pi,Po,PHI12,2)
35742       DO ll=1,3
35743         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35744       END DO
35745 c        WRITE(*,*) po
35746       p(1,1)=po(1)
35747       p(1,2)=po(2)
35748       p(1,3)=po(3)
35749
35750       enu=p(1,4)
35751
35752 C...Kinematical limits in Q**2
35753 c      S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) !            ????
35754       S = P(2,5)**2 + 2.*ENU*P(2,5)
35755       SQS = SQRT(S)                          ! E centro massa
35756       IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
35757       ELF = (S-AMF2+AML2)/(2.*SQS)           ! energia leptone finale p
35758       PSTAR = (S-P(2,5)**2)/(2.*SQS)       ! p* neutrino nel c.m.
35759       PLF = SQRT(ELF**2-AML2)               ! 3-momento leptone finale
35760       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)    ! + o -
35761       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)    ! according con cos(theta)
35762       IF (Q2MIN .LT. 0.)   Q2MIN = 0.      ! ??? non fisico
35763
35764 C...Generate Q**2
35765       DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
35766   200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35767       DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
35768       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
35769       CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
35770       NDSIG=NDSIG+1
35771 C     WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
35772 C    &Q2,Q2min,Q2MAX,DSIGEV
35773
35774 C...c.m. frame. Neutrino along z axis
35775       DETOT = (P(1,4)) + (P(2,4)) ! e totale
35776       DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
35777       DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
35778       DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
35779 c      WRITE(*,*)
35780 c      WRITE(*,*)
35781 C      WRITE(*,*) 'Input values laboratory frame'
35782       N=2
35783
35784       CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
35785
35786       N=5
35787 c      STHETA = ULANGL(P(1,3),P(1,1))
35788 c      write(*,*) 'stheta' ,stheta
35789 c      stheta=0.
35790 c      CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
35791 c      WRITE(*,*)
35792 c      WRITE(*,*)
35793 C      WRITE(*,*) 'Output values cm frame'
35794 C...Kinematic in c.m. frame
35795       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
35796       STSTAR = SQRT(1.-CTSTAR**2)
35797       PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
35798       P(4,5) = AML                  ! massa leptone
35799       P(4,4) = ELF                 ! e leptone
35800       P(4,3) = PLF*CTSTAR          ! px
35801       P(4,1) = PLF*STSTAR*COS(PHI) ! py
35802       P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
35803
35804       P(5,5) = AMF                  ! barione
35805       P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
35806       P(5,3) = -P(4,3)             ! px
35807       P(5,1) = -P(4,1)             ! py
35808       P(5,2) = -P(4,2)             ! pz
35809
35810       P(3,5) = -Q2
35811       P(3,1) = P(1,1)-P(4,1)
35812       P(3,2) = P(1,2)-P(4,2)
35813       P(3,3) = P(1,3)-P(4,3)
35814       P(3,4) = P(1,4)-P(4,4)
35815
35816 C...Transform back to laboratory  frame
35817 C      WRITE(*,*) 'before going back to nucl rest frame'
35818 c      CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
35819       N=5
35820
35821       CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
35822
35823 C      WRITE(*,*) 'Now back in nucl rest frame'
35824       IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
35825
35826 c********************************************
35827
35828       DO kw=1,5
35829         pi(1)=p(kw,1)
35830         pi(2)=p(kw,2)
35831         pi(3)=p(kw,3)
35832         CALL DT_TESTROT(Pi,Po,PHI12,3)
35833         DO ll=1,3
35834           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35835         END DO
35836         p(kw,1)=po(1)
35837         p(kw,2)=po(2)
35838         p(kw,3)=po(3)
35839       END DO
35840 c********************************************
35841
35842       DO kw=1,5
35843         pi(1)=p(kw,1)
35844         pi(2)=p(kw,2)
35845         pi(3)=p(kw,3)
35846         CALL DT_TESTROT(Pi,Po,PHI11,4)
35847         DO ll=1,3
35848           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35849         END DO
35850         p(kw,1)=po(1)
35851         p(kw,2)=po(2)
35852         p(kw,3)=po(3)
35853       END DO
35854
35855 c********************************************
35856
35857 C      WRITE(*,*) 'Now back in lab frame'
35858
35859       CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35860
35861 CGB+...
35862 C...test (on final momentum of nucleon) if Fermi-blocking
35863 C...is operating
35864       ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
35865      &  - P(5,5)
35866       IF (ENUCL.LT. EFMAX) THEN
35867         IF(INIPRI.LT.10)THEN
35868           INIPRI=INIPRI+1
35869 C         WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
35870 C...the interaction is not possible due to Pauli-Blocking and
35871 C...it must be resampled
35872         ENDIF
35873         GOTO 100
35874       ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
35875         IF(INIPRI.LT.10)THEN
35876           INIPRI=INIPRI+1
35877 C     WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
35878         ENDIF
35879 C                      Reject (J:R) here all these events
35880 C                      are otherwise rejected in dpmjet
35881         GOTO 100
35882 C...the interaction is possible, but the nucleon remains inside
35883 C...the nucleus. The nucleus is therefore left excited.
35884 C...We treat this case as a nucleon with 0 kinetic energy.
35885 C       P(5,5) = AMF
35886 C       P(5,4) = AMF
35887 C       P(5,1) = 0.
35888 C       P(5,2) = 0.
35889 C       P(5,3) = 0.
35890       ELSE IF (ENUCL.GE.ENWELL) THEN
35891 C     WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
35892 C...the interaction is possible, the nucleon can exit the nucleus
35893 C...but the nuclear well depth must be subtracted. The nucleus could be
35894 C...left in an excited state.
35895         Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
35896 C       P(5,4) = ENUCL-ENWELL + AMF
35897         Pnucl = SQRT(P(5,4)**2-AMF**2)
35898 C...The 3-momentum is scaled assuming that the direction remains
35899 C...unaffected
35900         P(5,1) = P(5,1) * Pnucl/Pstart
35901         P(5,2) = P(5,2) * Pnucl/Pstart
35902         P(5,3) = P(5,3) * Pnucl/Pstart
35903 C     WRITE(6,*)' qel new P(5,4) ',P(5,4)
35904       ENDIF
35905 CGB-...
35906       DSIGSU=DSIGSU+DSIGEV
35907
35908          GA=P(4,4)/P(4,5)
35909          BGX=P(4,1)/P(4,5)
35910          BGY=P(4,2)/P(4,5)
35911          BGZ=P(4,3)/P(4,5)
35912 *
35913          DBETB(1)=BGX/GA
35914          DBETB(2)=BGY/GA
35915          DBETB(3)=BGZ/GA
35916          IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
35917
35918             CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
35919
35920          ENDIF
35921 c
35922 C      PRINT*,' FINE   EVENTO '
35923       enu=enu0
35924       RETURN
35925
35926  1001 FORMAT(2X, 'DT_GEN_QEL   : event rejected ', I5,  G10.3)
35927       END
35928
35929 *$ CREATE DT_MASS_INI.FOR
35930 *COPY DT_MASS_INI
35931 C====================================================================
35932 C.  Masses
35933 C====================================================================
35934 *
35935 *===mass_ini===========================================================*
35936 *
35937       SUBROUTINE DT_MASS_INI
35938 C...Initialize  the kinematics for the quasi-elastic cross section
35939
35940       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35941       SAVE
35942
35943 * particle masses used in qel neutrino scattering modules
35944       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
35945      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
35946      &                EMPROTSQ,EMNEUTSQ,EMNSQ
35947
35948       EML(1) = 0.51100D-03   ! e-
35949       EML(2) = EML(1)        ! e+
35950       EML(3) = 0.105659D0      ! mu-
35951       EML(4) = EML(3)        ! mu+
35952       EML(5) = 1.7777D0        ! tau-
35953       EML(6) = EML(5)        ! tau+
35954       EMPROT = 0.93827231D0    ! p
35955       EMNEUT = 0.93956563D0    ! n
35956       EMPROTSQ = EMPROT**2
35957       EMNEUTSQ = EMNEUT**2
35958       EMN = (EMPROT + EMNEUT)/2.
35959       EMNSQ = EMN**2
35960       DO J=1,3
35961         J0 = 2*(J-1)
35962         EMN1(J0+1) = EMNEUT
35963         EMN1(J0+2) = EMPROT
35964         EMN2(J0+1) = EMPROT
35965         EMN2(J0+2) = EMNEUT
35966       ENDDO
35967       DO J=1,6
35968         EMLSQ(J) = EML(J)**2
35969         ETQE(J)  = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
35970       ENDDO
35971       RETURN
35972       END
35973
35974 *$ CREATE DT_DSQEL_Q2.FOR
35975 *COPY DT_DSQEL_Q2
35976 *
35977 *===dsqel_q2===========================================================*
35978 *
35979       DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
35980
35981 C...differential cross section for  Quasi-Elastic scattering
35982 C.       nu + N -> l + N'
35983 C.  From Llewellin Smith  Phys.Rep.  3C, 261, (1971).
35984 C.
35985 C.  INPUT :  JTYP = 1,...,6    nu_e, ...., nubar_tau
35986 C.           ENU (GeV) =  Neutrino energy
35987 C.           Q2  (GeV**2) =  (Transfer momentum)**2
35988 C.
35989 C.  OUTPUT : DSQEL_Q2  = differential  cross section :
35990 C.                       dsigma/dq**2  (10**-38 cm+2/GeV**2)
35991 C------------------------------------------------------------------
35992
35993       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35994       SAVE
35995
35996 * particle masses used in qel neutrino scattering modules
35997       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
35998      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
35999      &                EMPROTSQ,EMNEUTSQ,EMNSQ
36000 **sr - removed (not needed)
36001 C     COMMON /CAXIAL/ FA0, AXIAL2
36002 **
36003
36004       DIMENSION SS(6)
36005       DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
36006       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
36007       DATA AXIAL2 /1.03D0/  ! to be checked
36008
36009       FA0=-1.253D0
36010       CSI = 3.71D0                   !  ???
36011       GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2   ! G_e(q**2)
36012       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
36013       X = Q2/(EMN*EMN)     ! emn=massa barione
36014       XA = X/4.D0
36015       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
36016       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
36017       FA = FA0/(1.D0 + Q2/AXIAL2)**2
36018       FFA = FA*FA
36019       FFV1 = FV1*FV1
36020       FFV2 = FV2*FV2
36021       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
36022       A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
36023       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
36024       AA = (XA+0.25D0*RM)*(A1 + A2)
36025       BB = -X*FA*(FV1 + FV2)
36026       CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
36027       SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
36028       DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU)  !
36029       IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
36030
36031       RETURN
36032       END
36033
36034 *$ CREATE DT_PREPOLA.FOR
36035 *COPY DT_PREPOLA
36036 *
36037 *===prepola============================================================*
36038 *
36039       SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
36040
36041       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36042       SAVE
36043 c
36044 c By G. Battistoni and E. Scapparone (sept. 1997)
36045 c According to:
36046 c     Albright & Jarlskog, Nucl Phys B84 (1975) 467
36047 c
36048 c
36049       PARAMETER (MAXLND=4000)
36050       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36051       COMMON /QNPOL/ POLARX(4),PMODUL
36052 * particle masses used in qel neutrino scattering modules
36053       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
36054      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
36055      &                EMPROTSQ,EMNEUTSQ,EMNSQ
36056 * steering flags for qel neutrino scattering modules
36057       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
36058 **sr - removed (not needed)
36059 C     COMMON /CAXIAL/ FA0, AXIAL2
36060 C     COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
36061 C    &        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
36062 **
36063       REAL*8 POL(4,4),BB2(3)
36064       DIMENSION SS(6)
36065 C     DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
36066       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
36067 **sr uncommented since common block CAXIAL is now commented
36068       DATA AXIAL2 /1.03D0/  ! to be checked
36069 **
36070
36071       RML=P(4,5)
36072       RMM=0.93960D+00
36073       FM2 = RMM**2
36074       MPI = 0.135D+00
36075       OLDQ2=Q2
36076       FA0=-1.253D+00
36077       CSI = 3.71D+00                      !
36078       GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2   ! G_e(q**2)
36079       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
36080       X = Q2/(EMN*EMN)     ! emn=massa barione
36081       XA = X/4.D0
36082       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
36083       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
36084       FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
36085       FFA = FA*FA
36086       FFV1 = FV1*FV1
36087       FFV2 = FV2*FV2
36088       FP=2.D0*FA*RMM/(MPI**2 + Q2)
36089       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
36090       A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
36091       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
36092       AA = (XA+0.25D+00*RM)*(A1 + A2)
36093       BB = -X*FA*(FV1 + FV2)
36094       CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
36095       SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
36096
36097       OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2   )  ! articolo di ll...-smith
36098       OMEGA2=4.D+00*CC
36099       OMEGA3=2.D+00*FA*(FV1+FV2)
36100       OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
36101      1     (Q2/FM2))*FP**2)
36102       OMEGA5=OMEGA2
36103       OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
36104       WW1=2.D+00*OMEGA1*EMN**2
36105       WW2=2.D+00*OMEGA2*EMN**2
36106       WW3=2.D+00*OMEGA3*EMN**2
36107       WW4=2.D+00*OMEGA4*EMN**2
36108       WW5=2.D+00*OMEGA5*EMN**2
36109
36110       DO I=1,3
36111         BB2(I)=-P(4,I)/P(4,4)
36112       END DO
36113 c      WRITE(*,*)
36114 c      WRITE(*,*)
36115 c      WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
36116       N=5
36117       CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
36118 * NOW PARTICLES ARE IN THE SCATTERED LEPTON  REST FRAME
36119 c      WRITE(*,*)
36120 c      WRITE(*,*)
36121 c      WRITE(*,*) 'Prepola: now in lepton rest frame'
36122       EE=ENU
36123       QM2=Q2+RML**2
36124       U=Q2/(2.*RMM)
36125       FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
36126      +     (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
36127      +     ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
36128
36129       FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
36130      +     - ((RML**2)/FM2)*WW4                        !<=FM2 inv di RMM!!
36131
36132       FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
36133
36134       DO I=1,3
36135         POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
36136         POLARX(I)=POL(4,I)
36137       END DO
36138
36139       PMODUL=0.D0
36140       DO I=1,3
36141         PMODUL=PMODUL+POL(4,I)**2
36142       END DO
36143
36144       IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
36145          IF(NEUDEC.EQ.1) THEN
36146             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
36147      +        ETL,PXL,PYL,PZL,
36148      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36149 c
36150 c     Tau has decayed in muon
36151 c
36152          ENDIF
36153          IF(NEUDEC.EQ.2) THEN
36154             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
36155      +        ETL,PXL,PYL,PZL,
36156      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36157 c
36158 c     Tau has decayed in electron
36159 c
36160          ENDIF
36161          K(4,1)=15
36162          K(4,4) = 6
36163          K(4,5) = 8
36164          N=N+3
36165 c
36166 c     fill common for muon(electron)
36167 c
36168          P(6,1)=PXL
36169          P(6,2)=PYL
36170          P(6,3)=PZL
36171          P(6,4)=ETL
36172          K(6,1)=1
36173          IF(JTYP.EQ.5) THEN
36174             IF(NEUDEC.EQ.1) THEN
36175                P(6,5)=EML(JTYP-2)
36176                K(6,2)=13
36177             ELSEIF(NEUDEC.EQ.2) THEN
36178                P(6,5)=EML(JTYP-4)
36179                K(6,2)=11
36180             ENDIF
36181          ELSEIF(JTYP.EQ.6) THEN
36182             IF(NEUDEC.EQ.1) THEN
36183                K(6,2)=-13
36184             ELSEIF(NEUDEC.EQ.2) THEN
36185                K(6,2)=-11
36186             ENDIF
36187          END IF
36188          K(6,3)=4
36189          K(6,4)=0
36190          K(6,5)=0
36191 c
36192 c     fill common for tau_(anti)neutrino
36193 c
36194          P(7,1)=PXB
36195          P(7,2)=PYB
36196          P(7,3)=PZB
36197          P(7,4)=ETB
36198          P(7,5)=0.
36199          K(7,1)=1
36200          IF(JTYP.EQ.5) THEN
36201             K(7,2)=16
36202          ELSEIF(JTYP.EQ.6) THEN
36203             K(7,2)=-16
36204          END IF
36205          K(7,3)=4
36206          K(7,4)=0
36207          K(7,5)=0
36208 c
36209 c     Fill common for muon(electron)_(anti)neutrino
36210 c
36211          P(8,1)=PXN
36212          P(8,2)=PYN
36213          P(8,3)=PZN
36214          P(8,4)=ETN
36215          P(8,5)=0.
36216          K(8,1)=1
36217          IF(JTYP.EQ.5) THEN
36218             IF(NEUDEC.EQ.1) THEN
36219                K(8,2)=-14
36220             ELSEIF(NEUDEC.EQ.2) THEN
36221                K(8,2)=-12
36222             ENDIF
36223          ELSEIF(JTYP.EQ.6) THEN
36224             IF(NEUDEC.EQ.1) THEN
36225                K(8,2)=14
36226             ELSEIF(NEUDEC.EQ.2) THEN
36227                K(8,2)=12
36228             ENDIF
36229          END IF
36230          K(8,3)=4
36231          K(8,4)=0
36232          K(8,5)=0
36233       ENDIF
36234 c      WRITE(*,*)
36235 c      WRITE(*,*)
36236
36237 c      IF(PMODUL.GE.1.D+00) THEN
36238 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36239 c        write(*,*) pmodul
36240 c        DO I=1,3
36241 c          POL(4,I)=POL(4,I)/PMODUL
36242 c          POLARX(I)=POL(4,I)
36243 c        END DO
36244 c        PMODUL=0.
36245 c        DO I=1,3
36246 c          PMODUL=PMODUL+POL(4,I)**2
36247 c        END DO
36248 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36249 c
36250 c      ENDIF
36251
36252 c      WRITE(*,*) 'PMODUL = ',PMODUL
36253
36254 c      WRITE(*,*)
36255 c      WRITE(*,*)
36256 c      WRITE(*,*) 'prepola: Now back to nucl rest frame'
36257       CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
36258
36259       XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
36260       YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
36261       ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
36262       DO NDC =6,8
36263          V(NDC,1) = XDC
36264          V(NDC,2) = YDC
36265          V(NDC,3) = ZDC
36266       END DO
36267
36268       RETURN
36269       END
36270
36271 *$ CREATE DT_TESTROT.FOR
36272 *COPY DT_TESTROT
36273 *
36274 *===testrot============================================================*
36275 *
36276       SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
36277
36278       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36279       SAVE
36280
36281       DIMENSION ROT(3,3),PI(3),PO(3)
36282
36283       IF (MODE.EQ.1) THEN
36284          ROT(1,1) = 1.D0
36285          ROT(1,2) = 0.D0
36286          ROT(1,3) = 0.D0
36287          ROT(2,1) = 0.D0
36288          ROT(2,2) = COS(PHI)
36289          ROT(2,3) = -SIN(PHI)
36290          ROT(3,1) = 0.D0
36291          ROT(3,2) = SIN(PHI)
36292          ROT(3,3) = COS(PHI)
36293       ELSEIF (MODE.EQ.2) THEN
36294          ROT(1,1) = 0.D0
36295          ROT(1,2) = 1.D0
36296          ROT(1,3) = 0.D0
36297          ROT(2,1) = COS(PHI)
36298          ROT(2,2) = 0.D0
36299          ROT(2,3) = -SIN(PHI)
36300          ROT(3,1) = SIN(PHI)
36301          ROT(3,2) = 0.D0
36302          ROT(3,3) = COS(PHI)
36303       ELSEIF (MODE.EQ.3) THEN
36304          ROT(1,1) = 0.D0
36305          ROT(2,1) = 1.D0
36306          ROT(3,1) = 0.D0
36307          ROT(1,2) = COS(PHI)
36308          ROT(2,2) = 0.D0
36309          ROT(3,2) = -SIN(PHI)
36310          ROT(1,3) = SIN(PHI)
36311          ROT(2,3) = 0.D0
36312          ROT(3,3) = COS(PHI)
36313       ELSEIF (MODE.EQ.4) THEN
36314          ROT(1,1) = 1.D0
36315          ROT(2,1) = 0.D0
36316          ROT(3,1) = 0.D0
36317          ROT(1,2) = 0.D0
36318          ROT(2,2) = COS(PHI)
36319          ROT(3,2) = -SIN(PHI)
36320          ROT(1,3) = 0.D0
36321          ROT(2,3) = SIN(PHI)
36322          ROT(3,3) = COS(PHI)
36323       ELSE
36324          STOP ' TESTROT: mode not supported!'
36325       ENDIF
36326       DO 1 J=1,3
36327         PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
36328     1 CONTINUE
36329
36330       RETURN
36331       END
36332
36333 *$ CREATE DT_LEPDCYP.FOR
36334 *COPY DT_LEPDCYP
36335 *
36336 *===lepdcyp============================================================*
36337 *
36338       SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
36339      &                      ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36340 C
36341 C-----------------------------------------------------------------
36342 C
36343 C   Author   :- G. Battistoni         10-NOV-1995
36344 C
36345 C=================================================================
36346 C
36347 C   Purpose   : performs decay of polarized lepton in
36348 C               its rest frame: a => b + l + anti-nu
36349 C               (Example: mu- => nu-mu + e- + anti-nu-e)
36350 C               Polarization is assumed along Z-axis
36351 C               WARNING:
36352 C               1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
36353 C                  OF NEGLIGIBLE MASS
36354 C               2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
36355 C                  IN THIS VERSION
36356 C
36357 C   Method    : modifies phase space distribution obtained
36358 C               by routine EXPLOD using a rejection against the
36359 C               matrix element for unpolarized lepton decay
36360 C
36361 C   Inputs    : Mass of a :  AMA
36362 C               Mass of l :  AML
36363 C               Polar. of a: POL
36364 C               (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
36365 C                                                 POL = -1)
36366 C
36367 C   Outputs   : kinematic variables in the rest frame of decaying lepton
36368 C               ETL,PXL,PYL,PZL 4-moment of l
36369 C               ETB,PXB,PYB,PZB 4-moment of b
36370 C               ETN,PXN,PYN,PZN 4-moment of anti-nu
36371 C
36372 C============================================================
36373 C +
36374 C Declarations.
36375 C -
36376       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36377       SAVE
36378
36379       PARAMETER ( LINP = 10 ,
36380      &            LOUT = 6 ,
36381      &            LDAT = 9 )
36382       PARAMETER ( KALGNM = 2 )
36383       PARAMETER ( ANGLGB = 5.0D-16 )
36384       PARAMETER ( ANGLSQ = 2.5D-31 )
36385       PARAMETER ( AXCSSV = 0.2D+16 )
36386       PARAMETER ( ANDRFL = 1.0D-38 )
36387       PARAMETER ( AVRFLW = 1.0D+38 )
36388       PARAMETER ( AINFNT = 1.0D+30 )
36389       PARAMETER ( AZRZRZ = 1.0D-30 )
36390       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
36391       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
36392       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
36393       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
36394       PARAMETER ( CSNNRM = 2.0D-15 )
36395       PARAMETER ( DMXTRN = 1.0D+08 )
36396       PARAMETER ( ZERZER = 0.D+00 )
36397       PARAMETER ( ONEONE = 1.D+00 )
36398       PARAMETER ( TWOTWO = 2.D+00 )
36399       PARAMETER ( THRTHR = 3.D+00 )
36400       PARAMETER ( FOUFOU = 4.D+00 )
36401       PARAMETER ( FIVFIV = 5.D+00 )
36402       PARAMETER ( SIXSIX = 6.D+00 )
36403       PARAMETER ( SEVSEV = 7.D+00 )
36404       PARAMETER ( EIGEIG = 8.D+00 )
36405       PARAMETER ( ANINEN = 9.D+00 )
36406       PARAMETER ( TENTEN = 10.D+00 )
36407       PARAMETER ( HLFHLF = 0.5D+00 )
36408       PARAMETER ( ONETHI = ONEONE / THRTHR )
36409       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
36410       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
36411       PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
36412       PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
36413       PARAMETER ( CLIGHT = 2.99792458         D+10 )
36414       PARAMETER ( AVOGAD = 6.0221367          D+23 )
36415       PARAMETER ( AMELGR = 9.1093897          D-28 )
36416       PARAMETER ( PLCKBR = 1.05457266         D-27 )
36417       PARAMETER ( ELCCGS = 4.8032068          D-10 )
36418       PARAMETER ( ELCMKS = 1.60217733         D-19 )
36419       PARAMETER ( AMUGRM = 1.6605402          D-24 )
36420       PARAMETER ( AMMUMU = 0.113428913        D+00 )
36421       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
36422       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
36423       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
36424       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
36425       PARAMETER ( PLABRC = 0.197327053        D+00 )
36426       PARAMETER ( AMELCT = 0.51099906         D-03 )
36427       PARAMETER ( AMUGEV = 0.93149432         D+00 )
36428       PARAMETER ( AMMUON = 0.105658389        D+00 )
36429       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
36430       PARAMETER ( GEVMEV = 1.0                D+03 )
36431       PARAMETER ( EMVGEV = 1.0                D-03 )
36432       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
36433       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
36434       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
36435 C +
36436 C    variables for EXPLOD
36437 C -
36438       PARAMETER ( KPMX = 10 )
36439       DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
36440      &          PZEXPL (KPMX), ETEXPL (KPMX)
36441 C +
36442 C      test variables
36443 C -
36444 **sr - removed (not needed)
36445 C     COMMON /GBATNU/ ELERAT,NTRY
36446 **
36447 C +
36448 C     Initializes test variables
36449 C -
36450       NTRY = 0
36451       ELERAT = 0.D+00
36452 C +
36453 C     Maximum value for matrix element
36454 C -
36455       ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
36456      &  SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
36457 C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
36458 C     Inputs for EXPLOD
36459 C part. no. 1 is l       (e- in mu- decay)
36460 C part. no. 2 is b       (nu-mu in mu- decay)
36461 C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
36462 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
36463       NPEXPL = 3
36464       ETOTEX = AMA
36465       AMEXPL(1) = AML
36466       AMEXPL(2) = 0.D+00
36467       AMEXPL(3) = 0.D+00
36468 C +
36469 C     phase space distribution
36470 C -
36471   100 CONTINUE
36472       NTRY = NTRY + 1
36473
36474       CALL DT_EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
36475      &                 PYEXPL, PZEXPL )
36476
36477 C +
36478 C  Calculates matrix element:
36479 C  64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
36480 C  Here CTH is the cosine of the angle between anti-nu and Z axis
36481 C -
36482       CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
36483      &  PZEXPL(3)**2 )
36484       PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
36485       PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
36486      &     PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
36487       ELEMAT = 16.D+00 * PROD1 * PROD2
36488       IF(ELEMAT.GT.ELEMAX) THEN
36489         WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
36490         STOP
36491       ENDIF
36492 C +
36493 C     Here performs the rejection
36494 C -
36495       TEST = DT_RNDM(ETOTEX) * ELEMAX
36496       IF ( TEST .GT. ELEMAT ) GO TO 100
36497 C +
36498 C     final assignment of variables
36499 C -
36500       ELERAT = ELEMAT/ELEMAX
36501       ETL = ETEXPL(1)
36502       PXL = PXEXPL(1)
36503       PYL = PYEXPL(1)
36504       PZL = PZEXPL(1)
36505       ETB = ETEXPL(2)
36506       PXB = PXEXPL(2)
36507       PYB = PYEXPL(2)
36508       PZB = PZEXPL(2)
36509       ETN = ETEXPL(3)
36510       PXN = PXEXPL(3)
36511       PYN = PYEXPL(3)
36512       PZN = PZEXPL(3)
36513   999 RETURN
36514       END
36515
36516 *$ CREATE DT_GEN_DELTA.FOR
36517 *COPY DT_GEN_DELTA
36518 C==================================================================
36519 C.  Generation of  Delta resonance events
36520 C==================================================================
36521 *
36522 *===gen_delta==========================================================*
36523 *
36524       SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
36525
36526       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36527       SAVE
36528
36529       PARAMETER ( LINP = 10 ,
36530      &            LOUT = 6 ,
36531      &            LDAT = 9 )
36532 C...Generate a Delta-production neutrino/antineutrino
36533 C.  CC-interaction on a nucleon
36534 C
36535 C.  INPUT  ENU (GeV) = Neutrino Energy
36536 C.         LLEP = neutrino type
36537 C.         LTARG = nucleon target type 1=p, 2=n.
36538 C.         JINT = 1:CC, 2::NC
36539 C.
36540 C.  OUTPUT PPL(4)  4-monentum of final lepton
36541 C----------------------------------------------------
36542       PARAMETER (MAXLND=4000)
36543       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36544 **sr - removed (not needed)
36545 C     COMMON /CBAD/  LBAD, NBAD
36546 **
36547
36548       DIMENSION PI(3),PO(3)
36549 C     REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
36550       DIMENSION AML0(6),AMN(2)
36551       DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
36552       DATA AMN  /0.93827231, 0.93956563/
36553       DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
36554
36555 c     WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
36556       LBAD = 0
36557 C...Final lepton mass
36558       IF (JINT.EQ.1) THEN
36559         AML = AML0(LLEP)
36560       ELSE
36561         AML = 0.
36562       ENDIF
36563       AML2 = AML**2
36564
36565 C...Particle labels (LUND)
36566       N = 5
36567       K(1,1) = 21
36568       K(2,1) = 21
36569       K(3,1) = 21
36570       K(4,1) = 1
36571       K(3,3) = 1
36572       K(4,3) = 1
36573       IF (LTARG .EQ. 1)  THEN
36574          K(2,2) = 2212
36575       ELSE
36576          K(2,2) = 2112
36577       ENDIF
36578       K0 = (LLEP-1)/2
36579       K1 = LLEP/2
36580       KA = 12 + 2*K0
36581       IS = -1 + 2*LLEP - 4*K1
36582       LNU = 2 - LLEP + 2*K1
36583       K(1,2) = IS*KA
36584       K(5,1) = 1
36585       K(5,3) = 2
36586       IF (JINT .EQ. 1)  THEN                    ! CC interactions
36587          K(3,2) = IS*24
36588          K(4,2) = IS*(KA-1)
36589         IF(LNU.EQ.1) THEN
36590           IF (LTARG .EQ. 1)  THEN
36591               K(5,2) = 2224
36592           ELSE
36593               K(5,2) = 2214
36594           ENDIF
36595         ELSE
36596           IF (LTARG .EQ. 1)  THEN
36597               K(5,2) = 2114
36598           ELSE
36599               K(5,2) = 1114
36600           ENDIF
36601         ENDIF
36602       ELSE
36603          K(3,2) = 23                           ! NC (Z0) interactions
36604          K(4,2) = K(1,2)
36605 **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
36606 *                                Delta0 for neutron (LTARG=2)
36607 C        IF (LTARG .EQ. 1)  THEN
36608 C           K(5,2) = 2114
36609 C        ELSE
36610 C           K(5,2) = 2214
36611 C        ENDIF
36612          IF (LTARG .EQ. 1)  THEN
36613             K(5,2) = 2214
36614          ELSE
36615             K(5,2) = 2114
36616          ENDIF
36617 **
36618       ENDIF
36619
36620 C...4-momentum initial lepton
36621       P(1,5) = 0.
36622       P(1,4) = ENU
36623       P(1,1) = 0.
36624       P(1,2) = 0.
36625       P(1,3) = ENU
36626 C...4-momentum initial nucleon
36627       P(2,5) = AMN(LTARG)
36628 C     P(2,4) = P(2,5)
36629 C     P(2,1) = 0.
36630 C     P(2,2) = 0.
36631 C     P(2,3) = 0.
36632        P(2,1) = P21
36633        P(2,2) = P22
36634        P(2,3) = P23
36635        P(2,4) = P24
36636        P(2,5) = P25
36637       N=2
36638       beta1=-p(2,1)/p(2,4)
36639       beta2=-p(2,2)/p(2,4)
36640       beta3=-p(2,3)/p(2,4)
36641       N=2
36642
36643       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
36644
36645 C     print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
36646
36647       phi11=atan(p(1,2)/p(1,3))
36648       pi(1)=p(1,1)
36649       pi(2)=p(1,2)
36650       pi(3)=p(1,3)
36651
36652       CALL DT_TESTROT(PI,Po,PHI11,1)
36653       DO ll=1,3
36654        IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36655       END DO
36656       p(1,1)=po(1)
36657       p(1,2)=po(2)
36658       p(1,3)=po(3)
36659       phi12=atan(p(1,1)/p(1,3))
36660
36661       pi(1)=p(1,1)
36662       pi(2)=p(1,2)
36663       pi(3)=p(1,3)
36664       CALL DT_TESTROT(Pi,Po,PHI12,2)
36665       DO ll=1,3
36666         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36667       END DO
36668       p(1,1)=po(1)
36669       p(1,2)=po(2)
36670       p(1,3)=po(3)
36671
36672       ENUU=P(1,4)
36673
36674 C...Generate the Mass of the Delta
36675       NTRY = 0
36676 100   R = PYR(0)
36677       AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
36678       NTRY = NTRY + 1
36679       IF (NTRY .GT. 1000)  THEN
36680          LBAD = 1
36681          WRITE (LOUT,1001)  NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
36682          RETURN
36683       ENDIF
36684       IF (AMD .LT. AMDMIN)  GOTO 100
36685       ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
36686       IF (ENUU .LT. ET) GOTO 100
36687
36688 C...Kinematical  limits in Q**2
36689       S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
36690       SQS = SQRT(S)
36691       PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
36692       ELF = (S - AMD**2 + AML2)/(2.*SQS)
36693       PLF = SQRT(ELF**2 - AML2)
36694       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
36695       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
36696       IF (Q2MIN .LT. 0.)   Q2MIN = 0.
36697
36698       DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
36699 200   Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
36700       DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
36701       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
36702
36703 C...Generate the kinematics of the final particles
36704       EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
36705       GAM = EISTAR/AMN(LTARG)
36706       BET = PSTAR/EISTAR
36707       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
36708       EL  = GAM*(ELF + BET*PLF*CTSTAR)
36709       PLZ = GAM*(PLF*CTSTAR + BET*ELF)
36710       PL  = SQRT(EL**2 - AML2)
36711       PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
36712       PHI = 6.28319*PYR(0)
36713       P(4,1) = PLT*COS(PHI)
36714       P(4,2) = PLT*SIN(PHI)
36715       P(4,3) = PLZ
36716       P(4,4) = EL
36717       P(4,5) = AML
36718
36719 C...4-momentum of Delta
36720       P(5,1) = -P(4,1)
36721       P(5,2) = -P(4,2)
36722       P(5,3) = ENUU-P(4,3)
36723       P(5,4) = ENUU+AMN(LTARG)-P(4,4)
36724       P(5,5) = AMD
36725
36726 C...4-momentum  of intermediate boson
36727       P(3,5) = -Q2
36728       P(3,4) = P(1,4)-P(4,4)
36729       P(3,1) = P(1,1)-P(4,1)
36730       P(3,2) = P(1,2)-P(4,2)
36731       P(3,3) = P(1,3)-P(4,3)
36732       N=5
36733
36734       DO kw=1,5
36735         pi(1)=p(kw,1)
36736         pi(2)=p(kw,2)
36737         pi(3)=p(kw,3)
36738         CALL DT_TESTROT(Pi,Po,PHI12,3)
36739         DO ll=1,3
36740           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36741         END DO
36742         p(kw,1)=po(1)
36743         p(kw,2)=po(2)
36744         p(kw,3)=po(3)
36745       END DO
36746
36747 c********************************************
36748
36749         DO kw=1,5
36750           pi(1)=p(kw,1)
36751           pi(2)=p(kw,2)
36752           pi(3)=p(kw,3)
36753           CALL DT_TESTROT(Pi,Po,PHI11,4)
36754           DO ll=1,3
36755             IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36756           END DO
36757           p(kw,1)=po(1)
36758           p(kw,2)=po(2)
36759           p(kw,3)=po(3)
36760        END DO
36761 c********************************************
36762 C         transform back into Lab.
36763
36764       CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
36765
36766 C     WRITE(6,*)' Lab fram ( fermi incl.) '
36767       N=5
36768       CALL PYEXEC
36769
36770       RETURN
36771 1001  FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5,  6G10.3)
36772       END
36773
36774 *$ CREATE DT_DSIGMA_DELTA.FOR
36775 *COPY DT_DSIGMA_DELTA
36776 *
36777 *===dsigma_delta=======================================================*
36778 *
36779       DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
36780
36781       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36782       SAVE
36783
36784 C...Reaction nu + N -> lepton + Delta
36785 C.  returns the  cross section
36786 C.  dsigma/dt
36787 C.  INPUT  LNU = 1, 2  (neutrino-antineutrino)
36788 C.         QQ = t (always negative)  GeV**2
36789 C.         S  = (c.m energy)**2      GeV**2
36790 C.  OUTPUT =  10**-38 cm+2/GeV**2
36791 C-----------------------------------------------------
36792       REAL*8 MN, MN2, MN4, MD,MD2, MD4
36793       DATA MN /0.938/
36794       DATA PI /3.1415926/
36795
36796       GF = (1.1664 * 1.97)
36797       GF2 = GF*GF
36798       MN2 = MN*MN
36799       MN4 = MN2*MN2
36800       MD2 = MD*MD
36801       MD4 = MD2*MD2
36802       AML2 = AML*AML
36803       AML4 = AML2*AML2
36804       VQ  = (MN2 - MD2 - QQ)/2.
36805       VPI = (MN2 + MD2 - QQ)/2.
36806       VK  = (S + QQ - MN2 - AML2)/2.
36807       PIK = (S - MN2)/2.
36808       QK = (AML2 - QQ)/2.
36809       PIQ = (QQ + MN2 - MD2)/2.
36810       Q = SQRT(-QQ)
36811       C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
36812       C3 = SQRT(3.)*C3V/MN
36813       C4 = -C3/MD             ! attenzione al segno
36814       C5A = 1.18/(1.-QQ/0.4225)**2
36815       C32 = C3**2
36816       C42 = C4**2
36817       C5A2 = C5A**2
36818
36819       IF (LNU .EQ. 1)  THEN
36820       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36821      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36822      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36823      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36824       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36825      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36826      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36827      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36828      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36829      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
36830      . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36831      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36832      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36833      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36834      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
36835      . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
36836      . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
36837      . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
36838      . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
36839      . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36840      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36841      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36842      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36843       ELSE
36844       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36845      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36846      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36847      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36848       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36849      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36850      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36851      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36852      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36853      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
36854      . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36855      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36856      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36857      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36858      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
36859      . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
36860      . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
36861      . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
36862      . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
36863      . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36864      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36865      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36866      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36867       ENDIF
36868       ANS1=32.*ANS2
36869       ANS=ANS1/(3.*MD2)
36870       P1CM = (S-MN2)/(2.*SQRT(S))
36871       DT_DSIGMA_DELTA  = GF2/2. * ANS/(64.*PI*S*P1CM**2)
36872
36873       RETURN
36874       END
36875
36876 *$ CREATE DT_QGAUS.FOR
36877 *COPY DT_QGAUS
36878 *
36879 *===qgaus==============================================================*
36880 *
36881       SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
36882
36883       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36884       SAVE
36885
36886       DIMENSION X(5),W(5)
36887       DATA X/.1488743389D0,.4333953941D0,
36888      & .6794095682D0,.8650633666D0,.9739065285D0
36889      */
36890       DATA W/.2955242247D0,.2692667193D0,
36891      & .2190863625D0,.1494513491D0,.0666713443D0
36892      */
36893       XM=0.5D0*(B+A)
36894       XR=0.5D0*(B-A)
36895       SS=0
36896       DO 11 J=1,5
36897         DX=XR*X(J)
36898         SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
36899      *  DT_DSQEL_Q2(LTYP,ENU,XM-DX))
36900 11    CONTINUE
36901       SS=XR*SS
36902
36903       RETURN
36904       END
36905
36906 *$ CREATE DT_DIQBRK.FOR
36907 *COPY DT_DIQBRK
36908 *
36909 *===diqbrk=============================================================*
36910 *
36911       SUBROUTINE DT_DIQBRK
36912
36913       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36914       SAVE
36915
36916 * event history
36917       PARAMETER (NMXHKK=200000)
36918       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36919      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36920      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36921 * extended event history
36922       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36923      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36924      &                IHIST(2,NMXHKK)
36925 * event flag
36926       COMMON /DTEVNO/ NEVENT,ICASCA
36927
36928 C     IF(DT_RNDM(VV).LE.0.5D0)THEN
36929 C       CALL GSQBS1(NHKK)
36930 C       CALL GSQBS2(NHKK)
36931 C       CALL USQBS1(NHKK)
36932 C       CALL USQBS2(NHKK)
36933 C       CALL GSABS1(NHKK)
36934 C       CALL GSABS2(NHKK)
36935 C       CALL USABS1(NHKK)
36936 C       CALL USABS2(NHKK)
36937 C     ELSE
36938 C       CALL GSQBS2(NHKK)
36939 C       CALL GSQBS1(NHKK)
36940 C       CALL USQBS2(NHKK)
36941 C       CALL USQBS1(NHKK)
36942 C       CALL GSABS2(NHKK)
36943 C       CALL GSABS1(NHKK)
36944 C       CALL USABS2(NHKK)
36945 C       CALL USABS1(NHKK)
36946 C     ENDIF
36947
36948       IF(DT_RNDM(VV).LE.0.5D0) THEN
36949         CALL DT_DBREAK(1)
36950         CALL DT_DBREAK(2)
36951         CALL DT_DBREAK(3)
36952         CALL DT_DBREAK(4)
36953         CALL DT_DBREAK(5)
36954         CALL DT_DBREAK(6)
36955         CALL DT_DBREAK(7)
36956         CALL DT_DBREAK(8)
36957       ELSE
36958         CALL DT_DBREAK(2)
36959         CALL DT_DBREAK(1)
36960         CALL DT_DBREAK(4)
36961         CALL DT_DBREAK(3)
36962         CALL DT_DBREAK(6)
36963         CALL DT_DBREAK(5)
36964         CALL DT_DBREAK(8)
36965         CALL DT_DBREAK(7)
36966       ENDIF
36967
36968       RETURN
36969       END
36970
36971 *$ CREATE MUSQBS2.FOR
36972 *COPY MUSQBS2
36973 C
36974 C
36975 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36976       SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36977      *              IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
36978 C
36979 C                  USQBS-2 diagram (split target diquark)
36980 C
36981       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36982       SAVE
36983
36984       PARAMETER ( LINP = 10 ,
36985      &            LOUT = 6 ,
36986      &            LDAT = 9 )
36987 * event history
36988       PARAMETER (NMXHKK=200000)
36989       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36990      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36991      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36992 * extended event history
36993       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36994      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36995      &                IHIST(2,NMXHKK)
36996 * Lorentz-parameters of the current interaction
36997       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
36998      &                UMO,PPCM,EPROJ,PPROJ
36999 * diquark-breaking mechanism
37000       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37001
37002 C
37003       PARAMETER (NTMHKK= 300)
37004       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37005      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37006      +(4,NTMHKK)
37007 *KEEP,XSEADI.
37008       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37009      +SSMIMQ,VVMTHR
37010 *KEEP,DPRIN.
37011       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37012       COMMON /EVFLAG/ NUMEV
37013 C
37014 C                  USQBS-2 diagram (split target diquark)
37015 C
37016 C
37017 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
37018 C     Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
37019 C
37020 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
37021 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37022 C
37023 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37024 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37025 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37026 C
37027 C
37028 C       Put new chains into COMMON /HKKTMP/
37029 C
37030       IIGLU1=NC1T-NC1P-1
37031       IIGLU2=NC2T-NC2P-1
37032       IGCOUN=0
37033 C     WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37034       CVQ=1.D0
37035       IREJ=0
37036       IF(IPIP.EQ.2)THEN
37037 C     IF(NUMEV.EQ.-324)THEN
37038 C     WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37039 C    *             'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
37040 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37041 C    *              IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
37042       ENDIF
37043 C
37044 C
37045 C
37046 C     determine x-values of NC1T diquark
37047       XDIQT=PHKK(4,NC1T)*2.D0/UMO
37048       XVQP=PHKK(4,NC1P)*2.D0/UMO
37049 C
37050 C     determine x-values of sea quark pair
37051 C
37052       IPCO=1
37053       ICOU=0
37054  2234 CONTINUE
37055       ICOU=ICOU+1
37056       IF(ICOU.GE.500)THEN
37057         IREJ=1
37058         IF(ISQ.EQ.3)IREJ=3
37059         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
37060         IPCO=0
37061         RETURN
37062       ENDIF
37063       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
37064      * UMO, XDIQT,XVQP
37065       XSQ=0.D0
37066       XSAQ=0.D0
37067 **NEW
37068 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37069       IF (IPIP.EQ.1) THEN
37070          XQMAX  = XDIQT/2.0D0
37071          XAQMAX = 2.D0*XVQP/3.0D0
37072       ELSE
37073          XQMAX  = 2.D0*XVQP/3.0D0
37074          XAQMAX = XDIQT/2.0D0
37075       ENDIF
37076       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37077       ISAQ = 6+ISQ
37078 C     write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37079 **
37080         IF(IPCO.GE.3)
37081      &     WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37082       IF(IREJ.GE.1)THEN
37083         IF(IPCO.GE.3)
37084      &     WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37085         IPCO=0
37086         RETURN
37087       ENDIF
37088       IF(IPIP.EQ.1)THEN
37089         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37090       ELSEIF(IPIP.EQ.2)THEN
37091         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37092       ENDIF
37093       IF(IPCO.GE.3)THEN
37094         WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37095      *  XDIQT,XVQP,XSQ,XSAQ
37096       ENDIF
37097 C
37098 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
37099 C
37100 C     XSQ=0.D0
37101       IF(IPIP.EQ.1)THEN
37102         XDIQT=XDIQT-XSQ
37103         XVQP =XVQP -XSAQ
37104       ELSEIF(IPIP.EQ.2)THEN
37105         XDIQT=XDIQT-XSAQ
37106         XVQP =XVQP -XSQ
37107       ENDIF
37108       IF(IPCO.GE.3)
37109      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37110 C
37111 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37112 C
37113       XVTHRO=CVQ/UMO
37114       IVTHR=0
37115  3466 CONTINUE
37116       IF(IVTHR.EQ.10)THEN
37117         IREJ=1
37118         IF(ISQ.EQ.3)IREJ=3
37119         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
37120       IPCO=0
37121         RETURN
37122       ENDIF
37123       IVTHR=IVTHR+1
37124       XVTHR=XVTHRO/(201-IVTHR)
37125       UNOPRV=UNON
37126  380  CONTINUE
37127       IF(XVTHR.GT.0.66D0*XDIQT)THEN
37128         IREJ=1
37129         IF(ISQ.EQ.3)IREJ=3
37130         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR  large ',
37131      *  XVTHR
37132       IPCO=0
37133         RETURN
37134       ENDIF
37135       IF(DT_RNDM(V).LT.0.5D0)THEN
37136         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37137         XVTQII=XDIQT-XVTQI
37138       ELSE
37139         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37140         XVTQI=XDIQT-XVTQII
37141       ENDIF
37142       IF(IPCO.GE.3)THEN
37143         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37144       ENDIF
37145 C
37146 C     Prepare 4 momenta of new chains and chain ends
37147 C
37148 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37149 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37150 C    +(4,NTMHKK)
37151 C
37152 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37153 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37154 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37155 C
37156 C     SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37157 C    *              IP1,IP21,IP22,IPP1,IPP2)
37158 C
37159       IF(IPIP.EQ.1)THEN
37160         XSQ1=XSQ
37161         XSAQ1=XSAQ
37162         ISQ1=ISQ
37163         ISAQ1=ISAQ
37164       ELSEIF(IPIP.EQ.2)THEN
37165         XSQ1=XSAQ
37166         XSAQ1=XSQ
37167         ISQ1=ISAQ
37168         ISAQ1=ISQ
37169       ENDIF
37170       IDHKT(1)   =IPP1
37171       ISTHKT(1)  =951
37172       JMOHKT(1,1)=NC2P
37173       JMOHKT(2,1)=0
37174       JDAHKT(1,1)=3+IIGLU1
37175       JDAHKT(2,1)=0
37176 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37177       PHKT(1,1)  =PHKK(1,NC2P)
37178       PHKT(2,1)  =PHKK(2,NC2P)
37179       PHKT(3,1)  =PHKK(3,NC2P)
37180       PHKT(4,1)  =PHKK(4,NC2P)
37181 C     PHKT(5,1)  =PHKK(5,NC2P)
37182       XMIST  =(PHKT(4,1)**2-
37183      * PHKT(3,1)**2-PHKT(2,1)**2-
37184      *PHKT(1,1)**2)
37185       IF(XMIST.GT.0.D0)THEN
37186       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37187      *PHKT(1,1)**2)
37188       ELSE
37189 C     WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
37190       PHKT(5,1)=0.D0
37191       ENDIF
37192       VHKT(1,1)  =VHKK(1,NC2P)
37193       VHKT(2,1)  =VHKK(2,NC2P)
37194       VHKT(3,1)  =VHKK(3,NC2P)
37195       VHKT(4,1)  =VHKK(4,NC2P)
37196       WHKT(1,1)  =WHKK(1,NC2P)
37197       WHKT(2,1)  =WHKK(2,NC2P)
37198       WHKT(3,1)  =WHKK(3,NC2P)
37199       WHKT(4,1)  =WHKK(4,NC2P)
37200 C     Add here IIGLU1 gluons to this chaina
37201       PG1=0.D0
37202       PG2=0.D0
37203       PG3=0.D0
37204       PG4=0.D0
37205       IF(IIGLU1.GE.1)THEN
37206       JJG=NC1P
37207       DO 61 IIG=2,2+IIGLU1-1
37208         KKG=JJG+IIG-1
37209         IDHKT(IIG)   =IDHKK(KKG)
37210         ISTHKT(IIG)  =921
37211         JMOHKT(1,IIG)=KKG
37212         JMOHKT(2,IIG)=0
37213         JDAHKT(1,IIG)=3+IIGLU1
37214         JDAHKT(2,IIG)=0
37215         PHKT(1,IIG)=PHKK(1,KKG)
37216         PG1=PG1+ PHKT(1,IIG)
37217         PHKT(2,IIG)=PHKK(2,KKG)
37218         PG2=PG2+ PHKT(2,IIG)
37219         PHKT(3,IIG)=PHKK(3,KKG)
37220         PG3=PG3+ PHKT(3,IIG)
37221         PHKT(4,IIG)=PHKK(4,KKG)
37222         PG4=PG4+ PHKT(4,IIG)
37223         PHKT(5,IIG)=PHKK(5,KKG)
37224         VHKT(1,IIG)  =VHKK(1,KKG)
37225         VHKT(2,IIG)  =VHKK(2,KKG)
37226         VHKT(3,IIG)  =VHKK(3,KKG)
37227         VHKT(4,IIG)  =VHKK(4,KKG)
37228         WHKT(1,IIG) =WHKK(1,KKG)
37229         WHKT(2,IIG) =WHKK(2,KKG)
37230         WHKT(3,IIG) =WHKK(3,KKG)
37231         WHKT(4,IIG) =WHKK(4,KKG)
37232    61 CONTINUE
37233       ENDIF
37234       IDHKT(2+IIGLU1)   =IP21
37235       ISTHKT(2+IIGLU1)  =952
37236       JMOHKT(1,2+IIGLU1)=NC1T
37237       JMOHKT(2,2+IIGLU1)=0
37238       JDAHKT(1,2+IIGLU1)=3+IIGLU1
37239       JDAHKT(2,2+IIGLU1)=0
37240       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
37241       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
37242       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
37243       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
37244 C     PHKT(5,2)  =PHKK(5,NC1T)
37245       XMIST  =(PHKT(4,2+IIGLU1)**2-
37246      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37247      *PHKT(1,2+IIGLU1)**2)
37248       IF(XMIST.GT.0.D0)THEN
37249       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
37250      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37251      *PHKT(1,2+IIGLU1)**2)
37252       ELSE
37253 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37254         PHKT(5,5+IIGLU1)=0.D0
37255       ENDIF
37256       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
37257       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
37258       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
37259       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
37260       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
37261       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
37262       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
37263       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
37264       IDHKT(3+IIGLU1)   =88888
37265       ISTHKT(3+IIGLU1)  =95
37266       JMOHKT(1,3+IIGLU1)=1
37267       JMOHKT(2,3+IIGLU1)=2+IIGLU1
37268       JDAHKT(1,3+IIGLU1)=0
37269       JDAHKT(2,3+IIGLU1)=0
37270       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37271       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37272       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37273       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37274       XMIST
37275      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37276      *            -PHKT(3,3+IIGLU1)**2)
37277       IF(XMIST.GT.0.D0)THEN
37278       PHKT(5,3+IIGLU1)
37279      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37280      *            -PHKT(3,3+IIGLU1)**2)
37281       ELSE
37282 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37283         PHKT(5,5+IIGLU1)=0.D0
37284       ENDIF
37285       IF(IPIP.GE.2)THEN
37286 C     IF(NUMEV.EQ.-324)THEN
37287 C     WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
37288 C    * JDAHKT(1,1),
37289 C    *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37290       DO 71 IIG=2,2+IIGLU1-1
37291 C     WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37292 C    &             JMOHKT(1,IIG),JMOHKT(2,IIG),
37293 C    * JDAHKT(1,IIG),
37294 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37295    71 CONTINUE
37296 C     WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37297 C    * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37298 C    *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37299 C     WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37300 C    * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37301 C    *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37302       ENDIF
37303       CHAMAL=CHAM1
37304       IF(IPIP.EQ.1)THEN
37305         IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
37306       ELSEIF(IPIP.EQ.2)THEN
37307         IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
37308       ENDIF
37309       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37310 C       IREJ=1
37311         IPCO=0
37312 C       RETURN
37313 C       WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
37314         GO TO 3466
37315       ENDIF
37316       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
37317       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
37318       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
37319       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
37320       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
37321       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
37322       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
37323       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
37324       IF(IPIP.EQ.1)THEN
37325         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
37326       ELSEIF(IPIP.EQ.2)THEN
37327         IDHKT(4+IIGLU1)   =ISAQ1
37328       ENDIF
37329       ISTHKT(4+IIGLU1)  =951
37330       JMOHKT(1,4+IIGLU1)=NC1P
37331       JMOHKT(2,4+IIGLU1)=0
37332       JDAHKT(1,4+IIGLU1)=6+IIGLU1
37333       JDAHKT(2,4+IIGLU1)=0
37334 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37335       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37336       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37337       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37338       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37339 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
37340       XMIST  =(PHKT(4,4+IIGLU1)**2-
37341      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37342      *PHKT(1,4+IIGLU1)**2)
37343       IF(XMIST.GT.0.D0)THEN
37344       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
37345      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37346      *PHKT(1,4+IIGLU1)**2)
37347       ELSE
37348 C     WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
37349       PHKT(5,4+IIGLU1)=0.D0
37350       ENDIF
37351       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
37352       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
37353       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
37354       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
37355       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
37356       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
37357       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
37358       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
37359       IDHKT(5+IIGLU1)   =IP22
37360       ISTHKT(5+IIGLU1)  =952
37361       JMOHKT(1,5+IIGLU1)=NC1T
37362       JMOHKT(2,5+IIGLU1)=0
37363       JDAHKT(1,5+IIGLU1)=6+IIGLU1
37364       JDAHKT(2,5+IIGLU1)=0
37365       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37366       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37367       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37368       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37369 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
37370       XMIST  =(PHKT(4,5+IIGLU1)**2-
37371      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37372      *PHKT(1,5+IIGLU1)**2)
37373       IF(XMIST.GT.0.D0)THEN
37374       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
37375      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37376      *PHKT(1,5+IIGLU1)**2)
37377       ELSE
37378 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37379         PHKT(5,5+IIGLU1)=0.D0
37380       ENDIF
37381       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
37382       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
37383       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
37384       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
37385       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
37386       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
37387       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
37388       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
37389       IDHKT(6+IIGLU1)   =88888
37390       ISTHKT(6+IIGLU1)  =95
37391       JMOHKT(1,6+IIGLU1)=4+IIGLU1
37392       JMOHKT(2,6+IIGLU1)=5+IIGLU1
37393       JDAHKT(1,6+IIGLU1)=0
37394       JDAHKT(2,6+IIGLU1)=0
37395       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37396       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37397       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37398       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37399       XMIST
37400      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37401      *            -PHKT(3,6+IIGLU1)**2)
37402       IF(XMIST.GT.0.D0)THEN
37403       PHKT(5,6+IIGLU1)
37404      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37405      *            -PHKT(3,6+IIGLU1)**2)
37406       ELSE
37407 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37408         PHKT(5,5+IIGLU1)=0.D0
37409       ENDIF
37410 C     IF(IPIP.GE.2)THEN
37411 C     IF(NUMEV.EQ.-324)THEN
37412 C     WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37413 C    * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37414 C    *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37415 C     WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37416 C    * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37417 C    *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37418 C     WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37419 C    * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37420 C    *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37421 C     ENDIF
37422       CHAMAL=CHAM1
37423       IF(IPIP.EQ.1)THEN
37424         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37425       ELSEIF(IPIP.EQ.2)THEN
37426         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37427       ENDIF
37428       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37429 C       IREJ=1
37430         IPCO=0
37431 C       RETURN
37432 C       WRITE(6,*)' MUSQBS1 jump back from chain 6',
37433 C    *  CHAMAL,PHKT(5,6+IIGLU1)
37434         GO TO 3466
37435       ENDIF
37436       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
37437       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
37438       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
37439       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
37440       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
37441       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
37442       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
37443       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
37444 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
37445       IDHKT(7+IIGLU1)   =IP1
37446       ISTHKT(7+IIGLU1)  =951
37447       JMOHKT(1,7+IIGLU1)=NC1P
37448       JMOHKT(2,7+IIGLU1)=0
37449 **NEW
37450 C     JDAHKT(1,7+IIGLU1)=9+IIGLU1
37451       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37452 **
37453       JDAHKT(2,7+IIGLU1)=0
37454       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
37455       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
37456       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
37457       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
37458 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
37459       XMIST  =(PHKT(4,7+IIGLU1)**2-
37460      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37461      *PHKT(1,7+IIGLU1)**2)
37462       IF(XMIST.GT.0.D0)THEN
37463       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
37464      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37465      *PHKT(1,7+IIGLU1)**2)
37466       ELSE
37467 C     WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
37468       PHKT(5,7+IIGLU1)=0.D0
37469       ENDIF
37470       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
37471       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
37472       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
37473       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
37474       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
37475       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
37476       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
37477       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
37478 C     Insert here the IIGLU2 gluons
37479       PG1=0.D0
37480       PG2=0.D0
37481       PG3=0.D0
37482       PG4=0.D0
37483       IF(IIGLU2.GE.1)THEN
37484       JJG=NC2P
37485       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37486         KKG=JJG+IIG-7-IIGLU1
37487         IDHKT(IIG)   =IDHKK(KKG)
37488         ISTHKT(IIG)  =921
37489         JMOHKT(1,IIG)=KKG
37490         JMOHKT(2,IIG)=0
37491         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37492         JDAHKT(2,IIG)=0
37493         PHKT(1,IIG)=PHKK(1,KKG)
37494         PG1=PG1+ PHKT(1,IIG)
37495         PHKT(2,IIG)=PHKK(2,KKG)
37496         PG2=PG2+ PHKT(2,IIG)
37497         PHKT(3,IIG)=PHKK(3,KKG)
37498         PG3=PG3+ PHKT(3,IIG)
37499         PHKT(4,IIG)=PHKK(4,KKG)
37500         PG4=PG4+ PHKT(4,IIG)
37501         PHKT(5,IIG)=PHKK(5,KKG)
37502         VHKT(1,IIG)  =VHKK(1,KKG)
37503         VHKT(2,IIG)  =VHKK(2,KKG)
37504         VHKT(3,IIG)  =VHKK(3,KKG)
37505         VHKT(4,IIG)  =VHKK(4,KKG)
37506         WHKT(1,IIG)  =WHKK(1,KKG)
37507         WHKT(2,IIG) =WHKK(2,KKG)
37508         WHKT(3,IIG) =WHKK(3,KKG)
37509         WHKT(4,IIG) =WHKK(4,KKG)
37510    81 CONTINUE
37511       ENDIF
37512       IF(IPIP.EQ.1)THEN
37513         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
37514         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
37515         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
37516         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
37517       ELSEIF(IPIP.EQ.2)THEN
37518         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
37519         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
37520         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
37521         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
37522       ENDIF
37523       ISTHKT(8+IIGLU1+IIGLU2)  =952
37524       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
37525       JMOHKT(2,8+IIGLU1+IIGLU2)=0
37526       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37527       JDAHKT(2,8+IIGLU1+IIGLU2)=0
37528       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC2T)+
37529      * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
37530       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC2T)+
37531      * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
37532       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC2T)+
37533      * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
37534       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC2T)+
37535      * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
37536 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
37537 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
37538       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
37539 C       IREJ=1
37540 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
37541 C    *  ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
37542         IPCO=0
37543 C       RETURN
37544         GO TO 3466
37545       ENDIF
37546 C     PHKT(5,8)  =PHKK(5,NC2T)
37547       XMIST  =(PHKT(4,8+IIGLU1+IIGLU2)**2-
37548      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37549      *PHKT(1,8+IIGLU1+IIGLU2)**2)
37550       IF(XMIST.GT.0.D0)THEN
37551       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37552      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37553      *PHKT(1,8+IIGLU1+IIGLU2)**2)
37554       ELSE
37555 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37556         PHKT(5,5+IIGLU1)=0.D0
37557       ENDIF
37558       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
37559       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
37560       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
37561       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
37562       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
37563       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
37564       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
37565       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
37566       IDHKT(9+IIGLU1+IIGLU2)   =88888
37567       ISTHKT(9+IIGLU1+IIGLU2)  =95
37568       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37569       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37570       JDAHKT(1,9+IIGLU1+IIGLU2)=0
37571       JDAHKT(2,9+IIGLU1+IIGLU2)=0
37572 **NEW
37573 C     PHKT(1,9+IIGLU1+IIGLU2)
37574 C    * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37575 C     PHKT(2,9+IIGLU1+IIGLU2)
37576 C    * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37577 C     PHKT(3,9+IIGLU1+IIGLU2)
37578 C    * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37579 C     PHKT(4,9+IIGLU1+IIGLU2)
37580 C    * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37581       PHKT(1,9+IIGLU1+IIGLU2)
37582      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37583       PHKT(2,9+IIGLU1+IIGLU2)
37584      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37585       PHKT(3,9+IIGLU1+IIGLU2)
37586      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37587       PHKT(4,9+IIGLU1+IIGLU2)
37588      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37589 **
37590       XMIST
37591      * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37592      * -PHKT(2,9+IIGLU1+IIGLU2)**2
37593      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
37594       IF(XMIST.GT.0.D0)THEN
37595       PHKT(5,9+IIGLU1+IIGLU2)
37596      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37597      * -PHKT(2,9+IIGLU1+IIGLU2)**2
37598      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
37599       ELSE
37600 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37601         PHKT(5,5+IIGLU1)=0.D0
37602       ENDIF
37603       IF(IPIP.GE.2)THEN
37604 C     IF(NUMEV.EQ.-324)THEN
37605 C     WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37606 C    * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37607 C    *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37608 C     DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37609 C     WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
37610 C    * JDAHKT(1,IIG),
37611 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37612 C  91 CONTINUE
37613 C     WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
37614 C    * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
37615 C    *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
37616 C    *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37617 C     WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37618 C    * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37619 C    *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37620 C    *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37621       ENDIF
37622       CHAMAL=CHAB1
37623       IF(IPIP.EQ.1)THEN
37624         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37625       ELSEIF(IPIP.EQ.2)THEN
37626         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37627       ENDIF
37628       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37629 C       IREJ=1
37630         IPCO=0
37631 C       RETURN
37632 C       WRITE(6,*)' MUSQBS1 jump back from chain 9',
37633 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37634         GO TO 3466
37635       ENDIF
37636       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
37637       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
37638       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
37639       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
37640       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
37641       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
37642       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
37643       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
37644 C
37645       IPCO=0
37646       IGCOUN=9+IIGLU1+IIGLU2
37647        RETURN
37648        END
37649
37650 *$ CREATE MGSQBS2.FOR
37651 *COPY MGSQBS2
37652 C
37653 C
37654 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37655       SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37656      *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
37657 C
37658 C                  GSQBS-2 diagram (split target diquark)
37659 C
37660       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37661       SAVE
37662
37663       PARAMETER ( LINP = 10 ,
37664      &            LOUT = 6 ,
37665      &            LDAT = 9 )
37666 * event history
37667       PARAMETER (NMXHKK=200000)
37668       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37669      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37670      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37671 * extended event history
37672       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37673      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37674      &                IHIST(2,NMXHKK)
37675 * Lorentz-parameters of the current interaction
37676       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37677      &                UMO,PPCM,EPROJ,PPROJ
37678 * diquark-breaking mechanism
37679       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37680
37681 C
37682       PARAMETER (NTMHKK= 300)
37683       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37684      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37685      +(4,NTMHKK)
37686
37687 *KEEP,XSEADI.
37688       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37689      +SSMIMQ,VVMTHR
37690 *KEEP,DPRIN.
37691       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37692 C
37693 C                  GSQBS-2 diagram (split target diquark)
37694 C
37695 C
37696 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
37697 C     Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
37698 C
37699 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
37700 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37701 C
37702 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37703 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37704 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37705 C
37706 C
37707 C
37708 C       Put new chains into COMMON /HKKTMP/
37709 C
37710       IIGLU1=NC1T-NC1P-1
37711       IIGLU2=NC2T-NC2P-1
37712       IGCOUN=0
37713 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37714       CVQ=1.D0
37715       IREJ=0
37716 C     IF(IPIP.EQ.2)THEN
37717 C     WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37718 C    *             'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
37719 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37720 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
37721 C     ENDIF
37722 C
37723 C
37724 C
37725 C     determine x-values of NC1T diquark
37726       XDIQT=PHKK(4,NC1T)*2.D0/UMO
37727       XVQP=PHKK(4,NC1P)*2.D0/UMO
37728 C
37729 C     determine x-values of sea quark pair
37730 C
37731       IPCO=1
37732       ICOU=0
37733  2234 CONTINUE
37734       ICOU=ICOU+1
37735       IF(ICOU.GE.500)THEN
37736         IREJ=1
37737         IF(ISQ.EQ.3)IREJ=3
37738         IF(IPCO.GE.3)
37739      &     WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
37740         IPCO=0
37741         RETURN
37742       ENDIF
37743       IF(IPCO.GE.3)
37744      &     WRITE(LOUT,*)'MGSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
37745      * UMO, XDIQT,XVQP
37746       XSQ=0.D0
37747       XSAQ=0.D0
37748 **NEW
37749 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37750       IF (IPIP.EQ.1) THEN
37751          XQMAX  = XDIQT/2.0D0
37752          XAQMAX = 2.D0*XVQP/3.0D0
37753       ELSE
37754          XQMAX  = 2.D0*XVQP/3.0D0
37755          XAQMAX = XDIQT/2.0D0
37756       ENDIF
37757       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37758       ISAQ = 6+ISQ
37759 C     write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37760 **
37761         IF(IPCO.GE.3)
37762      &     WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37763       IF(IREJ.GE.1)THEN
37764         IF(IPCO.GE.3)
37765      &     WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37766         IPCO=0
37767         RETURN
37768       ENDIF
37769       IF(IPIP.EQ.1)THEN
37770         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37771       ELSEIF(IPIP.EQ.2)THEN
37772         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37773       ENDIF
37774       IF(IPCO.GE.3)THEN
37775         WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37776      *  XDIQT,XVQP,XSQ,XSAQ
37777       ENDIF
37778 C
37779 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
37780 C
37781 C     XSQ=0.D0
37782       IF(IPIP.EQ.1)THEN
37783         XDIQT=XDIQT-XSQ
37784         XVQP =XVQP -XSAQ
37785       ELSEIF(IPIP.EQ.2)THEN
37786         XDIQT=XDIQT-XSAQ
37787         XVQP =XVQP -XSQ
37788       ENDIF
37789       IF(IPCO.GE.3)
37790      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37791 C
37792 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37793 C
37794       XVTHRO=CVQ/UMO
37795       IVTHR=0
37796  3466 CONTINUE
37797       IF(IVTHR.EQ.10)THEN
37798         IREJ=1
37799         IF(ISQ.EQ.3)IREJ=3
37800         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
37801         IPCO=0
37802         RETURN
37803       ENDIF
37804       IVTHR=IVTHR+1
37805       XVTHR=XVTHRO/(201-IVTHR)
37806       UNOPRV=UNON
37807  380  CONTINUE
37808       IF(XVTHR.GT.0.66D0*XDIQT)THEN
37809         IREJ=1
37810         IF(ISQ.EQ.3)IREJ=3
37811         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR  large ',
37812      *  XVTHR
37813         IPCO=0
37814         RETURN
37815       ENDIF
37816       IF(DT_RNDM(V).LT.0.5D0)THEN
37817         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37818         XVTQII=XDIQT-XVTQI
37819       ELSE
37820         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37821         XVTQI=XDIQT-XVTQII
37822       ENDIF
37823       IF(IPCO.GE.3)THEN
37824         WRITE(LOUT,'(A,2E12.4)')'  MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37825       ENDIF
37826 C
37827 C     Prepare 4 momenta of new chains and chain ends
37828 C
37829 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37830 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37831 C    +(4,NTMHKK)
37832 C
37833 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37834 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37835 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37836 C
37837 C     SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37838 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
37839 C
37840       IF(IPIP.EQ.1)THEN
37841         XSQ1=XSQ
37842         XSAQ1=XSAQ
37843         ISQ1=ISQ
37844         ISAQ1=ISAQ
37845       ELSEIF(IPIP.EQ.2)THEN
37846         XSQ1=XSAQ
37847         XSAQ1=XSQ
37848         ISQ1=ISAQ
37849         ISAQ1=ISQ
37850       ENDIF
37851       KK11=IP21
37852 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
37853       KK21=IPP11
37854       KK22=IPP12
37855       XGIVE=0.D0
37856       IF(IPIP.EQ.1)THEN
37857         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
37858       ELSEIF(IPIP.EQ.2)THEN
37859         IDHKT(4+IIGLU1)   =ISAQ1
37860       ENDIF
37861       ISTHKT(4+IIGLU1)  =961
37862       JMOHKT(1,4+IIGLU1)=NC1P
37863       JMOHKT(2,4+IIGLU1)=0
37864       JDAHKT(1,4+IIGLU1)=6+IIGLU1
37865       JDAHKT(2,4+IIGLU1)=0
37866 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37867       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37868       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37869       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37870       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37871 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
37872       XXMIST=(PHKT(4,4+IIGLU1)**2-
37873      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37874      *PHKT(1,4+IIGLU1)**2)
37875       IF(XXMIST.GT.0.D0)THEN
37876         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
37877       ELSE
37878         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
37879         XXMIST=ABS(XXMIST)
37880         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
37881       ENDIF
37882       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
37883       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
37884       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
37885       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
37886       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
37887       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
37888       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
37889       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
37890       IDHKT(5+IIGLU1)   =IP22
37891       ISTHKT(5+IIGLU1)  =962
37892       JMOHKT(1,5+IIGLU1)=NC1T
37893       JMOHKT(2,5+IIGLU1)=0
37894       JDAHKT(1,5+IIGLU1)=6+IIGLU1
37895       JDAHKT(2,5+IIGLU1)=0
37896       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37897       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37898       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37899       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37900 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
37901       XXMIST=(PHKT(4,5+IIGLU1)**2-
37902      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37903      *PHKT(1,5+IIGLU1)**2)
37904       IF(XXMIST.GT.0.D0)THEN
37905         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
37906       ELSE
37907         WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
37908         XXMIST=ABS(XXMIST)
37909         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
37910       ENDIF
37911       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
37912       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
37913       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
37914       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
37915       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
37916       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
37917       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
37918       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
37919       IDHKT(6+IIGLU1)   =88888
37920       ISTHKT(6+IIGLU1)  =96
37921       JMOHKT(1,6+IIGLU1)=4+IIGLU1
37922       JMOHKT(2,6+IIGLU1)=5+IIGLU1
37923       JDAHKT(1,6+IIGLU1)=0
37924       JDAHKT(2,6+IIGLU1)=0
37925       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37926       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37927       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37928       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37929       PHKT(5,6+IIGLU1)
37930      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37931      *            -PHKT(3,6+IIGLU1)**2)
37932       CHAMAL=CHAM1
37933       IF(IPIP.EQ.1)THEN
37934         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37935       ELSEIF(IPIP.EQ.2)THEN
37936         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37937       ENDIF
37938 C---------------------------------------------------
37939       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37940         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37941 C                    we drop chain 6 and give the energy to chain 3
37942           IDHKT(6+IIGLU1)=22888
37943           XGIVE=1.D0
37944 C         WRITE(6,*)' drop chain 6 xgive=1'
37945           GO TO 7788
37946         ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
37947 C                    we drop chain 6 and give the energy to chain 3
37948 C                    and change KK11 to IDHKT(5)
37949           IDHKT(6+IIGLU1)=22888
37950           XGIVE=1.D0
37951 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
37952           KK11=IDHKT(5+IIGLU1)
37953           GO TO 7788
37954         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
37955 C                    we drop chain 6 and give the energy to chain 3
37956 C                    and change KK21 to IDHKT(5+IIGLU1)
37957 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
37958           IDHKT(6+IIGLU1)=22888
37959           XGIVE=1.D0
37960 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
37961           KK21=IDHKT(5+IIGLU1)
37962           GO TO 7788
37963         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
37964 C                    we drop chain 6 and give the energy to chain 3
37965 C                    and change KK22 to IDHKT(5)
37966 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
37967           IDHKT(6+IIGLU1)=22888
37968           XGIVE=1.D0
37969 C         WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
37970           KK22=IDHKT(5+IIGLU1)
37971           GO TO 7788
37972         ENDIF
37973 C       IREJ=1
37974         IPCO=0
37975 C       RETURN
37976         GO TO 3466
37977       ENDIF
37978  7788 CONTINUE
37979 C---------------------------------------------------
37980       IF(IPIP.GE.3)THEN
37981       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37982      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37983      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37984       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37985      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37986      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37987       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37988      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37989      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37990       ENDIF
37991       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
37992       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
37993       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
37994       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
37995       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
37996       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
37997       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
37998       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
37999 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
38000       IF(IPIP.EQ.1)THEN
38001         IDHKT(1)   =1000*KK21+100*KK22+3
38002         IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
38003         IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
38004         IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
38005       ELSEIF(IPIP.EQ.2)THEN
38006         IDHKT(1)   =1000*KK21+100*KK22-3
38007         IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
38008         IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
38009         IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
38010       ENDIF
38011       ISTHKT(1)  =961
38012       JMOHKT(1,1)=NC2P
38013       JMOHKT(2,1)=0
38014       JDAHKT(1,1)=3+IIGLU1
38015       JDAHKT(2,1)=0
38016 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
38017       PHKT(1,1)  =PHKK(1,NC2P)
38018      *+XGIVE*PHKT(1,4+IIGLU1)
38019       PHKT(2,1)  =PHKK(2,NC2P)
38020      *+XGIVE*PHKT(2,4+IIGLU1)
38021       PHKT(3,1)  =PHKK(3,NC2P)
38022      *+XGIVE*PHKT(3,4+IIGLU1)
38023       PHKT(4,1)  =PHKK(4,NC2P)
38024      *+XGIVE*PHKT(4,4+IIGLU1)
38025 C     PHKT(5,1)  =PHKK(5,NC2P)
38026       XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38027      *PHKT(1,1)**2
38028       IF(XXMIST.GT.0.D0)THEN
38029         PHKT(5,1)  =SQRT(XXMIST)
38030       ELSE
38031         WRITE(LOUT,*)'MGSQBS2',XXMIST
38032         XXMIST=ABS(XXMIST)
38033         PHKT(5,1)  =SQRT(XXMIST)
38034       ENDIF
38035       VHKT(1,1)  =VHKK(1,NC2P)
38036       VHKT(2,1)  =VHKK(2,NC2P)
38037       VHKT(3,1)  =VHKK(3,NC2P)
38038       VHKT(4,1)  =VHKK(4,NC2P)
38039       WHKT(1,1)  =WHKK(1,NC2P)
38040       WHKT(2,1)  =WHKK(2,NC2P)
38041       WHKT(3,1)  =WHKK(3,NC2P)
38042       WHKT(4,1)  =WHKK(4,NC2P)
38043 C     Add here IIGLU1 gluons to this chaina
38044       PG1=0.D0
38045       PG2=0.D0
38046       PG3=0.D0
38047       PG4=0.D0
38048       IF(IIGLU1.GE.1)THEN
38049       JJG=NC1P
38050       DO 61 IIG=2,2+IIGLU1-1
38051         KKG=JJG+IIG-1
38052         IDHKT(IIG)   =IDHKK(KKG)
38053         ISTHKT(IIG)  =921
38054         JMOHKT(1,IIG)=KKG
38055         JMOHKT(2,IIG)=0
38056         JDAHKT(1,IIG)=3+IIGLU1
38057         JDAHKT(2,IIG)=0
38058         PHKT(1,IIG)=PHKK(1,KKG)
38059         PG1=PG1+ PHKT(1,IIG)
38060         PHKT(2,IIG)=PHKK(2,KKG)
38061         PG2=PG2+ PHKT(2,IIG)
38062         PHKT(3,IIG)=PHKK(3,KKG)
38063         PG3=PG3+ PHKT(3,IIG)
38064         PHKT(4,IIG)=PHKK(4,KKG)
38065         PG4=PG4+ PHKT(4,IIG)
38066         PHKT(5,IIG)=PHKK(5,KKG)
38067         VHKT(1,IIG)  =VHKK(1,KKG)
38068         VHKT(2,IIG)  =VHKK(2,KKG)
38069         VHKT(3,IIG)  =VHKK(3,KKG)
38070         VHKT(4,IIG)  =VHKK(4,KKG)
38071         WHKT(1,IIG)  =WHKK(1,KKG)
38072         WHKT(2,IIG)  =WHKK(2,KKG)
38073         WHKT(3,IIG)  =WHKK(3,KKG)
38074         WHKT(4,IIG)  =WHKK(4,KKG)
38075    61 CONTINUE
38076       ENDIF
38077 C     IDHKT(2)   =IP21
38078       IDHKT(2+IIGLU1)   =KK11
38079       ISTHKT(2+IIGLU1)  =962
38080       JMOHKT(1,2+IIGLU1)=NC1T
38081       JMOHKT(2,2+IIGLU1)=0
38082       JDAHKT(1,2+IIGLU1)=3+IIGLU1
38083       JDAHKT(2,2+IIGLU1)=0
38084       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
38085 C    * +0.5D0*PHKK(1,NC2T)
38086      *+XGIVE*PHKT(1,5+IIGLU1)
38087       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
38088 C    *+0.5D0*PHKK(2,NC2T)
38089      *+XGIVE*PHKT(2,5+IIGLU1)
38090       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
38091 C    *+0.5D0*PHKK(3,NC2T)
38092      *+XGIVE*PHKT(3,5+IIGLU1)
38093       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
38094 C    *+0.5D0*PHKK(4,NC2T)
38095      *+XGIVE*PHKT(4,5+IIGLU1)
38096 C     PHKT(5,2)  =PHKK(5,NC1T)
38097       XXMIST=(PHKT(4,2+IIGLU1)**2-
38098      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38099      *PHKT(1,2+IIGLU1)**2)
38100       IF(XXMIST.GT.0.D0)THEN
38101         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
38102       ELSE
38103         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
38104         XXMIST=ABS(XXMIST)
38105         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
38106       ENDIF
38107       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
38108       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
38109       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
38110       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
38111       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
38112       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
38113       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
38114       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
38115       IDHKT(3+IIGLU1)   =88888
38116       ISTHKT(3+IIGLU1)  =96
38117       JMOHKT(1,3+IIGLU1)=1
38118       JMOHKT(2,3+IIGLU1)=2+IIGLU1
38119       JDAHKT(1,3+IIGLU1)=0
38120       JDAHKT(2,3+IIGLU1)=0
38121       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38122       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38123       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38124       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38125       PHKT(5,3+IIGLU1)
38126      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38127      *            -PHKT(3,3+IIGLU1)**2)
38128       IF(IPIP.EQ.3)THEN
38129       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38130      * JDAHKT(1,1),
38131      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38132       DO 71 IIG=2,2+IIGLU1-1
38133       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38134      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38135      * JDAHKT(1,IIG),
38136      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38137    71 CONTINUE
38138       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38139      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38140      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38141       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38142      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38143      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38144       ENDIF
38145       CHAMAL=CHAB1
38146       IF(IPIP.EQ.1)THEN
38147         IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
38148       ELSEIF(IPIP.EQ.2)THEN
38149         IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
38150       ENDIF
38151       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38152 C       IREJ=1
38153         IPCO=0
38154 C       RETURN
38155         GO TO 3466
38156       ENDIF
38157       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
38158       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
38159       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
38160       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
38161       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
38162       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
38163       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
38164       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
38165 C     IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+1
38166       IDHKT(7+IIGLU1)   =IP1
38167       ISTHKT(7+IIGLU1)  =961
38168       JMOHKT(1,7+IIGLU1)=NC1P
38169       JMOHKT(2,7+IIGLU1)=0
38170       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38171       JDAHKT(2,7+IIGLU1)=0
38172       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
38173       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
38174       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
38175       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
38176 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
38177       XXMIST=(PHKT(4,7+IIGLU1)**2-
38178      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38179      *PHKT(1,7+IIGLU1)**2)
38180       IF(XXMIST.GT.0.D0)THEN
38181         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
38182       ELSE
38183         WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
38184         XXMIST=ABS(XXMIST)
38185         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
38186       ENDIF
38187       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
38188       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
38189       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
38190       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
38191       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
38192       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
38193       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
38194       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
38195 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
38196 C     Insert here the IIGLU2 gluons
38197       PG1=0.D0
38198       PG2=0.D0
38199       PG3=0.D0
38200       PG4=0.D0
38201       IF(IIGLU2.GE.1)THEN
38202       JJG=NC2P
38203       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38204         KKG=JJG+IIG-7-IIGLU1
38205         IDHKT(IIG)   =IDHKK(KKG)
38206         ISTHKT(IIG)  =921
38207         JMOHKT(1,IIG)=KKG
38208         JMOHKT(2,IIG)=0
38209         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38210         JDAHKT(2,IIG)=0
38211         PHKT(1,IIG)=PHKK(1,KKG)
38212         PG1=PG1+ PHKT(1,IIG)
38213         PHKT(2,IIG)=PHKK(2,KKG)
38214         PG2=PG2+ PHKT(2,IIG)
38215         PHKT(3,IIG)=PHKK(3,KKG)
38216         PG3=PG3+ PHKT(3,IIG)
38217         PHKT(4,IIG)=PHKK(4,KKG)
38218         PG4=PG4+ PHKT(4,IIG)
38219         PHKT(5,IIG)=PHKK(5,KKG)
38220         VHKT(1,IIG)  =VHKK(1,KKG)
38221         VHKT(2,IIG)  =VHKK(2,KKG)
38222         VHKT(3,IIG)  =VHKK(3,KKG)
38223         VHKT(4,IIG)  =VHKK(4,KKG)
38224         WHKT(1,IIG)  =WHKK(1,KKG)
38225         WHKT(2,IIG)  =WHKK(2,KKG)
38226         WHKT(3,IIG)  =WHKK(3,KKG)
38227         WHKT(4,IIG)  =WHKK(4,KKG)
38228    81 CONTINUE
38229       ENDIF
38230       IF(IPIP.EQ.1)THEN
38231         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
38232         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
38233         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
38234         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
38235       ELSEIF(IPIP.EQ.2)THEN
38236 **NEW
38237 C       IDHKT(8)   =1000*IPP2+100*(-ISQ1+6)-3
38238         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
38239 **
38240         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
38241         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
38242         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
38243       ENDIF
38244       ISTHKT(8+IIGLU1+IIGLU2)  =962
38245       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
38246       JMOHKT(2,8+IIGLU1+IIGLU2)=0
38247       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38248       JDAHKT(2,8+IIGLU1+IIGLU2)=0
38249 C     PHKT(1,8)  =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
38250 C     PHKT(2,8)  =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
38251 C     PHKT(3,8)  =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
38252 C     PHKT(4,8)  =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
38253       PHKT(1,8+IIGLU1+IIGLU2)  =
38254      * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
38255       PHKT(2,8+IIGLU1+IIGLU2)  =
38256      * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
38257       PHKT(3,8+IIGLU1+IIGLU2)  =
38258      * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
38259       PHKT(4,8+IIGLU1+IIGLU2)  =
38260      * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
38261 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
38262 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
38263       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
38264 C       IREJ=1
38265 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
38266         IPCO=0
38267 C       RETURN
38268         GO TO 3466
38269       ENDIF
38270 C     PHKT(5,8)  =PHKK(5,NC2T)
38271       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38272      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38273      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38274       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
38275       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
38276       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
38277       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
38278       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
38279       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
38280       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
38281       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
38282       IDHKT(9+IIGLU1+IIGLU2)   =88888
38283       ISTHKT(9+IIGLU1+IIGLU2)  =96
38284       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38285       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38286       JDAHKT(1,9+IIGLU1+IIGLU2)=0
38287       JDAHKT(2,9+IIGLU1+IIGLU2)=0
38288       PHKT(1,9+IIGLU1+IIGLU2)
38289      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38290       PHKT(2,9+IIGLU1+IIGLU2)
38291      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38292       PHKT(3,9+IIGLU1+IIGLU2)
38293      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38294       PHKT(4,9+IIGLU1+IIGLU2)
38295      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38296       PHKT(5,9+IIGLU1+IIGLU2)
38297      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38298      * PHKT(2,9+IIGLU1+IIGLU2)**2
38299      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38300       IF(IPIP.GE.3)THEN
38301       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38302      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38303      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38304       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38305       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38306      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38307      * JDAHKT(1,IIG),
38308      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38309    91 CONTINUE
38310       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38311      * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
38312      *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
38313      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38314       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38315      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38316      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38317      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38318       ENDIF
38319       CHAMAL=CHAB1
38320       IF(IPIP.EQ.1)THEN
38321         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38322       ELSEIF(IPIP.EQ.2)THEN
38323         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38324       ENDIF
38325       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38326 C       IREJ=1
38327         IPCO=0
38328 C       RETURN
38329         GO TO 3466
38330       ENDIF
38331       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
38332       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
38333       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
38334       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
38335       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
38336       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
38337       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
38338       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
38339 C
38340       IPCO=0
38341       IGCOUN=9+IIGLU1+IIGLU2
38342        RETURN
38343        END
38344
38345 *$ CREATE MUSQBS1.FOR
38346 *COPY MUSQBS1
38347 C
38348 C
38349 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38350       SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38351      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
38352 C
38353 C                  USQBS-1 diagram (split projectile diquark)
38354 C
38355       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38356       SAVE
38357
38358       PARAMETER ( LINP = 10 ,
38359      &            LOUT = 6 ,
38360      &            LDAT = 9 )
38361 * event history
38362       PARAMETER (NMXHKK=200000)
38363       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38364      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38365      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38366 * extended event history
38367       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38368      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38369      &                IHIST(2,NMXHKK)
38370 * Lorentz-parameters of the current interaction
38371       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38372      &                UMO,PPCM,EPROJ,PPROJ
38373 * diquark-breaking mechanism
38374       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38375
38376 C
38377       PARAMETER (NTMHKK= 300)
38378       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38379      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38380      +(4,NTMHKK)
38381 *KEEP,XSEADI.
38382       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
38383      +SSMIMQ,VVMTHR
38384 *KEEP,DPRIN.
38385       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
38386       COMMON /EVFLAG/ NUMEV
38387 C
38388 C                  USQBS-1 diagram (split projectile diquark)
38389 C
38390 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
38391 C     Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
38392 C
38393 C     Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
38394 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38395 C
38396 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38397 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38398 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38399 C
38400 C       Put new chains into COMMON /HKKTMP/
38401 C
38402       IIGLU1=NC1T-NC1P-1
38403       IIGLU2=NC2T-NC2P-1
38404       IGCOUN=0
38405 C     WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
38406       CVQ=1.D0
38407       IREJ=0
38408       IF(IPIP.EQ.3)THEN
38409 C     IF(NUMEV.EQ.-324)THEN
38410       WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
38411      *             ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
38412      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38413      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
38414       ENDIF
38415 C
38416 C
38417 C
38418 C     determine x-values of NC1P diquark
38419       XDIQP=PHKK(4,NC1P)*2.D0/UMO
38420       XVQT=PHKK(4,NC1T)*2.D0/UMO
38421 C
38422 C     determine x-values of sea quark pair
38423 C
38424       IPCO=1
38425       ICOU=0
38426  2234 CONTINUE
38427       ICOU=ICOU+1
38428       IF(ICOU.GE.500)THEN
38429         IREJ=1
38430         IF(ISQ.EQ.3)IREJ=3
38431         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
38432         IPCO=0
38433         RETURN
38434       ENDIF
38435       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
38436      * UMO, XDIQP,XVQT
38437       XSQ=0.D0
38438       XSAQ=0.D0
38439 **NEW
38440 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
38441       IF (IPIP.EQ.1) THEN
38442          XQMAX  = XDIQP/2.0D0
38443          XAQMAX = 2.D0*XVQT/3.0D0
38444       ELSE
38445          XQMAX  = 2.D0*XVQT/3.0D0
38446          XAQMAX = XDIQP/2.0D0
38447       ENDIF
38448       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
38449       ISAQ = 6+ISQ
38450 C     write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
38451 **
38452       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38453       IF(IREJ.GE.1)THEN
38454         IF(IPCO.GE.3)
38455      &     WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38456         IPCO=0
38457         RETURN
38458       ENDIF
38459       IF(IPIP.EQ.1)THEN
38460         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38461       ELSEIF(IPIP.EQ.2)THEN
38462         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38463       ENDIF
38464       IF(IPCO.GE.3)THEN
38465         WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
38466      *  XDIQP,XVQT,XSQ,XSAQ
38467       ENDIF
38468 C
38469 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
38470 C
38471 C     XSQ=0.D0
38472       IF(IPIP.EQ.1)THEN
38473         XDIQP=XDIQP-XSQ
38474         XVQT =XVQT -XSAQ
38475       ELSEIF(IPIP.EQ.2)THEN
38476         XDIQP=XDIQP-XSAQ
38477         XVQT =XVQT -XSQ
38478       ENDIF
38479       IF(IPCO.GE.3)
38480      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
38481 C
38482 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38483 C
38484       XVTHRO=CVQ/UMO
38485       IVTHR=0
38486  3466 CONTINUE
38487       IF(IVTHR.EQ.10)THEN
38488         IREJ=1
38489         IF(ISQ.EQ.3)IREJ=3
38490         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
38491         IPCO=0
38492         RETURN
38493       ENDIF
38494       IVTHR=IVTHR+1
38495       XVTHR=XVTHRO/(201-IVTHR)
38496       UNOPRV=UNON
38497  380  CONTINUE
38498       IF(XVTHR.GT.0.66D0*XDIQP)THEN
38499         IREJ=1
38500         IF(ISQ.EQ.3)IREJ=3
38501         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR  large ',
38502      *  XVTHR
38503         IPCO=0
38504         RETURN
38505       ENDIF
38506       IF(DT_RNDM(V).LT.0.5D0)THEN
38507         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38508         XVPQII=XDIQP-XVPQI
38509       ELSE
38510         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38511         XVPQI=XDIQP-XVPQII
38512       ENDIF
38513       IF(IPCO.GE.3)THEN
38514         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
38515       ENDIF
38516 C
38517 C     Prepare 4 momenta of new chains and chain ends
38518 C
38519 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38520 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38521 C    +(4,NTMHKK)
38522 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38523 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38524 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38525       IF(IPIP.EQ.1)THEN
38526         XSQ1=XSQ
38527         XSAQ1=XSAQ
38528         ISQ1=ISQ
38529         ISAQ1=ISAQ
38530       ELSEIF(IPIP.EQ.2)THEN
38531         XSQ1=XSAQ
38532         XSAQ1=XSQ
38533         ISQ1=ISAQ
38534         ISAQ1=ISQ
38535       ENDIF
38536       IDHKT(1)   =IP11
38537       ISTHKT(1)  =931
38538       JMOHKT(1,1)=NC1P
38539       JMOHKT(2,1)=0
38540       JDAHKT(1,1)=3+IIGLU1
38541       JDAHKT(2,1)=0
38542 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38543       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38544       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38545       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38546       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38547 C     PHKT(5,1)  =PHKK(5,NC1P)
38548       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38549      *PHKT(1,1)**2)
38550       IF(XMIST.GE.0.D0)THEN
38551       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38552      *PHKT(1,1)**2)
38553       ELSE
38554 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38555        PHKT(5,1)=0.D0
38556       ENDIF
38557       VHKT(1,1)  =VHKK(1,NC1P)
38558       VHKT(2,1)  =VHKK(2,NC1P)
38559       VHKT(3,1)  =VHKK(3,NC1P)
38560       VHKT(4,1)  =VHKK(4,NC1P)
38561       WHKT(1,1)  =WHKK(1,NC1P)
38562       WHKT(2,1)  =WHKK(2,NC1P)
38563       WHKT(3,1)  =WHKK(3,NC1P)
38564       WHKT(4,1)  =WHKK(4,NC1P)
38565 C     Add here IIGLU1 gluons to this chaina
38566       PG1=0.D0
38567       PG2=0.D0
38568       PG3=0.D0
38569       PG4=0.D0
38570       IF(IIGLU1.GE.1)THEN
38571       JJG=NC1P
38572       DO 61 IIG=2,2+IIGLU1-1
38573         KKG=JJG+IIG-1
38574         IDHKT(IIG)   =IDHKK(KKG)
38575         ISTHKT(IIG)  =921
38576         JMOHKT(1,IIG)=KKG
38577         JMOHKT(2,IIG)=0
38578         JDAHKT(1,IIG)=3+IIGLU1
38579         JDAHKT(2,IIG)=0
38580         PHKT(1,IIG)=PHKK(1,KKG)
38581         PG1=PG1+ PHKT(1,IIG)
38582         PHKT(2,IIG)=PHKK(2,KKG)
38583         PG2=PG2+ PHKT(2,IIG)
38584         PHKT(3,IIG)=PHKK(3,KKG)
38585         PG3=PG3+ PHKT(3,IIG)
38586         PHKT(4,IIG)=PHKK(4,KKG)
38587         PG4=PG4+ PHKT(4,IIG)
38588         PHKT(5,IIG)=PHKK(5,KKG)
38589         VHKT(1,IIG)  =VHKK(1,KKG)
38590         VHKT(2,IIG)  =VHKK(2,KKG)
38591         VHKT(3,IIG)  =VHKK(3,KKG)
38592         VHKT(4,IIG)  =VHKK(4,KKG)
38593         WHKT(1,IIG) =WHKK(1,KKG)
38594         WHKT(2,IIG) =WHKK(2,KKG)
38595         WHKT(3,IIG) =WHKK(3,KKG)
38596         WHKT(4,IIG) =WHKK(4,KKG)
38597    61 CONTINUE
38598       ENDIF
38599       IDHKT(2+IIGLU1)   =IPP2
38600       ISTHKT(2+IIGLU1)  =932
38601       JMOHKT(1,2+IIGLU1)=NC2T
38602       JMOHKT(2,2+IIGLU1)=0
38603       JDAHKT(1,2+IIGLU1)=3+IIGLU1
38604       JDAHKT(2,2+IIGLU1)=0
38605       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
38606       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
38607       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
38608       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
38609 C     PHKT(5,2+IIGLU1)  =PHKK(5,NC2T)
38610       XMIST=(PHKT(4,2+IIGLU1)**2-
38611      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38612      *PHKT(1,2+IIGLU1)**2)
38613       IF(XMIST.GT.0.D0)THEN
38614       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
38615      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38616      *PHKT(1,2+IIGLU1)**2)
38617       ELSE
38618 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38619         PHKT(5,2+IIGLU1)=0.D0
38620       ENDIF
38621       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
38622       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
38623       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
38624       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
38625       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
38626       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
38627       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
38628       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
38629       IDHKT(3+IIGLU1)   =88888
38630       ISTHKT(3+IIGLU1)  =94
38631       JMOHKT(1,3+IIGLU1)=1
38632       JMOHKT(2,3+IIGLU1)=2+IIGLU1
38633       JDAHKT(1,3+IIGLU1)=0
38634       JDAHKT(2,3+IIGLU1)=0
38635       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38636       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38637       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38638       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38639       XMIST
38640      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38641      *            -PHKT(3,3+IIGLU1)**2)
38642       IF(XMIST.GE.0.D0)THEN
38643       PHKT(5,3+IIGLU1)
38644      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38645      *            -PHKT(3,3+IIGLU1)**2)
38646       ELSE
38647 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38648        PHKT(5,1)=0.D0
38649       ENDIF
38650       IF(IPIP.GE.3)THEN
38651 C     IF(NUMEV.EQ.-324)THEN
38652       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
38653      * JMOHKT(2,1),JDAHKT(1,1),
38654      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38655       DO 71 IIG=2,2+IIGLU1-1
38656       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38657      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38658      * JDAHKT(1,IIG),
38659      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38660    71 CONTINUE
38661       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38662      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38663      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38664       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38665      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38666      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38667       ENDIF
38668       CHAMAL=CHAM1
38669       IF(IPIP.EQ.1)THEN
38670         IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
38671       ELSEIF(IPIP.EQ.2)THEN
38672         IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
38673       ENDIF
38674       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38675 C       IREJ=1
38676         IPCO=0
38677 C       RETURN
38678 C       WRITE(6,*)' MUSQBS1 jump back from chain 3'
38679         GO TO 3466
38680       ENDIF
38681       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
38682       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
38683       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
38684       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
38685       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
38686       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
38687       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
38688       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
38689       IDHKT(4+IIGLU1)   =IP12
38690       ISTHKT(4+IIGLU1)  =931
38691       JMOHKT(1,4+IIGLU1)=NC1P
38692       JMOHKT(2,4+IIGLU1)=0
38693       JDAHKT(1,4+IIGLU1)=6+IIGLU1
38694       JDAHKT(2,4+IIGLU1)=0
38695 C   create  chain   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38696       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
38697       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
38698       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
38699       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
38700 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
38701       XMIST  =(PHKT(4,4+IIGLU1)**2-
38702      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38703      *PHKT(1,4+IIGLU1)**2)
38704       IF(XMIST.GT.0.D0)THEN
38705       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
38706      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38707      *PHKT(1,4+IIGLU1)**2)
38708       ELSE
38709 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38710         PHKT(5,4+IIGLU1)=0.D0
38711       ENDIF
38712       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
38713       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
38714       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
38715       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
38716       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
38717       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
38718       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
38719       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
38720       IF(IPIP.EQ.1)THEN
38721         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
38722       ELSEIF(IPIP.EQ.2)THEN
38723         IDHKT(5+IIGLU1)   =ISAQ1
38724       ENDIF
38725       ISTHKT(5+IIGLU1)  =932
38726       JMOHKT(1,5+IIGLU1)=NC1T
38727       JMOHKT(2,5+IIGLU1)=0
38728       JDAHKT(1,5+IIGLU1)=6+IIGLU1
38729       JDAHKT(2,5+IIGLU1)=0
38730       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
38731       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
38732       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
38733       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
38734 C     IF( PHKT(4,5).EQ.0.D0)THEN
38735 C       IREJ=1
38736 CIPCO=0
38737 CRETURN
38738 C     ENDIF
38739 C     PHKT(5,5)  =PHKK(5,NC1T)
38740       XMIST=(PHKT(4,5+IIGLU1)**2-
38741      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38742      *PHKT(1,5+IIGLU1)**2)
38743       IF(XMIST.GT.0.D0)THEN
38744       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
38745      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38746      *PHKT(1,5+IIGLU1)**2)
38747       ELSE
38748 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38749         PHKT(5,5+IIGLU1)=0.D0
38750       ENDIF
38751       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
38752       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
38753       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
38754       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
38755       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
38756       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
38757       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
38758       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
38759       IDHKT(6+IIGLU1)   =88888
38760       ISTHKT(6+IIGLU1)  =94
38761       JMOHKT(1,6+IIGLU1)=4+IIGLU1
38762       JMOHKT(2,6+IIGLU1)=5+IIGLU1
38763       JDAHKT(1,6+IIGLU1)=0
38764       JDAHKT(2,6+IIGLU1)=0
38765       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
38766       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
38767       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
38768       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
38769       XMIST
38770      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38771      *            -PHKT(3,6+IIGLU1)**2)
38772       IF(XMIST.GE.0.D0)THEN
38773       PHKT(5,6+IIGLU1)
38774      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38775      *            -PHKT(3,6+IIGLU1)**2)
38776       ELSE
38777 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38778        PHKT(5,1)=0.D0
38779       ENDIF
38780 C     IF(IPIP.EQ.3)THEN
38781       CHAMAL=CHAM1
38782       IF(IPIP.EQ.1)THEN
38783         IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
38784       ELSEIF(IPIP.EQ.2)THEN
38785         IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
38786       ENDIF
38787       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
38788 C       IREJ=1
38789         IPCO=0
38790 C       RETURN
38791 C       WRITE(6,*)' MGSQBS1 jump back from chain 6',
38792 C    *  CHAMAL,PHKT(5,6+IIGLU1)
38793         GO TO 3466
38794       ENDIF
38795       IF(IPIP.GE.3)THEN
38796 C     IF(NUMEV.EQ.-324)THEN
38797       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38798      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38799      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38800       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38801      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38802      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38803       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38804      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38805      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38806       ENDIF
38807       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
38808       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
38809       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
38810       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
38811       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
38812       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
38813       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
38814       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
38815       IF(IPIP.EQ.1)THEN
38816         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+3
38817         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
38818         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
38819         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
38820       ELSEIF(IPIP.EQ.2)THEN
38821         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
38822         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38823         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38824         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38825 C       WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
38826       ENDIF
38827       ISTHKT(7+IIGLU1)  =931
38828       JMOHKT(1,7+IIGLU1)=NC2P
38829       JMOHKT(2,7+IIGLU1)=0
38830       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38831       JDAHKT(2,7+IIGLU1)=0
38832 C    create chain     9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38833       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38834       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38835       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38836       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38837 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38838 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38839       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38840 C       IREJ=1
38841 C       WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
38842         IPCO=0
38843 C       RETURN
38844         GO TO 3466
38845       ENDIF
38846 C     PHKT(5,7)  =PHKK(5,NC2P)
38847       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
38848      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38849      *PHKT(1,7+IIGLU1)**2)
38850       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
38851       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
38852       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
38853       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
38854       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
38855       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
38856       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
38857       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
38858 C     Insert here the IIGLU2 gluons
38859       PG1=0.D0
38860       PG2=0.D0
38861       PG3=0.D0
38862       PG4=0.D0
38863       IF(IIGLU2.GE.1)THEN
38864       JJG=NC2P
38865       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38866         KKG=JJG+IIG-7-IIGLU1
38867         IDHKT(IIG)   =IDHKK(KKG)
38868         ISTHKT(IIG)  =921
38869         JMOHKT(1,IIG)=KKG
38870         JMOHKT(2,IIG)=0
38871         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38872         JDAHKT(2,IIG)=0
38873         PHKT(1,IIG)=PHKK(1,KKG)
38874         PG1=PG1+ PHKT(1,IIG)
38875         PHKT(2,IIG)=PHKK(2,KKG)
38876         PG2=PG2+ PHKT(2,IIG)
38877         PHKT(3,IIG)=PHKK(3,KKG)
38878         PG3=PG3+ PHKT(3,IIG)
38879         PHKT(4,IIG)=PHKK(4,KKG)
38880         PG4=PG4+ PHKT(4,IIG)
38881         PHKT(5,IIG)=PHKK(5,KKG)
38882         VHKT(1,IIG)  =VHKK(1,KKG)
38883         VHKT(2,IIG)  =VHKK(2,KKG)
38884         VHKT(3,IIG)  =VHKK(3,KKG)
38885         VHKT(4,IIG)  =VHKK(4,KKG)
38886         WHKT(1,IIG)  =WHKK(1,KKG)
38887         WHKT(2,IIG) =WHKK(2,KKG)
38888         WHKT(3,IIG) =WHKK(3,KKG)
38889         WHKT(4,IIG) =WHKK(4,KKG)
38890    81 CONTINUE
38891       ENDIF
38892       IDHKT(8+IIGLU1+IIGLU2)   =IP2
38893       ISTHKT(8+IIGLU1+IIGLU2)  =932
38894       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38895       JMOHKT(2,8+IIGLU1+IIGLU2)=0
38896       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38897       JDAHKT(2,8+IIGLU1+IIGLU2)=0
38898       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38899       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38900       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38901       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38902 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
38903       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38904      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38905      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38906       IF(XMIST.GT.0.D0)THEN
38907       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38908      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38909      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38910       ELSE
38911 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38912         PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38913       ENDIF
38914       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
38915       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
38916       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
38917       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
38918       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
38919       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
38920       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
38921       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
38922       IDHKT(9+IIGLU1+IIGLU2)   =88888
38923       ISTHKT(9+IIGLU1+IIGLU2)  =94
38924       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38925       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38926       JDAHKT(1,9+IIGLU1+IIGLU2)=0
38927       JDAHKT(2,9+IIGLU1+IIGLU2)=0
38928       PHKT(1,9+IIGLU1+IIGLU2)
38929      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38930       PHKT(2,9+IIGLU1+IIGLU2)
38931      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38932       PHKT(3,9+IIGLU1+IIGLU2)
38933      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38934       PHKT(4,9+IIGLU1+IIGLU2)
38935      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38936       XMIST
38937      *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38938      * -PHKT(2,9+IIGLU1+IIGLU2)**2
38939      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38940       IF(XMIST.GE.0.D0)THEN
38941       PHKT(5,9+IIGLU1+IIGLU2)
38942      *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38943      * -PHKT(2,9+IIGLU1+IIGLU2)**2
38944      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38945       ELSE
38946 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38947        PHKT(5,1)=0.D0
38948       ENDIF
38949       IF(IPIP.GE.3)THEN
38950 C     IF(NUMEV.EQ.-324)THEN
38951       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38952      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38953      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38954       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38955       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38956      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38957      * JDAHKT(1,IIG),
38958      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38959    91 CONTINUE
38960       WRITE(LOUT,*)8+IIGLU1+IIGLU2,
38961      * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
38962      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38963      *JDAHKT(1,8+IIGLU1+IIGLU2),
38964      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38965       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38966      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38967      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38968      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38969       ENDIF
38970       CHAMAL=CHAB1
38971       IF(IPIP.EQ.1)THEN
38972         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38973       ELSEIF(IPIP.EQ.2)THEN
38974         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38975       ENDIF
38976       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38977 C       IREJ=1
38978         IPCO=0
38979 C       RETURN
38980 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
38981 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
38982         GO TO 3466
38983       ENDIF
38984       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
38985       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
38986       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
38987       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
38988       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
38989       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
38990       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
38991       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
38992 C
38993       IPCO=0
38994       IGCOUN=9+IIGLU1+IIGLU2
38995        RETURN
38996        END
38997
38998 *$ CREATE MGSQBS1.FOR
38999 *COPY MGSQBS1
39000 C
39001 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
39002       SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
39003      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
39004 C
39005 C                  GSQBS-1 diagram (split projectile diquark)
39006 C
39007       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39008       SAVE
39009
39010       PARAMETER ( LINP = 10 ,
39011      &            LOUT = 6 ,
39012      &            LDAT = 9 )
39013 * event history
39014       PARAMETER (NMXHKK=200000)
39015       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39016      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39017      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39018 * extended event history
39019       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39020      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39021      &                IHIST(2,NMXHKK)
39022 * Lorentz-parameters of the current interaction
39023       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
39024      &                UMO,PPCM,EPROJ,PPROJ
39025 * diquark-breaking mechanism
39026       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
39027
39028 C
39029       PARAMETER (NTMHKK= 300)
39030       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39031      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39032      +(4,NTMHKK)
39033 *KEEP,XSEADI.
39034       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
39035      +SSMIMQ,VVMTHR
39036 *KEEP,DPRIN.
39037       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
39038 C
39039 C                  GSQBS-1 diagram (split projectile diquark)
39040 C
39041 C
39042 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
39043 C     Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
39044 C
39045 C     Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
39046 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39047 C
39048 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39049 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39050 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39051 C
39052 C       Put new chains into COMMON /HKKTMP/
39053 C
39054       IIGLU1=NC1T-NC1P-1
39055       IIGLU2=NC2T-NC2P-1
39056       IGCOUN=0
39057 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
39058       CVQ=1.D0
39059       NNNC1=IDHKK(NC1)/1000
39060       MMMC1=IDHKK(NC1)-NNNC1*1000
39061       KKKC1=ISTHKK(NC1)
39062       NNNC2=IDHKK(NC2)/1000
39063       MMMC2=IDHKK(NC2)-NNNC2*1000
39064       KKKC2=ISTHKK(NC2)
39065       IREJ=0
39066       IF(IPIP.EQ.3)THEN
39067       WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
39068      *             ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
39069      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
39070      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
39071       ENDIF
39072 C
39073 C
39074 C
39075 C     determine x-values of NC1P diquark
39076       XDIQP=PHKK(4,NC1P)*2.D0/UMO
39077       XVQT=PHKK(4,NC1T)*2.D0/UMO
39078 C
39079 C     determine x-values of sea quark pair
39080 C
39081       IPCO=1
39082       ICOU=0
39083  2234 CONTINUE
39084       ICOU=ICOU+1
39085       IF(ICOU.GE.500)THEN
39086         IREJ=1
39087         IF(ISQ.EQ.3)IREJ=3
39088         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
39089       IPCO=0
39090         RETURN
39091       ENDIF
39092       IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
39093      * UMO, XDIQP,XVQT
39094       XSQ=0.D0
39095       XSAQ=0.D0
39096 **NEW
39097 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
39098       IF (IPIP.EQ.1) THEN
39099          XQMAX  = XDIQP/2.0D0
39100          XAQMAX = 2.D0*XVQT/3.0D0
39101       ELSE
39102          XQMAX  = 2.D0*XVQT/3.0D0
39103          XAQMAX = XDIQP/2.0D0
39104       ENDIF
39105       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
39106       ISAQ = 6+ISQ
39107 C     write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
39108 **
39109         IF(IPCO.GE.3)
39110      &     WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39111       IF(IREJ.GE.1)THEN
39112         IF(IPCO.GE.3)
39113      &     WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39114       IPCO=0
39115         RETURN
39116       ENDIF
39117       IF(IPIP.EQ.1)THEN
39118         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39119       ELSEIF(IPIP.EQ.2)THEN
39120         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39121       ENDIF
39122       IF(IPCO.GE.3)THEN
39123         WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
39124      *  XDIQP,XVQT,XSQ,XSAQ
39125       ENDIF
39126 C
39127 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
39128 C
39129 C     XSQ=0.D0
39130       IF(IPIP.EQ.1)THEN
39131         XDIQP=XDIQP-XSQ
39132 **NEW
39133 C       IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
39134 **
39135         XVQT =XVQT -XSAQ
39136       ELSEIF(IPIP.EQ.2)THEN
39137         XDIQP=XDIQP-XSAQ
39138         XVQT =XVQT -XSQ
39139       ENDIF
39140       IF(IPCO.GE.3)
39141      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
39142 C
39143 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39144 C
39145       XVTHRO=CVQ/UMO
39146       IVTHR=0
39147  3466 CONTINUE
39148       IF(IVTHR.EQ.10)THEN
39149         IREJ=1
39150         IF(ISQ.EQ.3)IREJ=3
39151         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
39152       IPCO=0
39153         RETURN
39154       ENDIF
39155       IVTHR=IVTHR+1
39156       XVTHR=XVTHRO/(201-IVTHR)
39157       UNOPRV=UNON
39158  380  CONTINUE
39159       IF(XVTHR.GT.0.66D0*XDIQP)THEN
39160         IREJ=1
39161         IF(ISQ.EQ.3)IREJ=3
39162         IF(IPCO.GE.3)
39163      &     WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR  large ',
39164      *  XVTHR
39165       IPCO=0
39166         RETURN
39167       ENDIF
39168       IF(DT_RNDM(V).LT.0.5D0)THEN
39169         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39170         XVPQII=XDIQP-XVPQI
39171       ELSE
39172         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39173         XVPQI=XDIQP-XVPQII
39174       ENDIF
39175       IF(IPCO.GE.3)THEN
39176         WRITE(LOUT,'(A,4E12.4)')'  MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
39177      *  XVTHR,XDIQP,XVPQI,XVPQII
39178       ENDIF
39179 C
39180 C     Prepare 4 momenta of new chains and chain ends
39181 C
39182 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39183 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39184 C    +(4,NTMHKK)
39185 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39186 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39187 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39188       IF(IPIP.EQ.1)THEN
39189         XSQ1=XSQ
39190         XSAQ1=XSAQ
39191         ISQ1=ISQ
39192         ISAQ1=ISAQ
39193       ELSEIF(IPIP.EQ.2)THEN
39194         XSQ1=XSAQ
39195         XSAQ1=XSQ
39196         ISQ1=ISAQ
39197         ISAQ1=ISQ
39198       ENDIF
39199       KK11=IP11
39200 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39201       KK21= IPP21
39202       KK22= IPP22
39203       XGIVE=0.D0
39204       IDHKT(4+IIGLU1)   =IP12
39205       ISTHKT(4+IIGLU1)  =921
39206       JMOHKT(1,4+IIGLU1)=NC1P
39207       JMOHKT(2,4+IIGLU1)=0
39208       JDAHKT(1,4+IIGLU1)=6+IIGLU1
39209       JDAHKT(2,4+IIGLU1)=0
39210 **NEW
39211       IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
39212      &    (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
39213 **
39214       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
39215       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
39216       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
39217       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
39218 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
39219       XXMIST=(PHKT(4,4+IIGLU1)**2-
39220      *              PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
39221      *              PHKT(1,4+IIGLU1)**2)
39222       IF(XXMIST.GT.0.D0)THEN
39223         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
39224       ELSE
39225         WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
39226         XXMIST=ABS(XXMIST)
39227         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
39228       ENDIF
39229       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
39230       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
39231       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
39232       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
39233       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
39234       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
39235       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
39236       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
39237       IF(IPIP.EQ.1)THEN
39238         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
39239       ELSEIF(IPIP.EQ.2)THEN
39240         IDHKT(5+IIGLU1)   =ISAQ1
39241       ENDIF
39242       ISTHKT(5+IIGLU1)  =922
39243       JMOHKT(1,5+IIGLU1)=NC1T
39244       JMOHKT(2,5+IIGLU1)=0
39245       JDAHKT(1,5+IIGLU1)=6+IIGLU1
39246       JDAHKT(2,5+IIGLU1)=0
39247 **NEW
39248       IF ((XSAQ1.LT.0.0D0).OR.(XVQT  .LT.0.0D0))
39249      &    WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
39250 **
39251       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
39252       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
39253       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
39254       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
39255 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
39256       XMIST=(PHKT(4,5+IIGLU1)**2-
39257      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39258      *PHKT(1,5+IIGLU1)**2)
39259       IF(XMIST.GT.0.D0)THEN
39260       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
39261      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39262      *PHKT(1,5+IIGLU1)**2)
39263       ELSE
39264 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
39265         PHKT(5,5+IIGLU1)=0.D0
39266       ENDIF
39267       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
39268       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
39269       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
39270       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
39271       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
39272       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
39273       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
39274       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
39275       IDHKT(6+IIGLU1)   =88888
39276 C     IDHKT(6)   =1000*NNNC1+MMMC1
39277       ISTHKT(6+IIGLU1)  =93
39278 C     ISTHKT(6)  =KKKC1
39279       JMOHKT(1,6+IIGLU1)=4+IIGLU1
39280       JMOHKT(2,6+IIGLU1)=5+IIGLU1
39281       JDAHKT(1,6+IIGLU1)=0
39282       JDAHKT(2,6+IIGLU1)=0
39283       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
39284       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
39285       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
39286       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
39287       PHKT(5,6+IIGLU1)
39288      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
39289      *            -PHKT(3,6+IIGLU1)**2)
39290       CHAMAL=CHAM1
39291       IF(IPIP.EQ.1)THEN
39292         IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
39293       ELSEIF(IPIP.EQ.2)THEN
39294         IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
39295       ENDIF
39296       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
39297         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
39298 C                    we drop chain 6 and give the energy to chain 3
39299           IDHKT(6+IIGLU1)=33888
39300           XGIVE=1.D0
39301 C         WRITE(6,*)' drop chain 6 xgive=1'
39302           GO TO 7788
39303         ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
39304 C                    we drop chain 6 and give the energy to chain 3
39305 C                    and change KK11 to IDHKT(4)
39306           IDHKT(6+IIGLU1)=33888
39307           XGIVE=1.D0
39308 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
39309           KK11=IDHKT(4+IIGLU1)
39310           GO TO 7788
39311         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
39312 C                    we drop chain 6 and give the energy to chain 3
39313 C                    and change KK21 to IDHKT(4)
39314 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39315           IDHKT(6+IIGLU1)=33888
39316           XGIVE=1.D0
39317 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
39318           KK21=IDHKT(4+IIGLU1)
39319           GO TO 7788
39320         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
39321 C                    we drop chain 6 and give the energy to chain 3
39322 C                    and change KK22 to IDHKT(4)
39323 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39324           IDHKT(6+IIGLU1)=33888
39325           XGIVE=1.D0
39326 C         WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
39327           KK22=IDHKT(4+IIGLU1)
39328           GO TO 7788
39329         ENDIF
39330 C       IREJ=1
39331         IPCO=0
39332 C       RETURN
39333 C       WRITE(6,*)' MGSQBS1 jump back from chain 6'
39334         GO TO 3466
39335       ENDIF
39336  7788 CONTINUE
39337       IF(IPIP.GE.3)THEN
39338       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
39339      * JMOHKT(1,4+IIGLU1),
39340      * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
39341      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
39342       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
39343      * JMOHKT(1,5+IIGLU1),
39344      * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
39345      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
39346       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
39347      * JMOHKT(1,6+IIGLU1),
39348      * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
39349      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
39350       ENDIF
39351       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
39352       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
39353       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
39354       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
39355       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
39356       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
39357       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
39358       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
39359 C     IDHKT(1)   =IP11
39360       IDHKT(1)   =KK11
39361       ISTHKT(1)  =921
39362       JMOHKT(1,1)=NC1P
39363       JMOHKT(2,1)=0
39364       JDAHKT(1,1)=3+IIGLU1
39365       JDAHKT(2,1)=0
39366       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
39367 C    * +0.5D0*PHKK(1,NC2P)
39368      *+XGIVE*PHKT(1,4+IIGLU1)
39369       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
39370 C    * +0.5D0*PHKK(2,NC2P)
39371      *+XGIVE*PHKT(2,4+IIGLU1)
39372       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
39373 C    * +0.5D0*PHKK(3,NC2P)
39374      *+XGIVE*PHKT(3,4+IIGLU1)
39375       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
39376 C    * +0.5D0*PHKK(4,NC2P)
39377      *+XGIVE*PHKT(4,4+IIGLU1)
39378 C     PHKT(5,1)  =PHKK(5,NC1P)
39379       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39380      *PHKT(1,1)**2)
39381       IF(XMIST.GE.0.D0)THEN
39382       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39383      *PHKT(1,1)**2)
39384       ELSE
39385 C      WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
39386        PHKT(5,1)=0.D0
39387       ENDIF
39388       VHKT(1,1)  =VHKK(1,NC1P)
39389       VHKT(2,1)  =VHKK(2,NC1P)
39390       VHKT(3,1)  =VHKK(3,NC1P)
39391       VHKT(4,1)  =VHKK(4,NC1P)
39392       WHKT(1,1)  =WHKK(1,NC1P)
39393       WHKT(2,1)  =WHKK(2,NC1P)
39394       WHKT(3,1)  =WHKK(3,NC1P)
39395       WHKT(4,1)  =WHKK(4,NC1P)
39396 C     Add here IIGLU1 gluons to this chaina
39397       PG1=0.D0
39398       PG2=0.D0
39399       PG3=0.D0
39400       PG4=0.D0
39401       IF(IIGLU1.GE.1)THEN
39402       JJG=NC1P
39403       DO 61 IIG=2,2+IIGLU1-1
39404         KKG=JJG+IIG-1
39405         IDHKT(IIG)   =IDHKK(KKG)
39406         ISTHKT(IIG)  =921
39407         JMOHKT(1,IIG)=KKG
39408         JMOHKT(2,IIG)=0
39409         JDAHKT(1,IIG)=3+IIGLU1
39410         JDAHKT(2,IIG)=0
39411         PHKT(1,IIG)=PHKK(1,KKG)
39412         PG1=PG1+ PHKT(1,IIG)
39413         PHKT(2,IIG)=PHKK(2,KKG)
39414         PG2=PG2+ PHKT(2,IIG)
39415         PHKT(3,IIG)=PHKK(3,KKG)
39416         PG3=PG3+ PHKT(3,IIG)
39417         PHKT(4,IIG)=PHKK(4,KKG)
39418         PG4=PG4+ PHKT(4,IIG)
39419         PHKT(5,IIG)=PHKK(5,KKG)
39420         VHKT(1,IIG)  =VHKK(1,KKG)
39421         VHKT(2,IIG)  =VHKK(2,KKG)
39422         VHKT(3,IIG)  =VHKK(3,KKG)
39423         VHKT(4,IIG)  =VHKK(4,KKG)
39424         WHKT(1,IIG)  =WHKK(1,KKG)
39425         WHKT(2,IIG)  =WHKK(2,KKG)
39426         WHKT(3,IIG)  =WHKK(3,KKG)
39427         WHKT(4,IIG)  =WHKK(4,KKG)
39428    61 CONTINUE
39429       ENDIF
39430 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39431       IF(IPIP.EQ.1)THEN
39432         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22+3
39433         IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
39434         IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
39435         IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
39436       ELSEIF(IPIP.EQ.2)THEN
39437         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22-3
39438         IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
39439         IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
39440         IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
39441       ENDIF
39442       ISTHKT(2+IIGLU1)  =922
39443       JMOHKT(1,2+IIGLU1)=NC2T
39444       JMOHKT(2,2+IIGLU1)=0
39445       JDAHKT(1,2+IIGLU1)=3+IIGLU1
39446       JDAHKT(2,2+IIGLU1)=0
39447       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
39448      *+XGIVE*PHKT(1,5+IIGLU1)
39449       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
39450      *+XGIVE*PHKT(2,5+IIGLU1)
39451       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
39452      *+XGIVE*PHKT(3,5+IIGLU1)
39453       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
39454      *+XGIVE*PHKT(4,5+IIGLU1)
39455 C     PHKT(5,2)  =PHKK(5,NC2T)
39456       XMIST=(PHKT(4,2+IIGLU1)**2-
39457      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39458      *PHKT(1,2+IIGLU1)**2)
39459       IF(XMIST.GT.0.D0)THEN
39460       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
39461      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39462      *PHKT(1,2+IIGLU1)**2)
39463       ELSE
39464 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39465       PHKT(5,2+IIGLU1)=0.D0
39466       ENDIF
39467       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
39468       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
39469       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
39470       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
39471       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
39472       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
39473       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
39474       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
39475       IDHKT(3+IIGLU1)   =88888
39476 C     IDHKT(3)   =1000*NNNC1+MMMC1+10
39477       ISTHKT(3+IIGLU1)  =93
39478 C     ISTHKT(3)  =KKKC1
39479       JMOHKT(1,3+IIGLU1)=1
39480       JMOHKT(2,3+IIGLU1)=2+IIGLU1
39481       JDAHKT(1,3+IIGLU1)=0
39482       JDAHKT(2,3+IIGLU1)=0
39483       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
39484       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
39485       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
39486       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
39487       PHKT(5,3+IIGLU1)
39488      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
39489      *            -PHKT(3,3+IIGLU1)**2)
39490       IF(IPIP.GE.3)THEN
39491       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
39492      * JDAHKT(1,1),
39493      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
39494       DO 71 IIG=2,2+IIGLU1-1
39495       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39496      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
39497      * JDAHKT(1,IIG),
39498      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39499    71 CONTINUE
39500       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
39501      &             IDHKT(2),JMOHKT(1,2+IIGLU1),
39502      * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
39503      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
39504       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
39505      * JMOHKT(1,3+IIGLU1),
39506      * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
39507      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
39508       ENDIF
39509       CHAMAL=CHAB1
39510 **NEW
39511 C     IF(IPIP.EQ.1)THEN
39512 C       IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
39513 C     ELSEIF(IPIP.EQ.2)THEN
39514 C       IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
39515 C     ENDIF
39516       IF(IPIP.EQ.1)THEN
39517         IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
39518       ELSEIF(IPIP.EQ.2)THEN
39519         IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
39520       ENDIF
39521 **
39522       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
39523 C       IREJ=1
39524         IPCO=0
39525 C       RETURN
39526 C       WRITE(6,*)' MGSQBS1 jump back from chain 3'
39527         GO TO 3466
39528       ENDIF
39529       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
39530       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
39531       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
39532       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
39533       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
39534       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
39535       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
39536       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
39537       IF(IPIP.EQ.1)THEN
39538         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ1+3
39539         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
39540         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
39541         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
39542       ELSEIF(IPIP.EQ.2)THEN
39543         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
39544         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
39545         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
39546         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
39547 C       WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
39548       ENDIF
39549       ISTHKT(7+IIGLU1)  =921
39550       JMOHKT(1,7+IIGLU1)=NC2P
39551       JMOHKT(2,7+IIGLU1)=0
39552       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
39553       JDAHKT(2,7+IIGLU1)=0
39554 C     PHKT(1,7)  =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
39555 C     PHKT(2,7)  =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
39556 C     PHKT(3,7)  =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
39557 C     PHKT(4,7+IIGLU1)  =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
39558 **NEW
39559       IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
39560      &    WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
39561 **
39562       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
39563       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
39564       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
39565       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
39566 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
39567 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
39568       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
39569 C       IREJ=1
39570 C       WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
39571         IPCO=0
39572 C       RETURN
39573         GO TO 3466
39574       ENDIF
39575 C     PHKT(5,7)  =PHKK(5,NC2P)
39576       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
39577      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
39578      *PHKT(1,7+IIGLU1)**2)
39579       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
39580       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
39581       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
39582       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
39583       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
39584       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
39585       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
39586       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
39587 C     Insert here the IIGLU2 gluons
39588       PG1=0.D0
39589       PG2=0.D0
39590       PG3=0.D0
39591       PG4=0.D0
39592       IF(IIGLU2.GE.1)THEN
39593       JJG=NC2P
39594       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39595         KKG=JJG+IIG-7-IIGLU1
39596         IDHKT(IIG)   =IDHKK(KKG)
39597         ISTHKT(IIG)  =921
39598         JMOHKT(1,IIG)=KKG
39599         JMOHKT(2,IIG)=0
39600         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
39601         JDAHKT(2,IIG)=0
39602         PHKT(1,IIG)=PHKK(1,KKG)
39603         PG1=PG1+ PHKT(1,IIG)
39604         PHKT(2,IIG)=PHKK(2,KKG)
39605         PG2=PG2+ PHKT(2,IIG)
39606         PHKT(3,IIG)=PHKK(3,KKG)
39607         PG3=PG3+ PHKT(3,IIG)
39608         PHKT(4,IIG)=PHKK(4,KKG)
39609         PG4=PG4+ PHKT(4,IIG)
39610         PHKT(5,IIG)=PHKK(5,KKG)
39611         VHKT(1,IIG)  =VHKK(1,KKG)
39612         VHKT(2,IIG)  =VHKK(2,KKG)
39613         VHKT(3,IIG)  =VHKK(3,KKG)
39614         VHKT(4,IIG)  =VHKK(4,KKG)
39615         WHKT(1,IIG)  =WHKK(1,KKG)
39616         WHKT(2,IIG)  =WHKK(2,KKG)
39617         WHKT(3,IIG)  =WHKK(3,KKG)
39618         WHKT(4,IIG)  =WHKK(4,KKG)
39619    81 CONTINUE
39620       ENDIF
39621       IDHKT(8+IIGLU1+IIGLU2)   =IP2
39622       ISTHKT(8+IIGLU1+IIGLU2)  =922
39623       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
39624       JMOHKT(2,8+IIGLU1+IIGLU2)=0
39625       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
39626       JDAHKT(2,8+IIGLU1+IIGLU2)=0
39627 **NEW
39628       IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
39629      &    WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
39630 **
39631       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
39632       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
39633       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
39634       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
39635 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
39636       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
39637      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39638      *PHKT(1,8+IIGLU1+IIGLU2)**2)
39639       IF(XMIST.GT.0.D0)THEN
39640       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
39641      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39642      *PHKT(1,8+IIGLU1+IIGLU2)**2)
39643       ELSE
39644 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39645       PHKT(5,8+IIGLU1+IIGLU2)=0.D0
39646       ENDIF
39647       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
39648       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
39649       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
39650       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
39651       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
39652       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
39653       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
39654       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
39655       IDHKT(9+IIGLU1+IIGLU2)   =88888
39656 C     IDHKT(9)   =1000*NNNC2+MMMC2+10
39657       ISTHKT(9+IIGLU1+IIGLU2)  =93
39658 C     ISTHKT(9)  =KKKC2
39659       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
39660       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
39661       JDAHKT(1,9+IIGLU1+IIGLU2)=0
39662       JDAHKT(2,9+IIGLU1+IIGLU2)=0
39663       PHKT(1,9+IIGLU1+IIGLU2)  =PHKT(1,7+IIGLU1)
39664      * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
39665       PHKT(2,9+IIGLU1+IIGLU2)  =PHKT(2,7+IIGLU1)
39666      * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
39667       PHKT(3,9+IIGLU1+IIGLU2)  =PHKT(3,7+IIGLU1)
39668      * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
39669       PHKT(4,9+IIGLU1+IIGLU2)  =PHKT(4,7+IIGLU1)
39670      * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
39671       PHKT(5,9+IIGLU1+IIGLU2)
39672      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
39673      * PHKT(2,9+IIGLU1+IIGLU2)**2
39674      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
39675       IF(IPIP.GE.3)THEN
39676       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
39677      * JMOHKT(1,7+IIGLU1),
39678      * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
39679      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
39680       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39681       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39682      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
39683      * JDAHKT(1,IIG),
39684      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39685    91 CONTINUE
39686       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
39687      * IDHKT(8+IIGLU1+IIGLU2),
39688      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
39689      * JDAHKT(1,8+IIGLU1+IIGLU2),
39690      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
39691       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
39692      * IDHKT(9+IIGLU1+IIGLU2),
39693      * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
39694      * JDAHKT(1,9+IIGLU1+IIGLU2),
39695      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
39696       ENDIF
39697       CHAMAL=CHAB1
39698       IF(IPIP.EQ.1)THEN
39699         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
39700       ELSEIF(IPIP.EQ.2)THEN
39701         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
39702       ENDIF
39703       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
39704 C       IREJ=1
39705         IPCO=0
39706 C       RETURN
39707 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
39708 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
39709         GO TO 3466
39710       ENDIF
39711       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
39712       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
39713       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
39714       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
39715       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
39716       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
39717       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
39718       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
39719 C
39720       IGCOUN=9+IIGLU1+IIGLU2
39721       IPCO=0
39722        RETURN
39723        END
39724
39725 *$ CREATE HKKHKT.FOR
39726 *COPY HKKHKT
39727 C
39728 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
39729 C
39730       SUBROUTINE HKKHKT(I,J)
39731       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39732       SAVE
39733
39734 * event history
39735       PARAMETER (NMXHKK=200000)
39736       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39737      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39738      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39739 * extended event history
39740       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39741      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39742      &                IHIST(2,NMXHKK)
39743
39744       PARAMETER (NTMHKK= 300)
39745       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39746      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39747      +(4,NTMHKK)
39748 C
39749       ISTHKK(I)  =ISTHKT(J)
39750       IDHKK(I)   =IDHKT(J)
39751 C     IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
39752       IF(IDHKK(I).EQ.88888)THEN
39753 C       JMOHKK(1,I)=I-2
39754 C       JMOHKK(2,I)=I-1
39755         JMOHKK(1,I)=I-(J-JMOHKT(1,J))
39756         JMOHKK(2,I)=I-(J-JMOHKT(2,J))
39757       ELSE
39758         JMOHKK(1,I)=JMOHKT(1,J)
39759         JMOHKK(2,I)=JMOHKT(2,J)
39760       ENDIF
39761       JDAHKK(1,I)=JDAHKT(1,J)
39762       JDAHKK(2,I)=JDAHKT(2,J)
39763 C       IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
39764 C       JDAHKK(1,I)=I+2
39765 C     ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
39766 C       JDAHKK(1,I)=I+1
39767 C     ENDIF
39768       IF(JDAHKT(1,J).GT.0)THEN
39769         JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
39770       ENDIF
39771       PHKK(1,I)  =PHKT(1,J)
39772       PHKK(2,I)  =PHKT(2,J)
39773       PHKK(3,I)  =PHKT(3,J)
39774       PHKK(4,I)  =PHKT(4,J)
39775       PHKK(5,I)  =PHKT(5,J)
39776       VHKK(1,I)  =VHKT(1,J)
39777       VHKK(2,I)  =VHKT(2,J)
39778       VHKK(3,I)  =VHKT(3,J)
39779       VHKK(4,I)  =VHKT(4,J)
39780       WHKK(1,I)  =WHKT(1,J)
39781       WHKK(2,I)  =WHKT(2,J)
39782       WHKK(3,I)  =WHKT(3,J)
39783       WHKK(4,I)  =WHKT(4,J)
39784       RETURN
39785       END
39786
39787 *$ CREATE DT_DBREAK.FOR
39788 *COPY DT_DBREAK
39789 *
39790 *===dbreak=============================================================*
39791 *
39792       SUBROUTINE DT_DBREAK(MODE)
39793
39794 ************************************************************************
39795 * This is the steering subroutine for the different diquark breaking   *
39796 * mechanisms.                                                          *
39797 *                                                                      *
39798 * MODE = 1  breaking of projectile diquark in qq-q chain using         *
39799 *           a sea quark (q-qq chain) of the same projectile            *
39800 *      = 2  breaking of target     diquark in q-qq chain using         *
39801 *           a sea quark (qq-q chain) of the same target                *
39802 *      = 3  breaking of projectile diquark in qq-q chain using         *
39803 *           a sea quark (q-aq chain) of the same projectile            *
39804 *      = 4  breaking of target     diquark in q-qq chain using         *
39805 *           a sea quark (aq-q chain) of the same target                *
39806 *      = 5  breaking of projectile anti-diquark in aqaq-aq chain using *
39807 *           a sea anti-quark (aq-aqaq chain) of the same projectile    *
39808 *      = 6  breaking of target     anti-diquark in aq-aqaq chain using *
39809 *           a sea anti-quark (aqaq-aq chain) of the same target        *
39810 *      = 7  breaking of projectile anti-diquark in aqaq-aq chain using *
39811 *           a sea anti-quark (aq-q chain) of the same projectile       *
39812 *      = 8  breaking of target     anti-diquark in aq-aqaq chain using *
39813 *           a sea anti-quark (q-aq chain) of the same target           *
39814 *                                                                      *
39815 * Original version by J. Ranft.                                        *
39816 * This version dated 17.5.00  is written by S. Roesler.                *
39817 ************************************************************************
39818
39819       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39820       SAVE
39821       PARAMETER ( LINP = 10 ,
39822      &            LOUT = 6 ,
39823      &            LDAT = 9 )
39824
39825 * event history
39826       PARAMETER (NMXHKK=200000)
39827       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39828      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39829      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39830 * extended event history
39831       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39832      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39833      &                IHIST(2,NMXHKK)
39834 * flags for input different options
39835       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
39836       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
39837      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
39838 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
39839       PARAMETER (MAXCHN=10000)
39840       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
39841 * diquark-breaking mechanism
39842       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
39843 * flags for particle decays
39844       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
39845      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
39846      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
39847
39848 *
39849 * chain identifiers
39850 * ( 1 = q-aq,   2 = aq-q,   3 = q-qq,   4 = qq-q,
39851 *   5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
39852       DIMENSION IDCHN1(8),IDCHN2(8)
39853       DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
39854       DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
39855 *
39856 * parton identifiers
39857 * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
39858 *   +-51/52 = unitarity-sea, +-61/62 = gluons )
39859       DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
39860       DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
39861      &             31, 31, 31, 31, 31, 31, 31, 31,
39862      &             41, 41, 41, 41, 51, 51, 51, 51/
39863       DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
39864      &             32, 32, 32, 32, 32, 32, 32, 32,
39865      &             42, 42, 42, 42, 52, 52, 52, 52/
39866       DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
39867      &             51, 31, 41, 41, 31, 31, 31, 31,
39868      &              0, 41, 51, 51, 51, 51, 51, 51/
39869       DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
39870      &             32, 52, 42, 42, 32, 32, 32, 32,
39871      &             42,  0, 52, 52, 52, 52, 52, 52/
39872
39873       IF (NCHAIN.LE.0) RETURN
39874       DO 1 I=1,NCHAIN
39875          IDX1 = IDXCHN(1,I)
39876          IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
39877          IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
39878          IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
39879      &       .AND.
39880      &        ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
39881      &                                    (IS1P.EQ.ISP1P(MODE,3)))
39882      &       .AND.
39883      &        ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
39884      &                                    (IS1T.EQ.ISP1T(MODE,3)))
39885      &      ) THEN
39886             DO 2 J=1,NCHAIN
39887                IDX2 = IDXCHN(1,J)
39888                IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
39889                IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
39890                IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
39891      &             .AND.
39892      &              ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
39893      &                                      .OR.(IS2P.EQ.ISP2P(MODE,3)))
39894      &             .AND.
39895      &              ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
39896      &                                      .OR.(IS2T.EQ.ISP2T(MODE,3)))
39897      &            ) THEN
39898 *   find mother nucleons of the diquark to be splitted and of the
39899 *   sea-quark and reject this combination if it is not the same
39900                   IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
39901      &                (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
39902                      IANCES = 1
39903                   ELSE
39904                      IANCES = 2
39905                   ENDIF
39906                   IDXMO1 = JMOHKK(IANCES,IDX1)
39907     4             CONTINUE
39908                   IF ((JMOHKK(1,IDXMO1).NE.0).AND.
39909      &                (JMOHKK(2,IDXMO1).NE.0)) THEN
39910                      IANC = IANCES
39911                   ELSE
39912                      IANC = 1
39913                   ENDIF
39914                   IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
39915                      IDXMO1 = JMOHKK(IANC,IDXMO1)
39916                      GOTO 4
39917                   ENDIF
39918                   IDXMO2 = JMOHKK(IANCES,IDX2)
39919     5             CONTINUE
39920                   IF ((JMOHKK(1,IDXMO2).NE.0).AND.
39921      &                (JMOHKK(2,IDXMO2).NE.0)) THEN
39922                      IANC = IANCES
39923                   ELSE
39924                      IANC = 1
39925                   ENDIF
39926                   IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
39927                      IDXMO2 = JMOHKK(IANC,IDXMO2)
39928                      GOTO 5
39929                   ENDIF
39930                   IF (IDXMO1.NE.IDXMO2) GOTO 2
39931 *   quark content of projectile parton
39932                   IP1   = IDHKK(JMOHKK(1,IDX1))
39933                   IP11  = IP1/1000
39934                   IP12  = (IP1-1000*IP11)/100
39935                   IP2   = IDHKK(JMOHKK(2,IDX1))
39936                   IP21  = IP2/1000
39937                   IP22  = (IP2-1000*IP21)/100
39938 *   quark content of target parton
39939                   IT1  = IDHKK(JMOHKK(1,IDX2))
39940                   IT11 = IT1/1000
39941                   IT12 = (IT1-1000*IT11)/100
39942                   IT2  = IDHKK(JMOHKK(2,IDX2))
39943                   IT21 = IT2/1000
39944                   IT22 = (IT2-1000*IT21)/100
39945 *   split diquark and form new chains
39946                   IF (MODE.EQ.1) THEN
39947                      IF (IT1.EQ.4) GOTO 2
39948                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39949      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39950      &                         IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
39951                   ELSEIF (MODE.EQ.2) THEN
39952                      IF (IT2.EQ.4) GOTO 2
39953                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39954      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39955      &                         IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
39956                   ELSEIF (MODE.EQ.3) THEN
39957                      IF (IT1.EQ.4) GOTO 2
39958                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39959      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39960      &                         IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
39961                   ELSEIF (MODE.EQ.4) THEN
39962                      IF (IT2.EQ.4) GOTO 2
39963                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39964      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39965      &                         IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
39966                   ELSEIF (MODE.EQ.5) THEN
39967                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39968      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39969      &                         IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
39970                   ELSEIF (MODE.EQ.6) THEN
39971                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39972      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39973      &                         IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
39974                   ELSEIF (MODE.EQ.7) THEN
39975                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39976      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39977      &                         IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
39978                   ELSEIF (MODE.EQ.8) THEN
39979                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39980      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39981      &                         IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
39982                   ENDIF
39983                   IF (IREJ.GE.1) THEN
39984                      if ((ipq.lt.0).or.(ipq.ge.4))
39985      &                  write(LOUT,*) 'ipq !!!',ipq,mode
39986                      DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
39987 *   accept or reject new chains corresponding to PDBSEA
39988                   ELSE
39989                      IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
39990                         ACC   = DBRKA(1,MODE)+DBRKA(2,MODE)
39991                         REJ   = DBRKR(1,MODE)+DBRKR(2,MODE)
39992                      ELSEIF (IPQ.EQ.3) THEN
39993                         ACC   = DBRKA(3,MODE)
39994                         REJ   = DBRKR(3,MODE)
39995                      ELSE
39996                         WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
39997                         STOP
39998                      ENDIF
39999                      IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
40000                         DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
40001                         IACC = 1
40002                      ELSE
40003                         DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
40004                         IACC = 0
40005                      ENDIF
40006 *   new chains have been accepted and are now copied into HKKEVT
40007                      IF (IACC.EQ.1) THEN
40008                         IF (LEMCCK) THEN
40009                            CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
40010      &                                    PHKK(3,IDX1),PHKK(4,IDX1),
40011      &                                    1,IDUM1,IDUM2)
40012                            CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
40013      &                                    PHKK(3,IDX2),PHKK(4,IDX2),
40014      &                                    2,IDUM1,IDUM2)
40015                         ENDIF
40016                         IDHKK(IDX1) = 99888
40017                         IDHKK(IDX2) = 99888
40018                         IDXCHN(2,I) = -1
40019                         IDXCHN(2,J) = -1
40020                         DO 3 K=1,IGCOUN
40021                            NHKK = NHKK+1
40022                            CALL HKKHKT(NHKK,K)
40023                            IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
40024                               PX = -PHKK(1,NHKK)
40025                               PY = -PHKK(2,NHKK)
40026                               PZ = -PHKK(3,NHKK)
40027                               PE = -PHKK(4,NHKK)
40028                               CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
40029                            ENDIF
40030     3                   CONTINUE
40031                         IF (LEMCCK) THEN
40032                            CHKLEV = 0.1D0
40033                            CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
40034      &                                                             IREJ)
40035                            IF (IREJ.NE.0) CALL DT_EVTOUT(4)
40036                         ENDIF
40037                         GOTO 1
40038                      ENDIF
40039                   ENDIF
40040                ENDIF
40041     2       CONTINUE
40042          ENDIF
40043     1 CONTINUE
40044       RETURN
40045       END
40046
40047 *$ CREATE DT_CQPAIR.FOR
40048 *COPY DT_CQPAIR
40049 *
40050 *===cqpair=============================================================*
40051 *
40052       SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
40053
40054 ************************************************************************
40055 * This subroutine Creates a Quark-antiquark PAIR from the sea.         *
40056 *                                                                      *
40057 *   XQMAX   maxium energy fraction of quark (input)                    *
40058 *   XAQMAX  maxium energy fraction of antiquark (input)                *
40059 *   XQ      energy fraction of quark (output)                          *
40060 *   XAQ     energy fraction of antiquark (output)                      *
40061 *   IFLV    quark flavour (- antiquark flavor) (output)                *
40062 *                                                                      *
40063 * This version dated 14.5.00  is written by S. Roesler.                *
40064 ************************************************************************
40065
40066       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
40067       SAVE
40068       PARAMETER ( LINP = 10 ,
40069      &            LOUT = 6 ,
40070      &            LDAT = 9 )
40071
40072 * Lorentz-parameters of the current interaction
40073       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
40074      &                UMO,PPCM,EPROJ,PPROJ
40075
40076 *
40077       IREJ = 0
40078       XQ   = 0.0D0
40079       XAQ  = 0.0D0
40080 *
40081 * sample quark flavour
40082 *
40083 *  set seasq here (the one from DTCHAI should be used in the future)
40084       SEASQ = 0.5D0
40085       IFLV  = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
40086 *
40087 * sample energy fractions of sea pair
40088 * we first sample the energy fraction of a gluon and then split the gluon
40089 *
40090 *  maximum energy fraction of the gluon forced via input
40091       XGMAXI = XQMAX+XAQMAX
40092 *  minimum energy fraction of the gluon
40093       XTHR1 = 4.0D0 /UMO**2
40094       XTHR2 = 0.54D0/UMO**1.5D0
40095       XGMIN = MAX(XTHR1,XTHR2)
40096 *  maximum energy fraction of the gluon
40097       XGMAX = 0.3D0
40098       XGMAX = MIN(XGMAXI,XGMAX)
40099       IF (XGMIN.GE.XGMAX) THEN
40100          IREJ = 1
40101          RETURN
40102       ENDIF
40103 *
40104 *  sample energy fraction of the gluon
40105       NLOOP = 0
40106     1 CONTINUE
40107       NLOOP = NLOOP+1
40108       IF (NLOOP.GE.50) THEN
40109          IREJ = 1
40110          RETURN
40111       ENDIF
40112       XGLUON = DT_SAMSQX(XGMIN,XGMAX)
40113       EGLUON = XGLUON*UMO/2.0D0
40114 *
40115 *  split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
40116       ZMIN = MIN(0.1D0,0.5D0/EGLUON)
40117       ZMAX = 1.0D0-ZMIN
40118       RZ   = DT_RNDM(ZMAX)
40119       XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
40120       RQ   = DT_RNDM(ZMAX)
40121       IF (RQ.LT.0.5D0) THEN
40122          XQ  = XGLUON*XHLP
40123          XAQ = XGLUON-XQ
40124       ELSE
40125          XAQ = XGLUON*XHLP
40126          XQ  = XGLUON-XAQ
40127       ENDIF
40128       IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1
40129
40130       RETURN
40131       END