GEANT321/fluka/hadevv.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1995/10/24 10:19:56  cernlib
   6 * Geant
   7 *
   8 *
   9 #include "geant321/pilot.h"
  10 *CMZ :  3.21/02 29/03/94  15.41.43  by  S.Giani
  11 *-- Author :
  12 *$ CREATE HADEVV.FOR
  13 *COPY HADEVV
  14 *
  15 *=== hadevv ===========================================================*
  16 *
  17       SUBROUTINE HADEVV ( NHAD, KPROJ, KTARG, PPROJ, EPROJ, UMO )
  18
  19 #include "geant321/dblprc.inc"
  20 #include "geant321/dimpar.inc"
  21 #include "geant321/iounit.inc"
  22 *
  23 *----------------------------------------------------------------------*
  24 *                                                                      *
  25 *    Modified version of Hadevt created by Alfredo Ferrari, INFN-Milan *
  26 *                                                                      *
  27 *    Last change  on  20-jun-93  by  Alfredo Ferrari, INFN - MIlan     *
  28 *                                                                      *
  29 *  Hadevt90: kinematics completed revised by A. Ferrari, before it was *
  30 *            always wrong every time the second jet to be sampled was  *
  31 *            a "parjet". A few other bugs corrected: maybe others are  *
  32 *            still in!!!                                               *
  33 *----------------------------------------------------------------------*
  34 *
  35 C
  36 C     GENERATE HADRON PRODC
  37 C     GENERATE HADRON PRODUCTION EVENT IN  KPROJ - KTARG  COLLISION
  38 C     WITH  LAB PROJECTILE MOMENTUM  PPROJ
  39 C     INCLUDING MESON MESON AND MESON ANTIBARYON COLLISIONS
  40 C
  41 C********************************************************************
  42 C
  43 #include "geant321/auxpar.inc"
  44 #include "geant321/balanc.inc"
  45 #include "geant321/cmsres.inc"
  46 #include "geant321/finpar.inc"
  47 #include "geant321/hadpar.inc"
  48 #include "geant321/inpdat2.inc"
  49 #include "geant321/part.inc"
  50 #include "geant321/qquark.inc"
  51       COMMON /FKINVT/PNUC(3),INUCVT
  52       COMMON /FKPRIN/ IPRI, INIT
  53       REAL RNDM(2)
  54       LOGICAL LISSU, LQTARG, LQPROJ
  55 *
  56       SAVE UNON,UNOM,UNOMS
  57       DATA UNON/2.0D0/
  58       DATA UNOM/1.5D0/
  59       DATA UNOMS/0.5D0/
  60 *
  61 C
  62 C*******************************************************************"
  63 C
  64 C     KINEMATICS
  65 C
  66 C********************************************************************
  67 C
  68  8899 CONTINUE
  69 * Ijproj = paprop numbering
  70       IJPROJ = KPTOIP (KPROJ)
  71       IJTARG = KPTOIP (KTARG)
  72       AMPROJ = AM(KPROJ)
  73       AMTAR = AM(KTARG)
  74 *  The usual gamma and sqrt[beta**2/(1-beta**2)]=eta=gamma*beta factors
  75 *  for the CMS system
  76 *
  77       GAMCM = (EPROJ+AMTAR)/UMO
  78       BGCM  = PPROJ / UMO
  79 C
  80 *or      IF(IPRI.EQ.1) WRITE(LUNOUT,101)KPROJ,KTARG,PPROJ,AMPROJ,AMTAR,
  81 *or     &EPROJ,UMO,GAMCM,BGCM
  82 *or 101  FORMAT(2I5,10F11.5)
  83 C
  84 C********************************************************************
  85 C
  86 C     SELECTION OF  QUARK - DIQUARK - CHAINS
  87 C
  88 C********************************************************************
  89 C
  90 *
  91 *  Ibproj = baryonic charge of the projectile
  92 *
  93       IBPROJ = IBAR(KPROJ)
  94 *
  95 *  Ibtarg = baryonic charge of the target nucleon
  96 *
  97       IBTARG = IBAR(KTARG)
  98 *
  99 *  Ipq1,ipq2,ipq3 = quarks of the projectile
 100 *
 101       IQP1 = MQUARK(1,IJPROJ)
 102       IQP2 = MQUARK(2,IJPROJ)
 103       IQP3 = MQUARK(3,IJPROJ)
 104 *
 105 *  Iqt1,iqt2,iqt3 = quarks of the projectile
 106 *
 107       IQT1 = MQUARK(1,IJTARG)
 108       IQT2 = MQUARK(2,IJTARG)
 109       IQT3 = MQUARK(3,IJTARG)
 110 *or      IF (IPRI .EQ. 1)
 111 *or     &WRITE(LUNOUT,102)IBPROJ, IQP1,IQP2,IQP3,IQT1,IQT2,
 112 *or     &IQT3
 113 *or 102  FORMAT(12I10)
 114       IF (IBPROJ) 11, 12, 13
 115   11  CONTINUE
 116 C
 117 C********************************************************************
 118 C
 119 C     SELECTION OF CHAINS
 120 C     ANTIBARYON - BARYON   COLLISION
 121 C
 122 C********************************************************************
 123 C
 124 *  +-------------------------------------------------------------------*
 125 *  | The incoming projectile is an antibaryon!!!
 126 *  |
 127          CALL GRNDM(RNDM,1)
 128          ISAM1 = 1.D0 + 3.D0*RNDM(1)
 129          GO TO (111,112,113),ISAM1
 130  111     CONTINUE
 131             IBF = IQP1
 132             IFF1 = IQP2
 133             IFF2 = IQP3
 134             GO TO 114
 135  112     CONTINUE
 136             IBF = IQP2
 137             IFF1 = IQP1
 138             IFF2 = IQP3
 139             GO TO 114
 140  113     CONTINUE
 141             IBF = IQP3
 142             IFF1 = IQP1
 143             IFF2 = IQP2
 144  114     CONTINUE
 145          CALL GRNDM(RNDM,1)
 146          ISAM2 = 1.D0 + 3.D0*RNDM(1)
 147          GO TO (115,116,117),ISAM2
 148  115     CONTINUE
 149             IBB = IQT1
 150             IFB1 = IQT2
 151             IFB2 = IQT3
 152             GO TO 118
 153  116     CONTINUE
 154             IBB = IQT2
 155             IFB1 = IQT1
 156             IFB2 = IQT3
 157             GO TO 118
 158  117     CONTINUE
 159             IBB = IQT3
 160             IFB1 = IQT1
 161             IFB2 = IQT2
 162  118     CONTINUE
 163          GO TO 14
 164 *  | Quark selection for incoming antibaryon has been completed
 165 *  +-->-->-->-->-->-->-->-->-->--> go to 14 continue
 166
 167   12  CONTINUE
 168 *  +-------------------------------------------------------------------*
 169 *  | The incoming projectile is a meson!!!
 170 *  |
 171          IF (IBTARG)712,812,912
 172 *  |  +----------------------------------------------------------------*
 173 *  |  | The target nucleon is a baryon (meson projectile)
 174 *  |  |
 175  912        CONTINUE
 176 C
 177 C********************************************************************
 178 C
 179 C     SELECTION OF CHAINS
 180 C     MESON - BARYON  COLLISION
 181 C
 182 C********************************************************************
 183 C
 184             CALL GRNDM(RNDM,1)
 185             ISAM3 = 1.D0 + 2.D0*RNDM(1)
 186             GO TO (121,122),ISAM3
 187  121        CONTINUE
 188                IFF = IQP1
 189                IBF = IQP2
 190                GO TO 123
 191  122        CONTINUE
 192                IFF = IQP2
 193                IBF = IQP1
 194  123        CONTINUE
 195             CALL GRNDM(RNDM,1)
 196             ISAM4 = 1.D0 + 3.D0*RNDM(1)
 197             GO TO (124,125,126),ISAM4
 198  124        CONTINUE
 199                GO TO (1241,1242),ISAM3
 200 1241           CONTINUE
 201                   IBB = IQT1
 202                   IFB1 = IQT2
 203                   IFB2 = IQT3
 204                   GO TO 127
 205 1242           CONTINUE
 206                   IBB1 = IQT2
 207                   IBB2 = IQT3
 208                   IFB = IQT1
 209                   GO TO 127
 210  125        CONTINUE
 211                GO TO (1251,1252),ISAM3
 212 1251           CONTINUE
 213                   IBB = IQT2
 214                   IFB1 = IQT1
 215                   IFB2 = IQT3
 216                   GO TO 127
 217 1252           CONTINUE
 218                   IBB1 = IQT1
 219                   IBB2 = IQT3
 220                   IFB = IQT2
 221                   GO TO 127
 222  126        CONTINUE
 223                GO TO (1261,1262),ISAM3
 224 1261           CONTINUE
 225                   IBB = IQT3
 226                   IFB1 = IQT1
 227                   IFB2 = IQT2
 228                   GO TO 127
 229 1262           CONTINUE
 230                   IBB1 = IQT1
 231                   IBB2 = IQT2
 232                   IFB = IQT3
 233  127        CONTINUE
 234             GO TO 14
 235 *  |  | Quark selection for incoming meson and baryon target completed
 236 *  |  +-->-->-->-->-->-->-->-->-->--> go to 114 continue
 237
 238 *  |  +----------------------------------------------------------------*
 239 *  |  | The target nucleon is a meson (meson projectile)
 240 *  |  |
 241  812        CONTINUE
 242 C===============================================================
 243 C
 244 C     SELECTION OF CHAINS
 245 C        MESON MESON COLLISIONS
 246 C
 247 C================================================================
 248             CALL GRNDM(RNDM,1)
 249             ISAM3 = 1.D0 + 2.D0*RNDM(1)
 250             GO TO (1218,1228),ISAM3
 251 1218        CONTINUE
 252                IFF = IQP1
 253                IBF = IQP2
 254                IBB = IQT1
 255                IFB = IQT2
 256                GO TO 1238
 257 1228        CONTINUE
 258                IFF = IQP2
 259                IBF = IQP1
 260                IBB = IQT2
 261                IFB = IQT1
 262 1238        CONTINUE
 263             GO TO 14
 264 *  |  | Quark selection for incoming meson and meson target completed
 265 *  |  +-->-->-->-->-->-->-->-->-->--> go to 14 continue
 266
 267 *  |  +----------------------------------------------------------------*
 268 *  |  | The target nucleon is an anti-baryon (meson projectile)
 269 *  |  |
 270  712        CONTINUE
 271 C=================================================================
 272 C
 273 C     SELECTION OF CHAINS
 274 C      MESON ANTIBARYON COLLISIONS
 275 C
 276 C==================================================================
 277             ISAM3 = 2
 278             IFF = IQP1
 279             IBF = IQP2
 280             CALL GRNDM(RNDM,1)
 281             ISAM4 = 1.D0 + 3.D0*RNDM(1)
 282             GO TO (1247,1257,1267),ISAM4
 283 1247        CONTINUE
 284                GO TO (12417,12427),ISAM3
 285 12417          CONTINUE
 286                   IBB = IQT1
 287                   IFB1 = IQT2
 288                   IFB2 = IQT3
 289                   GO TO 1277
 290 12427          CONTINUE
 291                   IBB1 = IQT2
 292                   IBB2 = IQT3
 293                   IFB = IQT1
 294                   GO TO 1277
 295 1257        CONTINUE
 296                GO TO (12517,12527),ISAM3
 297 12517          CONTINUE
 298                   IBB = IQT2
 299                   IFB1 = IQT1
 300                   IFB2 = IQT3
 301                   GO TO 1277
 302 12527          CONTINUE
 303                   IBB1 = IQT1
 304                   IBB2 = IQT3
 305                   IFB = IQT2
 306                   GO TO 1277
 307 1267        CONTINUE
 308                GO TO (12617,12627),ISAM3
 309 12617          CONTINUE
 310                   IBB = IQT3
 311                   IFB1 = IQT1
 312                   IFB2 = IQT2
 313                   GO TO 1277
 314 12627          CONTINUE
 315                   IBB1 = IQT1
 316                   IBB2 = IQT2
 317                   IFB = IQT3
 318 1277        CONTINUE
 319             GO TO 14
 320 *  |  | Quark selection for incoming meson and a-baryon target completed
 321 *  |  +-->-->-->-->-->-->-->-->-->--> go to 14 continue
 322 *  |
 323 *  |                                     end meson projectile
 324 *  +-------------------------------------------------------------------*
 325
 326 *  +-------------------------------------------------------------------*
 327 *  |  The incoming projectile is a baryon!!!
 328 *  |
 329   13  CONTINUE
 330 C
 331 C********************************************************************
 332 C
 333 C     SELECTION OF CHAINS
 334 C     BARYON - BARYON   COLLISION
 335 C
 336 C********************************************************************
 337 C
 338          CALL GRNDM(RNDM,1)
 339          ISAM5 = 1.D0 + 3.D0*RNDM(1)
 340          GO TO (131,132,133),ISAM5
 341  131     CONTINUE
 342             IBF = IQP1
 343             IFF1 = IQP2
 344             IFF2 = IQP3
 345             GO TO 134
 346  132     CONTINUE
 347             IBF = IQP2
 348             IFF1 = IQP1
 349             IFF2 = IQP3
 350             GO TO 134
 351  133     CONTINUE
 352             IBF = IQP3
 353             IFF1 = IQP1
 354             IFF2 = IQP2
 355  134     CONTINUE
 356          CALL GRNDM(RNDM,1)
 357          ISAM6 = 1.D0 + 3.D0*RNDM(1)
 358          GO TO (135,136,137),ISAM6
 359  135     CONTINUE
 360             IFB = IQT1
 361             IBB1 = IQT2
 362             IBB2 = IQT3
 363             GO TO 138
 364  136     CONTINUE
 365             IFB = IQT2
 366             IBB1 = IQT1
 367             IBB2 = IQT3
 368             GO TO 138
 369  137     CONTINUE
 370             IFB = IQT3
 371             IBB1 = IQT1
 372             IBB2 = IQT2
 373  138     CONTINUE
 374 *  |  | Quark selection for incoming baryon and baryon target completed
 375 *  +  |-->-->-->-->-->-->-->-->-->--> go to 14 continue
 376   14  CONTINUE
 377 *  | Quark selection completed
 378 *  +-------------------------------------------------------------------*
 379
 380 *or      IF (IPRI.EQ.1) WRITE(LUNOUT,102)IFF,IBF,IFF1,IFF2,IFB1,IFB2,
 381 *or     &IFB,IBB,IBB1,IBB2
 382 C
 383 C********************************************************************
 384 C
 385 C*** SAMPLING MOMENTUM FRACTIONS OF QUARKS AND DIQUARKS
 386 C
 387 C********************************************************************
 388 C
 389       IXPXT = 0
 390   25  CONTINUE
 391       IXPXT = IXPXT + 1
 392 *  +-------------------------------------------------------------------*
 393 *  | Selection of xp and xt from beta distribution:
 394 *  |   xp and xt are then used to select the fraction of momentum and
 395 *  |   energy for each jet, according to the following relations:
 396 *  |   (where we assume to use xp, xt for the jet n. 1)
 397 *  |
 398 *  |      xxp = 1 - xp
 399 *  |      xxt = 1 - xt
 400 *  |      Ech1 = umo * (xp  + xt ) / 2
 401 *  |      Ech2 = umo * (xxp + xxt) / 2
 402 *  |      Pch1 = umo * (xp  - xt ) / 2
 403 *  |      Pch2 = umo * (xxp - xxt) / 2
 404 *  |      Amch1 = umo * sqrt (xp  * xt )
 405 *  |      Amch2 = umo * sqrt (xxp * xxt)
 406 *  |
 407       IF (IBPROJ) 21,22,23
 408   21  CONTINUE
 409 *  |  Note for antibaryon projectile xp and xt are sampled from the
 410 *  |  same distribution, ===> no difference in exchanging them!
 411          UNO = UNON
 412          XP  = BETARN(HLFHLF,UNO)
 413          XXP = 1.D0 - XP
 414          UNO = UNON
 415          XT  = BETARN(HLFHLF,UNO)
 416          XXT = 1.D0 - XT
 417          GO TO 24
 418   23  CONTINUE
 419 *  |  Note for baryon projectile xp and xt are sampled from the
 420 *  |  same distribution, ===> no difference in exchanging them!
 421          UNO = UNON
 422          XP  = BETARN(HLFHLF,UNO)
 423          XXP = 1.D0 - XP
 424          UNO = UNON
 425          XT  = BETARN(HLFHLF,UNO)
 426          XXT = 1.D0 - XT
 427          GO TO 24
 428   22  CONTINUE
 429 *  |  Note for meson projectile xp and xt are not sampled from the
 430 *  |  same distribution, ===> difference in exchanging them!
 431          UNO = UNOM
 432          IF (IFF.EQ.3 .OR. IFF.EQ.-3) UNO = UNOMS
 433          XP  = BETARN(HLFHLF,UNO)
 434          XXP = 1.D0 - XP
 435          IF (IBTARG .EQ. 0) GO TO 2288
 436             UNO = UNON
 437 2288     CONTINUE
 438          XT  = BETARN(HLFHLF,UNO)
 439          XXT = 1.D0 - XT
 440   24  CONTINUE
 441 *  |  Now xp and xt have been selected from the appropriate beta
 442 *  |  distributions, xxp and xxt are the complements to one of xp and xt
 443 *  +-------------------------------------------------------------------*
 444
 445 *  +-------------------------------------------------------------------*
 446 *  |  From here to 1124 it is likely to be obsolete (inucvt is now used
 447 *  |  nowhere in the code, the same for pnuc
 448 *  |
 449 *or      RNDMVV=RNDM(V)
 450 *or      IF (INUCVT.EQ.0) GO TO 1124
 451 *or      IF (RNDMVV.LT.PNUC(1)) GO TO 1124
 452 *or      XT=2.D0*BETARN(0.5D0,UNO+6.D0)
 453 *or      XXT=1.D0-XT
 454 *or      IF (XXT.LE.0.D0) XXT=RNDM(V)
 455 *or      IF (RNDMVV.LT.PNUC(2)) GO TO 1124
 456 *or      XT=3.D0*BETARN(0.5D0,UNO+12.D0)
 457 *or      XXT=1.D0-XT
 458 *or      IF (XXT.LE.0.D0) XXT=RNDM(V)
 459 *or 1124 CONTINUE
 460 *  |
 461 *  +-------------------------------------------------------------------*
 462 *or      IF (IPRI .EQ. 1) WRITE(LUNOUT,103)XP,XT,XXP,XXT
 463 *or 103  FORMAT (10F10.5)
 464 C
 465 C********************************************************************
 466 C
 467 C*** KINEMATICAL PARAMETERS OF BOTH CHAINS IN CMS
 468 C
 469 C********************************************************************
 470 C
 471 ****
 472 ****===================================================================*
 473 *  |  Now selecting the kinematical parameters for the two jets:
 474 *  |
 475 *  |      amch1 = invariant mass of the 1st jet
 476 *  |      ech1  = total energy of the 1st jet in CMS
 477 *  |      pch1  = total momentum of the 1st jet in CMS (with sign)
 478 *  |
 479 *  |      amch2 = invariant mass of the 2nd jet
 480 *  |      ech2  = total energy of the 2nd jet in CMS
 481 *  |      pch2  = total momentum of the 2nd jet in CMS (with sign)
 482 *  |
 483 *  |  The following relations must be fulfilled:
 484 *  |
 485 *  |      ech1 + ech2 = umo (energy in CMS = inv. mass of the system)
 486 *  |      ech1 = sqrt (pch1**2 + amch1**2)
 487 *  |      ech2 = sqrt (pch2**2 + amch2**2)
 488 *  |      pch1 + pch2 = 0
 489 *  |
 490 ****===================================================================*
 491 ****
 492       IF (IBPROJ) 31,32,33
 493 *  +-------------------------------------------------------------------*
 494 *  |   antibaryon projectile!!! (note that only antibaryon projectile
 495 *  |   baryon target is allowed, antibaryon projectile meson target is
 496 *  |   considered as meson projectile antibaryon target)
 497 *  |
 498   31  CONTINUE
 499 C
 500 C********************************************************************
 501 C
 502 C*** KINEMATICAL PARAMETERS OF BOTH CHAINS IN CMS
 503 C*** ANTINUCLEON-NUCLEUON
 504 C*** LONG ANTIDIQUARK - DIQUARK CHAIN
 505 C
 506 C********************************************************************
 507 C
 508 *  |  Ibb, ifb1, ifb2 contain the quark numbers of the target, ibf,
 509 *  |  iff1, iff2 the quark numbers of the projectile
 510 *  |  iff...= forward chain, forward quark (diquark)
 511 *  |  ifb...= forward chain, backward quark (diquark)
 512 *  |  ibf...= backward chain, forward quark
 513 *  |  ibb...= backward chain, backward quark
 514 *  |  By definition all i..f.. come from the projectile and all
 515 *  |  i..b.. from the target
 516 *  |  Of course, since we are treating an antibaryon projectile and
 517 *  |  a baryon target all i..f.. are antiquark and all i..b.. are
 518 *  |  quark
 519 *  |  Of course the two following cards are equivalent to
 520 *  |     IIFF1 = IABS (IFF1) ...
 521          IIFF1 = -IFF1
 522          IIFF2 = -IFF2
 523          IF (IIFF1 .EQ. IFB1) GO TO 3111
 524          IF (IIFF1 .EQ. IFB2) GO TO 3112
 525          IF (IIFF2 .EQ. IFB1) GO TO 3113
 526          IF (IIFF2 .EQ. IFB2) GO TO 3114
 527 *  |    Get the index and the mass of the pseudoscalar meson corre-
 528 *  |    sponding to the lowest energy for chain 2 ("b")
 529          IIBF = IABS(IBF)
 530          IBPS = IMPS(IIBF,IBB)
 531          AMBPS = AM(IBPS)
 532 *  |  *****************************************************************
 533 *  |    New version: of course, as it is explained below it is not    *
 534 *  |    correct to comment the "go to 3115", however it is not correct*
 535 *  |    also to use it in its original form, we need to compute a de- *
 536 *  |    tailed threshold, also for the Amff value: we can believe that*
 537 *  |    the lowest threshold is given by the two scalar mesons resul- *
 538 *  |    ting from the combinations of the 4 quarks (iff1,iff2,ibf1,   *
 539 *  |    ibf2).  Remember that the Imps(i,j) array gives the index of  *
 540 *  |    the pseudoscalar meson with antiquark -i and quark j, the same*
 541 *  |    apply to the Imve array but for vector mesons                 *
 542 *  |    But, since bamjev it is likely to produce at least one baryon *
 543 *  |    and one antibaryon when called with Iopt=5 (since it hadroni- *
 544 *  |    zes a chain with a diquark and an anti-diquark at the extremi-*
 545 *  |    ties) a more realistic threshold could be to check for the    *
 546 *  |    masses of the baryon-antibaryon combinations corresponding to *
 547 *  |    a uubar or a ddbar sea pair added to the original diquarks    *
 548 *  |  *****************************************************************
 549 *  |  Selection of the mass threshold from the two pseudoscalar mesons
 550 *        IMPS11 = IMPS(IIFF1,IFB1)
 551 *        IMPS21 = IMPS(IIFF2,IFB2)
 552 *        IMPS12 = IMPS(IIFF1,IFB2)
 553 *        IMPS22 = IMPS(IIFF2,IFB1)
 554 *  |  Amff is selected as the maximum of the two possible meson configu-
 555 *  |  rations, to be sure that no problem will result during frag-
 556 *  |  mentation
 557 *        AMFF = MAX ( AM (IMPS11) + AM (IMPS21), AM (IMPS12) +
 558 *    &                AM (IMPS22) )
 559 *  |  Of course at least two mesons must be produced
 560 *  |  First check that the total invariant mass is enough (it must
 561 *  |  be larger than the two meson masses and the pseudoscalar
 562 *  |  meson mass of the second chain)
 563 *        AMFF = AMFF
 564 *  |  Selection of the mass threshold from the two baryon configura-
 565 *  |  tions
 566          CALL BKLASS (-1, IFF1, IFF2, IA1F8, IA1F10 )
 567          CALL BKLASS ( 1, IFB1, IFB2,  I1F8,  I1F10 )
 568          CALL BKLASS (-2, IFF1, IFF2, IA2F8, IA2F10 )
 569          CALL BKLASS ( 2, IFB1, IFB2,  I2F8,  I2F10 )
 570          AMFF = MIN ( AM (IA1F8) + AM (I1F8), AM (IA2F8) + AM (I2F8) )
 571      &        + 0.3D+00
 572 *  |  +----------------------------------------------------------------*
 573 *  |  |  New treatment: check the mass threshold
 574          IF ( AMFF + AMBPS .LT. UMO ) THEN
 575             XSQ   = SQRT(XXP*XXT)
 576             AMCH1 = UMO*XSQ
 577             NNCH1 = 0
 578             AMCH2 = UMO*UMO*XP*XT
 579 *  |  |  +------------------------------------------------------------*
 580 *  |  |  |  Check if we have enough energy for the "f" jet
 581             IF ( AMCH1 .LE. AMFF .OR. AMCH2 .LE. AMBPS * AMBPS ) THEN
 582                IXPXT = IXPXT + 1
 583                IF ( IXPXT .LT. 5 ) GO TO 25
 584 *  |  |  |   if amch1 < amfps xp and xt are resampled, but if we are
 585 *  |  |  |   resampling too often force amch1 to be above
 586 *  |  |  |   the minimum required, anyway the kinematic region
 587 *  |  |  |   allowed for xp, xt seems to be marginal
 588 *  |  |  *-->-->-->-->-->-->-->-->-->--> xp, xt resampling
 589                XSQ1 = ( AMFF  / UMO )**2
 590                XSQ2 = ( AMBPS / UMO )**2
 591                XXXMN = XSQ1
 592                XXYMX = 0.5D+00 * ( 1.D+00 + XSQ1 - XSQ2 )
 593                XXYMN = SQRT ( 1.D+00 - XSQ1 / ( XXYMX * XXYMX ) )
 594                XXXMN = MAX  ( XSQ1, XXYMX * ( ONEONE - XXYMN ) )
 595                XXXMX = MIN  ( 1.D+00, XXYMX * ( 1.D+00 + XXYMN ) )
 596 *  |  |  |  +----------------------------------------------------------*
 597 *  |  |  |  |
 598  3161          CONTINUE
 599                   CALL GRNDM(RNDM,1)
 600                   XXP = XXXMN + ( XXXMX - XXXMN ) * RNDM (1)
 601                   XP  = 1.D+00 - XXP
 602                   XXYMN = XSQ1 / XXP
 603                   XXYMX = 1.D+00 - XSQ2 / XP
 604 *  |  |  |  |  +-------------------------------------------------------*
 605 *  |  |  |  |  |
 606                   IF ( XXYMN .GT. XXYMX ) THEN
 607                      XXXMN = XXP
 608                      GO TO 3161
 609 *  |  |  |  |-<|--<--<--<--< no allowed interval for xxt, resample
 610                   END IF
 611 *  |  |  |  |  |
 612 *  |  |  |  |  +-------------------------------------------------------*
 613 *  |  |  |  |
 614 *  |  |  |  +----------------------------------------------------------*
 615                CALL GRNDM(RNDM,1)
 616                XXT = XXYMN + ( XXYMX - XXYMN ) * RNDM (1)
 617                XT  = 1.D+00 - XXT
 618                XSQ   = SQRT(XXP*XXT)
 619                AMCH1 = UMO*XSQ
 620                NNCH1 = 0
 621             END IF
 622 *  |  |  |
 623 *  |  |  +------------------------------------------------------------*
 624             IOPBAM = 5
 625             GO TO 3116
 626 *  |  |
 627 *  |  +----------------------------------------------------------------*
 628 *  |  |           We are in troubles: the selected quark combinations
 629 *  |  |           for the two chains are unphysical since the invariant
 630 *  |  |           mass is too low to produce the required three mesons
 631 *  |  |           First try to change the quark combinations:
 632          ELSE
 633             CALL GRNDM(RNDM,1)
 634             IRNDM = 1.D+00 + RNDM (1)
 635             LQPROJ = .FALSE.
 636             LQTARG = .FALSE.
 637             GO TO (3171,3181) IRNDM
 638 *  |  |  +-------------------------------------------------------------*
 639 *  |  |  |        Try to change one of the projectile quarks in the
 640 *  |  |  |        first chain
 641  3171       CONTINUE
 642                LQPROJ = .TRUE.
 643 *  |  |  |  +----------------------------------------------------------*
 644 *  |  |  |  |     The third antibaryon quark can combine with the
 645 *  |  |  |  |     first or/and the second quark of the target diquark
 646                IF ( -IBF .EQ. IFB1 .OR. -IBF .EQ. IFB2 ) THEN
 647 *  |  |  |  |  +-------------------------------------------------------*
 648 *  |  |  |  |  |  Make a random choiche of the quark to be substituted
 649                   CALL GRNDM(RNDM,1)
 650                   IF ( RNDM (1) .LT. 0.5D+00 ) THEN
 651                      IBF0 = IBF
 652                      IBF  = IFF1
 653                      IFF1 = IBF0
 654 *  |  |  |  |  |
 655 *  |  |  |  |  +-------------------------------------------------------*
 656 *  |  |  |  |  |
 657                   ELSE
 658                      IBF0 = IBF
 659                      IBF  = IFF2
 660                      IFF2 = IBF0
 661                   END IF
 662 *  |  |  |  |  |
 663 *  |  |  |  |  +-------------------------------------------------------*
 664                   GO TO 31
 665 *  |  |  |  |
 666 *  |  |  |  +----------------------------------------------------------*
 667 *  |  |  |  |  No possibility to solve the situation changing one of
 668 *  |  |  |  |  the projectile quarks inside the "f" chain, try with
 669 *  |  |  |  |  the projectile quarks (if not yet tried)
 670                ELSE
 671                   IF ( .NOT. LQTARG ) GO TO 3181
 672                   GO TO 3191
 673                END IF
 674 *  |  |  |  |
 675 *  |  |  |  +----------------------------------------------------------*
 676 *  |  |  |
 677 *  |  |  +-------------------------------------------------------------*
 678 *  |  |  +-------------------------------------------------------------*
 679 *  |  |  |        Try to change one of the target quarks in the
 680 *  |  |  |        first chain (for uud and udd targets this is usually
 681 *  |  |  |        useless, but it has been included for the sake of
 682 *  |  |  |        completness )
 683  3181       CONTINUE
 684                LQTARG = .TRUE.
 685 *  |  |  |  +----------------------------------------------------------*
 686 *  |  |  |  |     The third target quark can combine with the first
 687 *  |  |  |  |     or/and the second quark of the projectile diquark
 688                IF ( IBB .EQ. -IFF1 .OR. IBB .EQ. -IFF2 ) THEN
 689 *  |  |  |  |  +-------------------------------------------------------*
 690 *  |  |  |  |  |  Make a random choiche of the quark to be substituted
 691                   CALL GRNDM(RNDM,1)
 692                   IF ( RNDM (1) .LT. 0.5D+00 ) THEN
 693                      IBB0 = IBB
 694                      IBB  = IFB1
 695                      IFB1 = IBB0
 696 *  |  |  |  |  |
 697 *  |  |  |  |  +-------------------------------------------------------*
 698 *  |  |  |  |  |
 699                   ELSE
 700                      IBB0 = IBB
 701                      IBB  = IFB2
 702                      IFB2 = IBB0
 703                   END IF
 704 *  |  |  |  |  |
 705 *  |  |  |  |  +-------------------------------------------------------*
 706                   GO TO 31
 707 *  |  |  |  |
 708 *  |  |  |  +----------------------------------------------------------*
 709 *  |  |  |  |  No possibility to solve the situation changing one of
 710 *  |  |  |  |  the target quarks inside the "f" chain, try with
 711 *  |  |  |  |  the projectile quarks (if not yet tried)
 712                ELSE
 713                   IF ( .NOT. LQPROJ ) GO TO 3171
 714                END IF
 715 *  |  |  |  |
 716 *  |  |  |  +----------------------------------------------------------*
 717 *  |  |  |
 718 *  |  |  +-------------------------------------------------------------*
 719  3191       CONTINUE
 720 *  |  |  If we are here we cannot perform an interaction conserving
 721 *  |  |  all additive quantum numbers: ignore one (typically it is
 722 *  |  |  strangeness) and go on
 723             WRITE (LUNERR,*)
 724      &      ' *** Hadevv, impossible interaction, kp,kt, Umo',
 725      &        KPROJ,KTARG,UMO
 726             WRITE (LUNOUT,*)
 727      &      ' *** Hadevv, impossible interaction, kp,kt, Umo',
 728      &        KPROJ,KTARG,UMO
 729          END IF
 730 *  |  |
 731 *  |  +----------------------------------------------------------------*
 732 *  |  Now we want to get the indexes of the pseudo-scalar and vector
 733 *  |  mesons which can be created from the first (forward) chain.
 734 *  |  Of course if one of the ff quark is the antiquark of one of
 735 *  |  fb quarks then the mesons are defined completely by the remaining
 736 *  |  two quarks: we have anyway to deal also with the situation
 737 *  |  were no ff quark is the antiquark of a fb quark (the goto 3115...)
 738 *  |  which clearly requires at least two mesons!!! So no Amfps and
 739 *  |  Amfv can be defined in this situation, and the "go to 3115" was
 740 *  |  really important to assure that we are not producing single
 741 *  |  particle jets which are not possible, we have only to substitute
 742 *  |  the 1.5 threshold with the proper threshold for the two
 743 *  |  mesons (at least the two scalar mesons): this is also true for
 744 *  |  the Amff value which of course should be equal to the sum
 745 *  |  of the two scalar mesons resulting from the combinations
 746 *  |  of the 4 quarks (see above)
 747 3111     CONTINUE
 748             IIFF2 = IABS(IFF2)
 749             IFPS  = IMPS(IIFF2,IFB2)
 750             IAIFF = IFF2
 751             IFB   = IFB2
 752             IFPS2 = IMPS(IIFF1,IFB1)
 753             IFV   = IMVE(IIFF2,IFB2)
 754             GO TO 3117
 755 3112     CONTINUE
 756             IIFF2 = IABS(IFF2)
 757             IFPS  = IMPS(IIFF2,IFB1)
 758             IAIFF = IFF2
 759             IFB   = IFB1
 760             IFPS2 = IMPS(IIFF1,IFB2)
 761             IFV   = IMVE(IIFF2,IFB1)
 762             GO TO 3117
 763 3113     CONTINUE
 764             IIFF1 = IABS(IFF1)
 765             IFPS  = IMPS(IIFF1,IFB2)
 766             IAIFF = IFF1
 767             IFB   = IFB2
 768             IFPS2 = IMPS(IIFF2,IFB1)
 769             IFV   = IMVE(IIFF1,IFB2)
 770             GO TO 3117
 771 3114     CONTINUE
 772             IIFF1 = IABS(IIFF1)
 773             IFPS  = IMPS(IIFF1,IFB1)
 774             IAIFF = IFF1
 775             IFB   = IFB1
 776             IFPS2 = IMPS(IIFF2,IFB2)
 777             IFV   = IMVE(IIFF1,IFB1)
 778 3117     CONTINUE
 779 *  Amfps, amfv are the masses of the pseudoscalar and vector mesons
 780 *  corresponding to the two unpaired quarks of the 1 (f) chain
 781          AMFPS = AM(IFPS)
 782          AMFV  = AM(IFV )
 783          AMFPS2= AM(IFPS2)
 784          NNCH1 = 0
 785 C     ATTENTION THIS MIGHT LEAD TO TOO LOW ANNIHILATION MULTIPLICITIES
 786 C        AMFF = AMFV+0.3D0
 787 *        AMFF = 2.3D0
 788          AMFF  = MAX ( AMFV + 0.3D+00, AMFV + AMFPS2 + 0.1D+00 )
 789 *  | This expression for Amff0 (threshold for a complete diquark-diquark
 790 *  | jet) is not correct: this jet will fragment at least into two
 791 *  | hadrons corresponding to the lowest energy hadrons with respecti-
 792 *  | vely the first and the second diquark. Of corse one will be an
 793 *  | antibaryon. It must be checked that bamjet produces a baryon-
 794 *  | antibaryon pair any time it is called with iopt = 5 (corresponding
 795 *  | to the fragmentation of a complete diquark-antidiquark jet)
 796 *  | It is also questionable if it is correct to call bamjet with
 797 *  | iopt=5 whenever energetically possible: this clearly implies
 798 *  | that no annihilation takes place (an antibaryon will emerge
 799 *  | from the interaction). This is a question to be addressed
 800 *  | to Hannes!!
 801 *        AMFF0 = 2.D+00 * AMFF
 802 *  | A tentative way could be to check for the masses of the
 803 *  | baryon-antibaryon combinations corresponding to a uubar
 804 *  | or a ddbar sea pair
 805          CALL BKLASS (-1, IFF1, IFF2, IA1F8, IA1F10 )
 806          CALL BKLASS ( 1, IFB1, IFB2,  I1F8,  I1F10 )
 807          CALL BKLASS (-2, IFF1, IFF2, IA2F8, IA2F10 )
 808          CALL BKLASS ( 2, IFB1, IFB2,  I2F8,  I2F10 )
 809          AMFF0 = MIN ( AM (IA1F8) + AM (I1F8), AM (IA2F8) + AM (I2F8) )
 810      &         + 0.3D+00
 811 *  |
 812 *  |  here xxt and xxp are used for the first jet
 813 *  |
 814          XSQ  = SQRT(XXP*XXT)
 815          AMCH1 = UMO*XSQ
 816          AAPS  = IFPS
 817          AAV  = IFV
 818 *or         IF (IPRI.EQ.1) WRITE(LUNOUT,103)XSQ,AMCH1,AMCH2,AAPS,AAV,
 819 *or     &                                   AMFPS,AMFV
 820
 821 *  |  +----------------------------------------------------------------*
 822 *  |  |
 823          IF (AMCH1 .LT. AMFPS) GO TO 25
 824 *  |  |   if amch1 < amfps xp and xt are resampled
 825 *  |  *-->-->-->-->-->-->-->-->-->--> xp, xt resampling
 826
 827 *  |  Kinematical parameters xxp, xxt for the 1st jet
 828          IF (AMCH1 .GT. AMFV ) GO TO 3151
 829 C*** PRODUCE AMFPS
 830             AMCH1 = AMFPS
 831             NNCH1 = -1
 832             XSQ = AMFPS/UMO
 833 *  |  |  recalculating xxp, xp
 834             XXP = XSQ**2/XXT
 835             XP  = 1.D0 - XXP
 836             GO TO 3153
 837 3151     CONTINUE
 838          IF (AMCH1 .GT. AMFF) GO TO 3153
 839 C*** PRODUCE AMFV
 840             AMCH1 = AMFV
 841             NNCH1 = 1
 842             XSQ = AMFV/UMO
 843 *  |  |  recalculating xxp, xp
 844             XXP = XSQ**2/XXT
 845             XP  = 1.D0 - XXP
 846             GO TO 3153
 847 3153     CONTINUE
 848          IF (AMCH1 .LE. AMFF0) THEN
 849             IOPBAM = 3
 850          ELSE
 851             IOPBAM = 5
 852          END IF
 853          GO TO 3116
 854 3116     CONTINUE
 855 C
 856 C********************************************************************
 857 C
 858 C*** KINEMATICAL PARAMETERS OF BOTH CHAINS IN CMS
 859 C     ANTINUCLEON NUCLEON
 860 C*** SHORT ANTIQUARK - QUARK CHAIN
 861 C
 862 C********************************************************************
 863 C
 864          IIBF = IABS(IBF)
 865          IBPS = IMPS(IIBF,IBB)
 866          IBV  = IMVE(IIBF,IBB)
 867          AMBPS = AM(IBPS)
 868          AMBV  = AM(IBV)
 869          NNCH2 = 0
 870          AMBB = AMBV + 0.3D0
 871          AAPS = IBPS
 872          AAV  = IBV
 873 *  |  +----------------------------------------------------------------*1
 874 *  |  |
 875 *  |  | Now commented, is useless!!!
 876 *         IF (XP .LE. 0.D0 .OR. XT .LE. 0.D0) GO TO 25
 877 *  |  | resample xp and xt if one is negative or zero
 878 *  |  +-->-->-->-->-->-->-->-->-->--> xp, xt resampling
 879
 880 *  |  Now xp and xt are used for the second jet
 881          XXSQ  = SQRT(XP*XT)
 882          AMCH2 = UMO*XXSQ
 883 *or         IF (IPRI.EQ.1) WRITE(LUNOUT,103)XSQ,AMCH1,AMCH2
 884 *or     &                  ,AAPS,AAV,AMBPS,AMBV
 885
 886 *  |  +----------------------------------------------------------------*
 887 *  |  |
 888          IF (AMCH2 .LT. AMBPS) THEN
 889             IXPXT = IXPXT + 1
 890             GO TO 25
 891 *  |  |   if amch1 < amfps xp and xt are resampled
 892 *  |  *-->-->-->-->-->-->-->-->-->--> xp, xt resampling
 893          END IF
 894 *  |  |
 895 *  |  +----------------------------------------------------------------*
 896
 897          IF (AMCH2 .GT. AMBV ) GO TO 3121
 898 C*** PRODUCE AMBPS
 899 * For Prof. Ranft: here there was a "large" mistake, amch2 = ambps
 900 * was missing
 901             AMCH2 = AMBPS
 902             NNCH2 = -1
 903             XXSQ  = AMBPS/UMO
 904 *or            IF (INUCVT .EQ. 1) GO TO 3123
 905             GO TO 31236
 906 3121     CONTINUE
 907          IF (AMCH2 .GT. AMBB) GO TO 3123
 908 C*** PRODUCE AMBV
 909             AMCH2 = AMBV
 910             NNCH2 = 1
 911             XXSQ  = AMBV/UMO
 912 *or            IF (INUCVT .EQ. 1) GO TO 3123
 913             GO TO 31236
 914 *  |  +----------------------------------------------------------------*
 915 *  |  |  Here adjusting kinematics!!!!!
 916 *  |  |  Now, chain 2 is a single particle jet, so we have to reset the
 917 *  |  |  kinematical parameters xp, xxp, xt and xxt
 918 *  |  |
 919 31236       CONTINUE
 920             XXSQ2  = XXSQ  * XXSQ
 921 *  |  |  +-------------------------------------------------------------*
 922 *  |  |  |  If also chain 1 is a parjet (nnch1 .ne. 0) then the paramet.
 923 *  |  |  |  to be recomputed are xp and xt, from alpha and beta, in
 924 *  |  |  |  such a way to conserve the original momentum direction
 925 *  |  |  |
 926             IF (NNCH1 .NE. 0) THEN
 927                XSQ2 = XSQ * XSQ
 928                HELP  = XSQ2 * (XSQ2 - 2.D0) + XXSQ2 * (XXSQ2 - 2.D0)
 929      &                 - 2.D0 * XSQ2 * XXSQ2
 930                DDIFF = SQRT (HELP + 1.D0)
 931                SSUM  = SQRT (HELP + 1.D0 + 4.D0 * XXSQ2)
 932                ALPHA = (SSUM + DDIFF) * 0.5D0
 933                BETA  = (SSUM - DDIFF) * 0.5D0
 934                IF (XP .GT. XT) THEN
 935                   XP  = ALPHA
 936                   XT  = BETA
 937                ELSE
 938                   XT  = ALPHA
 939                   XP  = BETA
 940                END IF
 941                XXP = 1.D0 - XP
 942                XXT = 1.D0 - XT
 943 *  |  |  |
 944 *  |  |  +-------------------------------------------------------------*
 945             ELSE
 946 *  |  |  +-------------------------------------------------------------*
 947 *  |  |  |  If chain 1 is not a parjet (nnch1 .eq. 0) then the paramet.
 948 *  |  |  |  xp, xt are to be recomputed in such a way to conserve the
 949 *  |  |  |  original momentum direction and modulus
 950 *  |  |  |
 951                DDIFF = XP  - XT
 952                SSUM  = SQRT (4.D0 * XXSQ2 + DDIFF**2)
 953                XP  = (SSUM + DDIFF) * 0.5D0
 954                XT  = (SSUM - DDIFF) * 0.5D0
 955                XXP = 1.D0 - XP
 956                XXT = 1.D0 - XT
 957                XSQ   = SQRT (XXP * XXT)
 958                AMCH1 = XSQ * UMO
 959             END IF
 960 *  |  |  |
 961 *  |  |  +-------------------------------------------------------------*
 962 *  |  |                             end kinematics correction
 963 *  |  +----------------------------------------------------------------*
 964
 965 3123     CONTINUE
 966 C
 967          PCH1 = UMO*(XXP - XXT)*.5D0
 968          ECH1 = UMO*(XXP + XXT)*.5D0
 969          GAMCH1 = ECH1/AMCH1
 970          BGCH1  = PCH1/AMCH1
 971          PCH2 = UMO*(XP - XT)*.5D0
 972          ECH2 = UMO*(XP + XT)*.5D0
 973          GAMCH2 = ECH2/AMCH2
 974          BGCH2  = PCH2/AMCH2
 975          GO TO 34
 976 *  |              end kin. sel. for antibaryon projectile
 977 *  +-->-->-->-->-->-->-->-->-->--> go to 34
 978
 979 *  +-------------------------------------------------------------------*
 980 *  |   baryon projectile!!!
 981 *  |
 982   33  CONTINUE
 983 C
 984 C********************************************************************
 985 C
 986 C*** KINEMATICAL PARAMETERS OF BOTH CHAINS IN CMS
 987 C*** NUCLEON - NUCLEON
 988 C*** FORWARD DIQUARK - QUARK CHAIN
 989 C
 990 C********************************************************************
 991 C
 992          GO TO 332
 993 *  |
 994 *  +-->-->-->-->-->-->-->-->-->--> jump # 1 to 332
 995
 996 *  +--<--<--<--<--<--<--<--<--<--< here from jump # 3
 997 *  |
 998
 999 3310     CONTINUE
1000          CALL BKLASS (IFB,IFF1,IFF2,IF8,IF10)
1001          AMF8  = AM(IF8)
1002          AMF10 = AM(IF10)
1003          AMFF  = AMF10 + 0.3D0
1004          NNCH1 = 0
1005 *  |  here xxp, xt are used for the jet # 1
1006          XSQ = SQRT(ABS(XXP*XT))
1007          AMCH1 = UMO*XSQ
1008          AA8   = IF8
1009          AA10  = IF10
1010 *or         IF (IPRI .EQ. 1) WRITE(LUNOUT,103)XSQ,AMCH1,AMCH2
1011 *or     &                  ,AA8,AA10,AMF8,AMF10
1012
1013 *  |  +----------------------------------------------------------------*
1014 *  |  | This check added by A. Ferrari, to avoid negative x(x)p or
1015 *  |  | x(x)t !!!!!?????? Maybe also "go to 33366" if we want to create
1016 *  |  | the jet anyway
1017 * I (A. Ferrari) think this check was missing and is
1018 * actually needed, else we can get negative energies
1019          IF (AMCH1 .LT. AMF8) GO TO 25
1020 *  |  |   if amch1 < amf8 xp and xt are resampled
1021 *  |  +-->-->-->-->-->-->-->-->-->--> xp, xt resampling
1022
1023          IF (AMCH1 .GT. AMF10) GO TO 331
1024 C*** PRODUCE AMF8
1025             AMCH1 = AMF8
1026             NNCH1 = -1
1027             XSQ = AMF8/UMO
1028             GO TO 33366
1029  331     CONTINUE
1030          IF (AMCH1 .GT. AMFF) GO TO 333
1031 C*** PRODUCE AMF10
1032             AMCH1 = AMF10
1033             NNCH1 = 1
1034             XSQ = AMF10/UMO
1035             GO TO 33366
1036 *  |  +----------------------------------------------------------------*
1037 *  |  |  Here adjusting kinematics!!!!!
1038 *  |  |  Now, chain 1 is a single particle jet, so we have to reset the
1039 *  |  |  kinematical parameters xp, xxp, xt and xxt
1040 *  |  |
1041 33366       CONTINUE
1042             XSQ2  = XSQ  * XSQ
1043 *  |  |  +-------------------------------------------------------------*
1044 *  |  |  |  If also chain 2 is a parjet (nnch2 .ne. 0) then the paramet.
1045 *  |  |  |  to be recomputed are xxp and xt, from alpha and beta, in
1046 *  |  |  |  such a way to conserve the original momentum direction
1047 *  |  |  |
1048             IF (NNCH2 .NE. 0) THEN
1049                XXSQ2 = XXSQ * XXSQ
1050                HELP  = XSQ2 * (XSQ2 - 2.D0) + XXSQ2 * (XXSQ2 - 2.D0)
1051      &                 - 2.D0 * XSQ2 * XXSQ2
1052                DDIFF = SQRT (HELP + 1.D0)
1053                SSUM  = SQRT (HELP + 1.D0 + 4.D0 * XSQ2)
1054                ALPHA = (SSUM + DDIFF) * 0.5D0
1055                BETA  = (SSUM - DDIFF) * 0.5D0
1056                IF (XXP .GT. XT) THEN
1057                   XXP = ALPHA
1058                   XT  = BETA
1059                ELSE
1060                   XT  = ALPHA
1061                   XXP = BETA
1062                END IF
1063                XP  = 1.D0 - XXP
1064                XXT = 1.D0 - XT
1065 *  |  |  |
1066 *  |  |  +-------------------------------------------------------------*
1067             ELSE
1068 *  |  |  +-------------------------------------------------------------*
1069 *  |  |  |  If chain 2 is not a parjet (nnch2 .eq. 0) then the paramet.
1070 *  |  |  |  xxp,xt have to be recomputed in such a way to conserve the
1071 *  |  |  |  original momentum direction and modulus
1072 *  |  |  |
1073                DDIFF = XXP - XT
1074                SSUM  = SQRT (4.D0 * XSQ2 + DDIFF**2)
1075                XXP = (SSUM + DDIFF) * 0.5D0
1076                XT  = (SSUM - DDIFF) * 0.5D0
1077                XP  = 1.D0 - XXP
1078                XXT = 1.D0 - XT
1079                XXSQ  = SQRT (XP * XXT)
1080                AMCH2 = XXSQ * UMO
1081             END IF
1082 *  |  |  |
1083 *  |  |  +-------------------------------------------------------------*
1084 *  |  |                             end kinematics correction
1085 *  |  +----------------------------------------------------------------*
1086
1087  333     CONTINUE
1088 *  |  we are using xp and xxt for chain 2
1089          PCH1 = UMO*(XXP - XT)*.5D0
1090          ECH1 = UMO*(XXP + XT)*.5D0
1091          GAMCH1 = ECH1/AMCH1
1092          BGCH1  = PCH1/AMCH1
1093          PCH2 = UMO*(XP - XXT)*.5D0
1094          ECH2 = UMO*(XP + XXT)*.5D0
1095          GAMCH2 = ECH2/AMCH2
1096          BGCH2  = PCH2/AMCH2
1097          GO TO 34
1098 *  |              end kin. sel. for baryon projectile
1099 *  +-->-->-->-->-->-->-->-->-->--> go to 34
1100
1101 C
1102 C********************************************************************
1103 C
1104 C*** KINEMATICAL PARAMETERS OF BOTH CHAINS IN CMS
1105 C     NUCLEON NUCLEON
1106 C*** BACKWARD QUARK - DIQUARK CHAIN
1107 C
1108 C********************************************************************
1109 C
1110 *  +--<--<--<--<--<--<--<--<--<--< here from the previous jump # 1
1111 *  |
1112  332     CONTINUE
1113 *  |  Starting from chain # 2!!!
1114          CALL BKLASS (IBF,IBB1,IBB2,IB8,IBIO)
1115          NNCH2 = 0
1116          AMB8  = AM(IB8)
1117          AMB10 = AM(IBIO)
1118          AMBB  = AMB10 + 0.3D0
1119 *  |  here xp, xxt are used for the jet # 2
1120          XXSQ  = SQRT(XP*XXT)
1121          AMCH2 = UMO*XXSQ
1122          AAB8  = IB8
1123          AAB10 = IBIO
1124 *or         IF (IPRI.EQ.1) WRITE(LUNOUT,103)XSQ,AMCH1,AMCH2
1125 *or     &                  ,AAB8,AAB10,AMB8,AMB10
1126
1127 *  |  +----------------------------------------------------------------*
1128 *  |  | This check added by A. Ferrari, to avoid negative x(x)p or
1129 *  |  | x(x)t !!!!!??????  Maybe also "go to 335" if we want to create
1130 *  |  | the jet anyway
1131 * I (A. Ferrari) think this check was missing and is
1132 * actually needed, else we can get negative energies
1133          IF (AMCH2 .LT. AMB8) GO TO 25
1134 *  |  |   if amch2 < amb8 xp and xt are resampled
1135 *  |  +-->-->-->-->-->-->-->-->-->--> xp, xt resampling
1136
1137          IF (AMCH2 .GT. AMB10) GO TO 334
1138 C*** PRODUCE AMB8
1139             AMCH2 = AMB8
1140             NNCH2 = -1
1141             XXSQ = AMB8/UMO
1142             XP   = XXSQ**2/XXT
1143             XXP  = 1.D0 - XP
1144             GO TO 335
1145  334     CONTINUE
1146          IF (AMCH2 .GT. AMBB) GO TO 335
1147 C*** PRODUCE AMB10
1148             AMCH2 = AMB10
1149             NNCH2 = 1
1150             XXSQ = AMB10/UMO
1151             XP   = XXSQ**2/XXT
1152             XXP  = 1.D0 - XP
1153
1154 C     PCH1=UMO*(XXP-XT)*.5D0
1155 C     ECH1=UMO*(XXP+XT)*.5D0
1156 C     GAMCH1=ECH1/AMCH1
1157 C     BGCH1=PCH1/AMCH1
1158 C     GO TO 335
1159
1160  335     CONTINUE
1161          GO TO 3310
1162 *  |
1163 *  +-->-->-->-->-->-->-->-->-->--> jump # 3 to 3310
1164
1165 *  +-------------------------------------------------------------------*
1166 *  |   meson projectile!!!
1167 *  |
1168   32  CONTINUE
1169 C
1170 C********************************************************************
1171 C
1172 C*** KINEMATICAL PARAMETERS OF BOTH CHAINS IN CMS
1173 C*** MESON NUCLEON
1174 C
1175 C********************************************************************
1176 C
1177          IF (IBTARG)3277,3288,3299
1178 *  |  +----------------------------------------------------------------*
1179 *  |  |  meson projectile, baryon target!!!!
1180 *  |  |
1181 3299     CONTINUE
1182             GO TO (321,325),ISAM3
1183 *  |  |  +-------------------------------------------------------------*
1184 *  |  |  |  meson projectile, baryon target, isam3 = 1
1185 *  |  |  |
1186  321        CONTINUE
1187 C*** MESON NUCLEON Q(XXP)-QQ(XXT)+AQ(XP-Q(XT)
1188                GO TO 322
1189 *  |  |  |
1190 *  |  |  +-->-->-->-->-->-->-->-->-->--> jump # 4 to 322
1191
1192 *  |  |  +--<--<--<--<--<--<--<--<--<--< here from jump # 5
1193 *  |  |  |
1194 3259           CONTINUE
1195 C=================================================================
1196 C
1197 C*** KINEMATICAL PARAMETERS OF BOTH CHAINS IN CMS
1198 C      MESON NUCLEON
1199 C*** FIRST LONG Q(XXP)-QQ(XXT) CHAIN
1200 C
1201 C===================================================================
1202                CALL BKLASS (IFF,IFB1,IFB2,IF8,IFIO)
1203                AMF8  = AM(IF8)
1204                AMF10 = AM(IFIO)
1205                NNCH1 = 0
1206                AMFF  = AMF10 + 0.3D0
1207 *  |  here xxp, xxt are used for the jet # 1
1208                XSQ   = SQRT(XXP*XXT)
1209                AMCH1 = UMO*XSQ
1210                AA8   = IF8
1211                AA10  = IFIO
1212 *or               IF (IPRI .EQ. 1) WRITE(LUNOUT,103)XSQ,AMCH1,AMCH2
1213 *or     &         ,AA8,AA10,AMF8,AMF10
1214
1215 *  |  |  |  +----------------------------------------------------------*
1216 *  |  |  |  |
1217                IF (AMCH1 .LT. AMF8) GO TO 25
1218 *  |  |  |  | if amch1 < amf8 xp and xt are resampled
1219 *  |  |  |  +-->-->-->-->-->-->-->-->-->--> xp, xt resampling
1220
1221                IF (AMCH1 .GT. AMF10) GO TO 3211
1222 C*** PRODUCE AMF8
1223                   AMCH1 = AMF8
1224                   NNCH1 = -1
1225                   XSQ = AMF8/UMO
1226                   GO TO 32136
1227 3211           CONTINUE
1228                IF (AMCH1 .GT. AMFF) GO TO 3213
1229 C*** PRODUCE AMF10
1230                   AMCH1 = AMF10
1231                   NNCH1 = 1
1232                   XSQ = AMF10/UMO
1233                   GO TO 32136
1234 *  |  |  |  +----------------------------------------------------------*
1235 *  |  |  |  |  Here adjusting kinematics!!!!!
1236 *  |  |  |  |  Now, chain 1 is a single particle jet, so we have to
1237 *  |  |  |  |  reset the kinematical parameters xp, xxp, xt and xxt
1238 *  |  |  |  |
1239 32136             CONTINUE
1240                   XSQ2  = XSQ  * XSQ
1241 *  |  |  |  |  +-------------------------------------------------------*
1242 *  |  |  |  |  |  If also chain 2 is a parjet (nnch2 .ne. 0) then the
1243 *  |  |  |  |  |  param. to be recomputed are xxp and xxt, from alpha
1244 *  |  |  |  |  |  and beta, in such a way to conserve the original
1245 *  |  |  |  |  |  momentum direction
1246 *  |  |  |  |  |
1247                   IF (NNCH2 .NE. 0) THEN
1248                      XXSQ2 = XXSQ * XXSQ
1249                      HELP  = XSQ2 * (XSQ2 - 2.D0) + XXSQ2 *
1250      &                      (XXSQ2 - 2.D0) - 2.D0 * XSQ2 * XXSQ2
1251                      DDIFF = SQRT (HELP + 1.D0)
1252                      SSUM  = SQRT (HELP + 1.D0 + 4.D0 * XSQ2)
1253                      ALPHA = (SSUM + DDIFF) * 0.5D0
1254                      BETA  = (SSUM - DDIFF) * 0.5D0
1255                      IF (XXP .GT. XXT) THEN
1256                          XXP = ALPHA
1257                          XXT = BETA
1258                      ELSE
1259                          XXT = ALPHA
1260                          XXP = BETA
1261                      END IF
1262                      XP  = 1.D0 - XXP
1263                      XT  = 1.D0 - XXT
1264 *  |  |  |  |  |
1265 *  |  |  |  |  +-------------------------------------------------------*
1266                   ELSE
1267 *  |  |  |  |  +-------------------------------------------------------*
1268 *  |  |  |  |  |  If chain 2 is not a parjet (nnch2 .eq. 0) then the
1269 *  |  |  |  |  |  paramet. xxp,xxt have to be recomputed in such a way
1270 *  |  |  |  |  |  to conserve the original momentum direction and
1271 *  |  |  |  |  |  modulus
1272 *  |  |  |  |  |
1273                      DDIFF = XXP - XXT
1274                      SSUM  = SQRT (4.D0 * XSQ2 + DDIFF**2)
1275                      XXP = (SSUM + DDIFF) * 0.5D0
1276                      XXT  = (SSUM - DDIFF) * 0.5D0
1277                      XP  = 1.D0 - XXP
1278                      XT  = 1.D0 - XXT
1279                      XXSQ  = SQRT (XP * XT)
1280                      AMCH2 = XXSQ * UMO
1281                   END IF
1282 *  |  |  |  |  |
1283 *  |  |  |  |  +-------------------------------------------------------*
1284 *  |  |  |  |                       end kinematics correction
1285 *  |  |  |  +----------------------------------------------------------*
1286
1287 3213           CONTINUE
1288                PCH1 = UMO*(XXP - XXT)*.5D0
1289                ECH1 = UMO*(XXP + XXT)*.5D0
1290                GAMCH1 = ECH1/AMCH1
1291                BGCH1  = PCH1/AMCH1
1292                PCH2 = UMO*(XP - XT)*.5D0
1293                ECH2 = UMO*(XP + XT)*.5D0
1294                GAMCH2 = ECH2/AMCH2
1295                BGCH2  = PCH2/AMCH2
1296                GO TO 34
1297 *  |  |  | end kin. sel. for meson proj. (baryon target), isam3 = 1
1298 *  |  |  +-->-->-->-->-->-->-->-->-->--> go to 34
1299
1300 *  |  |  +--<--<--<--<--<--<--<--<--<--< here from jump # 4
1301 *  |  |  |
1302  322           CONTINUE
1303 C===============================================================
1304 C
1305 C*** KINEMATICAL PARAMETERS OF BOTH CHAINS IN CMS
1306 C       MESON NUCLEON
1307 C*** SHORT AQ(XP)-Q(XT) CHAIN
1308 C
1309 C================================================================
1310                IIBF = IABS(IBF)
1311                IBPS = IMPS(IIBF,IBB)
1312                IBV  = IMVE(IIBF,IBB)
1313                AMBPS = AM(IBPS)
1314                AMBV  = AM(IBV)
1315                NNCH2 = 0
1316                AMBB  = AMBV + 0.3D0
1317 *  |  here xp, xt are used for the jet # 2
1318                XXSQ  = SQRT(XP*XT)
1319                AMCH2 = UMO*XXSQ
1320                AAPS  = IBPS
1321                AAV   = IBV
1322 *or               IF (IPRI.EQ.1) WRITE(LUNOUT,103)XSQ,AMCH1,AMCH2
1323 *or     &         ,AAPS,AAV,AMBPS,AMBV
1324
1325 *  |  |  |  +----------------------------------------------------------*
1326 *  |  |  |  |
1327                IF (AMCH2 .LT. AMBPS) GO TO 25
1328 *  |  |  |  | if amch2 < ambps xp and xt are resampled
1329 *  |  |  |  +-->-->-->-->-->-->-->-->-->--> xp, xt resampling
1330
1331                IF (AMCH2 .GT. AMBV) GO TO 3221
1332 C*** PRODUCE AMBPS
1333                   AMCH2 = AMBPS
1334                   NNCH2 = -1
1335                   XXSQ  = AMBPS/UMO
1336                   XT  = XXSQ**2/XP
1337 *or                  IF (INUCVT .EQ. 1) GO TO 3223
1338                   XXT = 1.D0 - XT
1339                   GO TO 3223
1340 3221           CONTINUE
1341                IF (AMCH2 .GT. AMBB) GO TO 3223
1342 C*** PRODUCE AMBV
1343                   AMCH2 = AMBV
1344                   NNCH2 = 1
1345                   XXSQ  = AMBV/UMO
1346                   XT  = XXSQ**2/XP
1347 *or                  IF (INUCVT .EQ. 1) GO TO 3223
1348                   XXT = 1.D0 - XT
1349
1350 C     PCH1=UMO*(XXP-XXT)*.5D0
1351 C     ECH1=UMO*(XXP+XXT)*.5D0
1352 C     GAMCH1=ECH1/AMCH1
1353 C     BGCH1=PCH1/AMCH1
1354 C     GO TO 3223
1355
1356 3223           CONTINUE
1357                GO TO 3259
1358 *  |  |  |
1359 *  |  |  +-->-->-->-->-->-->-->-->-->--> jump # 5 to 3259
1360
1361 *  |  |  +-------------------------------------------------------------*
1362 *  |  |  |  meson projectile, baryon target, isam3 = 2
1363 *  |  |  |
1364  325        CONTINUE
1365 C=================================================================
1366 C
1367 C*** KINEMATICAL PARAMETERS OF BOTH CHAINS IN CMS
1368 C*** MESON NUCLEUS
1369 C*** FORWARD ANTIQUARK-DIQUARK CHAIN
1370 C
1371 C=================================================================
1372                GO TO 326
1373 *  |  |  |
1374 *  |  |  +-->-->-->-->-->-->-->-->-->--> jump # 6 to 326
1375
1376 *  |  |  +--<--<--<--<--<--<--<--<--<--< here from jump # 7
1377 *  |  |  |
1378 3250           CONTINUE
1379 C*** MESON NUCLEON FORWARD AQ(XXP)-Q(XT) AND BACKWARD CHAINS Q(XP)-QQ(
1380 C*** XXT) CHAINS
1381 C=====================================================================
1382 C
1383 C*** KINEMATICAL PARAMETERS OF BOTH CHAINS IN CMS
1384 C     MESON NUCLEON
1385 C*** FORWARD AQ(XXP)-Q(XT) CHAIN
1386 C
1387 C====================================================================
1388                IIFF = IABS(IFF)
1389                IFPS = IMPS(IIFF,IFB)
1390                IFV  = IMVE(IIFF,IFB)
1391                AMFPS = AM(IFPS)
1392                AMFV  = AM(IFV)
1393                NNCH1 = 0
1394                AMFF = AMFV + 0.3D0
1395 *  |  |  |  here xxp, xt are used for the jet # 1
1396                XSQ  = SQRT(XXP*XT)
1397                AMCH1 = UMO*XSQ
1398                AAPS  = IFPS
1399                AAV   = IFV
1400 *or               IF (IPRI .EQ. 1) WRITE(LUNOUT,103)XSQ,AMCH1,AMCH2
1401 *or     &         ,AAPS,AAV,AMFPS,AMFV
1402
1403 *  |  |  +-------------------------------------------------------------*
1404 *  |  |  |
1405                IF (AMCH1 .LT. AMFPS) GO TO 25
1406 *  |  |  | if amch1 < amfps xp and xt are resampled
1407 *  |  |  +-->-->-->-->-->-->-->-->-->--> xp, xt resampling
1408
1409                IF (AMCH1 .GT. AMFV) GO TO 3251
1410 C*** PRODUCE AMFPS
1411                   AMCH1 = AMFPS
1412                   NNCH1 = -1
1413                   XSQ = AMFPS/UMO
1414                   GO TO 32536
1415 3251           CONTINUE
1416                IF (AMCH1.GT.AMFF) GO TO 3253
1417 C*** PRODUCE AMFV
1418                   AMCH1 = AMFV
1419                   NNCH1 = 1
1420                   XSQ = AMFV/UMO
1421                   GO TO 32536
1422 *  |  |  |  +----------------------------------------------------------*
1423 *  |  |  |  |  Here adjusting kinematics!!!!!
1424 *  |  |  |  |  Now, chain 1 is a single particle jet, so we have to
1425 *  |  |  |  |  reset the kinematical parameters xp, xxp, xt and xxt
1426 *  |  |  |  |
1427 32536             CONTINUE
1428                   XSQ2  = XSQ  * XSQ
1429 *  |  |  |  |  +-------------------------------------------------------*
1430 *  |  |  |  |  |  If also chain 2 is a parjet (nnch2 .ne. 0) then the
1431 *  |  |  |  |  |  param. to be recomputed are xxp and xt, from alpha
1432 *  |  |  |  |  |  and beta, in such a way to conserve the original
1433 *  |  |  |  |  |  momentum direction
1434 *  |  |  |  |  |
1435                   IF (NNCH2 .NE. 0) THEN
1436                      XXSQ2 = XXSQ * XXSQ
1437                      HELP  = XSQ2 * (XSQ2 - 2.D0) + XXSQ2 *
1438      &                      (XXSQ2 - 2.D0) - 2.D0 * XSQ2 * XXSQ2
1439                      DDIFF = SQRT (HELP + 1.D0)
1440                      SSUM  = SQRT (HELP + 1.D0 + 4.D0 * XSQ2)
1441                      ALPHA = (SSUM + DDIFF) * 0.5D0
1442                      BETA  = (SSUM - DDIFF) * 0.5D0
1443                      IF (XXP .GT. XT) THEN
1444                          XXP = ALPHA
1445                          XT  = BETA
1446                      ELSE
1447                          XT  = ALPHA
1448                          XXP = BETA
1449                      END IF
1450                      XP  = 1.D0 - XXP
1451                      XXT = 1.D0 - XT
1452 *  |  |  |  |  |
1453 *  |  |  |  |  +-------------------------------------------------------*
1454                   ELSE
1455 *  |  |  |  |  +-------------------------------------------------------*
1456 *  |  |  |  |  |  If chain 2 is not a parjet (nnch2 .eq. 0) then the
1457 *  |  |  |  |  |  paramet. xxp,xt have to be recomputed in such a way
1458 *  |  |  |  |  |  to conserve the original momentum direction and
1459 *  |  |  |  |  |  modulus
1460 *  |  |  |  |  |
1461                      DDIFF = XXP - XT
1462                      SSUM  = SQRT (4.D0 * XSQ2 + DDIFF**2)
1463                      XXP = (SSUM + DDIFF) * 0.5D0
1464                      XT  = (SSUM - DDIFF) * 0.5D0
1465                      XP  = 1.D0 - XXP
1466                      XXT = 1.D0 - XT
1467                      XXSQ  = SQRT (XP * XXT)
1468                      AMCH2 = XXSQ * UMO
1469                   END IF
1470 *  |  |  |  |  |
1471 *  |  |  |  |  +-------------------------------------------------------*
1472 *  |  |  |  |                       end kinematics correction
1473 *  |  |  |  +----------------------------------------------------------*
1474
1475 3253           CONTINUE
1476                PCH1 = UMO*(XXP - XT)*.5D0
1477                ECH1 = UMO*(XXP + XT)*.5D0
1478                GAMCH1 = ECH1/AMCH1
1479                BGCH1  = PCH1/AMCH1
1480                PCH2 = UMO*(XP - XXT)*.5D0
1481                ECH2 = UMO*(XP + XXT)*.5D0
1482                GAMCH2 = ECH2/AMCH2
1483                BGCH2  = PCH2/AMCH2
1484                GO TO 34
1485 *  |  |  | end kin. sel. for meson proj. (baryon target), isam3 = 2
1486 *  |  |  +-->-->-->-->-->-->-->-->-->--> go to 34
1487
1488 *  |  |  +--<--<--<--<--<--<--<--<--<--< here from jump # 6
1489 *  |  |  |
1490  326           CONTINUE
1491 C*** BACKWARD Q(XP)-QQ(XXT) CHAIN
1492                CALL BKLASS (IBF,IBB1,IBB2,IB8,IBIO)
1493                AMB8  = AM(IB8)
1494                AMB10 = AM(IBIO)
1495                NNCH2 = 0
1496                AMBB  = AMB10 + 0.3D0
1497 C===================================================================
1498 C
1499 C*** KINEMATICAL PARAMETERS OF BOTH CHAINS IN CMS
1500 C      MESON NUCLEON
1501 C*** BACKWARD QUARK -DIQUARK CHAIN
1502 C
1503 C====================================================================
1504 *  |  |  |  here xp, xxt are used for the jet # 2
1505                XXSQ  = SQRT(XP*XXT)
1506                AMCH2 = UMO*XXSQ
1507                AA8   = IB8
1508                AA10  = IBIO
1509 *or               IF (IPRI .EQ. 1) WRITE(LUNOUT,103)XXSQ,AMCH1,AMCH2
1510 *or     &         ,AA8,AA10,AMB8,AMB10
1511
1512 *  |  |  |  +----------------------------------------------------------*
1513 *  |  |  |  |
1514                IF (AMCH2 .LT. AMB8 ) GO TO 25
1515 *  |  |  |  |  if amch2 < amb8 xp and xt are resampled
1516 *  |  |  |  +-->-->-->-->-->-->-->-->-->--> xp, xt resampling
1517
1518                IF (AMCH2 .GT. AMB10) GO TO 3261
1519 C*** PRODUCE AMB8
1520                   AMCH2 = AMB8
1521                   NNCH2 = -1
1522                   XXSQ = AMB8/UMO
1523                   XXT  = XXSQ**2/XP
1524 *or                  IF (INUCVT .EQ. 1) GO TO 3263
1525                   XT  = 1.D0 - XXT
1526                   GO TO 3263
1527 3261           CONTINUE
1528                IF (AMCH2 .GT. AMBB) GO TO 3263
1529 C*** PRODUCE AMB10
1530                   AMCH2 = AMB10
1531                   NNCH2 = 1
1532                   XXSQ = AMB10/UMO
1533                   XXT  = XXSQ**2/XP
1534 *or                  IF (INUCVT .EQ. 1) GO TO 3263
1535                   XT  = 1.D0 - XXT
1536
1537 C     PCH1=UMO*(XXP-XT)*.5D0
1538 C     ECH1=UMO*(XXP+XT)*.5D0
1539 C     GAMCH1=ECH1/AMCH1
1540 C     BGCH1=PCH1/AMCH1
1541
1542                   GO TO 3263
1543 3263           CONTINUE
1544                GO TO 3250
1545 *  |  |  |
1546 *  |  |  +-->-->-->-->-->-->-->-->-->--> jump # 7 to 3250
1547 *  |  +----------------------------------------------------------------*
1548 *  |
1549 *  |  +----------------------------------------------------------------*
1550 *  |  |  Meson projectile, meson target!!!
1551 *  |  |
1552 3288     CONTINUE
1553
1554 C================================================================
1555 C
1556 C*** KINEMATICAL PARAMETERS OF BOTH CHAINS IN CMS
1557 C           MESON MESON
1558 C
1559 C================================================================
1560             CALL GRNDM(RNDM,1)
1561             IF (RNDM(1) .LE. 0.5D0) GO TO 93288
1562                XT  = XXT
1563                XXT = 1.D0 - XT
1564 93288       CONTINUE
1565             GO TO (3218,3258),ISAM3
1566 *  |  |  +-------------------------------------------------------------*
1567 *  |  |  |  Meson projectile, meson target, isam3 = 1
1568 *  |  |  |
1569 3218        CONTINUE
1570 C==================================================================
1571 C*** MESON MESON Q(XXP)-AQ(XXT)+AQ(XP)-Q(XT)
1572 C=================================================================
1573                GO TO 3228
1574 *  |  |  |
1575 *  |  |  +-->-->-->-->-->-->-->-->-->--> jump # 8 to 3228
1576
1577 *  |  |  +--<--<--<--<--<--<--<--<--<--< here from jump # 9
1578 *  |  |  |
1579 32598          CONTINUE
1580 C=================================================================
1581 C
1582 C*** KINEMATICAL PARAMETERS OF BOTH CHAINS IN CMS
1583 C      MESON MESON
1584 C*** FIRST LONG Q(XXP)-AQ(XXT) CHAIN
1585 C
1586 C===================================================================
1587                IIFB = IABS(IFB)
1588                IFPS = IMPS(IIFB,IFF)
1589                IFV  = IMVE(IIFB,IFF)
1590                AMFPS = AM(IFPS)
1591 *  |  |  |  Of course AMPV seems to be a mistyping for AMFV
1592 *              AMPV  = AM(IFV)
1593                AMFV  = AM(IFV)
1594                NNCH1 = 0
1595                AMFF = AMFV + 0.3D0
1596 *  |  |  |  here we are using xxp, xxt for the jet # 1
1597                XSQ  = SQRT(XXP*XXT)
1598                AMCH1 = UMO*XSQ
1599                AAPS  = IFPS
1600                AAV   = IFV
1601 *or               IF (IPRI .EQ. 1) WRITE(LUNOUT,103)XSQ,AMCH1,AMCH2
1602 *or     &         ,AAPS,AAV,AMFPS,AMFV
1603
1604 *  |  |  +-------------------------------------------------------------*
1605 *  |  |  |
1606                IF (AMCH1 .LT. AMFPS) GO TO 25
1607 *  |  |  | if amch2 < amfps xp and xt are resampled
1608 *  |  |  +-->-->-->-->-->-->-->-->-->--> xp, xt resampling
1609
1610                IF (AMCH1 .GT. AMFV ) GO TO 32118
1611 C*** PRODUCE AMFPS
1612                   AMCH1 = AMFPS
1613                   NNCH1 = -1
1614                   XSQ = AMFPS/UMO
1615                   GO TO 32133
1616 32118          CONTINUE
1617                IF (AMCH1 .GT. AMFF) GO TO 32138
1618 C*** PRODUCE AMFV
1619                   AMCH1 = AMFV
1620                   NNCH1 = 1
1621                   XSQ = AMFV/UMO
1622                   GO TO 32133
1623 *  |  |  |  +----------------------------------------------------------*
1624 *  |  |  |  |  Here adjusting kinematics!!!!!
1625 *  |  |  |  |  Now, chain 1 is a single particle jet, so we have to
1626 *  |  |  |  |  reset the kinematical parameters xp, xxp, xt and xxt
1627 *  |  |  |  |
1628 32133             CONTINUE
1629                   XSQ2  = XSQ  * XSQ
1630 *  |  |  |  |  +-------------------------------------------------------*
1631 *  |  |  |  |  |  If also chain 2 is a parjet (nnch2 .ne. 0) then the
1632 *  |  |  |  |  |  param. to be recomputed are xxp and xxt, from alpha
1633 *  |  |  |  |  |  and beta, in such a way to conserve the original
1634 *  |  |  |  |  |  momentum direction
1635 *  |  |  |  |  |
1636                   IF (NNCH2 .NE. 0) THEN
1637                      XXSQ2 = XXSQ * XXSQ
1638                      HELP  = XSQ2 * (XSQ2 - 2.D0) + XXSQ2 *
1639      &                      (XXSQ2 - 2.D0) - 2.D0 * XSQ2 * XXSQ2
1640                      DDIFF = SQRT (HELP + 1.D0)
1641                      SSUM  = SQRT (HELP + 1.D0 + 4.D0 * XSQ2)
1642                      ALPHA = (SSUM + DDIFF) * 0.5D0
1643                      BETA  = (SSUM - DDIFF) * 0.5D0
1644                      IF (XXP .GT. XXT) THEN
1645                          XXP = ALPHA
1646                          XXT = BETA
1647                      ELSE
1648                          XXT = ALPHA
1649                          XXP = BETA
1650                      END IF
1651                      XP  = 1.D0 - XXP
1652                      XT  = 1.D0 - XXT
1653 *  |  |  |  |  |
1654 *  |  |  |  |  +-------------------------------------------------------*
1655                   ELSE
1656 *  |  |  |  |  +-------------------------------------------------------*
1657 *  |  |  |  |  |  If chain 2 is not a parjet (nnch2 .eq. 0) then the
1658 *  |  |  |  |  |  paramet. xxp,xxt have to be recomputed in such a way
1659 *  |  |  |  |  |  to conserve the original momentum direction and
1660 *  |  |  |  |  |  modulus
1661 *  |  |  |  |  |
1662                      DDIFF = XXP - XXT
1663                      SSUM  = SQRT (4.D0 * XSQ2 + DDIFF**2)
1664                      XXP = (SSUM + DDIFF) * 0.5D0
1665                      XXT = (SSUM - DDIFF) * 0.5D0
1666                      XP  = 1.D0 - XXP
1667                      XT  = 1.D0 - XXT
1668                      XXSQ  = SQRT (XP * XT)
1669                      AMCH2 = XXSQ * UMO
1670                   END IF
1671 *  |  |  |  |  |
1672 *  |  |  |  |  +-------------------------------------------------------*
1673 *  |  |  |  |                       end kinematics correction
1674 *  |  |  |  +----------------------------------------------------------*
1675
1676 32138          CONTINUE
1677                PCH1 = UMO*(XXP - XXT)*.5D0
1678                ECH1 = UMO*(XXP + XXT)*.5D0
1679                GAMCH1 = ECH1/AMCH1
1680                BGCH1  = PCH1/AMCH1
1681                PCH2 = UMO*(XP - XT)*.5D0
1682                ECH2 = UMO*(XP + XT)*.5D0
1683                GAMCH2 = ECH2/AMCH2
1684                BGCH2  = PCH2/AMCH2
1685                GO TO 348
1686 *  |  |  | end kin. sel. for meson proj. (meson target), isam3 = 1
1687 *  |  |  +-->-->-->-->-->-->-->-->-->--> go to 348
1688
1689 *  |  |  +--<--<--<--<--<--<--<--<--<--< here from jump # 8
1690 *  |  |  |
1691 3228           CONTINUE
1692 C===============================================================
1693 C
1694 C*** KINEMATICAL PARAMETERS OF BOTH CHAINS IN CMS
1695 C       MESON MESON
1696 C*** SHORT AQ(XP)-Q(XT) CHAIN
1697 C
1698 C================================================================
1699                IIBF = IABS(IBF)
1700                IBPS = IMPS(IIBF,IBB)
1701                IBV  = IMVE(IIBF,IBB)
1702                AMBPS = AM(IBPS)
1703                AMBV  = AM(IBV)
1704                NNCH2 = 0
1705                AMBB  = AMBV + 0.3D0
1706 *  |  |  |  here we are using xp, xt for the jet # 2
1707                XXSQ  = SQRT(XP*XT)
1708                AMCH2 = UMO*XXSQ
1709                AAPS = IBPS
1710                AAV  = IBV
1711 *or               IF (IPRI .EQ. 1) WRITE(LUNOUT,103)XXSQ,AMCH1,AMCH2
1712 *or     &         ,AAPS,AAV,AMBPS,AMBV
1713
1714 *  |  |  |  +----------------------------------------------------------*
1715 *  |  |  |  |
1716                IF (AMCH2 .LT. AMBPS) GO TO 25
1717 *  |  |  |  | if amch2 < ambps xp and xt are resampled
1718 *  |  |  |  +-->-->-->-->-->-->-->-->-->--> xp, xt resampling
1719
1720                IF (AMCH2 .GT. AMBV ) GO TO 32218
1721 C*** PRODUCE AMBPS
1722                   AMCH2 = AMBPS
1723                   NNCH2 = -1
1724                   XXSQ  = AMBPS/UMO
1725                   XT  = XXSQ**2/XP
1726 *or                  IF (INUCVT .EQ. 1) GO TO 32238
1727                   XXT = 1.D0 - XT
1728                   GO TO 32238
1729 32218          CONTINUE
1730                IF (AMCH2 .GT. AMBB) GO TO 32238
1731 C*** PRODUCE AMBV
1732                   AMCH2 = AMBV
1733                   NNCH2 = 1
1734                   XXSQ  = AMBV/UMO
1735                   XT  = XXSQ**2/XP
1736 *or                  IF (INUCVT .EQ. 1) GO TO 32238
1737                   XXT = 1.D0 - XT
1738
1739 C     PCH1=UMO*(XXP-XXT)*.5D0
1740 C     ECH1=UMO*(XXP+XXT)*.5D0
1741 C     GAMCH1=ECH1/AMCH1
1742 C     BGCH1=PCH1/AMCH1
1743 C     GO TO 32238
1744
1745 32238          CONTINUE
1746                GO TO 32598
1747 *  |  |  |
1748 *  |  |  +-->-->-->-->-->-->-->-->-->--> jump # 9 to 32598
1749
1750 *  |  |  +-------------------------------------------------------------*
1751 *  |  |  |  Meson projectile, meson target, isam3 = 2
1752 *  |  |  |
1753 3258        CONTINUE
1754 C=================================================================
1755 C
1756 C*** KINEMATICAL PARAMETERS OF BOTH CHAINS IN CMS
1757 C*** MESON MESON
1758 C*** FORWARD ANTIQUARK-DIQUARK CHAIN
1759 C
1760 C=================================================================
1761                GO TO 3268
1762 *  |  |  |
1763 *  |  |  +-->-->-->-->-->-->-->-->-->--> jump # 10 to 3268
1764
1765 *  |  |  +--<--<--<--<--<--<--<--<--<--< here from jump # 11
1766 *  |  |  |
1767 32508          CONTINUE
1768 C===================================================================
1769 C*** MESON MESON FORWARD AQ(XXP)-Q(XT) AND BACKWARD CHAINS Q(XP)-AQ(
1770 C*** XXT) CHAINS
1771 C====================================================================
1772 C=====================================================================
1773 C
1774 C*** KINEMATICAL PARAMETERS OF BOTH CHAINS IN CMS
1775 C     MESON MESON
1776 C*** FORWARD AQ(XXP)-Q(XT) CHAIN
1777 C
1778 C====================================================================
1779                IIFF = IABS(IFF)
1780                IFPS = IMPS(IIFF,IFB)
1781                IFV  = IMVE(IIFF,IFB)
1782                AMFPS = AM(IFPS)
1783                AMFV  = AM(IFV)
1784                NNCH1 = 0
1785                AMFF  = AMFV + 0.3D0
1786 *  |  |  |  here we are using xxp, xt for the jet # 1
1787                XSQ   = SQRT(XXP*XT)
1788                AMCH1 = UMO*XSQ
1789                AAPS = IFPS
1790                AAV  = IFV
1791 *or               IF (IPRI .EQ. 1) WRITE(LUNOUT,103)XSQ,AMCH1,AMCH2
1792 *or     &         ,AAPS,AAV,AMFPS,AMFV
1793
1794 *  |  |  |  +----------------------------------------------------------*
1795 *  |  |  |  |
1796                IF (AMCH1 .LT. AMFPS) GO TO 25
1797 *  |  |  |  | if amch1 < amfps xp and xt are resampled
1798 *  |  |  |  +-->-->-->-->-->-->-->-->-->--> xp, xt resampling
1799
1800                IF (AMCH1 .GT. AMFV) GO TO 32518
1801 C*** PRODUCE AMFPS
1802                   AMCH1 = AMFPS
1803                   NNCH1 = -1
1804                   XSQ = AMFPS/UMO
1805                   GO TO 32535
1806 32518          CONTINUE
1807                IF (AMCH1 .GT. AMFF) GO TO 32538
1808 C*** PRODUCE AMFV
1809                   AMCH1 = AMFV
1810                   NNCH1 = 1
1811                   XSQ = AMFV/UMO
1812                   GO TO 32535
1813 *  |  |  |  +----------------------------------------------------------*
1814 *  |  |  |  |  Here adjusting kinematics!!!!!
1815 *  |  |  |  |  Now, chain 1 is a single particle jet, so we have to
1816 *  |  |  |  |  reset the kinematical parameters xp, xxp, xt and xxt
1817 *  |  |  |  |
1818 32535             CONTINUE
1819                   XSQ2  = XSQ  * XSQ
1820 *  |  |  |  |  +-------------------------------------------------------*
1821 *  |  |  |  |  |  If also chain 2 is a parjet (nnch2 .ne. 0) then the
1822 *  |  |  |  |  |  param. to be recomputed are xxp and xt, from alpha
1823 *  |  |  |  |  |  and beta, in such a way to conserve the original
1824 *  |  |  |  |  |  momentum direction
1825 *  |  |  |  |  |
1826                   IF (NNCH2 .NE. 0) THEN
1827                      XXSQ2 = XXSQ * XXSQ
1828                      HELP  = XSQ2 * (XSQ2 - 2.D0) + XXSQ2 *
1829      &                      (XXSQ2 - 2.D0) - 2.D0 * XSQ2 * XXSQ2
1830                      DDIFF = SQRT (HELP + 1.D0)
1831                      SSUM  = SQRT (HELP + 1.D0 + 4.D0 * XSQ2)
1832                      ALPHA = (SSUM + DDIFF) * 0.5D0
1833                      BETA  = (SSUM - DDIFF) * 0.5D0
1834                      IF (XXP .GT.  XT) THEN
1835                          XXP = ALPHA
1836                          XT  = BETA
1837                      ELSE
1838                          XT  = ALPHA
1839                          XXP = BETA
1840                      END IF
1841                      XP  = 1.D0 - XXP
1842                      XXT = 1.D0 - XT
1843 *  |  |  |  |  |
1844 *  |  |  |  |  +-------------------------------------------------------*
1845                   ELSE
1846 *  |  |  |  |  +-------------------------------------------------------*
1847 *  |  |  |  |  |  If chain 2 is not a parjet (nnch2 .eq. 0) then the
1848 *  |  |  |  |  |  paramet. xxp,xt have to be recomputed in such a way
1849 *  |  |  |  |  |  to conserve the original momentum direction and
1850 *  |  |  |  |  |  modulus
1851 *  |  |  |  |  |
1852                      DDIFF = XXP - XT
1853                      SSUM  = SQRT (4.D0 * XSQ2 + DDIFF**2)
1854                      XXP = (SSUM + DDIFF) * 0.5D0
1855                      XT  = (SSUM - DDIFF) * 0.5D0
1856                      XP  = 1.D0 - XXP
1857                      XXT = 1.D0 - XT
1858                      XXSQ  = SQRT (XP * XXT)
1859                      AMCH2 = XXSQ * UMO
1860                   END IF
1861 *  |  |  |  |  |
1862 *  |  |  |  |  +-------------------------------------------------------*
1863 *  |  |  |  |                       end kinematics correction
1864 *  |  |  |  +----------------------------------------------------------*
1865
1866 32538          CONTINUE
1867                PCH1 = UMO*(XXP - XT)*.5D0
1868                ECH1 = UMO*(XXP + XT)*.5D0
1869                GAMCH1 = ECH1/AMCH1
1870                BGCH1  = PCH1/AMCH1
1871                PCH2 = UMO*(XP - XXT)*.5D0
1872                ECH2 = UMO*(XP + XXT)*.5D0
1873                GAMCH2 = ECH2/AMCH2
1874                BGCH2  = PCH2/AMCH2
1875                GO TO 348
1876 *  |  |  | end kin. sel. meson proj. (meson target), isam3 = 2
1877 *  |  |  +-->-->-->-->-->-->-->-->-->--> go to 348
1878
1879 *  |  |  +--<--<--<--<--<--<--<--<--<--< here from jump # 10
1880 *  |  |  |
1881 3268           CONTINUE
1882 C*** BACKWARD Q(XP)-AQ(XXT) CHAIN
1883                IIBB = IABS(IBB)
1884                IBPS = IMPS(IIBB,IBF)
1885                IBV  = IMVE(IIBB,IBF)
1886                AMBPS = AM(IBPS)
1887                AMBV  = AM(IBV)
1888                NNCH2 = 0
1889                AMBB  = AMBV + 0.3D0
1890 C===================================================================
1891 C
1892 C*** KINEMATICAL PARAMETERS OF BOTH CHAINS IN CMS
1893 C      MESON MESON
1894 C*** BACKWARD QUARK -ANTIQUARK CHAIN
1895 C
1896 C====================================================================
1897 *  |  |  |  here we are using xp, xxt for the jet # 2
1898                XXSQ  = SQRT(XP*XXT)
1899                AMCH2 = UMO*XXSQ
1900                AAPS  = IBPS
1901                AAV   = IBV
1902 *or               IF (IPRI .EQ. 1) WRITE(LUNOUT,103)XSQ,AMCH1,AMCH2
1903 *or     &         ,AAPS,AAV,AMBPS,AMBV
1904
1905 *  |  |  |  +----------------------------------------------------------*
1906 *  |  |  |  |
1907                IF (AMCH2 .LT. AMBPS) GO TO 25
1908 *  |  |  |  | if amch2 < ambps xp and xt are resampled
1909 *  |  |  |  +-->-->-->-->-->-->-->-->-->--> xp, xt resampling
1910
1911                IF (AMCH2 .GT. AMBV) GO TO 32618
1912 C*** PRODUCE AMBPS
1913                   AMCH2 = AMBPS
1914                   NNCH2 = -1
1915                   XXSQ = AMBPS/UMO
1916                   XXT  = XXSQ**2/XP
1917 *or                  IF (INUCVT .EQ. 1) GO TO 32638
1918                   XT = 1.D0 - XXT
1919                   GO TO 32638
1920 32618          CONTINUE
1921                IF (AMCH2 .GT. AMBB) GO TO 32638
1922 C*** PRODUCE AMBV
1923                   AMCH2 = AMBV
1924                   NNCH2 = 1
1925                   XXSQ = AMBV /UMO
1926                   XXT  = XXSQ**2/XP
1927 *or                  IF (INUCVT .EQ. 1) GO TO 32638
1928                   XT  = 1.D0 - XXT
1929
1930 C     PCH1=UMO*(XXP-XT)*.5D0
1931 C     ECH1=UMO*(XXP+XT)*.5D0
1932 C     GAMCH1=ECH1/AMCH1
1933 C     BGCH1=PCH1/AMCH1
1934
1935                   GO TO 32638
1936 32638          CONTINUE
1937                GO TO 32508
1938 *  |  |  |
1939 *  |  |  +-->-->-->-->-->-->-->-->-->--> jump # 11 to 32508
1940 *  |  +----------------------------------------------------------------*
1941
1942  348  CONTINUE
1943 *or      IF (IPRI .EQ. 1) WRITE(LUNOUT,103)XP,XT,XXP,XXT
1944 *or      IF (IPRI .EQ. 1) WRITE(LUNOUT,103)AMCH1,AMCH2,PCH1,PCH2,ECH1,
1945 *or     &ECH2,GAMCH1,GAMCH2,BGCH1,BGCH2
1946       GO TO 34
1947 *  |  | end kin. sel. meson proj. (meson target)
1948 *  |  +-->-->-->-->-->-->-->-->-->--> go to 34
1949
1950 *  |  +----------------------------------------------------------------*
1951 *  |  | meson projectile, antibaryon target!!!
1952 *  |  |
1953 3277     CONTINUE
1954 C=================================================================
1955 C
1956 C*** KINEMATICAL PARAMETERS OF BOTH CHAINS IN CMS
1957 C       MESON ANTIBARYON
1958 C
1959 C===============================================================
1960 C====================================================================
1961 C====================================================================
1962 C     TO BE CORRECTED
1963 C
1964 C====================================================================
1965 C`===================================================================
1966             GO TO (3217,3257),ISAM3
1967 *  |  |  +-------------------------------------------------------------*
1968 *  |  |  |  meson projectile, antibaryon target, isam = 2
1969 *  |  |  |
1970 3257        CONTINUE
1971 C*** MESON NUCLEON AQ(XXP)-AQAQ(XXT)+Q(XP)-AQ(XT)
1972                GO TO 3227
1973 *  |  |  |
1974 *  |  |  +-->-->-->-->-->-->-->-->-->--> jump # 12 to 3227
1975
1976 *  |  |  +--<--<--<--<--<--<--<--<--<--< here from jump # 13
1977 *  |  |  |
1978 32597 CONTINUE
1979 C=================================================================
1980 C
1981 C*** KINEMATICAL PARAMETERS OF BOTH CHAINS IN CMS
1982 C      MESON ANTINUCLEON
1983 C*** FIRST LONG AQ(XXP)-AQAQ(XXT) CHAIN
1984 C
1985 C===================================================================
1986                CALL BKLASS (IBF,IBB1,IBB2,IF8,IFIO)
1987                AMF8  = AM(IF8)
1988                AMF10 = AM(IFIO)
1989                NNCH1 = 0
1990                AMFF  = AMF10 + 0.3D0
1991 *  |  |  |  here we are using xxp, xxt for the jet # 1
1992                XSQ   = SQRT(XXP*XXT)
1993                AMCH1 = UMO*XSQ
1994                AA8   = IF8
1995                AA10  = IFIO
1996 *or               IF (IPRI .EQ. 1) WRITE(LUNOUT,103)XSQ,AMCH1,AMCH2
1997 *or     &         ,AA8,AA10,AMF8,AMF10
1998
1999 *  |  |  |  +----------------------------------------------------------*
2000 *  |  |  |  |
2001                IF (AMCH1 .LT. AMF8) GO TO 25
2002 *  |  |  |  | if amch1 < amf8 xp and xt are resampled
2003 *  |  |  |  +-->-->-->-->-->-->-->-->-->--> xp, xt resampling
2004
2005                IF (AMCH1 .GT. AMF10) GO TO 32117
2006 C*** PRODUCE AMF8
2007                   AMCH1 = AMF8
2008                   NNCH1 = -1
2009                   XSQ = AMF8/UMO
2010                   GO TO 32135
2011 32117          CONTINUE
2012                IF (AMCH1 .GT. AMFF) GO TO 32137
2013 C*** PRODUCE AMF10
2014                   AMCH1 = AMF10
2015                   NNCH1 = 1
2016                   XSQ = AMF10/UMO
2017                   GO TO 32135
2018 *  |  |  |  +----------------------------------------------------------*
2019 *  |  |  |  |  Here adjusting kinematics!!!!!
2020 *  |  |  |  |  Now, chain 1 is a single particle jet, so we have to
2021 *  |  |  |  |  reset the kinematical parameters xp, xxp, xt and xxt
2022 *  |  |  |  |
2023 32135             CONTINUE
2024                   XSQ2  = XSQ  * XSQ
2025 *  |  |  |  |  +-------------------------------------------------------*
2026 *  |  |  |  |  |  If also chain 2 is a parjet (nnch2 .ne. 0) then the
2027 *  |  |  |  |  |  param. to be recomputed are xxp and xxt, from alpha
2028 *  |  |  |  |  |  and beta, in such a way to conserve the original
2029 *  |  |  |  |  |  momentum direction
2030 *  |  |  |  |  |
2031                   IF (NNCH2 .NE. 0) THEN
2032                      XXSQ2 = XXSQ * XXSQ
2033                      HELP  = XSQ2 * (XSQ2 - 2.D0) + XXSQ2 *
2034      &                      (XXSQ2 - 2.D0) - 2.D0 * XSQ2 * XXSQ2
2035                      DDIFF = SQRT (HELP + 1.D0)
2036                      SSUM  = SQRT (HELP + 1.D0 + 4.D0 * XSQ2)
2037                      ALPHA = (SSUM + DDIFF) * 0.5D0
2038                      BETA  = (SSUM - DDIFF) * 0.5D0
2039                      IF (XXP .GT. XXT) THEN
2040                          XXP = ALPHA
2041                          XXT = BETA
2042                      ELSE
2043                          XXT = ALPHA
2044                          XXP = BETA
2045                      END IF
2046                      XP  = 1.D0 - XXP
2047                      XT  = 1.D0 - XXT
2048 *  |  |  |  |  |
2049 *  |  |  |  |  +-------------------------------------------------------*
2050                   ELSE
2051 *  |  |  |  |  +-------------------------------------------------------*
2052 *  |  |  |  |  |  If chain 2 is not a parjet (nnch2 .eq. 0) then the
2053 *  |  |  |  |  |  paramet. xxp,xxt have to be recomputed in such a way
2054 *  |  |  |  |  |  to conserve the original momentum direction and
2055 *  |  |  |  |  |  modulus
2056 *  |  |  |  |  |
2057                      DDIFF = XXP - XXT
2058                      SSUM  = SQRT (4.D0 * XSQ2 + DDIFF**2)
2059                      XXP = (SSUM + DDIFF) * 0.5D0
2060                      XXT = (SSUM - DDIFF) * 0.5D0
2061                      XP  = 1.D0 - XXP
2062                      XT  = 1.D0 - XXT
2063                      XXSQ  = SQRT (XP * XT)
2064                      AMCH2 = XXSQ * UMO
2065                   END IF
2066 *  |  |  |  |  |
2067 *  |  |  |  |  +-------------------------------------------------------*
2068 *  |  |  |  |                       end kinematics correction
2069 *  |  |  |  +----------------------------------------------------------*
2070
2071 32137          CONTINUE
2072                PCH1 = UMO*(XXP - XXT)*.5D0
2073                ECH1 = UMO*(XXP + XXT)*.5D0
2074                GAMCH1 = ECH1/AMCH1
2075                BGCH1  = PCH1/AMCH1
2076                PCH2 = UMO*(XP - XT)*.5D0
2077                ECH2 = UMO*(XP + XT)*.5D0
2078                GAMCH2 = ECH2/AMCH2
2079                BGCH2  = PCH2/AMCH2
2080                GO TO 34
2081 *  |  |  | end kin. sel. meson proj. (abaryon target), isam3 = 2
2082 *  |  |  +-->-->-->-->-->-->-->-->-->--> go to 34
2083
2084 *  |  |  +--<--<--<--<--<--<--<--<--<--< here from jump # 12
2085 *  |  |  |
2086 3227           CONTINUE
2087 C===============================================================
2088 C
2089 C*** KINEMATICAL PARAMETERS OF BOTH CHAINS IN CMS
2090 C       MESON ANTINUCLEON
2091 C*** SHORT AQ(XP)-Q(XT) CHAIN
2092 C
2093 C================================================================
2094               IIFB = IABS(IFB)
2095               IBPS = IMPS(IIFB,IFF)
2096               IBV  = IMVE(IIFB,IFF)
2097               AMBPS = AM(IBPS)
2098               AMBV  = AM(IBV)
2099               NNCH2 = 0
2100               AMBB = AMBV + 0.3D0
2101 *  |  |  | here we are using xp,xt for jet # 2
2102               XXSQ  = SQRT(XP*XT)
2103               AMCH2 = UMO*XXSQ
2104               AAPS  = IBPS
2105               AAV   = IBV
2106 *or              IF (IPRI .EQ. 1) WRITE(LUNOUT,103)XSQ,AMCH1,AMCH2
2107 *or     &        ,AAPS,AAV,AMBPS,AMBV
2108
2109 *  |  |  |  +----------------------------------------------------------*
2110 *  |  |  |  |
2111                IF (AMCH2 .LT. AMBPS) GO TO 25
2112 *  |  |  |  | if amch2 < ambps xp and xt are resampled
2113 *  |  |  |  +-->-->-->-->-->-->-->-->-->--> xp, xt resampling
2114
2115                IF (AMCH2 .GT. AMBV) GO TO 32217
2116 C*** PRODUCE AMBPS
2117                   AMCH2 = AMBPS
2118                   NNCH2 = -1
2119                   XXSQ = AMBPS/UMO
2120                   XT   = XXSQ**2/XP
2121 *or                  IF (INUCVT .EQ. 1) GO TO 32237
2122                   XXT = 1.D0 - XT
2123                   GO TO 32237
2124 32217          CONTINUE
2125                IF (AMCH2 .GT. AMBB) GO TO 32237
2126 C*** PRODUCE AMBV
2127                   AMCH2 = AMBV
2128                   NNCH2 = 1
2129                   XXSQ = AMBV/UMO
2130                   XT   = XXSQ**2/XP
2131 *or                  IF (INUCVT .EQ. 1) GO TO 32237
2132                   XXT = 1.D0 - XT
2133
2134 C     PCH1=UMO*(XXP-XXT)*.5D0
2135 C     ECH1=UMO*(XXP+XXT)*.5D0
2136 C     GAMCH1=ECH1/AMCH1
2137 C     BGCH1=PCH1/AMCH1
2138 C     GO TO 32237
2139
2140 32237          CONTINUE
2141                GO TO 32597
2142 *  |  |  |
2143 *  |  |  +-->-->-->-->-->-->-->-->-->--> jump # 13 to 32597
2144
2145 *  |  |  +-------------------------------------------------------------*
2146 *  |  |  |  meson projectile, antibaryon target, isam = 1
2147 *  |  |  |
2148 3217           CONTINUE
2149 C=================================================================
2150 C
2151 C*** KINEMATICAL PARAMETERS OF BOTH CHAINS IN CMS
2152 C*** MESON ANTINUCLEUS
2153 C*** BACKWARD    QUARK-  ANTIQUARK CHAIN
2154 C
2155 C=================================================================
2156 32507          CONTINUE
2157 C=====================================================================
2158 C
2159 C     MESON ANTINUCLEON
2160 C*** BACKWARD Q(XP)-AQ(XT) CHAIN
2161 C
2162 C====================================================================
2163                IIBB = IABS(IBB)
2164                IFPS = IMPS(IIBB,IBF)
2165                IFV  = IMVE(IIBB,IBF)
2166                AMFPS = AM(IFPS)
2167                AMFV  = AM(IFV)
2168                NNCH1 = 0
2169                AMFF = AMFV + 0.3D0
2170 *  |  |  | here we are using xp,xt for jet # 1
2171                XSQ  = SQRT(XP*XT)
2172                AMCH1 = UMO*XSQ
2173                AAPS  = IFPS
2174                AAV   = IFV
2175 *or               IF (IPRI .EQ. 1) WRITE(LUNOUT,103)XSQ,AMCH1,AMCH2
2176 *or     &         ,AAPS,AAV,AMFPS,AMFV
2177
2178 *  |  |  |  +----------------------------------------------------------*
2179 *  |  |  |  |
2180                IF (AMCH1 .LT. AMFPS) GO TO 25
2181 *  |  |  |  | if amch1 < amfps xp and xt are resampled
2182 *  |  |  |  +-->-->-->-->-->-->-->-->-->--> xp, xt resampling
2183
2184                IF (AMCH1 .GT. AMFV) GO TO 32517
2185 C*** PRODUCE AMFPS
2186                   AMCH1 = AMFPS
2187                   NNCH1 = -1
2188                   XSQ = AMFPS/UMO
2189                   XP  = XSQ**2/XT
2190                   XXP = 1.D0 - XP
2191                   GO TO 32537
2192 32517          CONTINUE
2193                IF (AMCH1 .GT. AMFF) GO TO 32537
2194 C*** PRODUCE AMFV
2195                   AMCH1 = AMFV
2196                   NNCH1 = 1
2197                   XSQ = AMFV/UMO
2198                   XP  = XSQ**2/XT
2199                   XXP = 1.D0 - XP
2200                   GO TO 32537
2201 32537          CONTINUE
2202                GO TO 3267
2203 3267           CONTINUE
2204 C***FORWARD AQ(XXP)-AQAQ(XXT) CHAIN
2205                CALL BKLASS(IFF,IFB1,IFB2,IB8,IBIO)
2206                AMB8  = AM(IB8)
2207                AMB10 = AM(IBIO)
2208                NNCH2 = 0
2209                AMBB  = AMB10 + 0.3D0
2210 C===================================================================
2211 C
2212 C*** KINEMATICAL PARAMETERS OF BOTH CHAINS IN CMS
2213 C               MESON ANTINUCLEON
2214 C*** FORWARD ANTIQUARK -ANTIDIQUARK CHAIN
2215 C
2216 C====================================================================
2217 *  |  |  | here we are using xxp,xXt for jet # 2
2218                XXSQ = SQRT(XXP*XXT)
2219                AMCH2 = UMO*XXSQ
2220                AA8   = IB8
2221                AA10  = IBIO
2222 *or               IF (IPRI .EQ. 1) WRITE(LUNOUT,103)XSQ,AMCH1,AMCH2
2223 *or     &         ,AA8,AA10,AMB8,AMB10
2224
2225 *  |  |  |  +----------------------------------------------------------*
2226 *  |  |  |  |
2227                IF (AMCH2 .LT. AMB8 ) GO TO 25
2228 *  |  |  |  | if amch2 < amb8 xp and xt are resampled
2229 *  |  |  |  +-->-->-->-->-->-->-->-->-->--> xp, xt resampling
2230
2231                IF (AMCH2 .GT. AMB10) GO TO 32617
2232 C*** PRODUCE AMB8
2233                   AMCH2 = AMB8
2234                   NNCH2 = -1
2235                   XXSQ = AMB8/UMO
2236 *or                  IF (INUCVT .EQ. 1) GO TO 32637
2237                   GO TO 32636
2238 32617          CONTINUE
2239                IF (AMCH2 .GT. AMBB) GO TO 32637
2240 C*** PRODUCE AMB10
2241                   AMCH2 = AMB10
2242                   NNCH2 = 1
2243                   XXSQ = AMB10/UMO
2244 *or                  IF (INUCVT .EQ. 1) GO TO 32637
2245
2246 C     PCH1=UMO*(XXP-XT)*.5D0
2247 C     ECH1=UMO*(XXP+XT)*.5D0
2248 C     GAMCH1=ECH1/AMCH1
2249 C     BGCH1=PCH1/AMCH1
2250 * Here there was a "large" mistake in the old Hadevt!!!
2251                   GO TO 32636
2252 *  |  |  |  +----------------------------------------------------------*
2253 *  |  |  |  |  Here adjusting kinematics!!!!!
2254 *  |  |  |  |  Now, chain 2 is a single particle jet, so we have to
2255 *  |  |  |  |  reset the kinematical parameters xp, xxp, xt and xxt
2256 *  |  |  |  |
2257 32636             CONTINUE
2258                   XXSQ2 = XXSQ  * XXSQ
2259 *  |  |  |  |  +-------------------------------------------------------*
2260 *  |  |  |  |  |  If also chain 1 is a parjet (nnch1 .ne. 0) then the
2261 *  |  |  |  |  |  param. to be recomputed are xxp and xxt, from alpha
2262 *  |  |  |  |  |  and beta, in such a way to conserve the original
2263 *  |  |  |  |  |  momentum direction
2264 *  |  |  |  |  |
2265                   IF (NNCH1 .NE. 0) THEN
2266                      XSQ2  = XSQ * XSQ
2267                      HELP  = XSQ2 * (XSQ2 - 2.D0) + XXSQ2 *
2268      &                      (XXSQ2 - 2.D0) - 2.D0 * XSQ2 * XXSQ2
2269                      DDIFF = SQRT (HELP + 1.D0)
2270                      SSUM  = SQRT (HELP + 1.D0 + 4.D0 * XXSQ2)
2271                      ALPHA = (SSUM + DDIFF) * 0.5D0
2272                      BETA  = (SSUM - DDIFF) * 0.5D0
2273                      IF (XXP .GT.  XXT) THEN
2274                          XXP = ALPHA
2275                          XXT = BETA
2276                      ELSE
2277                          XXT = ALPHA
2278                          XXP = BETA
2279                      END IF
2280                      XP  = 1.D0 - XXP
2281                      XT  = 1.D0 - XXT
2282 *  |  |  |  |  |
2283 *  |  |  |  |  +-------------------------------------------------------*
2284                   ELSE
2285 *  |  |  |  |  +-------------------------------------------------------*
2286 *  |  |  |  |  |  If chain 1 is not a parjet (nnch1 .eq. 0) then the
2287 *  |  |  |  |  |  paramet. xxp,xxt have to be recomputed in such a way
2288 *  |  |  |  |  |  to conserve the original momentum direction and
2289 *  |  |  |  |  |  modulus
2290 *  |  |  |  |  |
2291                      DDIFF = XXP - XXT
2292                      SSUM  = SQRT (4.D0 * XXSQ2 + DDIFF**2)
2293                      XXP = (SSUM + DDIFF) * 0.5D0
2294                      XXT = (SSUM - DDIFF) * 0.5D0
2295                      XP  = 1.D0 - XXP
2296                      XT  = 1.D0 - XXT
2297                      XSQ   = SQRT (XP * XT)
2298                      AMCH1 = XSQ * UMO
2299                   END IF
2300 *  |  |  |  |  |
2301 *  |  |  |  |  +-------------------------------------------------------*
2302 *  |  |  |  |                       end kinematics correction
2303 *  |  |  |  +----------------------------------------------------------*
2304
2305 32637          CONTINUE
2306                PCH1 = UMO*(XP - XT)*.5D0
2307                ECH1 = UMO*(XP + XT)*.5D0
2308                GAMCH1 = ECH1/AMCH1
2309                BGCH1  = PCH1/AMCH1
2310                PCH2 = UMO*(XXP - XXT)*.5D0
2311                ECH2 = UMO*(XXP + XXT)*.5D0
2312                GAMCH2 = ECH2/AMCH2
2313                BGCH2  = PCH2/AMCH2
2314                GO TO 34
2315 *  |  |  | end kin. sel. meson proj. (abaryon target), isam3 = 1
2316 *  |  |  +-->-->-->-->-->-->-->-->-->--> go to 34
2317 *  |  +----------------------------------------------------------------*
2318   34  CONTINUE
2319 *  |            end of kinematical selections!!!!!!!!!
2320 *  +-------------------------------------------------------------------*
2321 *or      IF (IPRI .EQ. 1) WRITE(LUNOUT,103)XP,XT,XXP,XXT
2322 *or      IF (IPRI .EQ. 1) WRITE(LUNOUT,103)AMCH1,AMCH2,PCH1,PCH2,
2323 *or     &ECH1,ECH2,GAMCH1,GAMCH2,BGCH1,BGCH2
2324 C
2325 C********************************************************************
2326 C
2327 C*** MC SAMPLING OF FORWARD CHAIN
2328 C
2329 C********************************************************************
2330 C
2331       IF (IBPROJ) 41,42,43
2332 C==================================================================
2333 C         FORWARD CHAIN OF ANTIBARYON BARYON
2334 C==================================================================
2335   41  CONTINUE
2336          IF (NNCH1) 4111,4112,4113
2337 4111     CONTINUE
2338             ICH1 = IFPS
2339             GO TO 4114
2340 4113     CONTINUE
2341             ICH1 = IFV
2342             GO TO 4114
2343 4112     CONTINUE
2344             IF (IOPBAM .EQ. 5) THEN
2345                IAIFF1 = IABS(IFF1) + 6
2346                IAIFF2 = IABS(IFF2) + 6
2347 *or               IF (IPRI .EQ. 1)WRITE(LUNOUT,991)IFB1,IFB2,IAIFF1
2348 *or 991           FORMAT (' BAMJEV 4112',5I5)
2349                CALL BAMJEV(IHAD,IFB1,IFB2,IAIFF1,IAIFF2,AMCH1,5)
2350             ELSE
2351                IAIFF = IABS(IAIFF) + 6
2352                CALL BAMJEV(IHAD,IFB,IAIFF,IFB,IFB,AMCH1,IOPBAM)
2353             END IF
2354             GO TO 4115
2355 4114  CONTINUE
2356 *or      IF (IPRI .EQ. 1) WRITE(LUNOUT,992)ICH1
2357 *or  992 FORMAT (' PARJET 4114 ',5I5)
2358             CALL PARJET(IHAD,ICH1)
2359 4115     CONTINUE
2360 C
2361 C
2362 C
2363 C     CALL DECAY(IHAD,2)
2364          GO TO 44
2365 42    CONTINUE
2366 C=====================================================================
2367 C*** FORWARD CHAIN OF MESON NUCLEON
2368 C======================================================================
2369          IF (IBTARG) 427,428,429
2370  429     CONTINUE
2371             GO TO (421,422),ISAM3
2372  421        CONTINUE
2373                IF (NNCH1) 4211,4212,4213
2374 4211           CONTINUE
2375                   ICH1 = IF8
2376                   GO TO 4214
2377 4213           CONTINUE
2378                   ICH1 = IFIO
2379                   GO TO 4214
2380 4212           CONTINUE
2381                   CALL BAMJEV(IHAD,IFF,IFB1,IFB2,IFF,AMCH1,4)
2382                   GO TO 4215
2383 4214           CONTINUE
2384                   CALL PARJET(IHAD,ICH1)
2385 4215           CONTINUE
2386 C     CALL DECAY(IHAD,2)
2387                GO TO 44
2388 422         CONTINUE
2389 C*** IFA - IFB AQ - Q EXISTIERT NICHT
2390                IF (NNCH1) 4221,4222,4223
2391 4221           CONTINUE
2392                   ICH1 = IFPS
2393                   GO TO 4224
2394 4223           CONTINUE
2395                   ICH1 = IFV
2396                   GO TO 4224
2397 4222           CONTINUE
2398                   IAIFF = IABS(IFF) + 6
2399                   CALL BAMJEV(IHAD,IFB,IAIFF,IFB,IFB,AMCH1,3)
2400                   GO TO 4225
2401 4224           CONTINUE
2402                   CALL PARJET(IHAD,ICH1)
2403 4225           CONTINUE
2404 C     CALL DECAY(IHAD,2)
2405                GO TO 44
2406 C===================================================================
2407 C
2408 C   FORWARD CHAIN OF MESON MESON
2409 C
2410 C====================================================================
2411 C=====================================================================
2412  428     CONTINUE
2413             GO TO (4218,4228),ISAM3
2414 4218        CONTINUE
2415                IF (NNCH1) 42118,42128,42138
2416 42118          CONTINUE
2417                   ICH1 = IFPS
2418                   GO TO 42148
2419 42138          CONTINUE
2420                   ICH1 = IFV
2421                   GO TO 42148
2422 42128          CONTINUE
2423                   IAIFB = IABS(IFB) + 6
2424                   CALL BAMJEV(IHAD,IFF,IAIFB,IFB2,IFF,AMCH1,3)
2425                   GO TO 42158
2426 42148          CONTINUE
2427                   CALL PARJET(IHAD,ICH1)
2428 42158          CONTINUE
2429 C     CALL DECAY(IHAD,2)
2430                GO TO 44
2431 4228        CONTINUE
2432 C*** IFA - IFB AQ - Q EXISTIERT NICHT
2433                IF (NNCH1) 42218,42228,42238
2434 42218          CONTINUE
2435                   ICH1 = IFPS
2436                   GO TO 42248
2437 42238          CONTINUE
2438                   ICH1 = IFV
2439                   GO TO 42248
2440 42228          CONTINUE
2441                   IAIFF = IABS(IFF) + 6
2442                   CALL BAMJEV(IHAD,IFB,IAIFF,IFB,IFB,AMCH1,3)
2443                   GO TO 42258
2444 42248          CONTINUE
2445                   CALL PARJET(IHAD,ICH1)
2446 42258          CONTINUE
2447 C     CALL DECAY(IHAD,2)
2448                GO TO 44
2449 C================================================================
2450 C
2451 C      FORWARD CHAIN OF MESON ANTIBARYON
2452 C
2453 C==================================================================
2454  427     CONTINUE
2455 C=================================================================
2456 C    TO BE CORRECTED
2457 C=================================================================
2458             GO TO (4217,4227),ISAM3
2459 4227        CONTINUE
2460                IF (NNCH1) 42117,42127,42137
2461 42117          CONTINUE
2462                   ICH1 = IF8
2463                   GO TO 42147
2464 42137          CONTINUE
2465                   ICH1 = IFIO
2466                   GO TO 42147
2467 42127          CONTINUE
2468                   IAIBF = IABS(IBF) + 6
2469                   IAIBB1= IABS(IBB1) + 6
2470                   IAIBB2= IABS(IBB2) + 6
2471 *or                  IF (IPRI.EQ.1) WRITE(LUNOUT,994)IAIBF,IAIBB1,IAIBB2
2472 *or  994 FORMAT(' BAMJEV 43147',5I5)
2473                   CALL BAMJEV(IHAD,IAIBF,IAIBB1,IAIBB2,IBB,AMCH1,4)
2474                   GO TO 42157
2475 42147          CONTINUE
2476 *or                  IF (IPRI.EQ.1) WRITE(LUNOUT,993)ICH1
2477 *or 993              FORMAT (' PARJET 42147',5I5)
2478                   CALL PARJET(IHAD,ICH1)
2479 42157          CONTINUE
2480 C     CALL DECAY(IHAD,2)
2481                GO TO 44
2482 4217        CONTINUE
2483 C*** IFA - IFB AQ - Q EXISTIERT NICHT
2484                IF (NNCH2) 42217,42227,42237
2485 42217          CONTINUE
2486                   ICH1 = IB8
2487                   GO TO 42247
2488 42237          CONTINUE
2489                   ICH1 = IBIO
2490                   GO TO 42247
2491 42227          CONTINUE
2492                   IAIFF = IABS(IFF) + 6
2493                   IAIFB1= IABS(IFB1) + 6
2494                   IAIFB2= IABS(IFB2) + 6
2495 *or                  IF (IPRI.EQ.1) WRITE(LUNOUT,995)IAIFF,IAIFB1,IAIFB2
2496 *or 995              FORMAT (' BAMJEV 42227',5I5)
2497                   CALL BAMJEV(IHAD,IAIFF,IAIFB1,IAIFB2,IFB,AMCH2,4)
2498                   GO TO 42257
2499 42247          CONTINUE
2500 *or                  IF (IPRI.EQ.1) WRITE(LUNOUT,996)ICH1
2501 *or 996              FORMAT ('PARJET 42247',5I5)
2502                   CALL PARJET(IHAD,ICH1)
2503 42257          CONTINUE
2504 C     CALL DECAY(IHAD,2)
2505                GO TO 44
2506   43  CONTINUE
2507 C==================================================================
2508 C*** FORWARD CHAIN OF NUCLEON NUCLEON
2509 C===================================================================
2510          IF (NNCH1) 431,432,433
2511  431     CONTINUE
2512             ICH1 = IF8
2513             GO TO 434
2514  433     CONTINUE
2515             ICH1 = IF10
2516             GO TO 434
2517  432     CONTINUE
2518             CALL BAMJEV(IHAD,IFB,IFF1,IFF2,IFB,AMCH1,4)
2519             GO TO 435
2520  434     CONTINUE
2521             CALL PARJET(IHAD,ICH1)
2522  435     CONTINUE
2523 C     CALL DECAY(IHAD,2)
2524   44  CONTINUE
2525 C*** TURN CHAINS AROUND IF NECESSARY
2526       IF (IBPROJ) 51,52,53
2527   51  CONTINUE
2528          GO TO 55
2529   52  CONTINUE
2530 C*** MESON NUCLEON
2531          GO TO (521,522),ISAM3
2532  521     CONTINUE
2533             GO TO 54
2534  522     CONTINUE
2535 C*** TURN JET
2536             GO TO 55
2537   53  CONTINUE
2538 C*** NUCLEON-NUCLEON
2539 C*** TURN JET
2540          GO TO 55
2541   55  CONTINUE
2542 C*** TURN JET AROUND
2543          DO 56 I=1,IHAD
2544             PZF(I) = -PZF(I)
2545   56     CONTINUE
2546   54  CONTINUE
2547       IIIHAD = IHAD
2548 C*** AND  INT. CHAIN TRANSVERSE MOMENTA
2549       B3SAVE = B3BAMJ
2550 * This is consistent with b3bamj = 10 for an initial value of 6
2551       B3BAMJ = 1.666666666666667D+00 * B3BAMJ
2552 *     B3BAMJ = 5.D+00 / ( LOG10 ( 1.D+00 + ( UMO / E00 )**1.5D+00 )
2553 *    &       + 1.D+00 )
2554       CALL GRNDM(RNDM,2)
2555       ES  = -2.D0/(B3BAMJ**2)*LOG(RNDM(1)*RNDM(2))
2556       B3BAMJ = B3SAVE
2557 *     HPS = SQRT(ES*ES+2.D0*ES*AMCH1)
2558       HPS = SQRT(ES*ES+2.D0*ES*AM(1))
2559       CALL SFECFE(SFE,CFE)
2560 *
2561 *  tentative guess
2562 *
2563       PTXCH1 = HPS * CFE
2564       PTYCH1 = HPS * SFE
2565 *  +-------------------------------------------------------------------*
2566 *  |                  Loop to establish the transverse momentum
2567       GO TO 6171
2568 6170  CONTINUE
2569          PTXCH1 = 0.75D0 * PTXCH1
2570          PTYCH1 = 0.75D0 * PTYCH1
2571 6171     CONTINUE
2572          IHAD = IIIHAD
2573 *  |         The following two cards provide momentum conservation for
2574 *  |         x and y components
2575          PTXCH2 = -PTXCH1
2576          PTYCH2 = -PTYCH1
2577          BGCH1X = PTXCH1/AMCH1
2578          BGCH1Y = PTYCH1/AMCH1
2579          ACH1 = BGCH1**2-(PTXCH1**2+PTYCH1**2)/AMCH1**2
2580          IF (ACH1.LE.0.D0) GO TO 6170
2581 *  |
2582 *  +--<--<--<--<--< if Pt is too large loop again on the forward jet
2583          BGCH2X = PTXCH2/AMCH2
2584          BGCH2Y = PTYCH2/AMCH2
2585          ACH2   = BGCH2**2-(PTXCH2**2+PTYCH2**2)/AMCH2**2
2586       IF (ACH2.LE.0.D0) GO TO 6170
2587 *  |
2588 *  +--<--<--<--<--<--<--<--<--<--< if Pt is too large loop again
2589       BGCH1Z = SQRT(ACH1)
2590       BGCH1Z = SIGN(BGCH1Z,BGCH1)
2591       BGCH2Z = SQRT(ACH2)
2592       BGCH2Z = SIGN(BGCH2Z,BGCH2)
2593
2594       CALL LORTRA(IHAD,1,GAMCH1,BGCH1X,BGCH1Y,BGCH1Z)
2595 C==============================================================
2596 C
2597 C*** TRANSFORM FORWARD JET INTO CMS
2598 C
2599 C================================================================
2600       IHAD = IIIHAD
2601       NAUX = IHAD
2602 C===============================================================
2603 C
2604 C*** SAMPLING OF BACKWARD CHAIN
2605 C
2606 C===============================================================
2607       IF (IBPROJ) 61,62,63
2608   61  CONTINUE
2609 C================================================================
2610 C      BACKWARD CHAIN OF ANTINUCLEON NUCLEON
2611 C=================================================================
2612          IF (NNCH2) 6111,6112,6113
2613 6111     CONTINUE
2614             ICH2 = IBPS
2615             GO TO 6114
2616 6113     CONTINUE
2617             ICH2 = IBV
2618             GO TO 6114
2619 6112     CONTINUE
2620             IAIBF = IABS(IBF) + 6
2621             CALL BAMJEV(IHAD,IBB,IAIBF,IBB,IBB,AMCH2,3)
2622             GO TO 6115
2623 6114     CONTINUE
2624             CALL PARJET(IHAD,ICH2)
2625 6115     CONTINUE
2626 C
2627 C
2628 C     CALL DECAY(IHAD,2)
2629          GO TO 64
2630   62  CONTINUE
2631 C================================================================
2632 C*** BACKWARD CHAIN OF MESON - BARYON
2633 C==================================================================
2634          IF (IBTARG) 627,628,629
2635  629     CONTINUE
2636             GO TO (621,622),ISAM3
2637  621        CONTINUE
2638                IF (NNCH2) 6211,6212,6213
2639 6211           CONTINUE
2640                  ICH2 = IBPS
2641                  GO TO 6214
2642 6213          CONTINUE
2643                  ICH2 = IBV
2644                  GO TO 6214
2645 6212          CONTINUE
2646                  IAIBF = IABS(IBF) + 6
2647                  CALL BAMJEV(IHAD,IBB,IAIBF,IBB,IBB,AMCH2,3)
2648                  GO TO 6215
2649 6214          CONTINUE
2650                  CALL PARJET(IHAD,ICH2)
2651 6215          CONTINUE
2652 C     CALL DECAY(IHAD,2)
2653               GO TO 64
2654 622        CONTINUE
2655               IF (NNCH2) 6221,6222,6223
2656 6221          CONTINUE
2657                  ICH2 = IB8
2658                  GO TO 6224
2659 6223          CONTINUE
2660                  ICH2 = IBIO
2661                  GO TO 6224
2662 6222          CONTINUE
2663                  CALL BAMJEV(IHAD,IBF,IBB1,IBB2,IBF,AMCH2,4)
2664                  GO TO 6225
2665 6224          CONTINUE
2666                  CALL PARJET(IHAD,ICH2)
2667 6225             CONTINUE
2668 C     CALL DECAY(IHAD,2)
2669                  GO TO 64
2670 C==================================================================
2671 C
2672 C     BACKWARD CHAIN OF MESON MESON
2673 C
2674 C===================================================================
2675 C        TO BE CORRECTED
2676 C===================================================================
2677  628    CONTINUE
2678            GO TO(6218,6228),ISAM3
2679 6218       CONTINUE
2680               IF (NNCH2) 62118,62128,62138
2681 62118         CONTINUE
2682                  ICH2 = IBPS
2683                  GO TO 62148
2684 62138         CONTINUE
2685                  ICH2 = IBV
2686                  GO TO 62148
2687 62128         CONTINUE
2688                  IAIBF = IABS(IBF) + 6
2689                  CALL BAMJEV(IHAD,IBB,IAIBF,IBB,IBB,AMCH2,3)
2690                  GO TO 62158
2691 62148         CONTINUE
2692                  CALL PARJET(IHAD,ICH2)
2693 62158         CONTINUE
2694 C     CALL DECAY(IHAD,2)
2695               GO TO 64
2696 6228       CONTINUE
2697               IF (NNCH2) 62218,62228,62238
2698 62218         CONTINUE
2699                  ICH2 = IBPS
2700                  GO TO 62248
2701 62238         CONTINUE
2702                  ICH2 = IBV
2703                  GO TO 62248
2704 62228         CONTINUE
2705                  IAIBB = IABS(IBB) + 6
2706                  CALL BAMJEV(IHAD,IBF,IAIBB,IBB2,IBF,AMCH2,3)
2707                  GO TO 62258
2708 62248         CONTINUE
2709                  CALL PARJET(IHAD,ICH2)
2710 62258 CONTINUE
2711 C     CALL DECAY(IHAD,2)
2712               GO TO 64
2713 C================================================================
2714 C
2715 C       BACKWARD CHAIN OF MESON ANTIBARYON
2716 C=================================================================
2717 C     TO BE CORRECTED
2718 C=================================================================
2719  627     CONTINUE
2720             GO TO(6217,6227),ISAM3
2721 6227        CONTINUE
2722                IF (NNCH2) 62117,62127,62137
2723 62117          CONTINUE
2724                  ICH2 = IBPS
2725                  GO TO 62147
2726 62137         CONTINUE
2727                  ICH2 = IBV
2728                  GO TO 62147
2729 62127         CONTINUE
2730                  IAIFB = IABS(IFB) + 6
2731 *or                 IF (IPRI.EQ.1) WRITE(LUNOUT,997)IFF,IAIFB
2732 *or 997             FORMAT (' BAMJEV 62127',5I5)
2733                  CALL BAMJEV(IHAD,IFF,IAIFB,IBB,IBB,AMCH2,3)
2734                  GO TO 62157
2735 62147         CONTINUE
2736 *or                 IF (IPRI.EQ.1) WRITE(LUNOUT,998)ICH2
2737 *or 998             FORMAT ('PARJET 62147',5I5)
2738                  CALL PARJET(IHAD,ICH2)
2739 62157         CONTINUE
2740 C     CALL DECAY(IHAD,2)
2741               GO TO 64
2742 6217       CONTINUE
2743               IF (NNCH1) 62217,62227,62237
2744 62217         CONTINUE
2745                  ICH2 = IFPS
2746                  GO TO 62247
2747 62237         CONTINUE
2748                  ICH2 = IFV
2749                  GO TO 62247
2750 62227         CONTINUE
2751                  IAIBB = IABS(IBB) + 6
2752 *or                 IF (IPR1.EQ.1) WRITE(LUNOUT,9911)IBF,IAIBB
2753 *or9911             FORMAT (' BAMJEV 62227',5I5)
2754                  CALL BAMJEV(IHAD,IBF,IAIBB,IAIFB2,IBF,AMCH1,3)
2755                  GO TO 62257
2756 62247         CONTINUE
2757 *or                 IF (IPRI .EQ. 1) WRITE(LUNOUT,9912)ICH2
2758 *or9912             FORMAT ('PARJET 62247',5I5)
2759                  CALL PARJET(IHAD,ICH2)
2760 62257         CONTINUE
2761 C     CALL DECAY(IHAD,2)
2762               GO TO 64
2763 63    CONTINUE
2764 C==================================================================
2765 C*** BACKWARD CHAIN OF BARYON BARYON
2766 C==================================================================
2767          IF (NNCH2) 631,632,633
2768 631      CONTINUE
2769             ICH2 = IB8
2770             GO TO 634
2771 633      CONTINUE
2772             ICH2 = IBIO
2773             GO TO 634
2774 632      CONTINUE
2775             CALL BAMJEV(IHAD,IBF,IBB1,IBB2,IBF,AMCH2,4)
2776             GO TO 635
2777  634     CONTINUE
2778             CALL PARJET(IHAD,ICH2)
2779  635     CONTINUE
2780 C     CALL DECAY(IHAD,2)
2781 *
2782 *  We arrive here after jet creation: created particles are in
2783 *  /finpar/ common (there are ihad particles)
2784 *
2785   64  CONTINUE
2786 C*** TURN CHAIN AROUND IF NECESSARY
2787       IF (IBPROJ) 71,72,73
2788   71  CONTINUE
2789          GO TO 75
2790   72  CONTINUE
2791          GO TO (721,722),ISAM3
2792  721     CONTINUE
2793 C*** TURN JET
2794             GO TO 75
2795  722     CONTINUE
2796             GO TO 74
2797   73  CONTINUE
2798 C*** KEEP JET
2799          GO TO 74
2800   75  CONTINUE
2801 C*** TURN JET AROUND
2802          DO 76 I=1,IHAD
2803             PZF(I) = -PZF(I)
2804   76     CONTINUE
2805   74  CONTINUE
2806 C================================================================
2807 C
2808 C*** TRANSFORM BACKWARD JET INTO CMS
2809 C
2810 C=================================================================
2811       NAUX   = NAUX+1
2812
2813
2814       CALL LORTRA(IHAD,NAUX,GAMCH2,BGCH2X,BGCH2Y,BGCH2Z)
2815       NAUX = IHAD + NAUX - 1
2816       DO 181 I=1,NAUX
2817          PXR(I)  = PXA(I)
2818          PYR(I)  = PYA(I)
2819          PZR(I)  = PZA(I)
2820          AMR(I)  = AMA(I)
2821          ICHR(I) = ICHA(I)
2822          ANR(I)  = ANA(I)
2823          IBARR(I)= IBARA(I)
2824          NRER(I) = NREA(I)
2825          HER(I)  = HEPA(I)
2826  181  CONTINUE
2827
2828       NRES=NAUX
2829       CALL DECAUX(NAUX,3)
2830
2831
2832 *or      IF (IPRI.EQ.1) WRITE(LUNOUT,85)(I,NREA(I),ICHA(I),IBARA(I),
2833 *or     &ANA(I)PXA(I),PYA(I),PZA(I),HEPA(I),AMA(I),I=1,NAUX)
2834
2835       EVZ = 0.D0
2836       PVX = 0.D0
2837       PVY = 0.D0
2838       PVZ = 0.D0
2839       ICCU = 0
2840       IBBU = 0
2841       ISSU = 0
2842       LISSU = .TRUE.
2843
2844 C*** TRANSFORM INTO LABSYSTEM
2845 *  +-------------------------------------------------------------------*
2846 *  |   particles from /auxpar/ common  are transformed back in the lab
2847 *  |   system (which is actually the system of the target nucleon with
2848 *  |   the projectile along the z-axis)
2849 *  |   and put in /hadpar/ common
2850 *  |
2851 *  | The transformation is:
2852 *  |     Elab  =  Ecms * gamma + ETAzlab * Pzcms
2853 *  |     Pzlab = Pzcms * gamma + ETAzlab * Ecms
2854 *  |                note ETAzlab = -ETAzcms!!!!
2855 *  |
2856       DO 81 I=1,NAUX
2857          HEPH(I) = GAMCM*HEPA(I) + BGCM*PZA(I)
2858          PZH(I)  = GAMCM*PZA(I)  + BGCM*HEPA(I)
2859          PXH(I)  = PXA(I)
2860          PYH(I)  = PYA(I)
2861          AMH(I)  = AMA(I)
2862          ICHH(I) = ICHA(I)
2863          ANH(I)  = ANA(I)
2864          IBARH(I)= IBARA(I)
2865          NREH(I) = NREA(I)
2866          EVZ = EVZ + HEPH(I)
2867          PVX = PVX + PXH(I)
2868          PVY = PVY + PYH(I)
2869          PVZ = PVZ + PZH(I)
2870          ICCU = ICCU + ICHH(I)
2871          IBBU = IBBU + IBARH(I)
2872          IJNREH = KPTOIP ( NREH (I) )
2873          IF (IJNREH .LE. 0 .OR. IJNREH .GT. 39) THEN
2874             WRITE (LUNOUT,*)' Hadevt: Ijnreh = 0, > 39 after decay!!',
2875      &      IJNREH,NREH(I),I,HEPH(I)
2876             WRITE (LUNERR,*)' Hadevt: Ijnreh = 0, > 39 after decay!!',
2877      &      IJNREH,NREH(I),I,HEPH(I)
2878             LISSU = .FALSE.
2879          ELSE
2880             DO 8011 J=1,3
2881                ISSU = ISSU + IQSCHR (MQUARK(J,IJNREH))
2882 8011        CONTINUE
2883          END IF
2884   81  CONTINUE
2885 *  |
2886 *  +-------------------------------------------------------------------*
2887
2888       NHAD = NAUX
2889       ICHTOT = ICH(KPROJ) + ICH(KTARG)
2890       IBTOT  = IBPROJ + IBTARG
2891       ISTOT  = 0
2892       DO 8111 J=1,3
2893          ISTOT = ISTOT + IQSCHR(MQUARK(J,IJPROJ))
2894      &         + IQSCHR(MQUARK(J,IJTARG))
2895 8111  CONTINUE
2896 *  +-------------------------------------------------------------------*
2897 *  |
2898       IF (ICCU .NE. ICHTOT) THEN
2899 *  | write an error message and then resample!!!
2900          WRITE(LUNOUT,*)' Hadevt: charge conservation failure: ',
2901      &                  ' ICCU,ICHTOT,IBBU,IBTOT,ISSU,ISTOT',
2902      &                  ICCU,ICHTOT,IBBU,IBTOT,ISSU,ISTOT
2903          WRITE(LUNERR,*)' Hadevt: charge conservation failure: ',
2904      &                  ' ICCU,ICHTOT,IBBU,IBTOT,ISSU,ISTOT',
2905      &                  ICCU,ICHTOT,IBBU,IBTOT,ISSU,ISTOT
2906          LRESMP = .TRUE.
2907       ELSE IF (IBBU .NE. IBTOT) THEN
2908 *  | write an error message and then resample!!!
2909          WRITE(LUNOUT,*)' Hadevt: baryon conservation failure: ',
2910      &                  ' ICCU,ICHTOT,IBBU,IBTOT,ISSU,ISTOT',
2911      &                  ICCU,ICHTOT,IBBU,IBTOT,ISSU,ISTOT
2912          WRITE(LUNERR,*)' Hadevt: baryon conservation failure: ',
2913      &                  ' ICCU,ICHTOT,IBBU,IBTOT,ISSU,ISTOT',
2914      &                  ICCU,ICHTOT,IBBU,IBTOT,ISSU,ISTOT
2915          LRESMP = .TRUE.
2916       ELSE IF (ISSU .NE. ISTOT .AND. LISSU) THEN
2917 *  | write an error message and then resample!!!
2918          WRITE(LUNOUT,*)' Hadevt: strangeness conservation failure: ',
2919      &                  ' ICCU,ICHTOT,IBBU,IBTOT,ISSU,ISTOT',
2920      &                  ICCU,ICHTOT,IBBU,IBTOT,ISSU,ISTOT
2921          WRITE(LUNERR,*)' Hadevt: strangeness conservation failure: ',
2922      &                  ' ICCU,ICHTOT,IBBU,IBTOT,ISSU,ISTOT',
2923      &                  ICCU,ICHTOT,IBBU,IBTOT,ISSU,ISTOT
2924          LRESMP = .TRUE.
2925       ELSE
2926       END IF
2927 *  |
2928 *  +-------------------------------------------------------------------*
2929       EPSEPS = MAX ( 10.D+00*ANGLGB, 1.D-12 )
2930 *  +-------------------------------------------------------------------*
2931 *  |
2932       IF (ABS(EVZ-AMTAR-EPROJ)/(AMTAR+EPROJ) .GT. EPSEPS) THEN
2933       ELSE IF (ABS(PVX)/PPROJ .GT. EPSEPS) THEN
2934       ELSE IF (ABS(PVY)/PPROJ .GT. EPSEPS) THEN
2935       ELSE IF (ABS(PVZ-PPROJ)/PPROJ .GT. EPSEPS) THEN
2936       ELSE
2937          GO TO 90
2938       END IF
2939 *  |
2940 *  +-------------------------------------------------------------------*
2941
2942 C
2943 C********************************************************************
2944 C
2945 C*** PRINT AND TEST ENERGY CONSERVATION
2946 C
2947 C********************************************************************
2948 C
2949 *or      PVZ = 0.D0
2950 *or      EVZ = 0.D0
2951 *or      PVX = 0.D0
2952 *or      PVY = 0.D0
2953 *or      ICCU = 0
2954 *or      IBBU = 0
2955 *or      DO 82 I=1,NHAD
2956 *or         PVX = PVX + PXH(I)
2957 *or         PVY = PVY + PYH(I)
2958 *or         PVZ = PVZ + PZH(I)
2959 *or         EVZ = EVZ + HEPH(I)
2960 *or         ICCU = ICCU + ICHH(I)
2961 *or         IBBU = IBBU + IBARH(I)
2962 *or  82  CONTINUE
2963 *or      IF (IBTOT  .NE. IBBU) GO TO 9999
2964 *or      IF (ICHTOT .NE. ICCU) GO TO 9999
2965 *or      IF (ABS(PVX).GE.0.01D0) GO TO 9999
2966 *or      IF (ABS(PVY).GE.0.01D0) GO TO 9999
2967 *or      IF ((PVZ.GT.1.02D0*PPROJ).OR.(PVZ.LT.0.98D0*PPROJ)) GO TO 9999
2968 *or      IF (IPRI.NE.1) GO TO 90
2969 9999  CONTINUE
2970 *
2971 *  If a failure occured the event is resampled!!!
2972 *
2973       GO TO 8899
2974 *or      IF (IPRI.EQ.0) GO TO 8899
2975 *or      WRITE(LUNOUT,83)NHAD,KPROJ,KTARG,PPROJ,EPROJ,PVX,PVY,PVZ,EVZ,
2976 *or     &ICCU,IBBU,NHAD
2977 *or  83  FORMAT (3I5,6F12.6,3I5)
2978 *or      DO 84 I=1,NHAD
2979 *or         WRITE(LUNOUT,85)I,NREH(I),ICHH(I),IBARH(I),ANH(I),PXH(I),
2980 *or     &   PYH(I),PZH(I),HEPH(I),AMH(I)
2981 *or  85     FORMAT (4I5,A8,5F12.6)
2982 *or  84  CONTINUE
2983 *
2984 *  If a failure occured the event is resampled!!!
2985 *
2986 *or      IF (IPRI.EQ.0)GO TO 8899
2987
2988   90  CONTINUE
2989       RETURN
2990       END