HERWIG/src/hwheww.f

   1
   2 CDECK  ID>, HWHEWW.
   3
   4 *CMZ :-        -02/05/91  10.58.29  by  Federico Carminati
   5
   6 *-- Author :    Zoltan Kunszt, modified by Bryan Webber
   7
   8 C-----------------------------------------------------------------------
   9
  10       SUBROUTINE HWHEWW
  11
  12 C-----------------------------------------------------------------------
  13
  14 C     E+E- -> W+W-/Z0Z0 (BASED ON ZOLTAN KUNSZT'S PROGRAM)
  15
  16 C-----------------------------------------------------------------------
  17
  18       INCLUDE 'HERWIG61.INC'
  19
  20       COMPLEX ZH,ZCH,ZD
  21
  22       DOUBLE PRECISION HWUAEM,HWR,HWUPCM,ETOT,STOT,FLUXW,GAMM,GIMM,
  23
  24      & WM2,WXMIN,WX1MAX,WX2MAX,FJAC1,FJAC2,WX1,WX2,WMM1,WMM2,XXM,W2BO,
  25
  26      & PST,WEIGHT,TOTSIG,WMASS,WWIDTH,ELST,CV,CA,BR,XMASS,PLAB,PRW,PCM,
  27
  28      & AMPWW(4),CCC,HELSUM,HELCTY,BRZED(12),BRTOT,CPFAC,CPALL,RLL(12),
  29
  30      & RRL(12),DIST(4)
  31
  32       INTEGER IB,IBOS,I,ID1,ID2,NTRY,IDP(10),IDBOS(2),J1,J2,IPRC,ILST,
  33
  34      & IDZOLT(16),MAP(12),NEWHEP
  35
  36       LOGICAL EISBM1,HWRLOG
  37
  38       EXTERNAL HWUAEM,HWR,HWUPCM
  39
  40       SAVE IDP,STOT,FLUXW,GAMM,GIMM,WM2,WXMIN,WX1MAX,FJAC1,ELST,ILST,
  41
  42      & IDBOS,WMASS,WWIDTH
  43
  44       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
  45
  46       COMMON/HWHEWQ/ZH(7,7),ZCH(7,7),ZD(7,7)
  47
  48       COMMON/HWHEWR/CPFAC(12,12,8),CPALL(8)
  49
  50       DATA ELST,ILST/0.,0/
  51
  52       DATA IDZOLT/4,3,8,7,12,11,4*0,2,1,6,5,10,9/
  53
  54       DATA MAP/12,11,2,1,14,13,4,3,16,15,6,5/
  55
  56       IF (IERROR.NE.0) RETURN
  57
  58       EISBM1=IDHW(1).LT.IDHW(2)
  59
  60       IF (GENEV) THEN
  61
  62         NEWHEP=NHEP
  63
  64         NHEP=NHEP+2
  65
  66         DO 20 IB=1,2
  67
  68         IBOS=IB+NEWHEP
  69
  70         CALL HWVEQU(5,PRW(1,IB),PHEP(1,IBOS))
  71
  72         IF (EISBM1) PHEP(3,IBOS)=-PHEP(3,IBOS)
  73
  74         CALL HWVZRO(4,VHEP(1,IBOS))
  75
  76         CALL HWUDKL(IDBOS(IB),PHEP(1,IBOS),DIST)
  77
  78         CALL HWVSUM(4,VHEP(1,IBOS),DIST,DIST)
  79
  80         IDHW(IBOS)=IDBOS(IB)
  81
  82         IDHEP(IBOS)=IDPDG(IDBOS(IB))
  83
  84         JMOHEP(1,IBOS)=1
  85
  86         JMOHEP(2,IBOS)=2
  87
  88         ISTHEP(IBOS)=110
  89
  90         DO 10 I=1,2
  91
  92           CALL HWVEQU(5,PLAB(1,2*IB+I),PHEP(1,NHEP+I))
  93
  94           IF (EISBM1) PHEP(3,NHEP+I)=-PHEP(3,NHEP+I)
  95
  96           CALL HWVEQU(4,DIST,VHEP(1,NHEP+I))
  97
  98 C---STATUS, IDs AND POINTERS
  99
 100           ISTHEP(NHEP+I)=112+I
 101
 102           IDHW(NHEP+I)=IDP(2*IB+I)
 103
 104           IDHEP(NHEP+I)=IDPDG(IDP(2*IB+I))
 105
 106           JDAHEP(I,IBOS)=NHEP+I
 107
 108           JMOHEP(1,NHEP+I)=IBOS
 109
 110           JMOHEP(2,NHEP+I)=JMOHEP(1,IBOS)
 111
 112  10     CONTINUE
 113
 114         NHEP=NHEP+2
 115
 116         JMOHEP(2,NHEP)=NHEP-1
 117
 118         JDAHEP(2,NHEP)=NHEP-1
 119
 120         JMOHEP(2,NHEP-1)=NHEP
 121
 122         JDAHEP(2,NHEP-1)=NHEP
 123
 124  20     CONTINUE
 125
 126       ELSE
 127
 128         EMSCA=PHEP(5,3)
 129
 130         ETOT=EMSCA
 131
 132         IPRC=MOD(IPROC,100)
 133
 134         IF (ETOT.NE.ELST .OR. IPRC.NE.ILST) THEN
 135
 136           STOT=ETOT*ETOT
 137
 138           FLUXW=GEV2NB*.125*(HWUAEM(STOT)/PIFAC)**4/STOT
 139
 140           IF (IPRC.EQ.0) THEN
 141
 142             WMASS=RMASS(198)
 143
 144             WWIDTH=GAMW
 145
 146             IDBOS(1)=198
 147
 148             IDBOS(2)=199
 149
 150           ELSEIF (IPRC.EQ.50) THEN
 151
 152             WMASS=RMASS(200)
 153
 154             WWIDTH=GAMZ
 155
 156             IDBOS(1)=200
 157
 158             IDBOS(2)=200
 159
 160 C---LOAD FERMION COUPLINGS TO Z
 161
 162             DO 30 I=1,12
 163
 164               RLL(I)=VFCH(MAP(I),1)+AFCH(MAP(I),1)
 165
 166               RRL(I)=VFCH(MAP(I),1)-AFCH(MAP(I),1)
 167
 168  30         CONTINUE
 169
 170             RLL(11)=0
 171
 172             RRL(11)=0
 173
 174             BRTOT=0
 175
 176             DO 60 J1=1,12
 177
 178               BRZED(J1)=0
 179
 180               DO 50 J2=1,12
 181
 182                 CCC=1
 183
 184                 IF (MOD(J1-1,4).GE.2) CCC=CCC*CAFAC
 185
 186                 IF (MOD(J2-1,4).GE.2) CCC=CCC*CAFAC
 187
 188                 CPFAC(J1,J2,1)=CCC*(RLL(2)**2*RLL(J1)*RLL(J2))**2
 189
 190                 CPFAC(J1,J2,2)=CCC*(RLL(2)**2*RRL(J1)*RLL(J2))**2
 191
 192                 CPFAC(J1,J2,3)=CCC*(RLL(2)**2*RLL(J1)*RRL(J2))**2
 193
 194                 CPFAC(J1,J2,4)=CCC*(RLL(2)**2*RRL(J1)*RRL(J2))**2
 195
 196                 CPFAC(J1,J2,5)=CCC*(RRL(2)**2*RLL(J1)*RLL(J2))**2
 197
 198                 CPFAC(J1,J2,6)=CCC*(RRL(2)**2*RRL(J1)*RLL(J2))**2
 199
 200                 CPFAC(J1,J2,7)=CCC*(RRL(2)**2*RLL(J1)*RRL(J2))**2
 201
 202                 CPFAC(J1,J2,8)=CCC*(RRL(2)**2*RRL(J1)*RRL(J2))**2
 203
 204                 DO 40 I=1,8
 205
 206                   IF (J1.EQ.1.AND.J2.EQ.1) CPALL(I)=0
 207
 208                   CPALL(I)=CPALL(I)+CPFAC(J1,J2,I)
 209
 210                   BRZED(J1)=BRZED(J1)+CPFAC(J1,J2,I)
 211
 212                   BRTOT=BRTOT+CPFAC(J1,J2,I)
 213
 214  40             CONTINUE
 215
 216  50           CONTINUE
 217
 218  60         CONTINUE
 219
 220             DO 70 I=1,12
 221
 222  70           BRZED(I)=BRZED(I)/BRTOT
 223
 224           ELSE
 225
 226             CALL HWWARN('HWHEWW',500,*999)
 227
 228           ENDIF
 229
 230           GAMM=WMASS*WWIDTH
 231
 232           GIMM=1.D0/GAMM
 233
 234           WM2=WMASS*WMASS
 235
 236           WXMIN=ATAN(-WMASS/WWIDTH)
 237
 238           WX1MAX=ATAN((STOT-WM2)*GIMM)
 239
 240           FJAC1=WX1MAX-WXMIN
 241
 242           ILST=IPRC
 243
 244           ELST=ETOT
 245
 246         ENDIF
 247
 248         EVWGT=0
 249
 250 C---CHOOSE W MASSES
 251
 252         WX1=WXMIN+FJAC1*HWR()
 253
 254         WMM1=GAMM*TAN(WX1)+WM2
 255
 256         XMASS(1)=SQRT(WMM1)
 257
 258         WX2MAX=ATAN(((ETOT-XMASS(1))**2-WM2)*GIMM)
 259
 260         FJAC2=WX2MAX-WXMIN
 261
 262         WX2=WXMIN+FJAC2*HWR()
 263
 264         WMM2=GAMM*TAN(WX2)+WM2
 265
 266         XMASS(2)=SQRT(WMM2)
 267
 268         IF (HWRLOG(HALF))THEN
 269
 270          XXM=XMASS(1)
 271
 272          XMASS(1)=XMASS(2)
 273
 274          XMASS(2)=XXM
 275
 276         ENDIF
 277
 278 C---CTMAX=ANGULAR CUT ON COS W-ANGLE
 279
 280         CALL HWHEW0(1,ETOT,XMASS(1),PRW(1,1),W2BO,CTMAX)
 281
 282         IF (W2BO.EQ.ZERO) RETURN
 283
 284 C---FOR ZZ EVENTS, FORCE BOSE STATISTICS, BY KILLING EVENTS WITH COS1<0
 285
 286         IF (IPRC.NE.0) THEN
 287
 288           IF (PRW(3,1).LT.ZERO) RETURN
 289
 290 C---AND THEN SYMMETRIZE (THIS PROCEDURE VASTLY IMPROVES EFFICIENCY)
 291
 292           IF (HWRLOG(HALF)) THEN
 293
 294             PRW(3,1)=-PRW(3,1)
 295
 296             PRW(3,2)=-PRW(3,2)
 297
 298           ENDIF
 299
 300         ENDIF
 301
 302         PLAB(3,1)=0.5*ETOT
 303
 304         PLAB(4,1)=PLAB(3,1)
 305
 306         PLAB(3,2)=-PLAB(3,1)
 307
 308         PLAB(4,2)=PLAB(3,1)
 309
 310 C
 311
 312 C---LET THE W BOSONS DECAY
 313
 314         NTRY=0
 315
 316  80     NTRY=NTRY+1
 317
 318         DO 90 IB=1,2
 319
 320         CALL HWDBOZ(IDBOS(IB),ID1,ID2,CV,CA,BR,1)
 321
 322         PST=HWUPCM(XMASS(IB),RMASS(ID1),RMASS(ID2))
 323
 324         IF (PST.LT.ZERO) THEN
 325
 326           CALL HWDBOZ(IDBOS(IB),ID1,ID2,CV,CA,BR,2)
 327
 328           IF (NTRY.LE.NBTRY) GOTO 80
 329
 330 C          CALL HWWARN('HWHEWW',1,*999)
 331
 332           RETURN
 333
 334         ENDIF
 335
 336         PRW(5,IB)=XMASS(IB)
 337
 338         IDP(2*IB+1)=ID1
 339
 340         IDP(2*IB+2)=ID2
 341
 342         PLAB(5,2*IB+1)=RMASS(ID1)
 343
 344         PLAB(5,2*IB+2)=RMASS(ID2)
 345
 346         CALL HWDTWO(PRW(1,IB),PLAB(1,2*IB+1),PLAB(1,2*IB+2),
 347
 348      &              PST,TWO,.TRUE.)
 349
 350  90     CONTINUE
 351
 352         WEIGHT=FLUXW*W2BO*FJAC1*FJAC2*(0.5D0*PIFAC*GIMM)**2
 353
 354         CALL HWHEW1(6)
 355
 356         CALL HWHEW2(6,PCM(1,1),ZH,ZCH,ZD)
 357
 358         IF (IPRC.EQ.0) THEN
 359
 360           CALL HWHEW3(5,6,3,4,1,2,AMPWW)
 361
 362           TOTSIG=9.*AMPWW(1)+6.*(AMPWW(2)+AMPWW(3))+4.*AMPWW(4)
 363
 364           EVWGT=TOTSIG*WEIGHT*BR
 365
 366         ELSE
 367
 368           ID1=IDZOLT(IDPDG(IDP(3)))
 369
 370           ID2=IDZOLT(IDPDG(IDP(5)))
 371
 372           CALL HWHEW5(5,6,3,4,1,2,HELSUM,HELCTY,ID1,ID2)
 373
 374           EVWGT=HELCTY*WEIGHT*BR/(BRZED(ID1)*BRZED(ID2))
 375
 376         ENDIF
 377
 378       ENDIF
 379
 380  999  END
 381
 382 CDECK  ID>, HWHHVY.
 383
 384 *CMZ :-        -18/05/99  14.55.44  by  Kosuke Odagiri
 385
 386 *-- Author :    Bryan Webber
 387
 388 C-----------------------------------------------------------------------
 389
 390       SUBROUTINE HWHHVY
 391
 392 C-----------------------------------------------------------------------
 393
 394 C     QCD HEAVY FLAVOUR PRODUCTION: MEAN EVWGT = SIGMA IN NB
 395
 396 C-----------------------------------------------------------------------
 397
 398       INCLUDE 'HERWIG61.INC'
 399
 400       DOUBLE PRECISION HWR,HWRUNI,HWUALF,EPS,RCS,Z1,Z2,ET,EJ,
 401
 402      & QM2,QPE,FACTR,S,T,U,ST,TU,US,TUS,UST,EN,RN,AF,ASTU,
 403
 404      & AUST,CF,CN,CS,CSTU,CSUT,CTSU,CTUS,HCS,UT,SU,GT,DIST,KK,KK2,
 405
 406      & YJ1INF,YJ1SUP,YJ2INF,YJ2SUP
 407
 408       INTEGER IQ1,IQ2,ID1,ID2
 409
 410       LOGICAL HQ1,HQ2
 411
 412       EXTERNAL HWR,HWRUNI,HWUALF
 413
 414       SAVE HCS,ASTU,AUST,CSTU,CSUT,CTSU,CTUS,S,T,TU,U,US
 415
 416       PARAMETER (EPS=1.D-9)
 417
 418       IF (GENEV) THEN
 419
 420         RCS=HCS*HWR()
 421
 422       ELSE
 423
 424         EVWGT=0.
 425
 426         CALL HWRPOW(ET,EJ)
 427
 428         KK = ET/PHEP(5,3)
 429
 430         KK2=KK**2
 431
 432         IF (KK.GE.ONE) RETURN
 433
 434         YJ1INF = MAX( YJMIN, LOG((ONE-SQRT(ONE-KK2))/KK) )
 435
 436         YJ1SUP = MIN( YJMAX, LOG((ONE+SQRT(ONE-KK2))/KK) )
 437
 438         IF (YJ1INF.GE.YJ1SUP) RETURN
 439
 440         Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
 441
 442         YJ2INF = MAX( YJMIN, -LOG(TWO/KK-ONE/Z1) )
 443
 444         YJ2SUP = MIN( YJMAX, LOG(TWO/KK-Z1) )
 445
 446         IF (YJ2INF.GE.YJ2SUP) RETURN
 447
 448         Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
 449
 450         XX(1)=HALF*(Z1+Z2)*KK
 451
 452         IF (XX(1).GE.ONE) RETURN
 453
 454         XX(2)=XX(1)/(Z1*Z2)
 455
 456         IF (XX(2).GE.ONE) RETURN
 457
 458         S=XX(1)*XX(2)*PHEP(5,3)**2
 459
 460         IQ1=MOD(IPROC,100)
 461
 462         QM2=RMASS(IQ1)**2
 463
 464         QPE=S-4.*QM2
 465
 466         IF (QPE.LE.ZERO) RETURN
 467
 468         COSTH=HALF*ET*(Z1-Z2)/SQRT(Z1*Z2*QPE)
 469
 470         IF (ABS(COSTH).GT.ONE) RETURN
 471
 472 C---REDEFINE S, T, U AS P1.P2, -P1.P3, -P1.P4
 473
 474         S=HALF*S
 475
 476         T=-HALF*(1.+Z2/Z1)*(HALF*ET)**2
 477
 478         U=-S-T
 479
 480 C---SET EMSCA TO HEAVY HARD PROCESS SCALE
 481
 482         EMSCA=SQRT(4.*S*T*U/(S*S+T*T+U*U))
 483
 484         FACTR = GEV2NB*.125*PIFAC*EJ*ET*(HWUALF(1,EMSCA)/S)**2
 485
 486      &         *(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
 487
 488         CALL HWSGEN(.FALSE.)
 489
 490 C
 491
 492         ST=S/T
 493
 494         TU=T/U
 495
 496         UT=U/T
 497
 498         US=U/S
 499
 500         SU=S/U
 501
 502         TUS=US/ST
 503
 504         UST=ST/TU
 505
 506 C
 507
 508         EN=CAFAC
 509
 510         RN=CFFAC/EN
 511
 512         AF=FACTR*RN
 513
 514         ASTU=AF*(1.-2.*UST+QM2/T)
 515
 516         AUST=AF*(1.-2.*TUS+QM2/S)
 517
 518         CF=FACTR/(2.*CFFAC)
 519
 520         CN=1./(EN*EN)
 521
 522 C-----------------------------------------------------------------------
 523
 524 C---Heavy flavour colour decomposition modifications below (KO)
 525
 526 C-----------------------------------------------------------------------
 527
 528         CS=(TU+UT-CN/TUS)*(HALF-TUS+QM2/S-QM2**2/U/T/TWO)
 529
 530         CSTU=CF*CS/(ONE+TU**2)
 531
 532         CSUT=CF*CS/(ONE+UT**2)
 533
 534         CS=(SU+US-CN/UST)*(HALF-UST+QM2/T-QM2**2/U/S/TWO)
 535
 536         CTSU=-FACTR*CS/(ONE+SU**2)
 537
 538         CTUS=-FACTR*CS/(ONE+US**2)
 539
 540 C-----------------------------------------------------------------------
 541
 542 C       CS=HALF/TU-QM2/T-HALF*(QM2/T)**2
 543
 544 C       CSTU=CF*(CS-   US**2-QM2/S - CN*(CS+QM2*QM2/(S*T)))
 545
 546 C       CS=HALF*TU-QM2/U-HALF*(QM2/U)**2
 547
 548 C       CSUT=CF*(CS-1./ST**2-QM2/S - CN*(CS+QM2*QM2/(S*U)))
 549
 550 C       CS=HALF*US-QM2/S-HALF*(QM2/S)**2
 551
 552 C       CTSU=-FACTR*(CS-1./TU**2-QM2/T - CN*(CS+QM2*QM2/(S*T)))
 553
 554 C       CS=HALF/US-QM2/U-HALF*(QM2/U)**2
 555
 556 C       CTUS=-FACTR*(CS-   ST**2-QM2/T - CN*(CS+QM2*QM2/(T*U)))
 557
 558 C-----------------------------------------------------------------------
 559
 560       ENDIF
 561
 562 C
 563
 564       HCS=0.
 565
 566       IQ2=IQ1+6
 567
 568       DO 6 ID1=1,13
 569
 570       IF (DISF(ID1,1).LT.EPS) GOTO 6
 571
 572       HQ1=ID1.EQ.IQ1.OR.ID1.EQ.IQ2
 573
 574       DO 5 ID2=1,13
 575
 576       IF (DISF(ID2,2).LT.EPS) GOTO 5
 577
 578       HQ2=ID2.EQ.IQ1.OR.ID2.EQ.IQ2
 579
 580       DIST=DISF(ID1,1)*DISF(ID2,2)
 581
 582       IF (HQ1.OR.HQ2) THEN
 583
 584 C---PROCESSES INVOLVING HEAVY CONSTITUENT
 585
 586 C   N.B. NEGLECT CASE THAT BOTH ARE HEAVY
 587
 588       IF (HQ1.AND.HQ2) GOTO 5
 589
 590       IF (ID1.LT.7) THEN
 591
 592 C---QUARK FIRST
 593
 594        IF (ID2.LT.7) THEN
 595
 596          HCS=HCS+ASTU*DIST
 597
 598          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421, 3,*9)
 599
 600        ELSEIF (ID2.NE.13) THEN
 601
 602          HCS=HCS+ASTU*DIST
 603
 604          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142, 9,*9)
 605
 606        ELSE
 607
 608          HCS=HCS+CTSU*DIST
 609
 610          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142,10,*9)
 611
 612          HCS=HCS+CTUS*DIST
 613
 614          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,11,*9)
 615
 616        ENDIF
 617
 618       ELSEIF (ID1.NE.13) THEN
 619
 620 C---QBAR FIRST
 621
 622        IF (ID2.LT.7) THEN
 623
 624          HCS=HCS+ASTU*DIST
 625
 626          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,17,*9)
 627
 628        ELSEIF (ID2.NE.13) THEN
 629
 630          HCS=HCS+ASTU*DIST
 631
 632          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,20,*9)
 633
 634        ELSE
 635
 636          HCS=HCS+CTSU*DIST
 637
 638          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,21,*9)
 639
 640          HCS=HCS+CTUS*DIST
 641
 642          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,22,*9)
 643
 644        ENDIF
 645
 646       ELSE
 647
 648 C---GLUON FIRST
 649
 650        IF (ID2.LT.7) THEN
 651
 652          HCS=HCS+CTSU*DIST
 653
 654          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,23,*9)
 655
 656          HCS=HCS+CTUS*DIST
 657
 658          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,24,*9)
 659
 660        ELSEIF (ID2.LT.13) THEN
 661
 662          HCS=HCS+CTSU*DIST
 663
 664          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142,25,*9)
 665
 666          HCS=HCS+CTUS*DIST
 667
 668          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,26,*9)
 669
 670        ENDIF
 671
 672       ENDIF
 673
 674       ELSEIF (ID2.NE.13.AND.ID2.EQ.ID1+6) THEN
 675
 676 C---LIGHT Q-QBAR ANNIHILATION
 677
 678          HCS=HCS+AUST*DIST
 679
 680          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IQ1,IQ2,2413, 4,*9)
 681
 682       ELSEIF (ID1.NE.13.AND.ID1.EQ.ID2+6) THEN
 683
 684 C---LIGHT QBAR-Q ANNIHILATION
 685
 686          HCS=HCS+AUST*DIST
 687
 688          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IQ2,IQ1,3142,12,*9)
 689
 690       ELSEIF (ID1.EQ.13.AND.ID2.EQ.13) THEN
 691
 692 C---GLUON FUSION
 693
 694          HCS=HCS+CSTU*DIST
 695
 696          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IQ1,IQ2,2413,27,*9)
 697
 698          HCS=HCS+CSUT*DIST
 699
 700          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IQ1,IQ2,4123,28,*9)
 701
 702       ENDIF
 703
 704     5 CONTINUE
 705
 706     6 CONTINUE
 707
 708       EVWGT=HCS
 709
 710       RETURN
 711
 712 C---GENERATE EVENT
 713
 714     9 IDN(1)=ID1
 715
 716       IDN(2)=ID2
 717
 718       IDCMF=15
 719
 720       CALL HWETWO
 721
 722       IF (AZSPIN) THEN
 723
 724 C Calculate coefficients for constructing spin density matrices
 725
 726          IF (IHPRO.EQ.7 .OR.IHPRO.EQ.8 .OR.
 727
 728      &       IHPRO.EQ.15.OR.IHPRO.EQ.16) THEN
 729
 730 C qqbar-->gg or qbarq-->gg
 731
 732             UT=1./TU
 733
 734             GCOEF(1)=UT+TU
 735
 736             GCOEF(2)=-2.
 737
 738             GCOEF(3)=0.
 739
 740             GCOEF(4)=0.
 741
 742             GCOEF(5)=GCOEF(1)
 743
 744             GCOEF(6)=UT-TU
 745
 746             GCOEF(7)=-GCOEF(6)
 747
 748          ELSEIF (IHPRO.EQ.10.OR.IHPRO.EQ.11.OR.
 749
 750      &           IHPRO.EQ.21.OR.IHPRO.EQ.22.OR.
 751
 752      &           IHPRO.EQ.23.OR.IHPRO.EQ.24.OR.
 753
 754      &           IHPRO.EQ.25.OR.IHPRO.EQ.26) THEN
 755
 756 C qg-->qg or qbarg-->qbarg or gq-->gq  or gqbar-->gqbar
 757
 758             SU=1./US
 759
 760             GCOEF(1)=-(SU+US)
 761
 762             GCOEF(2)=0.
 763
 764             GCOEF(3)=2.
 765
 766             GCOEF(4)=0.
 767
 768             GCOEF(5)=SU-US
 769
 770             GCOEF(6)=GCOEF(1)
 771
 772             GCOEF(7)=-GCOEF(5)
 773
 774          ELSEIF (IHPRO.EQ.27.OR.IHPRO.EQ.28) THEN
 775
 776 C gg-->qqbar
 777
 778             UT=1./TU
 779
 780             GCOEF(1)=TU+UT
 781
 782             GCOEF(2)=-2.
 783
 784             GCOEF(3)=0.
 785
 786             GCOEF(4)=0.
 787
 788             GCOEF(5)=GCOEF(1)
 789
 790             GCOEF(6)=TU-UT
 791
 792             GCOEF(7)=-GCOEF(6)
 793
 794          ELSEIF (IHPRO.EQ.29.OR.IHPRO.EQ.30.OR.
 795
 796      &                          IHPRO.EQ.31) THEN
 797
 798 C gg-->gg
 799
 800             GT=S*S+T*T+U*U
 801
 802             GCOEF(2)=2.*U*U*T*T
 803
 804             GCOEF(3)=2.*S*S*U*U
 805
 806             GCOEF(4)=2.*S*S*T*T
 807
 808             GCOEF(1)=GT*GT-GCOEF(2)-GCOEF(3)-GCOEF(4)
 809
 810             GCOEF(5)=GT*(GT-2.*S*S)-GCOEF(2)
 811
 812             GCOEF(6)=GT*(GT-2.*T*T)-GCOEF(3)
 813
 814             GCOEF(7)=GT*(GT-2.*U*U)-GCOEF(4)
 815
 816          ELSE
 817
 818             CALL HWVZRO(7,GCOEF)
 819
 820          ENDIF
 821
 822       ENDIF
 823
 824   999 END
 825
 826 CDECK  ID>, HWHIG1.
 827
 828 *CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
 829
 830 *-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
 831
 832 C-----------------------------------------------------------------------
 833
 834       FUNCTION HWHIG1(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1)
 835
 836 C-----------------------------------------------------------------------
 837
 838 C     Basic matrix elements for Higgs + jet production; used in HWHIGA
 839
 840 C-----------------------------------------------------------------------
 841
 842       IMPLICIT NONE
 843
 844       DOUBLE COMPLEX HWHIG1,HWHIG2,HWHIG5,BI(4),CI(7),DI(3)
 845
 846       DOUBLE PRECISION S,T,U,EH2,EQ2,S1,T1,U1,ONE,TWO,FOUR,HALF
 847
 848       INTEGER I,J,K,I1,J1,K1
 849
 850       COMMON/CINTS/BI,CI,DI
 851
 852       PARAMETER (ONE =1.D0, TWO =2.D0, FOUR =4.D0, HALF =0.5D0)
 853
 854 C-----------------------------------------------------------------------
 855
 856 C     +++ helicity amplitude for: g+g --> g+H
 857
 858 C-----------------------------------------------------------------------
 859
 860       S1=S-EH2
 861
 862       T1=T-EH2
 863
 864       U1=U-EH2
 865
 866       HWHIG1=EQ2*FOUR*DSQRT(TWO*S*T*U)*(
 867
 868      & -FOUR*(ONE/(U*T)+ONE/(U*U1)+ONE/(T*T1))
 869
 870      & -FOUR*((TWO*S+T)*BI(K)/U1**2+(TWO*S+U)*BI(J)/T1**2)/S
 871
 872      & -(S-FOUR*EQ2)*(S1*CI(I1)+(U-S)*CI(J1)+(T-S)*CI(K1))/(S*T*U)
 873
 874      & -8.D0*EQ2*(CI(J1)/(T*T1)+CI(K1)/(U*U1))
 875
 876      & +HALF*(S-FOUR*EQ2)*(S*T*DI(K)+U*S*DI(J)-U*T*DI(I))/(S*T*U)
 877
 878      & +FOUR*EQ2*DI(I)/S
 879
 880      & -TWO*(U*CI(K)+T*CI(J)+U1*CI(K1)+T1*CI(J1)-U*T*DI(I))/S**2 )
 881
 882       RETURN
 883       END
 884
 885 C-----------------------------------------------------------------------
 886
 887       FUNCTION HWHIG2(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1)
 888
 889 C-----------------------------------------------------------------------
 890
 891 C     ++- helicity amplitude for: g+g --> g+H
 892
 893 C-----------------------------------------------------------------------
 894 C-----------------------------------------------------------------------
 895
 896       IMPLICIT NONE
 897
 898       DOUBLE COMPLEX HWHIG2,BI(4),CI(7),DI(3)
 899
 900       DOUBLE PRECISION S,T,U,EH2,EQ2,S1,T1,U1,ONE,TWO,FOUR,HALF
 901
 902       INTEGER I,J,K,I1,J1,K1
 903
 904       COMMON/CINTS/BI,CI,DI
 905
 906       PARAMETER (ONE =1.D0, TWO =2.D0, FOUR =4.D0, HALF =0.5D0)
 907
 908 C-----------------------------------------------------------------------
 909
 910       S1=S-EH2
 911
 912       T1=T-EH2
 913
 914       U1=U-EH2
 915
 916       HWHIG2=EQ2*FOUR*DSQRT(TWO*S*T*U)*(FOUR*EH2
 917
 918      & +(EH2-FOUR*EQ2)*(S1*CI(4)+T1*CI(5)+U1*CI(6))
 919
 920      & -HALF*(EH2-FOUR*EQ2)*(S*T*DI(3)+U*S*DI(2)+U*T*DI(1)) )/(S*T*U)
 921
 922       RETURN
 923       END
 924
 925 C-----------------------------------------------------------------------
 926
 927       FUNCTION HWHIG5(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1)
 928
 929 C-----------------------------------------------------------------------
 930
 931 C     Amplitude for: q+qbar --> g+H
 932
 933 C-----------------------------------------------------------------------
 934 C-----------------------------------------------------------------------
 935
 936       IMPLICIT NONE
 937
 938       DOUBLE COMPLEX HWHIG5,BI(4),CI(7),DI(3)
 939
 940       DOUBLE PRECISION S,T,U,EH2,EQ2,S1,T1,U1,ONE,TWO,FOUR,HALF
 941
 942       INTEGER I,J,K,I1,J1,K1
 943
 944       COMMON/CINTS/BI,CI,DI
 945
 946       PARAMETER (ONE =1.D0, TWO =2.D0, FOUR =4.D0, HALF =0.5D0)
 947
 948 C-----------------------------------------------------------------------
 949
 950       HWHIG5=DCMPLX(TWO+TWO*S/(S-EH2))*BI(I)+DCMPLX(FOUR*EQ2-U-T)*CI(K)
 951
 952       RETURN
 953
 954       END